diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -1,5 +1,5 @@ name: Spock -version: 0.1.2.0 +version: 0.2.0.0 synopsis: Another Haskell web toolkit based on scotty description: This toolbox provides everything you need to get a quick start into web hacking with haskell: sessions, database helper, authentication and the power of scotty Homepage: https://github.com/agrafix/Spock @@ -15,8 +15,29 @@ library exposed-modules: Web.Spock other-modules: Web.Spock.SessionManager, - Web.Spock.Monad - build-depends: base >= 4 && < 5, scotty >= 0.5, wai, filepath, directory, http-types, text, containers, bytestring, mtl, wai-extra, resourcet, stm, crypto-api == 0.10.*, unordered-containers, old-locale, base64-bytestring, time, monad-control, transformers, cryptohash, xsd, aeson, resource-pool + Web.Spock.Monad, + Web.Spock.Cookie + build-depends: base >= 4 && < 5, + scotty >= 0.5, + wai ==1.4.*, + http-types ==0.8.*, + text ==0.11.*, + containers ==0.5.*, + bytestring ==0.10.*, + mtl ==2.1.*, + wai-extra ==1.3.*, + resourcet ==0.4.*, + stm ==2.4.*, + unordered-containers ==0.2.*, + old-locale ==1.*, + base64-bytestring ==1.*, + time ==1.4.*, + monad-control ==0.3.*, + transformers ==0.3.*, + xsd ==0.4.*, + aeson ==0.6.*, + resource-pool ==0.2.*, + random ==1.* ghc-options: -fwarn-unused-imports source-repository head diff --git a/Web/Spock.hs b/Web/Spock.hs --- a/Web/Spock.hs +++ b/Web/Spock.hs @@ -5,8 +5,9 @@ {-# LANGUAGE ScopedTypeVariables #-} module Web.Spock ( -- * Spock's core functions, types and helpers - spock, authed, runQuery, getState, Http.StdMethod(..), SpockM - , authedUser, unauthCurrent, StorageLayer (..) + spock, authed, runQuery, getState, Http.StdMethod (..), SpockM, SpockAction + , authedUser, unauthCurrent, StorageLayer (..), PoolCfg (..) + , setCookie, getCookie -- * Reexports from scotty , middleware, get, post, put, delete, patch, addroute, matchAny, notFound , request, reqHeader, body, param, params, jsonData, files @@ -18,23 +19,34 @@ import Web.Spock.SessionManager import Web.Spock.Monad +import Web.Spock.Types +import Web.Spock.Cookie import Control.Applicative import Control.Monad.Trans import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Data.Pool +import Data.Time.Clock import Web.Scotty.Trans import qualified Data.Text as T import qualified Network.HTTP.Types as Http -type SpockM conn sess st a = ScottyT (WebStateM conn sess st) a +data PoolCfg + = PoolCfg + { pc_stripeCount :: Int + , pc_keepOpenSec :: NominalDiffTime + , pc_resPerStripe :: Int + } + deriving (Show, Eq) -- | Run a spock application using the warp server, a given db storageLayer and an initial state -spock :: Int -> StorageLayer conn -> st -> SpockM conn sess st () -> IO () -spock port storageLayer initialState defs = +spock :: Int -> PoolCfg -> StorageLayer conn -> st -> SpockM conn sess st () -> IO () +spock port pc storageLayer initialState defs = do sessionMgr <- openSessionManager - connectionPool <- createPool (sl_createConn storageLayer) (sl_closeConn storageLayer) 5 (60*5) 5 + connectionPool <- createPool (sl_createConn storageLayer) + (sl_closeConn storageLayer) (pc_stripeCount pc) + (pc_keepOpenSec pc) (pc_resPerStripe pc) let internalState = WebState { web_dbConn = connectionPool @@ -49,13 +61,13 @@ -- | After checking that a login was successfull, register the usersId -- into the session and create a session cookie for later "authed" requests -- to work properly -authedUser :: user -> (user -> sess) -> ActionT (WebStateM conn sess st) () +authedUser :: user -> (user -> sess) -> SpockAction conn sess st () authedUser user getSessionId = do mgr <- getSessMgr (sm_createCookieSession mgr) (getSessionId user) -- | Destroy the current users session -unauthCurrent :: ActionT (WebStateM conn sess st) () +unauthCurrent :: SpockAction conn sess st () unauthCurrent = do mgr <- getSessMgr mSess <- sm_sessionFromCookie mgr @@ -69,7 +81,7 @@ authed :: Http.StdMethod -> [T.Text] -> RoutePattern -> (conn -> sess -> IO (Maybe user)) -> (conn -> user -> [T.Text] -> IO Bool) - -> (user -> ActionT (WebStateM conn sess st) ()) + -> (user -> SpockAction conn sess st ()) -> SpockM conn sess st () authed reqTy requiredRights route loadUser checkRights action = addroute reqTy route $ diff --git a/Web/Spock/Cookie.hs b/Web/Spock/Cookie.hs new file mode 100644 --- /dev/null +++ b/Web/Spock/Cookie.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +module Web.Spock.Cookie where + +import Control.Arrow +import Control.Monad.Trans +import Data.Time +import System.Locale +import Web.Scotty.Trans +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Network.Wai as Wai + +getCookie :: MonadIO m => T.Text -> ActionT m (Maybe T.Text) +getCookie name = + do req <- request + return $ lookup "cookie" (Wai.requestHeaders req) >>= + lookup name . parseCookies . T.decodeUtf8 + where + parseCookies :: T.Text -> [(T.Text, T.Text)] + parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words + parseCookie = first T.init . T.breakOnEnd "=" + +setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionT m () +setCookie name value validSeconds = + do now <- liftIO getCurrentTime + setCookie' name value (validSeconds `addUTCTime` now) + +setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionT m () +setCookie' name value validUntil = + let formattedTime = + TL.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil + in setHeader "Set-Cookie" (TL.concat [ TL.fromStrict name + , "=" + , TL.fromStrict value + , "; path=/; expires=" + , formattedTime + , ";" + ] + ) diff --git a/Web/Spock/Monad.hs b/Web/Spock/Monad.hs --- a/Web/Spock/Monad.hs +++ b/Web/Spock/Monad.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Web.Spock.Monad where +import Web.Spock.Types import Web.Spock.SessionManager import Control.Applicative @@ -15,22 +16,6 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Text.XML.XSD.DateTime as XSD - -data StorageLayer a - = StorageLayer - { sl_createConn :: IO a - , sl_closeConn :: a -> IO () - } - -data WebState conn sess st - = WebState - { web_dbConn :: Pool conn - , web_sessionMgr :: SessionManager sess - , web_state :: st - } - -newtype WebStateM conn sess st a = WebStateM { runWebStateM :: ReaderT (WebState conn sess st) (ResourceT IO) a } - deriving (Monad, Functor, Applicative, MonadIO, MonadReader (WebState conn sess st)) webM :: MonadTrans t => WebStateM conn sess st a -> t (WebStateM conn sess st) a webM = lift diff --git a/Web/Spock/SessionManager.hs b/Web/Spock/SessionManager.hs --- a/Web/Spock/SessionManager.hs +++ b/Web/Spock/SessionManager.hs @@ -5,38 +5,19 @@ ) where -import Control.Arrow +import Web.Spock.Types +import Web.Spock.Cookie + import Control.Concurrent.STM import Control.Monad.Trans -import Crypto.Random (newGenIO, genBytes, SystemRandom) import Data.Time -import System.Locale +import System.Random import Web.Scotty.Trans +import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Base64 as B64 import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Network.Wai as Wai -type SessionId = T.Text -data Session a - = Session - { sess_id :: SessionId - , sess_validUntil :: UTCTime - , sess_data :: a - } -type UserSessions a = TVar (HM.HashMap SessionId (Session a)) - -data SessionManager a - = SessionManager - { sm_loadSession :: SessionId -> IO (Maybe (Session a)) - , sm_sessionFromCookie :: MonadIO m => ActionT m (Maybe (Session a)) - , sm_createCookieSession :: MonadIO m => a -> ActionT m () - , sm_newSession :: a -> IO (Session a) - , sm_deleteSession :: SessionId -> IO () - } - _COOKIE_NAME_ = "asession" sessionTTL = 10 * 60 * 60 @@ -59,15 +40,7 @@ -> ActionT m () createCookieSessionImpl sessRef val = do sess <- liftIO $ newSessionImpl sessRef val - let formattedExp = T.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" (sess_validUntil sess) - setHeader "Set-Cookie" (TL.concat [ TL.fromStrict _COOKIE_NAME_ - , "=" - , TL.fromStrict (sess_id sess) - , "; path=/; expires=" - , TL.fromStrict formattedExp - , ";" - ] - ) + setCookie' _COOKIE_NAME_ (sess_id sess) (sess_validUntil sess) newSessionImpl :: UserSessions a -> a @@ -80,19 +53,13 @@ sessionFromCookieImpl :: MonadIO m => UserSessions a -> ActionT m (Maybe (Session a)) sessionFromCookieImpl sessionRef = - do req <- request - case lookup "cookie" (Wai.requestHeaders req) >>= - lookup _COOKIE_NAME_ . parseCookies . T.decodeUtf8 of + do mSid <- getCookie _COOKIE_NAME_ + case mSid of Just sid -> liftIO $ loadSessionImpl sessionRef sid Nothing -> return Nothing - where - parseCookies :: T.Text -> [(T.Text, T.Text)] - parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words - parseCookie = first T.init . T.breakOnEnd "=" - loadSessionImpl :: UserSessions a -> SessionId -> IO (Maybe (Session a)) @@ -118,11 +85,10 @@ createSession :: a -> IO (Session a) createSession content = do gen <- g - sid <- case genBytes sessionIdEntropy gen of - Left err -> fail $ show err - Right (x, _) -> return $ T.decodeUtf8 $ B64.encode x + let sid = T.decodeUtf8 $ B64.encode $ BSC.pack $ + take sessionIdEntropy $ randoms gen now <- getCurrentTime let validUntil = addUTCTime sessionTTL now return (Session sid validUntil content) where - g = newGenIO :: IO SystemRandom + g = newStdGen :: IO StdGen