Beginning of Yesod middlewares, massive refactor, more to come

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

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

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
 

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)

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