Permalink
Browse files

Adding Cookies and Sessions

  • Loading branch information...
1 parent 655e05e commit caa17e6af90e0daa525791d0e2d6230ee75f7ad2 @alsonkemp committed Feb 9, 2009
View
21 App/Controllers/TestCookies.hs
@@ -0,0 +1,21 @@
+import Turbinado.Controller
+
+createCounter :: Controller ()
+createCounter = do clearLayout
+ setCookie $ mkCookie "counter" (show 0)
+ setViewDataValue "show-me" "0"
+
+incrementCounter :: Controller ()
+incrementCounter = do clearLayout
+ c <- getCookie "counter"
+ case c of
+ Nothing -> do setCookie $ mkCookie "counter" (show 0)
+ setViewDataValue "show-me" (0::Int)
+ Just c' -> do let ctr = read c' :: Int
+ setCookie $ mkCookie "counter" (show $ ctr + 1)
+ setViewDataValue "show-me" $ show (ctr+1)
+
+deleteCounter :: Controller ()
+deleteCounter = do clearLayout
+ deleteCookie "counter"
+ setViewDataValue "show-me" "deleted"
View
22 App/Controllers/TestSession.hs
@@ -0,0 +1,22 @@
+import Turbinado.Controller
+
+createCounter :: Controller ()
+createCounter = do clearLayout
+ setSessionValue "counter" "0"
+ setViewDataValue "show-me" "0"
+
+incrementCounter :: Controller ()
+incrementCounter = do clearLayout
+ e <- getEnvironment
+ setViewDataValue "show-session" $ show $ fromJust $ getSession e
+ c <- getSessionValue "counter"
+ case c of
+ Nothing -> setViewDataValue "show-me" "No counter found in session"
+ Just c' -> do let ctr = read c' :: Int
+ setSessionValue "counter" (show $ ctr + 1)
+ setViewDataValue "show-me" $ show (ctr+1)
+
+deleteCounter :: Controller ()
+deleteCounter = do clearLayout
+ deleteSessionKey "counter"
+ setViewDataValue "show-me" "deleted"
View
3 App/Views/TestCookies/CreateCounter.hs
@@ -0,0 +1,3 @@
+markup = <div>
+ <% getViewDataValue_u "show-me" :: View String %>
+ </div>
View
1 App/Views/TestCookies/DeleteCounter.hs
@@ -0,0 +1 @@
+markup = <div><% getViewDataValue_u "show-me" :: View String %></div>
View
1 App/Views/TestCookies/IncrementCounter.hs
@@ -0,0 +1 @@
+markup = <div><% getViewDataValue_u "show-me" :: View String %></div>
View
3 App/Views/TestSession/CreateCounter.hs
@@ -0,0 +1,3 @@
+markup = <div>
+ <% getViewDataValue_u "show-me" :: View String %>
+ </div>
View
1 App/Views/TestSession/DeleteCounter.hs
@@ -0,0 +1 @@
+markup = <div><% getViewDataValue_u "show-me" :: View String %></div>
View
3 App/Views/TestSession/IncrementCounter.hs
@@ -0,0 +1,3 @@
+markup = <div><% getViewDataValue_u "show-me" :: View String %>
+ <div><% getViewDataValue_u "show-session" :: View String %></div>
+ </div>
View
29 Config/App.hs
@@ -1,8 +1,7 @@
module Config.App (
applicationPath,
applicationHost,
- AppEnvironment (..),
- newAppEnvironment,
+ useLowerCasePaths,
databaseConnection,
Connection,
customSetupFilters,
@@ -16,28 +15,44 @@ import System.Log.Logger
-- Your favorite HDBC driver
import Database.HDBC.PostgreSQL
+import Turbinado.Controller.Monad
+import Turbinado.Environment.Types
+import Turbinado.Environment.Session.CookieSession
+
----------------------------------------------------------------
-- Environment settings
----------------------------------------------------------------
applicationPath = ""
applicationHost = "localhost:8080"
-data AppEnvironment = AppEnvironment
-newAppEnvironment = AppEnvironment
+-- | Determines whether the server uses URLs of the form FooBar/BimBam or foo_bar/bim_bam.
+-- The Controllers and Views must still be named FooBar.hs and BimBam.hs.
+useLowerCasePaths = True
----------------------------------------------------------------
-- Database connection
----------------------------------------------------------------
-databaseConnection :: Maybe (IO Connection)
+-- databaseConnection :: Maybe (IO Connection)
-- databaseConnection = Nothing
databaseConnection = Just $ connectPostgreSQL "host=localhost dbname=turbinado user=turbinado password=turbinado"
----------------------------------------------------------------
+-- Session stuff
+----------------------------------------------------------------
+sessionOpts = [ ("cookie-name", "turb-sess")
+ , ("cipher-key", "super secret phrase")
+ ]
+
+----------------------------------------------------------------
-- RequestHandler Filter List additions
----------------------------------------------------------------
+
+customSetupFilters :: [Controller ()]
customSetupFilters = []
-customPreFilters = []
-customPostFilters = []
+customPreFilters :: [Controller ()]
+customPreFilters = [retrieveSession sessionOpts]
+customPostFilters :: [Controller ()]
+customPostFilters = [persistSession sessionOpts]
----------------------------------------------------------------
View
4 README
@@ -1 +1,3 @@
-Turbinado is a stab at producing a Rails-ish MVC web framework for Haskell. A very early stab...
+Turbinado is a Rails-ish MVC web framework for Haskell.
+See the homepage @ http://www.turbinado.org
+
View
2 Turbinado/Controller.hs
@@ -22,6 +22,7 @@ module Turbinado.Controller (
module Config.Master,
module Turbinado.Environment.CodeStore,
+ module Turbinado.Environment.Cookie,
module Turbinado.Environment.Header,
module Turbinado.Environment.Logger,
module Turbinado.Environment.Params,
@@ -43,6 +44,7 @@ import qualified Database.HDBC as HDBC
import Config.Master
import Turbinado.Environment.CodeStore
+import Turbinado.Environment.Cookie
import Turbinado.Environment.Database
import Turbinado.Environment.Header
import Turbinado.Environment.Logger
View
13 Turbinado/Environment/CodeStore.hs
@@ -9,6 +9,8 @@ import Control.Monad ( when, foldM)
import Data.Map hiding (map)
import Data.List (isPrefixOf, intersperse)
import Data.Maybe
+import Data.Time
+import Data.Time.Clock.POSIX
import Data.Typeable
import qualified Network.HTTP as HTTP
import Prelude hiding (lookup,catch)
@@ -43,8 +45,7 @@ retrieveCode ct cl' = do
e <- getEnvironment
let (CodeStore mv) = fromJust $ getCodeStore e
path = getDir ct
- cl <- do -- d <- getCurrentDirectory
- return (addExtension (joinPath $ map normalise [path, dropExtension $ fst cl']) "hs", snd cl')
+ cl <- return (addExtension (joinPath $ map normalise [path, dropExtension $ fst cl']) "hs", snd cl')
debugM $ " CodeStore : retrieveCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
cmap <- liftIO $ takeMVar mv
let c= lookup cl cmap
@@ -92,8 +93,8 @@ checkReloadCode ct cmap cstat cl = do
needReloadCode fp fd = do
fe <- liftIO $ doesFileExist fp
case fe of
- True -> do mt <- liftIO $ getModificationTime fp
- return $ (True, mt > fd)
+ True -> do TOD mt _ <- liftIO $ getModificationTime fp
+ return $ (True, fromIntegral mt > utcTimeToPOSIXSeconds fd)
False-> return (False, True)
@@ -152,7 +153,7 @@ _loadView ct cmap cl args fp = do
return (insert cl (CodeLoadFailure $ unlines err) cmap)
LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
liftIO $ unload m
- t <- liftIO $ getClockTime
+ t <- liftIO $ getCurrentTime
case ct of
CTLayout -> return (insert cl (CodeLoadView f t) cmap)
CTView -> return (insert cl (CodeLoadView f t) cmap)
@@ -170,7 +171,7 @@ _loadController ct cmap cl args fp = do
return (insert cl (CodeLoadFailure $ unlines err) cmap)
LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
liftIO $ unload m
- t <- liftIO $ getClockTime
+ t <- liftIO $ getCurrentTime
case ct of
CTController -> return (insert cl (CodeLoadController f t) cmap)
CTComponentController -> return (insert cl (CodeLoadComponentController f t) cmap)
View
180 Turbinado/Environment/Cookie.hs
@@ -1,116 +1,108 @@
-module Turbinado.Data.Cookie where
-
-import Data.Char (isSpace)
-import Data.List (intersperse)
-import Data.Maybe (catMaybes)
-import System.Locale (defaultTimeLocale, rfc822DateFormat)
-import System.Time (CalendarTime(..), Month(..), Day(..),
- formatCalendarTime)
-
+-----------------------------------------------------------------------------
+-- |
+-- Module : Turbinado.Environment.Cookie
+-- Copyright : (c) Alson Kemp 2008-2009
+-- (c) Bjorn Bringert 2004-2005
+-- (c) Ian Lynagh 2005
+-- License : BSD-style
+--
+-- Maintainer : alson@alsonkemp.com
+-- Stability : experimental
+-- Portability : portable
--
--- * Types
+-- General server side HTTP cookie library.
+-- Based on <http://wp.netscape.com/newsref/std/cookie_spec.html>
+-- Lifted in near entirety from the CGI package (http://hackage.haskell.org/cgi-bin/hackage-scripts/package/cgi)
--
+-----------------------------------------------------------------------------
--- | Contains all information about a cookie set by the server.
-data Cookie = Cookie {
- -- | Name of the cookie.
- cookieName :: String,
- -- | Value of the cookie.
- cookieValue :: String,
- -- | Expiry date of the cookie. If 'Nothing', the
- -- cookie expires when the browser sessions ends.
- -- If the date is in the past, the client should
- -- delete the cookie immediately.
- cookieExpires :: Maybe CalendarTime,
- -- | The domain suffix to which this cookie will be sent.
- cookieDomain :: Maybe String,
- -- | The path to which this cookie will be sent.
- cookiePath :: Maybe String,
- -- | 'True' if this cookie should only be sent using
- -- secure means.
- cookieSecure :: Bool
- }
- deriving (Show, Read, Eq, Ord)
+module Turbinado.Environment.Cookie
+ ( mkCookie
+ , getCookie
+ , setCookie
+ , deleteCookie
+ , readCookies
+ , showCookie
+ ) where
+import Data.Char (isSpace)
+import Data.List (intercalate)
+import Data.Maybe (catMaybes, fromJust)
+import System.Locale (defaultTimeLocale, rfc822DateFormat)
+import Data.Time
+import Network.HTTP.Headers
+import Turbinado.Environment.Header
+import Turbinado.Environment.Response
+import Turbinado.Environment.Types
--
--- * Constructing cookies
+-- * Getting cookies
--
+-- | Get the value of a cookie from a string on the form
+-- @\"cookieName1=cookieValue1;...;cookieName2=cookieValue2\"@.
+-- This is the format of the @Cookie@ HTTP header.
+getCookie :: HasEnvironment m =>
+ String -- ^ Cookie name
+ -> m (Maybe String) -- ^ Cookie value, if found
+getCookie name = do e <- getEnvironment
+ h <- getHeader HdrCookie
+ case h of
+ Nothing -> return Nothing
+ Just h' -> return $ maybeLast [ cv | (cn,cv) <- readCookies h', cn == name ]
+
+--
+-- * Setting Cookies
+--
+
+setCookie :: HasEnvironment m =>
+ Cookie ->
+ m ()
+setCookie c = do e <- getEnvironment
+ let r = fromJust $ getResponse e
+ setResponse $ insertHeaders [Header HdrSetCookie $ showCookie c] r
+
-- | Construct a cookie with only name and value set.
-- This client will expire when the browser sessions ends,
-- will only be sent to the server and path which set it
-- and may be sent using any means.
-newCookie :: String -- ^ Name
- -> String -- ^ Value
- -> Cookie -- ^ Cookie
-newCookie name value = Cookie { cookieName = name,
- cookieValue = value,
- cookieExpires = Nothing,
- cookieDomain = Nothing,
- cookiePath = Nothing,
- cookieSecure = False
+mkCookie :: String -- ^ Name
+ -> String -- ^ Value
+ -> Cookie -- ^ Cookie
+mkCookie name value = Cookie { cookieName = name,
+ cookieValue = value,
+ cookieExpires = Nothing,
+ cookieDomain = Nothing,
+ cookiePath = Nothing
}
---
--- * Getting and setting cookies
---
-
--- | Get the value of a cookie from a string on the form
--- @\"cookieName1=cookieValue1;...;cookieName2=cookieValue2\"@.
--- This is the format of the @Cookie@ HTTP header.
-findCookie :: String -- ^ Cookie name
- -> String -- ^ Semicolon separated list of name-value pairs
- -> Maybe String -- ^ Cookie value, if found
-findCookie name s = maybeLast [ cv | (cn,cv) <- readCookies s, cn == name ]
-
-- | Delete a cookie from the client by setting the cookie expiry date
-- to a date in the past.
-deleteCookie :: Cookie -- ^ Cookie to delete. The only fields that matter
- -- are 'cookieName', 'cookieDomain' and 'cookiePath'
- -> Cookie
-deleteCookie c = c { cookieExpires = Just epoch }
- where
- epoch = CalendarTime {
- ctYear = 1970,
- ctMonth = January,
- ctDay = 1,
- ctHour = 0,
- ctMin = 0,
- ctSec = 0,
- ctPicosec = 0,
- ctWDay = Thursday,
- ctYDay = 1,
- ctTZName = "GMT",
- ctTZ = 0,
- ctIsDST = False
- }
-
+deleteCookie :: HasEnvironment m =>
+ String -- ^ Cookie to delete.
+ -> m ()
+deleteCookie c = setCookie $ c' { cookieExpires = Just epoch }
+ where
+ c' = mkCookie c ""
+ epoch = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)
--
--- * Reading and showing cookies
+-- * Showing cookies
--
--- | Show a cookie on the format used as the value of the Set-Cookie header.
+-- | Show a cookie in the format used as the value of the Set-Cookie header.
showCookie :: Cookie -> String
-showCookie c = concat $ intersperse "; " $
+showCookie c = intercalate "; " $
showPair (cookieName c) (cookieValue c)
- : catMaybes [expires, path, domain, secure]
+ : catMaybes [expires, path, domain]
where expires = fmap (showPair "expires" . dateFmt) (cookieExpires c)
domain = fmap (showPair "domain") (cookieDomain c)
- path = fmap (showPair "path") (cookiePath c)
- secure = if cookieSecure c then Just "secure" else Nothing
- dateFmt = formatCalendarTime defaultTimeLocale rfc822DateFormat
-
--- | Show a name-value pair. FIXME: if the name or value
--- contains semicolons, this breaks. The problem
--- is that the original cookie spec does not mention
--- how to do escaping or quoting.
-showPair :: String -- ^ name
- -> String -- ^ value
- -> String
-showPair name value = name ++ "=" ++ value
+ path = fmap (showPair "path") (maybe (Just "/") Just (cookiePath c))
+ dateFmt = formatTime defaultTimeLocale rfc822DateFormat
+--
+-- * Reading cookies
+--
-- | Gets all the cookies from a Cookie: header value
readCookies :: String -- ^ String to parse
@@ -121,7 +113,7 @@ readCookies s =
in if null xs then [] else (xs,zs):readCookies (drop 1 ws)
--
--- Utilities
+-- * Utilities
--
-- | Return 'Nothing' is the list is empty, otherwise return
@@ -130,4 +122,14 @@ maybeLast :: [a] -> Maybe a
maybeLast [] = Nothing
maybeLast xs = Just (last xs)
+-- | Show a name-value pair. FIXME: if the name or value
+-- contains semicolons, this breaks. The problem
+-- is that the original cookie spec does not mention
+-- how to do escaping or quoting.
+showPair :: String -- ^ name
+ -> String -- ^ value
+ -> String
+showPair name value = name ++ "=" ++ value
+
+
View
5 Turbinado/Environment/Database.hs
@@ -10,8 +10,7 @@ import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Data.Maybe
-import qualified Database.HDBC as HDBC
-import Database.HDBC (IConnection)
+import Database.HDBC
import Config.Master
import Turbinado.Controller.Monad
@@ -23,5 +22,5 @@ addDatabaseToEnvironment = do e <- getEnvironment
case databaseConnection of
Nothing -> return ()
Just conn -> do c <- liftIO $ conn
- setEnvironment $ e {getDatabase = Just c}
+ setEnvironment $ e {getDatabase = Just (ConnWrapper c)}
View
4 Turbinado/Environment/Response.hs
@@ -16,6 +16,10 @@ import System.Time
import System.Locale
+--getResponse :: (HasEnvironment m) => m HTTP.Response
+--getResponse = do e <- getEnvironment
+-- return $ getResponse e
+
setResponse :: (HasEnvironment m) => HTTP.Response -> m ()
setResponse resp = do e <- getEnvironment
setEnvironment $ e {getResponse = Just resp}
View
132 Turbinado/Environment/Session.hs
@@ -1,132 +0,0 @@
-module Turbinado.Environment.Session (
- Session -- ^ Abstract
- -- * Functions used in HSP
- , getVarValue -- ^ :: Session -> Key -> (Maybe Value)
- , setVarValue -- ^ :: Session -> Key -> Value -> ()
- , deleteVar -- ^ :: Session -> Key -> ()
- , abandon -- ^ :: Session -> ()
- , setExpires -- ^ :: Session -> UTCTime -> ()
- -- * Functions used by the RTS
- , isSession -- ^ :: Session -> Bool
- , getSessionId -- ^ :: Session -> (Maybe SessionId)
- , getExpires -- ^ :: Session -> Expires
- , initSession -- ^ :: [(Key, Value)] -> Session
- , noSession -- ^ :: Session
- , getNewVars -- ^ :: Session -> [(Key, (Value, Expires))]
- , getUpdatedVars -- ^ :: Session -> [(Key, (Value, Expires))]
- , getDeletedVars -- ^ :: Session -> [Key]
- ) where
-
-import qualified Data.Map as M
-import Data.Time
-
--------------------------------------
--- Help types
-
-type Expires = Maybe UTCTime
-type Key = String
-type Value = String
-type SessionId = Int
-
-neverExpire :: Expires
-neverExpire = Nothing
-
-expire :: UTCTime -> Expires
-expire = Just
-
-data Status = New | Orig | Updated | Deleted
- deriving (Eq)
-
-updateStatus :: Status -> Status
-updateStatus s = case s of
- New -> New
- _ -> Updated
-
-----------------------------------------
--- The main datatypes
-
--- | The 'Session' datatype is basically a data repository.
--- To keep tracks of updates, we use an extra repository.
-newtype Session = Session (Maybe SessionData)
-
-data SessionData = SessionData {
- sessionId :: Maybe SessionId,
- expires :: Expires,
- dataRep :: M.Map Key (Value,Expires,Status)
- }
-
--- | Create a new 'Session' object with initial data.
-initSession :: SessionId -> Expires -> [(Key, (Value, Expires))] -> Session
-initSession sid exps initData =
- let dat = map (\(k,(v,e)) -> (k,(v,e,Orig))) initData
- rep = M.fromList dat
- sd = SessionData {
- dataRep = rep,
- expires = exps,
- sessionId = Just sid } in
- Session (Just sd)
-
-noSession :: Session
-noSession = Session Nothing
-
----------------------------------------
--- Operate on sessions
-
--- | Retrieve the value of a variable in the repository.
-getVarValue :: Session -> Key -> Maybe Value
-getVarValue (Session Nothing) k = Nothing
-getVarValue (Session (Just sd)) k =
- case (M.lookup k (dataRep sd)) of
- Nothing -> Nothing
- Just (v,e,Deleted) -> Nothing
- Just (v,e,_) -> Just v
-
-setVarValue :: Session -> Key -> Value -> Session
-setVarValue (Session Nothing) k v = error "Tried to setVarValue without a valid session"
-setVarValue (Session (Just sd)) k v =
- case (M.lookup k (dataRep sd)) of
- Nothing -> Session $ Just $ sd {dataRep = M.insert k (v, neverExpire, New) (dataRep sd)}
- Just (_,e,st) -> Session $ Just $ sd {dataRep = M.insert k (v, e, updateStatus st) (dataRep sd)}
-
-deleteVar :: Session -> Key -> Session
-deleteVar (Session Nothing) k = (Session Nothing)
-deleteVar (Session (Just sd)) k = Session $ Just $ sd {dataRep = M.delete k (dataRep sd)}
-
-abandon :: Session -> Session
-abandon (Session mvs) = (Session Nothing)
-
-setExpires :: Session -> UTCTime -> Session
-setExpires (Session Nothing) ct = error "Tried to setVarValue without a valid session"
-setExpires (Session (Just sd)) ct = Session $ Just $ sd {expires = expire ct}
-
------------------------------------------
--- Used by HSPR
-
-isSession :: Session -> Bool
-isSession (Session Nothing) = False
-isSession _ = True
-
-
-getSessionId :: Session -> Maybe SessionId
-getSessionId (Session Nothing) = Nothing
-getSessionId (Session (Just sd)) = sessionId sd
-
-getExpires :: Session -> Expires
-getExpires (Session Nothing) = Nothing
-getExpires (Session (Just sd)) = expires sd
-
-
-getVars :: Status -> Session -> [(Key, (Value, Expires))]
-getVars status (Session Nothing) = []
-getVars status (Session (Just sd)) =
- let vals = M.toList (dataRep sd)
- newVals = filter (\(_,(_,_,st)) -> st == status) vals
- in map (\(k,(v,e,_)) -> (k,(v,e))) newVals
-
-getNewVars, getUpdatedVars :: Session -> [(Key, (Value, Expires))]
-getNewVars = getVars New
-getUpdatedVars = getVars Updated
-
-getDeletedVars :: Session -> [Key]
-getDeletedVars (Session Nothing) = []
-getDeletedVars s = map fst $ getVars Deleted s
View
157 Turbinado/Environment/Session/CookieSession.hs
@@ -0,0 +1,157 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Turbinado.Environment.Session.CookieSession
+-- Copyright : (c) Niklas Broberg 2004, Michael Snoyman 2008-2009, Alson Kemp 2009
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : Alson Kemp, alson@alsonkemp.com
+-- Stability : experimental
+-- Portability : requires undecidable and overlapping instances
+--
+-- Much of this code is lifted/derived from Niklas' HSP and from Michael's HWeb.
+-----------------------------------------------------------------------------
+module Turbinado.Environment.Session.CookieSession where
+
+import Control.Monad.Trans
+import Data.List
+import Data.Maybe
+import qualified Data.Map as M
+import Data.Time
+import System.IO
+
+import qualified Data.Digest.MD5 as MD5
+import Data.LargeWord (Word128)
+import Data.Word (Word8)
+import Codec.Encryption.Modes
+import qualified Codec.Encryption.AES as AES
+import qualified Codec.Binary.Base64 as Base64
+import Codec.Utils
+import qualified Network.HTTP.Headers as Headers
+import Turbinado.Environment.Cookie
+import Turbinado.Environment.Types
+
+type Key = String
+type Value = String
+
+
+instance (HasEnvironment m) => HasSession m where
+ newSession opts = let n = maybe
+ (error "'cookie-name' didn't exist in options passed to newSession")
+ id
+ (lookup "cookie-name" opts)
+ in _setSession $ emptySession { sessionName = Just n }
+ hasValidSession = do e <- getEnvironment
+ case getSession e of
+ Nothing -> return False
+ Just s -> case expires s of
+ Nothing -> return True
+ Just t -> do now <- liftIO $ getCurrentTime
+ return $ t > now
+ retrieveSession opts = do let c = maybe
+ (error "'cipher-key' didn't exist in options passed to retrieveSession")
+ id
+ (lookup "cipher-key" opts)
+ n = maybe
+ (error "'cookie-name' didn't exist in options passed to retrieveSession")
+ id
+ (lookup "cookie-name" opts)
+ message'' <- getCookie n
+ e <- getEnvironment
+ case message'' of
+ Nothing -> newSession opts
+ Just m'' -> let message' = maybeRead m'' in
+ case message' of
+ Nothing -> newSession opts
+ Just (m, h) -> do let messageBlocks = unCbc AES.decrypt 0 (w8ToKey $ MD5.hash $ stringToW8 c) (w8ToBlocks $ fromJust $ Base64.decode m)
+ hashCode = fromJust $ Base64.decode h
+ hashCheck = MD5.hash $ blocksToW8 messageBlocks
+ if (hashCode == hashCheck)
+ then let s = read (w8ToString $ blocksToW8 messageBlocks) in
+ case (expires s) of
+ Nothing -> do _setSession s
+ Just t -> do t' <- liftIO $ getCurrentTime
+ if (t > t')
+ then _setSession s
+ else newSession opts
+ else newSession opts
+ persistSession opts = do s <- _getSession
+ let c = maybe
+ (error "'cipher-key' didn't exist in options passed to persistSession")
+ id
+ (lookup "cipher-key" opts)
+ ex = maybe
+ Nothing
+ maybeReadUTC
+ (lookup "session-expires" opts)
+ message = stringToW8 $ show s
+ cipheredMessage = Base64.encode $ blocksToW8 $ cbc AES.encrypt 0 (w8ToKey $ MD5.hash $ stringToW8 c) (w8ToBlocks message)
+ hashCode = Base64.encode $ MD5.hash message
+ setCookie
+ (Cookie {cookieName = fromJust $ sessionName s
+ ,cookieValue = (show $ (cipheredMessage, hashCode))
+ ,cookieExpires = ex
+ ,cookieDomain = Nothing
+ ,cookiePath = Nothing
+ }
+ )
+ abandonSession = do e <- getEnvironment
+ let s = getSession e
+ case s of
+ Nothing -> return ()
+ Just s' -> deleteCookie (fromJust $ sessionName s')
+ setEnvironment $ e {getSession = Nothing}
+ getSessionValue k = do s <- _getSession
+ return $ M.lookup k $ dataRep s
+ setSessionValue k v = do s <- _getSession
+ let s' = s {dataRep = M.insert k v (dataRep s)}
+ _setSession s'
+ deleteSessionKey k = do s <- _getSession
+ let s' = s {dataRep = M.delete k (dataRep s)}
+ _setSession s'
+ getSessionExpires = (return . expires) =<< _getSession
+ setSessionExpires ct = do s <- _getSession
+ let s' = s {expires = ct}
+ _setSession s'
+ setSessionId sid = do s <- _getSession
+ let s' = s {sessionId = sid}
+ _setSession s'
+ getSessionId = (return . sessionId) =<< _getSession
+
+
+--
+-- * Helpers
+--
+stringToW8 :: String -> [Word8]
+stringToW8 = map (fromInteger . toInteger . fromEnum)
+
+w128ToW8 :: Word128 -> [Word8]
+w128ToW8 w128 = toOctets 256 w128
+
+w8ToString :: [Word8] -> String
+w8ToString = map (toEnum . fromInteger . toInteger)
+
+blocksToString :: [[Word8]] -> String
+blocksToString ws = concat $ map w8ToString ws
+
+blocksToW8 :: [Word128] -> [Word8]
+blocksToW8 ws = concat $ map w128ToW8 ws
+
+w8ToKey :: [Word8] -> Word128
+w8ToKey ws = fromInteger $ foldl (\acc i -> acc*256 + toInteger i) (0::Integer) ws
+
+w8ToBlocks :: [Word8] -> [Word128]
+w8ToBlocks ws = map w8ToKey $ breakup ws
+ where breakup [] = []
+ breakup ws = (take 16 ws) : (breakup $ drop 16 ws)
+
+maybeRead = listToMaybe . map fst . filter (null . snd) . reads
+maybeReadUTC :: String -> Maybe UTCTime
+maybeReadUTC = listToMaybe . map fst . filter (null . snd) . reads
+
+_getSession :: (HasEnvironment m) => m Session
+_getSession = getEnvironment >>= (return . fromJust . getSession)
+
+_setSession :: (HasEnvironment m) => Session -> m ()
+_setSession s = getEnvironment >>= (\e -> setEnvironment $ e {getSession = Just s})
+
+
View
14 Turbinado/Environment/Settings.hs
@@ -18,6 +18,8 @@ import System.FilePath
import Turbinado.Environment.Logger
import Turbinado.Environment.Types
import Turbinado.Controller.Monad
+import Turbinado.Utility.Naming
+import qualified Config.Master as Config
-- | Used during request initialization to add the 'Settings' 'Map'
-- to the 'Environment'.
@@ -76,8 +78,11 @@ defaultSettings = [ ("layout", toDyn "Default") ]
getController :: (HasEnvironment m) => m (FilePath, String)
getController = do c <- getSetting_u "controller"
a <- getSetting_u "action"
- return $ (c,
- actionName a)
+ let converter = if Config.useLowerCasePaths
+ then fromUnderscore
+ else id
+ return $ (converter c,
+ actionName $ converter a)
where actionName s = (toLower $ head s) : (tail s)
-- | Tells the 'Controller' to use a particular 'Layout' for the 'View'.
@@ -92,5 +97,8 @@ clearLayout = unsetSetting "layout"
getView :: (HasEnvironment m) => m (FilePath, String)
getView = do c <- getSetting_u "controller"
a <- getSetting_u "action"
- return (joinPath $ map normalise [c,a], "markup")
+ let converter = if Config.useLowerCasePaths
+ then fromUnderscore
+ else id
+ return (joinPath $ map normalise [converter c, converter a], "markup")
View
78 Turbinado/Environment/Types.hs
@@ -3,6 +3,7 @@ module Turbinado.Environment.Types where
import Data.Dynamic
import qualified Data.Map as M
import Data.Maybe
+import Data.Time
import System.IO
import System.IO.Unsafe
import System.Log.Logger
@@ -12,8 +13,7 @@ import Control.Monad.State
import qualified Network.HTTP as HTTP
import HSX.XMLGenerator (XMLGenT(..), unXMLGenT)
import Turbinado.View.XML
-import Config.Master
-import System.Time
+import Database.HDBC
-- | The class of types which hold an 'Environment'.
@@ -25,17 +25,18 @@ class (MonadIO m) => HasEnvironment m where
-- | The Environment in which each request is handled.
-- All components are held within 'Maybe's so that the
-- Environment can be partially constructed.
-data Environment = Environment { getCodeStore :: Maybe CodeStore
- , getDatabase :: Maybe Database
- , getLoggerLock :: Maybe LoggerLock
- , getMimeTypes :: Maybe MimeTypes
- , getRequest :: Maybe HTTP.Request
- , getResponse :: Maybe HTTP.Response
- , getRoutes :: Maybe Routes
- , getSettings :: Maybe Settings
- , getViewData :: Maybe ViewData
- , getAppEnvironment :: Maybe AppEnvironment
- }
+data Environment = Environment { getCodeStore :: Maybe CodeStore
+ , getDatabase :: Maybe ConnWrapper
+ , getLoggerLock :: Maybe LoggerLock
+ , getMimeTypes :: Maybe MimeTypes
+ , getRequest :: Maybe HTTP.Request
+ , getResponse :: Maybe HTTP.Response
+ , getRoutes :: Maybe Routes
+ , getSession :: Maybe Session
+ , getSettings :: Maybe Settings
+ , getViewData :: Maybe ViewData
+ , getAppEnvironment :: Maybe (MVar Dynamic)
+ }
-- | Construct a new empty 'Environment'.
newEnvironment :: Environment
@@ -46,6 +47,7 @@ newEnvironment = Environment { getCodeStore = Nothing
, getRequest = Nothing
, getResponse = Nothing
, getRoutes = Nothing
+ , getSession = Nothing
, getSettings = Nothing
, getViewData = Nothing
, getAppEnvironment = Nothing
@@ -56,7 +58,7 @@ newEnvironment = Environment { getCodeStore = Nothing
--
data CodeType = CTView | CTController | CTComponentView | CTComponentController | CTLayout deriving (Show)
-type CodeDate = ClockTime
+type CodeDate = UTCTime
type Function = String
type CodeLocation = (FilePath, Function)
@@ -69,12 +71,28 @@ data CodeStatus = CodeLoadMissing |
CodeLoadComponentController (StateT Environment IO ()) CodeDate |
CodeLoadComponentView (XMLGenT (StateT Environment IO) XML ) CodeDate
+
--
--- * Types for Database
+-- * Types for Cookies
--
-type Database = Connection
-
+-- | Contains all information about a cookie set by the server.
+data Cookie = Cookie {
+ -- | Name of the cookie.
+ cookieName :: String,
+ -- | Value of the cookie.
+ cookieValue :: String,
+ -- | Expiry date of the cookie. If 'Nothing', the
+ -- cookie expires when the browser sessions ends.
+ -- If the date is in the past, the client should
+ -- delete the cookie immediately.
+ cookieExpires :: Maybe UTCTime,
+ -- | The domain suffix to which this cookie will be sent.
+ cookieDomain :: Maybe String,
+ -- | The path to which this cookie will be sent.
+ cookiePath :: Maybe String
+ }
+ deriving (Show, Read, Eq, Ord)
--
-- * Types for Logger
@@ -113,6 +131,32 @@ type Keys = [String]
data Routes = Routes [(Regex, Keys)]
--
+-- * Types for Session
+--
+data Session = Session {
+ sessionName :: Maybe String, -- Used by Cookie session
+ sessionId :: Maybe Int, -- Used by DB and Filesystem sessions
+ expires :: Maybe UTCTime,
+ dataRep :: M.Map String String
+ } deriving (Eq, Read, Show)
+
+emptySession = Session Nothing Nothing Nothing M.empty
+
+class HasSession m where
+ newSession :: [(String, String)] -> m ()
+ retrieveSession :: [(String, String)] -> m ()
+ persistSession :: [(String, String)] -> m ()
+ hasValidSession :: m Bool
+ abandonSession :: m ()
+ getSessionValue :: String -> m (Maybe String)
+ setSessionValue :: String -> String -> m ()
+ deleteSessionKey :: String -> m ()
+ getSessionId :: m (Maybe Int)
+ setSessionId :: Maybe Int -> m ()
+ getSessionExpires :: m (Maybe UTCTime)
+ setSessionExpires :: Maybe UTCTime -> m ()
+
+--
-- * Types for Settings
--
View
17 Turbinado/Server.hs
@@ -33,11 +33,11 @@ import Turbinado.Environment.Types
import Turbinado.Environment.ViewData
import Turbinado.Environment.CodeStore (addCodeStoreToEnvironment)
import Turbinado.Server.Exception
-import Turbinado.Server.Handlers.ErrorHandler (handleError, handleTurbinado)
-import Turbinado.Server.Handlers.RequestHandler (requestHandler)
+import Turbinado.Server.ErrorHandler (handleError, handleTurbinado)
+import Turbinado.Server.RequestProcess (processRequest)
import Turbinado.Server.Handlers.SessionHandler
import Turbinado.Server.Network (receiveRequest, sendResponse)
-import Turbinado.Server.StandardResponse (pageResponse)
+import Turbinado.Server.StandardResponse (addEmptyResponse, pageResponse)
import Turbinado.Server.StaticContent
data Flag
@@ -107,23 +107,24 @@ workerLoop workerPoolMVar e chan
where
mainLoop
= do sock <- readChan chan
- handleRequest sock e
+ workerProcessRequest sock e
putWorkerThread workerPoolMVar chan
mainLoop
-- | Basic request handling: setup the 'Environment' for this request,
-- run the real requestHandler, then ship the response back to the client.
-handleRequest :: Socket -> Environment -> IO ()
-handleRequest sock e
+workerProcessRequest :: Socket -> Environment -> IO ()
+workerProcessRequest sock e
= (do mytid <- myThreadId
- e' <- runController (sequence_ [ addViewDataToEnvironment
+ e' <- runController (sequence_ [ addEmptyResponse
+ , addViewDataToEnvironment
, addSettingsToEnvironment
, receiveRequest sock
, tryStaticContent
]) e
case (isResponseComplete e') of
True -> sendResponse sock e'
- False -> do e'' <- runController requestHandler e'
+ False -> do e'' <- runController processRequest e'
sendResponse sock e''
)
`catchTurbinado` (\ex -> handleTurbinado sock ex e)
View
2 Turbinado/Server/Handlers/ErrorHandler.hs → Turbinado/Server/ErrorHandler.hs
@@ -1,4 +1,4 @@
-module Turbinado.Server.Handlers.ErrorHandler where
+module Turbinado.Server.ErrorHandler where
import System.IO
import Prelude hiding (catch)
View
26 Turbinado/Server/Handlers/SessionHandler.hs
@@ -1,26 +0,0 @@
-module Turbinado.Server.Handlers.SessionHandler (
- SessionHandler(..),
- SessionId, Key, Value, Expires, SessionData, SessionItem
- ) where
-
-import Data.Time
-
-type SessionId = Int
-type Key = String
-type Value = String
-type Expires = Maybe UTCTime
-
-type SessionData = (Expires, [SessionItem])
-type SessionItem = (Key, (Value, Expires))
-
-----------------------------------------------------
--- The SessionHandler class
-
-class SessionHandler sh where
- lookupData :: sh -> SessionId -> IO (Maybe SessionData)
- insertNew :: sh -> SessionId -> Expires -> IO ()
- insertNewData :: sh -> SessionId -> SessionItem -> IO ()
- updateExpires :: sh -> SessionId -> Expires -> IO ()
- updateData :: sh -> SessionId -> SessionItem -> IO ()
- deleteSession :: sh -> SessionId -> IO ()
- deleteData :: sh -> SessionId -> Key -> IO ()
View
10 Turbinado/Server/Handlers/RequestHandler.hs → Turbinado/Server/RequestProcess.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
-- |
--- Module : Turbinado.Server.Handlers.RequestHandler
+-- Module : Turbinado.Server.RequestProcess
-- Copyright : (c) Alson Kemp 2008, Niklas Broberg 2004,
-- License : BSD-style (see the file LICENSE)
--
@@ -12,8 +12,8 @@
-- a response.
--
-----------------------------------------------------------------------------
-module Turbinado.Server.Handlers.RequestHandler (
- requestHandler
+module Turbinado.Server.RequestProcess (
+ processRequest
) where
import qualified Network.HTTP as HTTP
@@ -58,8 +58,8 @@ postFilters = []
-- | The main request handler. This runs standard and custom preFilters
-- then runs the Controller and View.
-requestHandler :: Controller ()
-requestHandler = do
+processRequest :: Controller ()
+processRequest = do
debugM $ " requestHandler : running pre and main filters"
-- Run the Pre filters, the page
sequence_ $ preFilters ++
View
60 Turbinado/Server/StandardResponse.hs
@@ -13,6 +13,7 @@
module Turbinado.Server.StandardResponse where
import Data.List
+import Data.Maybe
import Network.HTTP
import Network.HTTP.Headers
import System.Locale
@@ -26,64 +27,65 @@ import Turbinado.Controller.Monad
instance Eq Header where
(==) (Header hn1 _) (Header hn2 _) = hn1 == hn2
+addEmptyResponse :: (HasEnvironment m) => m ()
+addEmptyResponse =
+ do t <- liftIO $ getClockTime
+ setResponse (Response (0,0,0)
+ ""
+ (startingHeaders t)
+ ""
+ )
+
fileNotFoundResponse :: (HasEnvironment m) => FilePath -> m ()
fileNotFoundResponse fp =
do t <- liftIO $ getClockTime
- setResponse (Response (4,0,0)
- "File Not Found"
- (buildHeaders (Just $ length body) t [])
- (body))
- where body = "<html><body>\n <p><big>404 File Not Found</big></p>\n <p>Requested resource: "++ fp ++ "</p>\n </body></html>"
+ r <- getEnvironment >>= (return . fromJust . getResponse)
+ setResponse (Response (4,0,4)
+ "File Not Found"
+ (rspHeaders r ++ [Header HdrContentLength $ show $ length body])
+ (body))
+ where body = "<html><body>\n <p><big>404 File Not Found</big></p>\n <p>Requested resource: "++ fp ++ "</p>\n </body></html>"
cachedContentResponse :: (HasEnvironment m) => Int -> String -> String -> m ()
cachedContentResponse age ct body =
- do t <- liftIO $ getClockTime
- pageResponse (buildHeaders
- Nothing t
- [Header HdrCacheControl $ "max-age=" ++ (show age) ++ ", public"
- , Header HdrContentType ct])
+ do pageResponse [ Header HdrCacheControl $ "max-age=" ++ (show age) ++ ", public"
+ , Header HdrContentType ct]
body
pageResponse :: (HasEnvironment m) => [Header] -> String -> m ()
pageResponse hds body =
do t <- liftIO $ getClockTime
- setResponse (Response stSuccess "OK"
- (buildHeaders (Just $ length body) t hds) (body))
+ r <- getEnvironment >>= (return . fromJust . getResponse)
+ setResponse (Response (2,0,0)
+ "OK"
+ ((rspHeaders r) ++ [Header HdrContentLength $ show $ length body] ++ hds)
+ (body))
redirectResponse :: (HasEnvironment m) => String -> m ()
redirectResponse l =
do t <- liftIO $ getClockTime
- setResponse (Response (3,0,2) "OK" (buildHeaders Nothing t [Header HdrLocation l]) "")
+ r <- getEnvironment >>= (return . fromJust . getResponse)
+ setResponse (Response (3,0,2) "OK" (rspHeaders r ++ [Header HdrLocation l]) "")
errorResponse :: (HasEnvironment m) => String -> m ()
errorResponse err =
do t <- liftIO $ getClockTime
- setResponse (Response stError "Internal Server Error"
- (buildHeaders (Just $ length body) t []) (body))
+ r <- getEnvironment >>= (return . fromJust . getResponse)
+ setResponse (Response (5,0,0) "Internal Server Error"
+ ((rspHeaders r) ++ [Header HdrContentLength $ show $ length body]) body)
where body = "<html><body>\n <p><big>500 Internal Server Error</big></p>\n <p>Error specification:<br/>\n" ++ err ++ "</p>\n </body></html>"
badReqResponse :: (HasEnvironment m) => m ()
badReqResponse =
do t <- liftIO $ getClockTime
- setResponse (Response stBadReq "Bad Request"
- (buildHeaders (Just $ length body) t []) body)
+ r <- getEnvironment >>= (return . fromJust . getResponse)
+ setResponse (Response (4,0,0) "Bad Request"
+ (rspHeaders r ++ [Header HdrContentLength $ show $ length body]) body)
where body = "<html><body>\n <p><big>400 Bad Request</big></p>\n </body></html>"
-buildHeaders :: Maybe Int -> ClockTime -> [Header] -> [Header]
-buildHeaders Nothing t hdrs = union hdrs ( startingHeaders t)
-buildHeaders (Just l) t hdrs = union hdrs ((startingHeaders t) ++
- [Header HdrContentLength $ show l])
-
-
startingHeaders t = [ Header HdrServer "Turbinado www.turbinado.org"
, Header HdrContentType "text/html; charset=UTF-8"
, Header HdrDate $ formatCalendarTime defaultTimeLocale rfc822DateFormat $ toUTCTime t
]
-stSuccess, stFNF :: ResponseCode
-stSuccess = (2,0,0)
-stFNF = (4,0,4)
-stError = (5,0,0)
-stBadReq = (4,0,0)
-
View
35 Turbinado/Utility/Naming.hs
@@ -0,0 +1,35 @@
+module Turbinado.Utility.Naming where
+
+import Data.Char
+import Data.List
+
+--
+-- * Turbinado Utility functions for Naming
+--
+
+-- | Lowercases the first letter to make a valid function.
+underscoreToFunction [] = error "toFunction passed an empty string"
+underscoreToFunction (firstL:ls) = (Data.Char.toLower firstL) : fromUnderscore ls
+
+
+-- | Uppercases the first letter to make a valid type.
+underscoreToType [] = error "toType passed an empty string"
+underscoreToType l = fromUnderscore l
+
+-- | Convert AbbaDing to abba_ding
+toUnderscore [] = error "toUnderscore passed an empty string"
+toUnderscore (l:ls) = toLower l : worker ls
+ where worker [] = []
+ worker "_" = "_" -- end with "_", then end with "_"
+ worker (c:cs) | isUpper c = '_' : toLower c : worker cs
+ | otherwise = c : worker cs
+
+-- | Convert abba_ding to AbbaDing
+fromUnderscore [] = error "fromUnderscore passed an empty string"
+fromUnderscore (l:ls) = toUpper l : worker ls
+ where worker [] = []
+ worker "_" = "_" -- end with "_", then end with "_"
+ worker ('_':c:cs) | isLetter c = toUpper c : worker cs
+ | otherwise = '_' : c : worker cs
+ worker (c:cs) = c : worker cs
+
View
5 build
@@ -1,5 +0,0 @@
-#!/bin/bash
-
-runghc Setup.lhs clean
-runghc Setup.lhs configure
-runghc Setup.lhs build
View
6 turbinado.cabal
@@ -1,5 +1,5 @@
Name: turbinado
-Version: 0.4.9
+Version: 0.5.0
Synopsis: Haskell web application server
Description: The Haskell web application server
License: BSD3
@@ -14,6 +14,8 @@ Executable turbinado
Main-is: Turbinado/Server.hs
Build-Depends: base >= 4,
containers,
+ Crypto,
+ dataenc,
directory,
harp == 0.4,
filepath,
@@ -32,7 +34,7 @@ Executable turbinado
pretty,
regex-compat,
time
- ghc-options: -F -pgmFtrhsx -O
+ ghc-options: -F -pgmFtrhsx
Extensions: MultiParamTypeClasses,
FunctionalDependencies,
TypeFamilies,

0 comments on commit caa17e6

Please sign in to comment.