Migrated away from clientsession middleware

Yesod/Dispatch.hs

@@ -34,7 +34,6 @@ import qualified Network.Wai.Handler.CGI as CGI
 import System.Environment (getEnvironment)
 
 import qualified Data.ByteString.Char8 as B
-import Data.Maybe (fromMaybe)
 import Web.Encodings
 import Web.Mime
 import Data.List (intercalate)
@@ -44,7 +43,11 @@ import Control.Concurrent.MVar
 import Control.Arrow ((***))
 import Data.Convertible.Text (cs)
 
-import Data.Time.Clock
+import Data.Time
+
+import Control.Monad
+import Data.Maybe
+import Web.ClientSession
 
 -- | Generates URL datatype and site function for the given 'Resource's. This
 -- is used for creating sites, *not* subsites. See 'mkYesodSub' for the latter.
@@ -96,21 +99,18 @@ mkYesodGeneral name clazzes isSub res = do
                 }
     return $ (if isSub then id else (:) yes) [w, x, y, z]
 
-sessionName :: B.ByteString
+sessionName :: String
-sessionName = B.pack "_SESSION"
+sessionName = "_SESSION"
 
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. You can use 'basicHandler' if you wish.
 toWaiApp :: Yesod y => y -> IO W.Application
 toWaiApp a = do
-    key' <- encryptKey a
-    let mins = clientSessionDuration a
     return $ gzip
            $ jsonp
            $ methodOverride
            $ cleanPath
-           $ \thePath -> clientsession [sessionName] key' mins -- FIXME middleware is not helping us here, drop it
+           $ toWaiApp' a
-           $ toWaiApp' a thePath
 
 parseSession :: B.ByteString -> [(String, String)]
 parseSession bs = case reads $ cs bs of
@@ -120,11 +120,20 @@ parseSession bs = case reads $ cs bs of
 toWaiApp' :: Yesod y
           => y
           -> [B.ByteString]
-          -> [(B.ByteString, B.ByteString)]
           -> W.Request
           -> IO W.Response
-toWaiApp' y resource fullSession env = do
+toWaiApp' y resource env = do
-    let session' = maybe [] parseSession $ lookup sessionName fullSession
+    key' <- encryptKey y
+    now <- getCurrentTime
+    let getExpires m = fromIntegral (m * 60) `addUTCTime` now
+    let exp' = getExpires $ clientSessionDuration y
+    let host = W.remoteHost env
+    let session' = do
+            (_, raw) <- filter (\(x, _) -> x == W.Cookie) $ W.requestHeaders env
+            (name, val) <- parseCookies raw
+            guard $ name == B.pack sessionName
+            decoded <- maybeToList $ decodeCookie key' now host val
+            parseSession decoded
         site = getSite
         method = B.unpack $ W.methodToBS $ W.requestMethod env
         types = httpAccept env
@@ -153,7 +162,16 @@ toWaiApp' y resource fullSession env = do
                                 method
     let eurl' = either (const Nothing) Just eurl
     let eh er = runHandler (errorHandler y er) render eurl' id y id
