Added proper sessions

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)

Yesod/Definitions.hs

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

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
+toWaiApp' y resource fullSession env = do
-    let site = getSite
+    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

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:

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, session', c) <- handler rr
-        (headers', c') <-
+        (headers', session'', c') <-
             case c of
                 HCContent a -> unHandler (f a) rr
-                HCError e -> return ([], HCError e)
+                HCError e -> return ([], [], HCError e)
-                HCSendFile ct fp -> return ([], HCSendFile ct fp)
+                HCSendFile ct fp -> return ([], [], HCSendFile ct fp)
-                HCRedirect rt url -> return ([], HCRedirect rt url)
+                HCRedirect rt url -> return ([], [], HCRedirect rt url)
-        return (headers ++ headers', c')
+        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

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"

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)

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]

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

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