Yesod.Internal.Session

Yesod/Core.hs

@@ -39,6 +39,7 @@ import Yesod.Widget
 import Yesod.Request
 import qualified Network.Wai as W
 import Yesod.Internal
+import Yesod.Internal.Session
 import Web.ClientSession (getKey, defaultKeyFile)
 import qualified Web.ClientSession as CS
 import qualified Data.ByteString as S
@@ -58,15 +59,9 @@ 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)
-import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie)
 import qualified Data.Map as Map
-import Control.Monad (guard)
-import Data.Serialize
 import Data.Time
 
 #if TEST
@@ -248,6 +243,12 @@ class Eq (Route a) => Yesod a where
     yesodRunner :: YesodSite a => a -> Maybe CS.Key -> Maybe (Route a) -> GHandler a a ChooseRep -> W.Application
     yesodRunner = defaultYesodRunner
 
+defaultYesodRunner :: (Yesod a, YesodSite a)
+                   => a
+                   -> Maybe CS.Key
+                   -> Maybe (Route a)
+                   -> GHandler a a ChooseRep
+                   -> W.Application
 defaultYesodRunner y mkey murl handler req = do
     now <- liftIO getCurrentTime
     let getExpires m = fromIntegral (m * 60) `addUTCTime` now
@@ -617,53 +618,3 @@ parseWaiRequest env session' key' = do
         | i < 26 = toEnum $ i + fromEnum 'A'
         | i < 52 = toEnum $ i + fromEnum 'a' - 26
         | otherwise = toEnum $ i + fromEnum '0' - 52
-
-nonceKey :: String
-nonceKey = "_NONCE"
-
--- 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

@@ -226,9 +226,6 @@ mkToMasterArg ps fname = do
       e = rsg `AppE` e'
   return $ LamE xps e
 
-sessionName :: B.ByteString
-sessionName = "_SESSION"
-
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This is the same as 'toWaiAppPlain', except it includes three
 -- middlewares: GZIP compression, JSON-P and path cleaning. This is the

Yesod/Internal.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 -- | Normal users should never need access to these.
 module Yesod.Internal
     ( -- * Error responses
@@ -24,6 +25,9 @@ module Yesod.Internal
     , bsToChars
     , lbsToChars
     , charsToBs
+      -- * Names
+    , sessionName
+    , nonceKey
     ) where
 
 import Text.Hamlet (Hamlet, hamlet, Html)
@@ -106,3 +110,9 @@ bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode
 
 charsToBs :: String -> S.ByteString
 charsToBs = T.encodeUtf8 . T.pack
+
+nonceKey :: String
+nonceKey = "_NONCE"
+
+sessionName :: ByteString
+sessionName = "_SESSION"

Yesod/Internal/Session.hs

@@ -0,0 +1,53 @@
+module Yesod.Internal.Session
+    ( encodeSession
+    , decodeSession
+    ) where
+
+import qualified Web.ClientSession as CS
+import Data.Serialize
+import Data.Time
+import Data.ByteString (ByteString)
+import Control.Monad (guard)
+
+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-core.cabal

@@ -55,6 +55,7 @@ library
                      Yesod.Request
                      Yesod.Widget
     other-modules:   Yesod.Internal
+                     Yesod.Internal.Session
                      Paths_yesod_core
     ghc-options:     -Wall