haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added proper sessions

Browse Source
This commit is contained in:
Michael Snoyman 2010-05-05 00:46:54 +03:00
parent 8d58cc8051
commit fd0ce32687
10 changed files with 87 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Yesod.hs
View File

@ -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)

58
Yesod/Definitions.hs
View File

@ -1,58 +0,0 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
---------------------------------------------------------
--
-- Module : Yesod.Definitions
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- 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

24
Yesod/Dispatch.hs
View File

@ -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

2
Yesod/Hamlet.hs
View File

@ -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:

67
Yesod/Handler.hs
View File

@ -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

13
Yesod/Helpers/Auth.hs
View File

@ -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"

2
Yesod/Json.hs
View File

@ -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)

5
Yesod/Request.hs
View File

@ -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]

5
Yesod/Yesod.hs
View File

@ -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

1
yesod.cabal
View File

@ -35,7 +35,6 @@ library
transformers >= 0.1 && < 0.3
exposed-modules: Yesod
Yesod.Content
Yesod.Definitions
Yesod.Dispatch
Yesod.Form
Yesod.Hamlet