-    unYesodApp ya eh rr types >>= responseToWaiResponse
+    (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types
+    let sessionVal = encrypt key' $ B.pack $ show $ ACookie exp' host $ B.pack
+                                  $ show sessionFinal
+    let hs' = AddCookie (clientSessionDuration y) sessionName sessionVal : hs
+        hs'' = map (headerToPair getExpires) hs'
+        hs''' = (W.ContentType, cs $ contentTypeToString ct) : hs''
+    return $ W.Response s hs''' $ case c of
+                                    ContentFile fp -> Left fp
+                                    ContentEnum e -> Right $ W.buffer
+                                                           $ W.Enumerator e
 
 -- | Fully render a route to an absolute URL.
 fullRender :: String -- ^ approot, no trailing slash
@@ -235,25 +253,34 @@ iothunk = fmap go . newMVar . Left where
         val <- comp
         return (Right val, val)
 
-responseToWaiResponse :: (W.Status, [Header], ContentType, Content)
-                      -> IO W.Response
-responseToWaiResponse (sc, hs, ct, c) = do
-    hs' <- mapM headerToPair hs
-    let hs'' = (W.ContentType, cs $ contentTypeToString ct) : hs'
-    return $ W.Response sc hs'' $ case c of
-                                    ContentFile fp -> Left fp
-                                    ContentEnum e -> Right $ W.buffer
-                                                           $ W.Enumerator e
-
 -- | Convert Header to a key/value pair.
-headerToPair :: Header -> IO (W.ResponseHeader, B.ByteString)
+headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time
-headerToPair (AddCookie minutes key value) = do
+             -> Header
-    now <- getCurrentTime
+             -> (W.ResponseHeader, B.ByteString)
-    let expires = addUTCTime (fromIntegral $ minutes * 60) now
+headerToPair getExpires (AddCookie minutes key value) =
-    return (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires="
+    let expires = getExpires minutes
+     in (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires="
                               ++ formatW3 expires)
-headerToPair (DeleteCookie key) = return
+headerToPair _ (DeleteCookie key) =
     (W.SetCookie, cs $
      key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
-headerToPair (Header key value) =
+headerToPair _ (Header key value) = (W.responseHeaderFromBS $ cs key, cs value)
-    return (W.responseHeaderFromBS $ cs key, cs value)
+
+decodeCookie :: Word256 -- ^ key
+             -> UTCTime -- ^ current time
+             -> B.ByteString -- ^ remote host field
+             -> B.ByteString -- ^ cookie value
+             -> Maybe B.ByteString
+decodeCookie key now rhost encrypted = do
+    decrypted <- decrypt key $ B.unpack encrypted
+    (ACookie expire rhost' val) <-
+        case reads $ B.unpack decrypted of
+            [] -> Nothing
+            ((x, _):_) -> Just x
+    guard $ expire > now
+    guard $ rhost' == rhost
+    guard $ not $ B.null val
+    return val
+
+data ACookie = ACookie UTCTime B.ByteString B.ByteString
+    deriving (Show, Read)

Yesod/Handler.hs

@@ -106,7 +106,7 @@ newtype YesodApp = YesodApp
     :: (ErrorResponse -> YesodApp)
     -> Request
     -> [ContentType]
-    -> IO (W.Status, [Header], ContentType, Content)
+    -> IO (W.Status, [Header], ContentType, Content, [(String, String)])
     }
 
 data HandlerContents a =
@@ -194,7 +194,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do
     let toErrorHandler =
             InternalError
           . (show :: Control.Exception.SomeException -> String)
-    (headersOrig, session', contents) <- Control.Exception.catch
+    (headers, session', contents) <- Control.Exception.catch
         (unHandler handler HandlerData
             { handlerRequest = rr
             , handlerSub = tosa ma
@@ -205,22 +205,21 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do
             })
         (\e -> return ([], [], HCError $ toErrorHandler e))
     let finalSession = foldl' modifySession (reqSession rr) session'
-        headers = Header "_SESSION" (show finalSession) : headersOrig -- FIXME
     let handleError e = do
-            (_, hs, ct, c) <- unYesodApp (eh e) safeEh rr cts
+            (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts
             let hs' = headers ++ hs
-            return (getStatus e, hs', ct, c)
+            return (getStatus e, hs', ct, c, sess)
     let sendFile' ct fp = do
             c <- BL.readFile fp
-            return (W.Status200, headers, ct, cs c)
+            return (W.Status200, headers, ct, cs c, finalSession)
     case contents of
         HCContent a -> do
             (ct, c) <- chooseRep a cts
-            return (W.Status200, headers, ct, c)
+            return (W.Status200, headers, ct, c, finalSession)
         HCError e -> handleError e
         HCRedirect rt loc -> do
             let hs = Header "Location" loc : headers
-            return (getRedirectStatus rt, hs, TypePlain, cs "")
+            return (getRedirectStatus rt, hs, TypePlain, cs "", finalSession)
         HCSendFile ct fp -> Control.Exception.catch
             (sendFile' ct fp)
             (handleError . toErrorHandler)
@@ -228,7 +227,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do
 safeEh :: ErrorResponse -> YesodApp
 safeEh er = YesodApp $ \_ _ _ -> do
     liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
-    return (W.Status500, [], TypePlain, cs "Internal Server Error")
+    return (W.Status500, [], TypePlain, cs "Internal Server Error", [])
 
 -- | Redirect to the given route.
 redirect :: RedirectType -> Routes master -> GHandler sub master a

yesod.cabal

@@ -27,11 +27,12 @@ library
                      control-monad-attempt >= 0.2.0 && < 0.3,
                      text >= 0.5 && < 0.8,
                      convertible-text >= 0.2.0 && < 0.3,
-                     template-haskell,
+                     template-haskell >= 2.4 && < 2.5,
                      web-routes >= 0.22 && < 0.23,
                      web-routes-quasi >= 0.1 && < 0.2,
                      hamlet >= 0.0.1 && < 0.1,
-                     transformers >= 0.1 && < 0.3
+                     transformers >= 0.1 && < 0.3,
+                     clientsession >= 0.2 && < 0.3
     exposed-modules: Yesod
                      Yesod.Content
                      Yesod.Dispatch