diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index c5048a4c..45c298ee 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} module Yesod.Dispatch ( -- * Quasi-quoted routing parseRoutes @@ -13,10 +14,12 @@ module Yesod.Dispatch , basicHandler -- * Utilities , fullRender +#if TEST + , testSuite +#endif ) where import Yesod.Handler -import Yesod.Content import Yesod.Yesod import Yesod.Request import Yesod.Internal @@ -48,6 +51,17 @@ import Control.Monad import Data.Maybe import Web.ClientSession +import Data.Serialize + +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import System.IO.Unsafe +import Yesod.Content hiding (testSuite) +#else +import Yesod.Content +#endif + -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, *not* subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. @@ -129,11 +143,6 @@ toWaiApp a = $ cleanPath $ toWaiApp' a -parseSession :: B.ByteString -> [(String, String)] -parseSession bs = case reads $ cs bs of - [] -> [] - ((x, _):_) -> x - toWaiApp' :: (Yesod y, YesodSite y) => y -> [String] @@ -145,13 +154,11 @@ toWaiApp' y segments env = do 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 + let session' = fromMaybe [] $ do + raw <- lookup W.Cookie $ W.requestHeaders env + val <- lookup (B.pack sessionName) $ parseCookies raw + decodeSession key' now host val + let site = getSite method = B.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) segments @@ -179,9 +186,9 @@ toWaiApp' y segments env = do let eurl' = either (const Nothing) Just eurl let eh er = runHandler (errorHandler y er) render eurl' id y id (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 + sessionVal <- encodeSession key' exp' host 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 @@ -281,21 +288,64 @@ headerToPair _ (DeleteCookie key) = key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") 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 +encodeSession :: B.ByteString -- ^ key + -> UTCTime -- ^ expire time + -> B.ByteString -- ^ remote host + -> [(String, String)] -- ^ session + -> IO String -- ^ cookie value +encodeSession key expire rhost session' = + encrypt key $ cs $ encode $ SessionCookie expire rhost session' + +decodeSession :: B.ByteString -- ^ 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 $ B.unpack encrypted - (ACookie expire rhost' val) <- - case reads $ B.unpack decrypted of - [] -> Nothing - ((x, _):_) -> Just x + SessionCookie expire rhost' session' <- + either (const Nothing) Just $ decode + $ cs decrypted guard $ expire > now guard $ rhost' == rhost - guard $ not $ B.null val - return val + return session' -data ACookie = ACookie UTCTime B.ByteString B.ByteString +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 <- get + c <- get + return $ SessionCookie a b c + +putTime :: Putter UTCTime +putTime (UTCTime d t) = do + put $ toModifiedJulianDay d + put $ fromEnum t + +getTime :: Get UTCTime +getTime = do + d <- get + t <- get + return $ UTCTime (ModifiedJulianDay d) (toEnum t) + +#if TEST + +testSuite :: Test +testSuite = testGroup "Yesod.Dispatch" + [ testProperty "encode/decode session" propEncDecSession + ] + +propEncDecSession :: [(String, String)] -> Bool +propEncDecSession session' = unsafePerformIO $ do + key <- getDefaultKey + now <- getCurrentTime + let expire = addUTCTime 1 now + let rhost = B.pack "some host" + val <- encodeSession key expire rhost session' + return $ Just session' == + decodeSession key now rhost (B.pack val) + +#endif diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f971b09c..f8753be2 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -20,7 +20,8 @@ import Data.Convertible.Text import qualified Network.Wai as W import Yesod.Json import Yesod.Internal -import Web.ClientSession (Word256, getKey, defaultKeyFile) +import Web.ClientSession (getKey, defaultKeyFile) +import Data.ByteString (ByteString) import Web.Routes.Quasi (QuasiSite (..), Routes) @@ -45,7 +46,7 @@ class Yesod a where approot :: a -> String -- | The encryption key to be used for encrypting client sessions. - encryptKey :: a -> IO Word256 + encryptKey :: a -> IO ByteString encryptKey _ = getKey defaultKeyFile -- | Number of minutes before a client session times out. Defaults to diff --git a/runtests.hs b/runtests.hs index 59000fc0..de7ac4e1 100644 --- a/runtests.hs +++ b/runtests.hs @@ -2,9 +2,11 @@ import Test.Framework (defaultMain) import qualified Yesod.Content import qualified Yesod.Json +import qualified Yesod.Dispatch main :: IO () main = defaultMain [ Yesod.Content.testSuite , Yesod.Json.testSuite + , Yesod.Dispatch.testSuite ] diff --git a/yesod.cabal b/yesod.cabal index aec485ed..525fd4f3 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -45,11 +45,12 @@ library web-routes-quasi >= 0.2 && < 0.3, hamlet >= 0.2.2 && < 0.3, transformers >= 0.1 && < 0.3, - clientsession >= 0.2.1 && < 0.3, + clientsession >= 0.3.0 && < 0.4, MonadCatchIO-transformers >= 0.2.2 && < 0.3, pureMD5 >= 1.1.0.0 && < 1.2, random >= 1.0.0.2 && < 1.1, - control-monad-attempt >= 0.3 && < 0.4 + control-monad-attempt >= 0.3 && < 0.4, + cereal >= 0.2 && < 0.3 exposed-modules: Yesod Yesod.Content Yesod.Dispatch