From fd0ce32687e59b87a60ef1fc394ed9aad0117fe0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 5 May 2010 00:46:54 +0300 Subject: [PATCH] Added proper sessions --- Yesod.hs | 4 +-- Yesod/Definitions.hs | 58 ------------------------------------- Yesod/Dispatch.hs | 24 +++++++++++----- Yesod/Hamlet.hs | 2 +- Yesod/Handler.hs | 67 +++++++++++++++++++++++++++++++------------ Yesod/Helpers/Auth.hs | 13 +++++++++ Yesod/Json.hs | 2 +- Yesod/Request.hs | 5 ++-- Yesod/Yesod.hs | 5 ++-- yesod.cabal | 1 - 10 files changed, 87 insertions(+), 94 deletions(-) delete mode 100644 Yesod/Definitions.hs diff --git a/Yesod.hs b/Yesod.hs index f90f5f33..1e9ecb3e 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -5,7 +5,6 @@ module Yesod module Yesod.Request , module Yesod.Content , module Yesod.Yesod - , module Yesod.Definitions , module Yesod.Handler , module Yesod.Dispatch , module Yesod.Form @@ -15,6 +14,7 @@ module Yesod , Application , cs , liftIO + , Routes ) where #if TEST @@ -30,7 +30,6 @@ import Yesod.Request import Yesod.Dispatch import Yesod.Form import Yesod.Yesod -import Yesod.Definitions import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet @@ -40,3 +39,4 @@ import "transformers" Control.Monad.IO.Class (liftIO) #else import "transformers" Control.Monad.Trans (liftIO) #endif +import Web.Routes.Quasi (Routes) diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs deleted file mode 100644 index a6140165..00000000 --- a/Yesod/Definitions.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} ---------------------------------------------------------- --- --- Module : Yesod.Definitions --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Definitions throughout Restful. --- ---------------------------------------------------------- -module Yesod.Definitions - ( -- * Type synonyms - Approot - , Language - -- * Constant values - , authCookieName - , authDisplayName - , encryptedCookies - , langKey - , destCookieName - , destCookieTimeout - -- * Other - , Routes - ) where - -import Data.ByteString.Char8 (pack, ByteString) -import Web.Routes.Quasi (Routes) - --- | An absolute URL to the base of this application. This can almost be done --- programatically, but due to ambiguities in different ways of doing URL --- rewriting for (fast)cgi applications, it should be supplied by the user. -type Approot = String - -type Language = String - -authCookieName :: String -authCookieName = "IDENTIFIER" - -authDisplayName :: String -authDisplayName = "DISPLAY_NAME" - -encryptedCookies :: [ByteString] -- FIXME make this extensible -encryptedCookies = [pack authDisplayName, pack authCookieName] - -langKey :: String -langKey = "_LANG" - -destCookieName :: String -destCookieName = "DEST" - -destCookieTimeout :: Int -destCookieTimeout = 120 diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 19369a09..d5712ba9 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -14,7 +14,6 @@ module Yesod.Dispatch import Yesod.Handler import Yesod.Content -import Yesod.Definitions import Yesod.Yesod import Yesod.Request import Yesod.Internal @@ -97,6 +96,9 @@ mkYesodGeneral name clazzes isSub res = do } return $ (if isSub then id else (:) yes) [w, x, y, z] +sessionName :: B.ByteString +sessionName = B.pack "_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 @@ -107,17 +109,23 @@ toWaiApp a = do $ jsonp $ methodOverride $ cleanPath - $ \thePath -> clientsession encryptedCookies key' mins -- FIXME allow user input for encryptedCookies + $ \thePath -> clientsession [sessionName] key' mins $ toWaiApp' a thePath +parseSession :: B.ByteString -> [(String, String)] +parseSession bs = case reads $ cs bs of + [] -> [] + ((x, _):_) -> x + toWaiApp' :: Yesod y => y -> [B.ByteString] -> [(B.ByteString, B.ByteString)] -> W.Request -> IO W.Response -toWaiApp' y resource session' env = do - let site = getSite +toWaiApp' y resource fullSession env = do + let session' = maybe [] parseSession $ lookup sessionName fullSession + site = getSite method = B.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) $ cleanupSegments resource @@ -188,8 +196,11 @@ fixSegs [x] | otherwise = [x, ""] -- append trailing slash fixSegs (x:xs) = x : fixSegs xs +langKey :: String +langKey = "_LANG" + parseWaiRequest :: W.Request - -> [(B.ByteString, B.ByteString)] -- ^ session + -> [(String, String)] -- ^ session -> IO Request parseWaiRequest env session' = do let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env @@ -203,9 +214,8 @@ parseWaiRequest env session' = do langs'' = case lookup langKey gets' of Nothing -> langs' Just x -> x : langs' - session'' = map (cs *** cs) session' rbthunk <- iothunk $ rbHelper env - return $ Request gets' cookies' session'' rbthunk env langs'' + return $ Request gets' cookies' session' rbthunk env langs'' rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index a33b05b9..a30c42be 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -23,10 +23,10 @@ import Text.Hamlet import Text.Hamlet.Monad (outputHtml) import Yesod.Content import Yesod.Handler -import Yesod.Definitions import Data.Convertible.Text import Data.Object -- FIXME should we kill this? import Control.Arrow ((***)) +import Web.Routes.Quasi (Routes) -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 52d4e656..39413f51 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -44,6 +44,9 @@ module Yesod.Handler , addCookie , deleteCookie , header + -- * Session + , setSession + , clearSession -- * Internal Yesod , runHandler , YesodApp (..) @@ -52,8 +55,9 @@ module Yesod.Handler import Yesod.Request import Yesod.Content import Yesod.Internal -import Yesod.Definitions import Web.Mime +import Web.Routes.Quasi (Routes) +import Data.List (foldl') import Control.Exception hiding (Handler) import Control.Applicative @@ -85,7 +89,8 @@ data HandlerData sub master = HandlerData -- site. This monad is a combination of reader for basic arguments, a writer -- for headers, and an error-type monad for handling special responses. newtype GHandler sub master a = Handler { - unHandler :: HandlerData sub master -> IO ([Header], HandlerContents a) + unHandler :: HandlerData sub master + -> IO ([Header], [(String, Maybe String)], HandlerContents a) } -- | A 'GHandler' limited to the case where the master and sub sites are the @@ -117,25 +122,25 @@ instance Applicative (GHandler sub master) where (<*>) = ap instance Monad (GHandler sub master) where fail = failure . InternalError -- We want to catch all exceptions anyway - return x = Handler $ \_ -> return ([], HCContent x) + return x = Handler $ \_ -> return ([], [], HCContent x) (Handler handler) >>= f = Handler $ \rr -> do - (headers, c) <- handler rr - (headers', c') <- + (headers, session', c) <- handler rr + (headers', session'', c') <- case c of HCContent a -> unHandler (f a) rr - HCError e -> return ([], HCError e) - HCSendFile ct fp -> return ([], HCSendFile ct fp) - HCRedirect rt url -> return ([], HCRedirect rt url) - return (headers ++ headers', c') + HCError e -> return ([], [], HCError e) + HCSendFile ct fp -> return ([], [], HCSendFile ct fp) + HCRedirect rt url -> return ([], [], HCRedirect rt url) + return (headers ++ headers', session' ++ session'', c') instance MonadIO (GHandler sub master) where - liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') + liftIO i = Handler $ \_ -> i >>= \i' -> return ([], [], HCContent i') instance Failure ErrorResponse (GHandler sub master) where - failure e = Handler $ \_ -> return ([], HCError e) + failure e = Handler $ \_ -> return ([], [], HCError e) instance RequestReader (GHandler sub master) where - getRequest = Handler $ \r -> return ([], HCContent $ handlerRequest r) + getRequest = handlerRequest <$> getData getData :: GHandler sub master (HandlerData sub master) -getData = Handler $ \r -> return ([], HCContent r) +getData = Handler $ \r -> return ([], [], HCContent r) -- | Get the application argument. getYesod :: GHandler sub master sub @@ -165,6 +170,16 @@ getRoute = handlerRoute <$> getData getRouteToMaster :: GHandler sub master (Routes sub -> Routes master) getRouteToMaster = handlerToMaster <$> getData +modifySession :: [(String, String)] -> (String, Maybe String) + -> [(String, String)] +modifySession orig (k, v) = + case v of + Nothing -> dropKeys k orig + Just v' -> (k, v') : dropKeys k orig + +dropKeys :: String -> [(String, x)] -> [(String, x)] +dropKeys k = filter $ \(x, _) -> x /= k + -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c @@ -179,7 +194,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) - (headers, contents) <- Control.Exception.catch + (headersOrig, session', contents) <- Control.Exception.catch (unHandler handler HandlerData { handlerRequest = rr , handlerSub = tosa ma @@ -188,7 +203,9 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do , handlerRender = mrender , handlerToMaster = tomr }) - (\e -> return ([], HCError $ toErrorHandler e)) + (\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 let hs' = headers ++ hs @@ -221,14 +238,14 @@ redirect rt url = do -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt url = Handler $ \_ -> return ([], HCRedirect rt url) +redirectString rt url = Handler $ \_ -> return ([], [], HCRedirect rt url) -- | Bypass remaining handler code and output the given file. -- -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct fp = Handler $ \_ -> return ([], HCSendFile ct fp) +sendFile ct fp = Handler $ \_ -> return ([], [], HCSendFile ct fp) -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a @@ -264,8 +281,22 @@ deleteCookie = addHeader . DeleteCookie header :: String -> String -> GHandler sub master () header a = addHeader . Header a +-- | Set a variable in the user's session. +-- +-- The session is handled by the clientsession package: it sets an encrypted +-- and hashed cookie on the client. This ensures that all data is secure and +-- not tampered with. +setSession :: String -- ^ key + -> String -- ^ value + -> GHandler sub master () +setSession k v = Handler $ \_ -> return ([], [(k, Just v)], HCContent ()) + +-- | Unsets a session variable. See 'setSession'. +clearSession :: String -> GHandler sub master () +clearSession k = Handler $ \_ -> return ([], [(k, Nothing)], HCContent ()) + addHeader :: Header -> GHandler sub master () -addHeader h = Handler $ \_ -> return ([h], HCContent ()) +addHeader h = Handler $ \_ -> return ([h], [], HCContent ()) getStatus :: ErrorResponse -> W.Status getStatus NotFound = W.Status404 diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index b04dbb12..360be935 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -46,6 +46,7 @@ import Data.Typeable (Typeable) import Control.Exception (Exception) -- FIXME check referer header to determine destination +-- FIXME switch to session getAuth :: a -> Auth getAuth = const Auth @@ -249,3 +250,15 @@ redirectToDest rt def = do deleteCookie destCookieName return x redirectString rt dest + +authCookieName :: String -- FIXME don't use cookies!!! +authCookieName = "IDENTIFIER" + +authDisplayName :: String +authDisplayName = "DISPLAY_NAME" + +destCookieTimeout :: Int +destCookieTimeout = 120 + +destCookieName :: String +destCookieName = "DEST" diff --git a/Yesod/Json.hs b/Yesod/Json.hs index e300b124..081df005 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -24,10 +24,10 @@ import Control.Applicative import Data.Text (Text, pack) import Web.Encodings import Yesod.Hamlet -import Yesod.Definitions import Control.Monad (when) import Yesod.Handler import Yesod.Content +import Web.Routes.Quasi (Routes) #if TEST import Test.Framework (testGroup, Test) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 574d1ba9..e7ae9b32 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -35,7 +35,6 @@ module Yesod.Request ) where import qualified Network.Wai as W -import Yesod.Definitions import Web.Encodings import qualified Data.ByteString.Lazy as BL #if MIN_VERSION_transformers(0,2,0) @@ -56,7 +55,7 @@ instance RequestReader ((->) Request) where getRequest = id -- | Get the list of supported languages supplied by the user. -languages :: RequestReader m => m [Language] +languages :: RequestReader m => m [String] languages = reqLangs `liftM` getRequest -- | Get the request\'s 'W.Request' value. @@ -82,7 +81,7 @@ data Request = Request , reqRequestBody :: IO RequestBodyContents , reqWaiRequest :: W.Request -- | Languages which the client supports. - , reqLangs :: [Language] + , reqLangs :: [String] } multiLookup :: [(ParamName, ParamValue)] -> ParamName -> [ParamValue] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index d70ef4a1..9c61f3f7 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -20,11 +20,10 @@ import Data.Convertible.Text import Control.Arrow ((***)) import Network.Wai.Middleware.ClientSession import qualified Network.Wai as W -import Yesod.Definitions import Yesod.Json import Yesod.Internal -import Web.Routes.Quasi (QuasiSite (..)) +import Web.Routes.Quasi (QuasiSite (..), Routes) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -44,7 +43,7 @@ class YesodSite a => Yesod a where -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. - approot :: a -> Approot + approot :: a -> String -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 diff --git a/yesod.cabal b/yesod.cabal index 3da5cdbf..8b140bd4 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -35,7 +35,6 @@ library transformers >= 0.1 && < 0.3 exposed-modules: Yesod Yesod.Content - Yesod.Definitions Yesod.Dispatch Yesod.Form Yesod.Hamlet