diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 3771a54e..8ddfad1a 100644 --- a/Yesod/Core.hs +++ b/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, SetCookie (..), renderSetCookie) +import Web.Cookie (parseCookies) 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 diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 5cdb4768..c397f8e3 100644 --- a/Yesod/Dispatch.hs +++ b/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 diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 0082be82..f3e6ee30 100644 --- a/Yesod/Internal.hs +++ b/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" diff --git a/Yesod/Internal/Session.hs b/Yesod/Internal/Session.hs new file mode 100644 index 00000000..cb87d96c --- /dev/null +++ b/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 diff --git a/yesod-core.cabal b/yesod-core.cabal index 2979f520..db06e436 100644 --- a/yesod-core.cabal +++ b/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