Migrated away from clientsession middleware

2010-05-05 07:34:27 +03:00 · 2010-05-05 07:34:27 +03:00 · 58b2990794
commit 58b2990794
parent 5c5b2ca81d
3 changed files with 68 additions and 41 deletions
--- a/Yesod/Dispatch.hs
+++ b/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 = B.pack "_SESSION"
+sessionName :: String
+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 thePath
+           $ toWaiApp' a

 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
-    let session' = maybe [] parseSession $ lookup sessionName fullSession
+toWaiApp' y resource env = do
+    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 (AddCookie minutes key value) = do
-    now <- getCurrentTime
-    let expires = addUTCTime (fromIntegral $ minutes * 60) now
-    return (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires="
+headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time
+             -> Header
+             -> (W.ResponseHeader, B.ByteString)
+headerToPair getExpires (AddCookie minutes key value) =
+    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) =
-    return (W.responseHeaderFromBS $ cs key, cs value)
+headerToPair _ (Header key value) = (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)
--- a/Yesod/Handler.hs
+++ b/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
--- a/yesod.cabal
+++ b/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