diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -1,5 +1,5 @@ name: Spock -version: 0.2.0.0 +version: 0.3.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 @@ -16,7 +16,8 @@ exposed-modules: Web.Spock other-modules: Web.Spock.SessionManager, Web.Spock.Monad, - Web.Spock.Cookie + Web.Spock.Cookie, + Web.Spock.Types build-depends: base >= 4 && < 5, scotty >= 0.5, wai ==1.4.*, diff --git a/Web/Spock.hs b/Web/Spock.hs --- a/Web/Spock.hs +++ b/Web/Spock.hs @@ -4,12 +4,20 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Web.Spock - ( -- * Spock's core functions, types and helpers - 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 + ( -- * Spock's core + spock, SpockM, SpockAction + -- * Database + , runQuery, PoolOrConn (..), ConnBuilder (..), PoolCfg (..) + -- * Routing + , authed, get, post, put, delete, patch, addroute, Http.StdMethod (..) + -- * Cookies + , setCookie, setCookie', getCookie + -- * Sessions + , authedUser, unauthCurrent + -- * State + , getState + -- * Other reexports from scotty + , middleware, matchAny, notFound , request, reqHeader, body, param, params, jsonData, files , status, addHeader, setHeader, redirect , text, html, file, json, source, raw @@ -27,26 +35,24 @@ 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 -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 -> PoolCfg -> StorageLayer conn -> st -> SpockM conn sess st () -> IO () -spock port pc storageLayer initialState defs = +-- | Run a spock application using the warp server, a given db storageLayer and an initial state. +-- Spock works with database libraries that already implement connection pooling and +-- with those that don't come with it out of the box. For more see the 'PoolOrConn' type. +spock :: Int -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO () +spock port poolOrConn initialState defs = do sessionMgr <- openSessionManager - connectionPool <- createPool (sl_createConn storageLayer) - (sl_closeConn storageLayer) (pc_stripeCount pc) - (pc_keepOpenSec pc) (pc_resPerStripe pc) + connectionPool <- case poolOrConn of + PCPool p -> + return p + PCConn cb -> + let pc = cb_poolConfiguration cb + in createPool (cb_createConn cb) (cb_destroyConn cb) + (pc_stripes pc) (pc_keepOpenTime pc) + (pc_resPerStripe pc) let internalState = WebState { web_dbConn = connectionPool diff --git a/Web/Spock/Cookie.hs b/Web/Spock/Cookie.hs --- a/Web/Spock/Cookie.hs +++ b/Web/Spock/Cookie.hs @@ -11,6 +11,7 @@ import qualified Data.Text.Lazy as TL import qualified Network.Wai as Wai +-- | Read a cookie previously set in the users browser for your site getCookie :: MonadIO m => T.Text -> ActionT m (Maybe T.Text) getCookie name = do req <- request @@ -21,11 +22,13 @@ parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words parseCookie = first T.init . T.breakOnEnd "=" +-- | Set a cookie living for a given number of seconds setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionT m () setCookie name value validSeconds = do now <- liftIO getCurrentTime setCookie' name value (validSeconds `addUTCTime` now) +-- | Set a cookie living until a specific 'UTCTime' setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionT m () setCookie' name value validUntil = let formattedTime = diff --git a/Web/Spock/Monad.hs b/Web/Spock/Monad.hs --- a/Web/Spock/Monad.hs +++ b/Web/Spock/Monad.hs @@ -2,12 +2,10 @@ module Web.Spock.Monad where import Web.Spock.Types -import Web.Spock.SessionManager import Control.Applicative import Control.Monad import Control.Monad.Reader -import Control.Monad.Trans.Resource import Data.Pool import Data.Time.Clock ( UTCTime(..) ) import Web.Scotty.Trans @@ -20,12 +18,17 @@ webM :: MonadTrans t => WebStateM conn sess st a -> t (WebStateM conn sess st) a webM = lift -runQuery :: MonadTrans t => (conn -> IO a) -> t (WebStateM conn sess st) a +-- | Give you access to a database connectin from the connection pool. The connection is +-- released back to the pool once the function terminates. +runQuery :: MonadTrans t + => (conn -> IO a) -> t (WebStateM conn sess st) a runQuery query = webM $ do pool <- asks web_dbConn liftIO $ withResource pool query +-- | Read the application's state. If you wish to have immutable state, you could +-- use a 'TVar' from the STM packge. getState :: MonadTrans t => t (WebStateM conn sess st) st getState = webM $ asks web_state diff --git a/Web/Spock/Types.hs b/Web/Spock/Types.hs new file mode 100644 --- /dev/null +++ b/Web/Spock/Types.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Web.Spock.Types where + +import Web.Scotty.Trans + +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Pool +import Data.Time.Clock ( UTCTime(..), NominalDiffTime(..) ) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + +-- | Spock is supercharged Scotty, that's why the 'SpockM' is built on the +-- ScottyT monad. Insive the SpockM monad, you may define routes and middleware. +type SpockM conn sess st a = ScottyT (WebStateM conn sess st) a + +-- | The SpockAction is the monad of all route-actions. You have access +-- to the database, session and state of your application. +type SpockAction conn sess st a = ActionT (WebStateM conn sess st) a + +-- | If Spock should take care of connection pooling, you need to configure +-- it depending on what you need. +data PoolCfg + = PoolCfg + { pc_stripes :: Int + , pc_resPerStripe :: Int + , pc_keepOpenTime :: NominalDiffTime + } + +-- | The ConnBuilder instructs Spock how to create or close a database connection. +data ConnBuilder a + = ConnBuilder + { cb_createConn :: IO a + , cb_destroyConn :: a -> IO () + , cb_poolConfiguration :: PoolCfg + } + +-- | You can feed Spock with either a connection pool, or instructions on how to build +-- a connection pool. See 'ConnBuilder' +data PoolOrConn a + = PCPool (Pool a) + | PCConn (ConnBuilder a) + +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)) + +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 () + }