Spock 0.1.2.0 → 0.2.0.0
raw patch · 5 files changed
+97/−73 lines, 5 filesdep +randomdep −crypto-apidep −cryptohashdep −directorydep ~aesondep ~base64-bytestringdep ~bytestring
Dependencies added: random
Dependencies removed: crypto-api, cryptohash, directory, filepath
Dependency ranges changed: aeson, base64-bytestring, bytestring, containers, http-types, monad-control, mtl, old-locale, resource-pool, resourcet, stm, text, time, transformers, unordered-containers, wai, wai-extra, xsd
Files
- Spock.cabal +24/−3
- Web/Spock.hs +21/−9
- Web/Spock/Cookie.hs +40/−0
- Web/Spock/Monad.hs +1/−16
- Web/Spock/SessionManager.hs +11/−45
Spock.cabal view
@@ -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
Web/Spock.hs view
@@ -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 $
+ Web/Spock/Cookie.hs view
@@ -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+ , ";"+ ]+ )
Web/Spock/Monad.hs view
@@ -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
Web/Spock/SessionManager.hs view
@@ -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