From 2f7ac581899282cded1082d329de0edcec4e8016 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jan 2011 21:35:52 +0200 Subject: [PATCH] Beginning of Yesod middlewares, massive refactor, more to come --- Yesod/Content.hs | 14 ++- Yesod/Core.hs | 236 ++++++++++++++++++++++++++++++++++++++-- Yesod/Dispatch.hs | 271 +++++++--------------------------------------- Yesod/Handler.hs | 118 +++++++++++++++++--- Yesod/Internal.hs | 9 +- 5 files changed, 388 insertions(+), 260 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index cd28f5ca..a65acee5 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} module Yesod.Content ( -- * Content @@ -47,6 +48,7 @@ module Yesod.Content import Data.Maybe (mapMaybe) import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text, pack) import qualified Data.Text as T @@ -63,6 +65,7 @@ import Data.Monoid (mempty) import Text.Hamlet (Html) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) +import Data.String (IsString (fromString)) data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. | ContentEnum (forall a. Enumerator Builder IO a) @@ -72,6 +75,9 @@ data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional emptyContent :: Content emptyContent = ContentBuilder mempty $ Just 0 +instance IsString Content where + fromString = toContent + -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentBuilder' constructor. An easier approach will be to use -- a pre-defined 'toContent' function, such as converting your data into a lazy @@ -131,7 +137,7 @@ instance HasReps ChooseRep where chooseRep = id instance HasReps () where - chooseRep = defChooseRep [(typePlain, const $ return $ toContent "")] + chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)] instance HasReps (ContentType, Content) where chooseRep = const . return @@ -165,7 +171,7 @@ newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (typeXml, c) -type ContentType = String +type ContentType = B.ByteString typeHtml :: ContentType typeHtml = "text/html; charset=utf-8" @@ -214,8 +220,8 @@ typeOctet = "application/octet-stream" -- -- For example, \"text/html; charset=utf-8\" is commonly used to specify the -- character encoding for HTML data. This function would return \"text/html\". -simpleContentType :: String -> String -simpleContentType = fst . span (/= ';') +simpleContentType :: B.ByteString -> B.ByteString +simpleContentType = S8.takeWhile (/= ';') -- | Format a 'UTCTime' in W3 format. formatW3 :: UTCTime -> String diff --git a/Yesod/Core.hs b/Yesod/Core.hs index d16e10e2..72cf9a25 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -24,6 +24,7 @@ module Yesod.Core , AuthResult (..) -- * Misc , yesodVersion + , yesodRender #if TEST , coreTestSuite #endif @@ -45,7 +46,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Monoid import Control.Monad.Trans.Writer -import Control.Monad.Trans.State hiding (get) +import Control.Monad.Trans.State hiding (get, put) import Text.Hamlet import Text.Cassius import Text.Julius @@ -53,6 +54,20 @@ import Web.Routes import Text.Blaze (preEscapedLazyText) import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Maybe (fromMaybe) +import System.Random (randomR, newStdGen) +import Control.Arrow (first, (***)) +import qualified Network.Wai.Parse as NWP +import Data.ByteString (ByteString) +import Data.Enumerator (Iteratee, ($$), run_) +import Control.Concurrent.MVar (MVar, takeMVar, putMVar, newMVar) +import Control.Monad.IO.Class (liftIO) +import Control.Applicative ((<$>)) +import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie) +import qualified Data.Map as Map +import Control.Monad (guard) +import Data.Serialize +import Data.Time #if TEST import Test.Framework (testGroup, Test) @@ -69,18 +84,24 @@ import qualified Data.Text.Encoding #define HAMLET $hamlet #endif +{- FIXME +class YesodDispatcher y where + dispatchSubsite :: y -> Key -> [String] -> Maybe Application +-} + -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Eq (Route y) => YesodSite y where getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) + getSite' :: y -> Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) + getSite' _ = getSite + type Method = String -- | Same as 'YesodSite', but for subsites. Once again, users should not need --- to deal with it directly, as the mkYesodSub creates instances appropriately. +-- to deal with it directly, as mkYesodSub creates instances appropriately. class Eq (Route s) => YesodSubSite s y where getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSiteFromSubSite :: s -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSiteFromSubSite _ = getSubSite -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. @@ -95,6 +116,8 @@ class Eq (Route a) => Yesod a where -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. + -- + -- FIXME: is this the right typesig? approot :: a -> S.ByteString -- | The encryption key to be used for encrypting client sessions. @@ -129,12 +152,6 @@ class Eq (Route a) => Yesod a where ^{pageBody p} |] - -- | Gets called at the beginning of each request. Useful for logging. - -- - -- FIXME make this a part of the Yesod middlewares - onRequest :: GHandler sub a () - onRequest = return () - -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. @@ -193,6 +210,8 @@ class Eq (Route a) => Yesod a where -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. + -- + -- FIXME is this the right type sig? joinPath :: a -> S.ByteString -- ^ application root -> [String] -- ^ path pieces @@ -226,6 +245,68 @@ class Eq (Route a) => Yesod a where sessionIpAddress :: a -> Bool sessionIpAddress _ = True + yesodRunner :: YesodSite a => a -> Maybe CS.Key -> Maybe (Route a) -> GHandler a a ChooseRep -> W.Application + yesodRunner = defaultYesodRunner + +defaultYesodRunner y mkey murl handler req = do + now <- liftIO getCurrentTime + let getExpires m = fromIntegral (m * 60) `addUTCTime` now + let exp' = getExpires $ clientSessionDuration y + -- FIXME will show remoteHost give the answer I need? will it include port + -- information that changes on each request? + let host = if sessionIpAddress y then S8.pack (show (W.remoteHost req)) else "" + let session' = + case mkey of + Nothing -> [] + Just key -> fromMaybe [] $ do + raw <- lookup "Cookie" $ W.requestHeaders req + val <- lookup sessionName $ parseCookies raw + decodeSession key now host val + rr <- liftIO $ parseWaiRequest req session' mkey + let h = do + case murl of + Nothing -> handler + Just url -> do + isWrite <- isWriteRequest url + ar <- isAuthorized url isWrite + case ar of + Authorized -> return () + AuthenticationRequired -> + case authRoute y of + Nothing -> + permissionDenied "Authentication required" + Just url' -> do + setUltDest' + redirect RedirectTemporary url' + Unauthorized s -> permissionDenied s + handler + let sessionMap = Map.fromList + $ filter (\(x, _) -> x /= nonceKey) session' + yar <- handlerToYAR y (yesodRender y) errorHandler rr murl sessionMap h + let mnonce = Just $ reqNonce rr -- FIXME + return $ yarToResponse (hr mnonce getExpires host exp') yar + where + hr mnonce getExpires host exp' hs ct sm = + hs''' + where + sessionVal = + case (mkey, mnonce) of + (Just key, Just nonce) + -> encodeSession key exp' host + $ Map.toList + $ Map.insert nonceKey nonce sm + _ -> S.empty + hs' = + case mkey of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration y) + sessionName + sessionVal + : hs + hs'' = map (headerToPair getExpires) hs' + hs''' = ("Content-Type", ct) : hs'' + data AuthResult = Authorized | AuthenticationRequired | Unauthorized String deriving (Eq, Show, Read) @@ -483,3 +564,138 @@ redirectToPost dest = hamletToRepHtml yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version + +yesodRender :: (Yesod y, YesodSite y) + => y + -> Route y + -> [(String, String)] + -> String +yesodRender y u qs = + S8.unpack $ fromMaybe + (joinPath y (approot y) ps $ qs ++ qs') + (urlRenderOverride y u) + where + (ps, qs') = formatPathSegments (getSite' y) u + +parseWaiRequest :: W.Request + -> [(String, String)] -- ^ session + -> Maybe a + -> IO Request +parseWaiRequest env session' key' = do + let gets' = map (bsToChars *** bsToChars) + $ NWP.parseQueryString $ W.queryString env + let reqCookie = fromMaybe S.empty $ lookup "Cookie" + $ W.requestHeaders env + cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie + acceptLang = lookup "Accept-Language" $ W.requestHeaders env + langs = map bsToChars $ maybe [] NWP.parseHttpAccept acceptLang + langs' = case lookup langKey session' of + Nothing -> langs + Just x -> x : langs + langs'' = case lookup langKey cookies' of + Nothing -> langs' + Just x -> x : langs' + langs''' = case lookup langKey gets' of + Nothing -> langs'' + Just x -> x : langs'' + rbthunk <- iothunk $ rbHelper env + nonce <- case (key', lookup nonceKey session') of + (Nothing, _) -> return $ error "You have attempted to use the nonce, but sessions are disabled." -- FIXME maybe this should be handled without an error? + (_, Just x) -> return x + (_, Nothing) -> do + g <- newStdGen + return $ fst $ randomString 10 g + return $ Request gets' cookies' rbthunk env langs''' nonce + where + randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + +nonceKey :: String +nonceKey = "_NONCE" + +rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents +rbHelper req = + (map fix1 *** map fix2) <$> iter + where + iter = NWP.parseRequestBody NWP.lbsSink req + fix1 = bsToChars *** bsToChars + fix2 (x, NWP.FileInfo a b c) = + (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) + +-- | Produces a \"compute on demand\" value. The computation will be run once +-- it is requested, and then the result will be stored. This will happen only +-- once. +-- +-- FIXME: remove this function and use a StateT in Handler +iothunk :: Iteratee ByteString IO a -> IO (Iteratee ByteString IO a) +iothunk = + fmap go . liftIO . newMVar . Left + where + go :: MVar (Either (Iteratee ByteString IO a) a) -> Iteratee ByteString IO a + go mvar = do + x <- liftIO $ takeMVar mvar + (x', a) <- go' x + liftIO $ putMVar mvar x' + return a + go' :: Either (Iteratee ByteString IO a) a + -> Iteratee ByteString IO (Either (Iteratee ByteString IO a) a, a) + go' (Right val) = return (Right val, val) + go' (Left comp) = do + val <- comp + return (Right val, val) + +-- FIXME don't duplicate +sessionName :: ByteString +sessionName = "_SESSION" + +encodeSession :: CS.Key + -> UTCTime -- ^ expire time + -> ByteString -- ^ remote host + -> [(String, String)] -- ^ session + -> ByteString -- ^ cookie value +encodeSession key expire rhost session' = + CS.encrypt key $ encode $ SessionCookie expire rhost session' + +decodeSession :: CS.Key + -> UTCTime -- ^ current time + -> ByteString -- ^ remote host field + -> ByteString -- ^ cookie value + -> Maybe [(String, String)] +decodeSession key now rhost encrypted = do + decrypted <- CS.decrypt key encrypted + SessionCookie expire rhost' session' <- + either (const Nothing) Just $ decode decrypted + guard $ expire > now + guard $ rhost' == rhost + return session' + +data SessionCookie = SessionCookie UTCTime ByteString [(String, String)] + deriving (Show, Read) +instance Serialize SessionCookie where + put (SessionCookie a b c) = putTime a >> put b >> put c + get = do + a <- getTime + b <- get + c <- get + return $ SessionCookie a b c + +putTime :: Putter UTCTime +putTime t@(UTCTime d _) = do + put $ toModifiedJulianDay d + let ndt = diffUTCTime t $ UTCTime d 0 + put $ toRational ndt + +getTime :: Get UTCTime +getTime = do + d <- get + ndt <- get + return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 08851dfb..5cdb4768 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -44,6 +44,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString as S import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Char8 () import Blaze.ByteString.Builder (toLazyByteString) import Control.Concurrent.MVar @@ -225,7 +226,7 @@ mkToMasterArg ps fname = do e = rsg `AppE` e' return $ LamE xps e -sessionName :: String +sessionName :: B.ByteString sessionName = "_SESSION" -- | Convert the given argument into a WAI application, executable with any WAI @@ -246,241 +247,53 @@ toWaiAppPlain a = do key' <- encryptKey a return $ toWaiApp' a key' +dispatchPieces _ _ _ = Nothing -- FIXME + toWaiApp' :: (Yesod y, YesodSite y) => y -> Maybe Key -> W.Application toWaiApp' y key' env = do - let segments = decodePathInfo $ B.unpack $ W.pathInfo env - -- FIXME call cleanPath - now <- liftIO getCurrentTime - let getExpires m = fromIntegral (m * 60) `addUTCTime` now - let exp' = getExpires $ clientSessionDuration y - -- FIXME will show remoteHost give the answer I need? will it include port - -- information that changes on each request? - let host = if sessionIpAddress y then B.pack (show (W.remoteHost env)) else "" - let session' = - case key' of - Nothing -> [] - Just key'' -> fromMaybe [] $ do - raw <- lookup "Cookie" $ W.requestHeaders env - val <- lookup (B.pack sessionName) $ parseCookies raw - decodeSession key'' now host val - let site = getSite - method = B.unpack $ W.requestMethod env - types = httpAccept env - pathSegments = filter (not . null) segments - eurl = parsePathSegments site pathSegments - render u qs = - let (ps, qs') = formatPathSegments site u - in B.unpack $ fromMaybe - (joinPath y (approot y) ps $ qs ++ qs') - (urlRenderOverride y u) - let errorHandler' = localNoCurrent . errorHandler - rr <- liftIO $ parseWaiRequest env session' key' - let h = do - onRequest - case eurl of - Left _ -> errorHandler' NotFound - Right url -> do - isWrite <- isWriteRequest url - ar <- isAuthorized url isWrite - case ar of - Authorized -> return () - AuthenticationRequired -> - case authRoute y of - Nothing -> - permissionDenied "Authentication required" - Just url' -> do - setUltDest' - redirect RedirectTemporary url' - Unauthorized s -> permissionDenied s - case handleSite site render url method of - Nothing -> errorHandler' $ BadMethod method - Just h' -> h' - let eurl' = either (const Nothing) Just eurl - let eh er = runHandler (errorHandler' er) render eurl' id y id - let ya = runHandler h render eurl' id y id - let sessionMap = Map.fromList - $ filter (\(x, _) -> x /= nonceKey) session' - yar <- unYesodApp ya eh rr types sessionMap - case yar of - YARPlain s hs ct c sessionFinal -> do - let sessionVal = - case key' of - Nothing -> B.empty - Just key'' -> - encodeSession key'' exp' host - $ Map.toList - $ Map.insert nonceKey (reqNonce rr) sessionFinal - let hs' = - case key' of - Nothing -> hs - Just _ -> AddCookie - (clientSessionDuration y) - sessionName - (bsToChars sessionVal) - : hs - hs'' = map (headerToPair getExpires) hs' - hs''' = ("Content-Type", charsToBs ct) : hs'' - return $ - case c of - ContentBuilder b mlen -> - let hs'''' = - case mlen of - Nothing -> hs''' - Just len -> - ("Content-Length", B.pack $ show len) - : hs''' - in W.ResponseBuilder s hs'''' b - ContentFile fp -> W.ResponseFile s hs''' fp - ContentEnum e -> W.ResponseEnumerator $ \iter -> - run_ $ e $$ iter s hs''' - YARWai r -> return r + let segments = + case decodePathInfo $ B.unpack $ W.pathInfo env of + "":x -> x + x -> x + liftIO $ print (W.pathInfo env, segments) + case dispatchPieces y key' segments of + Nothing -> + case cleanPath y segments of + Nothing -> normalDispatch y key' segments env + Just segments' -> + let dest = joinPath y (approot y) segments' [] + dest' = + if S.null (W.queryString env) + then dest + else S.concat + [ dest + , B.singleton '?' + , W.queryString env + ] + in return $ W.responseLBS W.status301 + [ ("Content-Type", "text/plain") + , ("Location", dest') + ] "Redirecting" + Just app -> app env -httpAccept :: W.Request -> [ContentType] -httpAccept = map B.unpack - . parseHttpAccept - . fromMaybe B.empty - . lookup "Accept" - . W.requestHeaders - -parseWaiRequest :: W.Request - -> [(String, String)] -- ^ session - -> Maybe a - -> IO Request -parseWaiRequest env session' key' = do - let gets' = map (bsToChars *** bsToChars) - $ parseQueryString $ W.queryString env - let reqCookie = fromMaybe B.empty $ lookup "Cookie" - $ W.requestHeaders env - cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie - acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map bsToChars $ maybe [] parseHttpAccept acceptLang - langs' = case lookup langKey session' of - Nothing -> langs - Just x -> x : langs - langs'' = case lookup langKey cookies' of - Nothing -> langs' - Just x -> x : langs' - langs''' = case lookup langKey gets' of - Nothing -> langs'' - Just x -> x : langs'' - rbthunk <- iothunk $ rbHelper env - nonce <- case (key', lookup nonceKey session') of - (Nothing, _) -> return $ error "You have attempted to use the nonce, but sessions are disabled." -- FIXME maybe this should be handled without an error? - (_, Just x) -> return x - (_, Nothing) -> do - g <- newStdGen - return $ fst $ randomString 10 g - return $ Request gets' cookies' rbthunk env langs''' nonce +normalDispatch :: (Yesod m, YesodSite m) + => m -> Maybe Key -> [String] + -> W.Application +normalDispatch y key' segments env = + yesodRunner y key' murl handler env where - randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - -nonceKey :: String -nonceKey = "_NONCE" - -rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents -rbHelper req = - (map fix1 *** map fix2) <$> iter - where - iter = parseRequestBody lbsSink req - fix1 = bsToChars *** bsToChars - fix2 (x, NWP.FileInfo a b c) = - (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) - --- | Produces a \"compute on demand\" value. The computation will be run once --- it is requested, and then the result will be stored. This will happen only --- once. -iothunk :: Iteratee ByteString IO a -> IO (Iteratee ByteString IO a) -iothunk = - fmap go . liftIO . newMVar . Left - where - go :: MVar (Either (Iteratee ByteString IO a) a) -> Iteratee ByteString IO a - go mvar = do - x <- liftIO $ takeMVar mvar - (x', a) <- go' x - liftIO $ putMVar mvar x' - return a - go' :: Either (Iteratee ByteString IO a) a - -> Iteratee ByteString IO (Either (Iteratee ByteString IO a) a, a) - go' (Right val) = return (Right val, val) - go' (Left comp) = do - val <- comp - return (Right val, val) - --- | Convert Header to a key/value pair. -headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time - -> Header - -> (W.ResponseHeader, B.ByteString) -headerToPair getExpires (AddCookie minutes key value) = - ("Set-Cookie", builderToBS $ renderSetCookie $ SetCookie - { setCookieName = B.pack key -- FIXME check for non-ASCII - , setCookieValue = B.pack value -- FIXME check for non-ASCII - , setCookiePath = Just "/" -- FIXME make a config option, or use approot? - , setCookieExpires = Just $ getExpires minutes - , setCookieDomain = Nothing - }) - where - builderToBS = S.concat . L.toChunks . toLazyByteString -headerToPair _ (DeleteCookie key) = - ("Set-Cookie", charsToBs $ - key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") -headerToPair _ (Header key value) = - (fromString key, charsToBs value) - -encodeSession :: CS.Key - -> UTCTime -- ^ expire time - -> B.ByteString -- ^ remote host - -> [(String, String)] -- ^ session - -> B.ByteString -- ^ cookie value -encodeSession key expire rhost session' = - encrypt key $ encode $ SessionCookie expire rhost session' - -decodeSession :: CS.Key - -> UTCTime -- ^ current time - -> B.ByteString -- ^ remote host field - -> B.ByteString -- ^ cookie value - -> Maybe [(String, String)] -decodeSession key now rhost encrypted = do - decrypted <- decrypt key encrypted - SessionCookie expire rhost' session' <- - either (const Nothing) Just $ decode decrypted - guard $ expire > now - guard $ rhost' == rhost - return session' - -data SessionCookie = SessionCookie UTCTime B.ByteString [(String, String)] - deriving (Show, Read) -instance Serialize SessionCookie where - put (SessionCookie a b c) = putTime a >> put b >> put c - get = do - a <- getTime - b <- Ser.get - c <- Ser.get - return $ SessionCookie a b c - -putTime :: Putter UTCTime -putTime t@(UTCTime d _) = do - put $ toModifiedJulianDay d - let ndt = diffUTCTime t $ UTCTime d 0 - put $ toRational ndt - -getTime :: Get UTCTime -getTime = do - d <- Ser.get - ndt <- Ser.get - return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 + method = B.unpack $ W.requestMethod env + murl = either (const Nothing) Just $ parsePathSegments (getSite' y) segments + handler = + case murl of + Nothing -> notFound + Just url -> + case handleSite (getSite' y) (yesodRender y) url method of + Nothing -> badMethod + Just h -> h #if TEST diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 6581c614..847a6737 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -9,6 +9,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -88,6 +89,9 @@ module Yesod.Handler , HandlerData , ErrorResponse (..) , YesodAppResult (..) + , handlerToYAR + , yarToResponse + , headerToPair #if TEST , handlerTestSuite #endif @@ -119,15 +123,21 @@ import Text.Hamlet import Control.Monad.IO.Peel (MonadPeelIO) import qualified Data.Map as Map +import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.ByteString (ByteString) import Data.Enumerator (Iteratee (..)) +import Network.Wai.Parse (parseHttpAccept) #if TEST import Test.Framework (testGroup, Test) #endif import Yesod.Content +import Data.Maybe (fromMaybe) +import Web.Cookie (SetCookie (..), renderSetCookie) +import Blaze.ByteString.Builder (toByteString) +import Data.Enumerator (run_, ($$)) -- | The type-safe URLs associated with a site argument. type family Route a @@ -251,8 +261,8 @@ data HandlerContents = HCContent W.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath - | HCRedirect RedirectType String - | HCCreated String + | HCRedirect RedirectType ByteString + | HCCreated ByteString | HCWai W.Response instance Error HandlerContents where @@ -349,7 +359,7 @@ runHandler handler mrender sroute tomr ma tosa = HCSendFile ct fp -> catchIter (sendFile' ct fp) (handleError . toErrorHandler) - HCCreated loc -> do -- FIXME add status201 to WAI + HCCreated loc -> do let hs = Header "Location" loc : headers [] return $ YARPlain (W.Status 201 (S8.pack "Created")) @@ -372,7 +382,7 @@ safeEh er = YesodApp $ \_ _ _ session -> do W.status500 [] typePlain - (toContent "Internal Server Error") + (toContent ("Internal Server Error" :: S.ByteString)) session -- | Redirect to the given route. @@ -384,10 +394,10 @@ redirectParams :: RedirectType -> Route master -> [(String, String)] -> GHandler sub master a redirectParams rt url params = do r <- getUrlRenderParams - redirectString rt $ r url params + redirectString rt $ S8.pack $ r url params -- | Redirect to the given URL. -redirectString :: RedirectType -> String -> GHandler sub master a +redirectString :: RedirectType -> ByteString -> GHandler sub master a redirectString rt = GHandler . lift . throwError . HCRedirect rt ultDestKey :: String @@ -431,7 +441,7 @@ redirectUltDest :: RedirectType redirectUltDest rt def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey - maybe (redirect rt def) (redirectString rt) mdest + maybe (redirect rt def) (redirectString rt . S8.pack) mdest msgKey :: String msgKey = "_MSG" @@ -476,7 +486,7 @@ sendResponseStatus s = GHandler . lift . throwError . HCContent s sendResponseCreated :: Route m -> GHandler s m a sendResponseCreated url = do r <- getUrlRender - GHandler $ lift $ throwError $ HCCreated $ r url + GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url -- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session @@ -507,13 +517,13 @@ invalidArgs = failure . InvalidArgs ------- Headers -- | Set the cookie on the client. setCookie :: Int -- ^ minutes to timeout - -> String -- ^ key - -> String -- ^ value + -> ByteString -- ^ key + -> ByteString -- ^ value -> GHandler sub master () setCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: String -> GHandler sub master () +deleteCookie :: ByteString -> GHandler sub master () deleteCookie = addHeader . DeleteCookie -- | Set the language in the user session. Will show up in 'languages' on the @@ -522,13 +532,13 @@ setLanguage :: String -> GHandler sub master () setLanguage = setSession langKey -- | Set an arbitrary response header. -setHeader :: String -> String -> GHandler sub master () +setHeader :: W.ResponseHeader -> ByteString -> GHandler sub master () setHeader a = addHeader . Header a -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. cacheSeconds :: Int -> GHandler s m () -cacheSeconds i = setHeader "Cache-Control" $ concat +cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat [ "max-age=" , show i , ", public" @@ -546,7 +556,7 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. expiresAt :: UTCTime -> GHandler s m () -expiresAt = setHeader "Expires" . formatRFC1123 +expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 -- | Set a variable in the user's session. -- @@ -606,3 +616,83 @@ handlerTestSuite = testGroup "Yesod.Handler" ] #endif + +handlerToYAR :: (HasReps a, HasReps b) + => m -- ^ master site foundation + -> (Route m -> [(String, String)] -> String) -- ^ url render + -> (ErrorResponse -> GHandler m m a) + -> Request + -> Maybe (Route m) + -> SessionMap + -> GHandler m m b + -> Iteratee ByteString IO YesodAppResult +handlerToYAR y render errorHandler rr murl sessionMap h = + unYesodApp ya eh' rr types sessionMap + where + ya = runHandler h render murl id y id + eh' er = runHandler (errorHandler' er) render murl id y id + types = httpAccept $ reqWaiRequest rr + errorHandler' = localNoCurrent . errorHandler + +type HeaderRenderer = [Header] + -> ContentType + -> SessionMap + -> [(W.ResponseHeader, ByteString)] + +yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response +yarToResponse _ (YARWai a) = a +yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) = + case c of + ContentBuilder b mlen -> + let hs' = maybe finalHeaders finalHeaders' mlen + in W.ResponseBuilder s hs' b + ContentFile fp -> W.ResponseFile s finalHeaders fp + ContentEnum e -> + W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders + where + finalHeaders = renderHeaders hs ct sessionFinal + finalHeaders' len = ("Content-Length", S8.pack $ show len) + : finalHeaders + {- + getExpires m = fromIntegral (m * 60) `addUTCTime` now + sessionVal = + case key' of + Nothing -> B.empty + Just key'' -> encodeSession key'' exp' host + $ Map.toList + $ Map.insert nonceKey (reqNonce rr) sessionFinal + hs' = + case key' of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration y) + sessionName + (bsToChars sessionVal) + : hs + hs'' = map (headerToPair getExpires) hs' + hs''' = ("Content-Type", charsToBs ct) : hs'' + -} + +httpAccept :: W.Request -> [ContentType] +httpAccept = parseHttpAccept + . fromMaybe S.empty + . lookup "Accept" + . W.requestHeaders + +-- | Convert Header to a key/value pair. +headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time + -> Header + -> (W.ResponseHeader, ByteString) +headerToPair getExpires (AddCookie minutes key value) = + ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie + { setCookieName = key + , setCookieValue = value + , setCookiePath = Just "/" -- FIXME make a config option, or use approot? + , setCookieExpires = Just $ getExpires minutes + , setCookieDomain = Nothing + }) +headerToPair _ (DeleteCookie key) = + ( "Set-Cookie" + , key `S.append` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT" + ) +headerToPair _ (Header key value) = (key, value) diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 1880260c..0082be82 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -30,6 +30,7 @@ import Text.Hamlet (Hamlet, hamlet, Html) import Data.Monoid (Monoid (..)) import Data.List (nub) +import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -40,6 +41,8 @@ import qualified Data.Text.Encoding.Error as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT +import qualified Network.Wai as W + #if GHC7 #define HAMLET hamlet #else @@ -59,9 +62,9 @@ data ErrorResponse = ----- header stuff -- | Headers to be added to a 'Result'. data Header = - AddCookie Int String String - | DeleteCookie String - | Header String String + AddCookie Int ByteString ByteString + | DeleteCookie ByteString + | Header W.ResponseHeader ByteString deriving (Eq, Show) langKey :: String