diff --git a/Spock.cabal b/Spock.cabal
--- a/Spock.cabal
+++ b/Spock.cabal
@@ -1,5 +1,5 @@
name: Spock
-version: 0.4.3.4
+version: 0.4.3.5
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, cookies, database helper, csrf-protection, global state and the power of scotty
Homepage: https://github.com/agrafix/Spock
@@ -13,7 +13,8 @@
cabal-version: >=1.8
library
- exposed-modules: Web.Spock
+ hs-source-dirs: src
+ exposed-modules: Web.Spock
other-modules: Web.Spock.SessionManager,
Web.Spock.Monad,
Web.Spock.Cookie,
diff --git a/Web/Spock.hs b/Web/Spock.hs
deleted file mode 100644
--- a/Web/Spock.hs
+++ /dev/null
@@ -1,110 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Web.Spock
- ( -- * Spock's core
- spock, SpockM, SpockAction
- -- * Database
- , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)
- -- * Accessing Database and State
- , HasSpock (runQuery, getState)
- -- * Sessions
- , SessionCfg (..)
- , readSession, writeSession, modifySession
- -- * Cookies
- , setCookie, setCookie', getCookie
- -- * Safe actions
- , SafeAction (..)
- , safeActionPath
- -- * General Routing
- , get, post, put, delete, patch, addroute, Http.StdMethod (..)
- -- * Other reexports from scotty
- , middleware, matchAny, notFound
- , request, reqHeader, body, param, params, jsonData, files
- , status, addHeader, setHeader, redirect
- , text, html, file, json, source, raw
- , raise, rescue, next
- , RoutePattern
- -- * Spock utilities
- , paramPathPiece
- -- * Internals for extending Spock
- , getSpockHeart, runSpockIO, WebStateM, WebState
- )
-where
-
-import Web.Spock.SessionManager
-import Web.Spock.Monad
-import Web.Spock.Types
-import Web.Spock.Cookie
-import Web.Spock.SafeActions
-
-import Control.Applicative
-import Control.Monad.Trans.Reader
-import Control.Monad.Trans.Resource
-import Data.Pool
-import Web.Scotty.Trans
-import Web.PathPieces
-import qualified Network.HTTP.Types as Http
-import qualified Data.Text.Lazy as TL
-
--- | 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 -> SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO ()
-spock port sessionCfg poolOrConn initialState defs =
- do sessionMgr <- createSessionManager sessionCfg
- connectionPool <-
- case poolOrConn of
- PCConduitPool p ->
- return (ConduitPool p)
- PCPool p ->
- return (DataPool p)
- PCConn cb ->
- let pc = cb_poolConfiguration cb
- in DataPool <$> createPool (cb_createConn cb) (cb_destroyConn cb)
- (pc_stripes pc) (pc_keepOpenTime pc)
- (pc_resPerStripe pc)
- let internalState =
- WebState
- { web_dbConn = connectionPool
- , web_sessionMgr = sessionMgr
- , web_state = initialState
- }
- runM m = runResourceT $ runReaderT (runWebStateM m) internalState
- runActionToIO = runM
-
- scottyT port runM runActionToIO $
- do middleware (sm_middleware sessionMgr)
- hookSafeActions
- defs
-
--- | Write to the current session. Note that all data is stored on the server.
--- The user only reciedes a sessionId to be identified.
-writeSession :: sess -> SpockAction conn sess st ()
-writeSession d =
- do mgr <- getSessMgr
- (sm_writeSession mgr) d
-
--- | Modify the stored session
-modifySession :: (sess -> sess) -> SpockAction conn sess st ()
-modifySession f =
- do mgr <- getSessMgr
- (sm_modifySession mgr) f
-
--- | Read the stored session
-readSession :: SpockAction conn sess st sess
-readSession =
- do mgr <- getSessMgr
- sm_readSession mgr
-
--- | Same as "param", but the target type needs to implement "PathPiece"
-paramPathPiece :: PathPiece s => TL.Text -> SpockAction conn sess st s
-paramPathPiece t =
- do val <- param t
- case fromPathPiece val of
- Just x ->
- return x
- Nothing ->
- raise $ stringError $ "Cannot convert param: " ++ TL.unpack t ++ " to path piece!"
diff --git a/Web/Spock/Cookie.hs b/Web/Spock/Cookie.hs
deleted file mode 100644
--- a/Web/Spock/Cookie.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Web.Spock.Cookie where
-
-import Web.Spock.Types
-
-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
-
--- | Read a cookie previously set in the users browser for your site
-getCookie :: (SpockError e, MonadIO m) => T.Text -> ActionT e m (Maybe T.Text)
-getCookie name =
- do r <- request
- return $ getCookieFromReq name r
-
-getCookieFromReq :: T.Text -> Wai.Request -> Maybe T.Text
-getCookieFromReq name req =
- 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 "="
-
--- | Set a cookie living for a given number of seconds
-setCookie :: (SpockError e, MonadIO m) => T.Text -> T.Text -> NominalDiffTime
- -> ActionT e m ()
-setCookie name value validSeconds =
- do now <- liftIO getCurrentTime
- setCookie' name value (validSeconds `addUTCTime` now)
-
--- | Set a cookie living until a specific 'UTCTime'
-setCookie' :: (SpockError e, MonadIO m) => T.Text -> T.Text -> UTCTime
- -> ActionT e m ()
-setCookie' name value validUntil =
- setHeader "Set-Cookie" (renderCookie name value validUntil)
-
-renderCookie :: T.Text -> T.Text -> UTCTime -> TL.Text
-renderCookie name value validUntil =
- let formattedTime =
- TL.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil
- in TL.concat [ TL.fromStrict name
- , "="
- , TL.fromStrict value
- , "; path=/; expires="
- , formattedTime
- , ";"
- ]
diff --git a/Web/Spock/Monad.hs b/Web/Spock/Monad.hs
deleted file mode 100644
--- a/Web/Spock/Monad.hs
+++ /dev/null
@@ -1,78 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-module Web.Spock.Monad where
-
-import Web.Spock.Types
-
-import Control.Monad
-import Control.Monad.Reader
-import Control.Monad.Trans.Resource
-import Data.Pool
-import Data.Time.Clock ( UTCTime(..) )
-import Web.Scotty.Trans
-import qualified Data.Conduit.Pool as CP
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.Text.Encoding as T
-import qualified Data.Text.Lazy as TL
-import qualified Text.XML.XSD.DateTime as XSD
-
-webM :: MonadTrans t => WebStateM conn sess st a -> t (WebStateM conn sess st) a
-webM = lift
-
-instance MonadTrans t => HasSpock (t (WebStateM conn sess st)) where
- type SpockConn (t (WebStateM conn sess st)) = conn
- type SpockState (t (WebStateM conn sess st)) = st
- type SpockSession (t (WebStateM conn sess st)) = sess
- runQuery a = webM $ runQueryImpl a
- getState = webM $ getStateImpl
- getSessMgr = webM $ getSessMgrImpl
-
-instance HasSpock (WebStateM conn sess st) where
- type SpockConn (WebStateM conn sess st) = conn
- type SpockState (WebStateM conn sess st) = st
- type SpockSession (WebStateM conn sess st) = sess
- runQuery = runQueryImpl
- getState = getStateImpl
- getSessMgr = getSessMgrImpl
-
-runQueryImpl :: (conn -> IO a) -> WebStateM conn sess st a
-runQueryImpl query =
- do pool <- asks web_dbConn
- let fun =
- case pool of
- DataPool p ->
- withResource p
- ConduitPool p ->
- CP.withResource p
- liftIO (fun query)
-
-getStateImpl :: WebStateM conn sess st st
-getStateImpl = asks web_state
-
--- | Read the heart of Spock. This is useful if you want to construct your own
--- monads that work with runQuery and getState using "runSpockIO"
-getSpockHeart :: MonadTrans t => t (WebStateM conn sess st) (WebState conn sess st)
-getSpockHeart = webM ask
-
--- | Run an action inside of Spocks core monad. This allows you to use runQuery and getState
-runSpockIO :: WebState conn sess st -> WebStateM conn sess st a -> IO a
-runSpockIO st (WebStateM action) =
- runResourceT $
- runReaderT action st
-
-getSessMgrImpl :: (WebStateM conn sess st) (SessionManager conn sess st)
-getSessMgrImpl = asks web_sessionMgr
-
-instance Parsable BSL.ByteString where
- parseParam =
- Right . BSL.fromStrict . T.encodeUtf8 . TL.toStrict
-
-instance Parsable UTCTime where
- parseParam p =
- case join $ fmap XSD.toUTCTime $ XSD.dateTime (TL.toStrict p) of
- Nothing ->
- Left $ TL.pack $ "Can't parse param (`" ++ show p ++ "`) as UTCTime!"
- Just x ->
- Right x
diff --git a/Web/Spock/SafeActions.hs b/Web/Spock/SafeActions.hs
deleted file mode 100644
--- a/Web/Spock/SafeActions.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-module Web.Spock.SafeActions where
-
-import Web.Scotty.Trans
-import Web.Spock.Types
-
-import qualified Data.Text as T
-
--- | Wire up a safe action: Safe actions are actions that are protected from
--- csrf attacks. Here's a usage example:
---
--- > newtype DeleteUser = DeleteUser Int deriving (Hashable, Typeable, Eq)
--- >
--- > instance SafeAction DeleteUser where
--- > runSafeAction (DeleteUser i) =
--- > do runQuery $ deleteUserFromDb i
--- > redirect "/user-list"
--- >
--- > get "/user-details/:userId" $
--- > do userId <- param "userId"
--- > deleteUrl <- safeActionPath (DeleteUser userId)
--- > html $ TL.concat [ "Click here to delete user!" ]
---
--- Note that safeActions currently only support GET and POST requests.
---
-safeActionPath :: forall conn sess st a.
- ( SafeAction conn sess st a
- , HasSpock(SpockAction conn sess st)
- , SpockConn (SpockAction conn sess st) ~ conn
- , SpockSession (SpockAction conn sess st) ~ sess
- , SpockState (SpockAction conn sess st) ~ st)
- => a
- -> SpockAction conn sess st T.Text
-safeActionPath safeAction =
- do mgr <- getSessMgr
- hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction)
- return $ T.concat [ "/h/", hash ]
-
-hookSafeActions :: forall conn sess st.
- ( HasSpock (SpockAction conn sess st)
- , SpockConn (SpockAction conn sess st) ~ conn
- , SpockSession (SpockAction conn sess st) ~ sess
- , SpockState (SpockAction conn sess st) ~ st)
- => SpockM conn sess st ()
-hookSafeActions =
- do get "/h/:spock-csurf-protection" run
- post "/h/:spock-csurf-protection" run
- where
- run =
- do h <- param "spock-csurf-protection"
- mgr <- getSessMgr
- mAction <- (sm_lookupSafeAction mgr) h
- case mAction of
- Nothing ->
- next
- Just (PackedSafeAction action) ->
- runSafeAction action
diff --git a/Web/Spock/SessionManager.hs b/Web/Spock/SessionManager.hs
deleted file mode 100644
--- a/Web/Spock/SessionManager.hs
+++ /dev/null
@@ -1,195 +0,0 @@
-{-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}
-module Web.Spock.SessionManager
- ( createSessionManager
- , SessionId, Session(..), SessionManager(..)
- )
-where
-
-import Web.Spock.Types
-import Web.Spock.Cookie
-
-import Control.Concurrent.STM
-import Control.Monad.Trans
-import Data.Time
-import System.Random
-import Web.Scotty.Trans
-import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Char8 as BSC
-import qualified Data.ByteString.Lazy as BSL
-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.Encoding as TL
-import qualified Data.Vault.Lazy as V
-import qualified Network.Wai as Wai
-import qualified Network.Wai.Util as Wai
-
-createSessionManager :: SessionCfg sess -> IO (SessionManager conn sess st)
-createSessionManager cfg =
- do cacheHM <- atomically $ newTVar HM.empty
- vaultKey <- V.newKey
- return $ SessionManager
- { sm_readSession = readSessionImpl vaultKey cacheHM
- , sm_writeSession = writeSessionImpl vaultKey cacheHM
- , sm_modifySession = modifySessionImpl vaultKey cacheHM
- , sm_middleware = sessionMiddleware cfg vaultKey cacheHM
- , sm_addSafeAction = addSafeActionImpl vaultKey cacheHM
- , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM
- }
-
-modifySessionBase :: V.Key SessionId
- -> UserSessions conn sess st
- -> (Session conn sess st -> Session conn sess st)
- -> SpockAction conn sess st ()
-modifySessionBase vK sessionRef modFun =
- do req <- request
- case V.lookup vK (Wai.vault req) of
- Nothing ->
- error "(3) Internal Spock Session Error. Please report this bug!"
- Just sid ->
- liftIO $ atomically $ modifyTVar sessionRef (HM.adjust modFun sid)
-
-readSessionBase :: V.Key SessionId
- -> UserSessions conn sess st
- -> SpockAction conn sess st (Session conn sess st)
-readSessionBase vK sessionRef =
- do req <- request
- case V.lookup vK (Wai.vault req) of
- Nothing ->
- error "(1) Internal Spock Session Error. Please report this bug!"
- Just sid ->
- do sessions <- liftIO $ atomically $ readTVar sessionRef
- case HM.lookup sid sessions of
- Nothing ->
- error "(2) Internal Spock Session Error. Please report this bug!"
- Just session ->
- return session
-
-addSafeActionImpl :: V.Key SessionId
- -> UserSessions conn sess st
- -> PackedSafeAction conn sess st
- -> SpockAction conn sess st SafeActionHash
-addSafeActionImpl vaultKey cacheHM safeAction =
- do base <- readSessionBase vaultKey cacheHM
- case HM.lookup safeAction (sas_reverse (sess_safeActions base)) of
- Just safeActionHash ->
- return safeActionHash
- Nothing ->
- do safeActionHash <- liftIO (randomHash 40)
- let f sas =
- sas
- { sas_forward = HM.insert safeActionHash safeAction (sas_forward sas)
- , sas_reverse = HM.insert safeAction safeActionHash (sas_reverse sas)
- }
- modifySessionBase vaultKey cacheHM (\s -> s { sess_safeActions = f (sess_safeActions s) })
- return safeActionHash
-
-lookupSafeActionImpl :: V.Key SessionId
- -> UserSessions conn sess st
- -> SafeActionHash
- -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))
-lookupSafeActionImpl vaultKey cacheHM hash =
- do base <- readSessionBase vaultKey cacheHM
- return $ HM.lookup hash (sas_forward (sess_safeActions base))
-
-readSessionImpl :: V.Key SessionId
- -> UserSessions conn sess st
- -> SpockAction conn sess st sess
-readSessionImpl vK sessionRef =
- do base <- readSessionBase vK sessionRef
- return (sess_data base)
-
-writeSessionImpl :: V.Key SessionId
- -> UserSessions conn sess st
- -> sess
- -> SpockAction conn sess st ()
-writeSessionImpl vK sessionRef value =
- modifySessionImpl vK sessionRef (const value)
-
-modifySessionImpl :: V.Key SessionId
- -> UserSessions conn sess st
- -> (sess -> sess)
- -> SpockAction conn sess st ()
-modifySessionImpl vK sessionRef f =
- do let modFun session =
- session { sess_data = f (sess_data session) }
- modifySessionBase vK sessionRef modFun
-
-sessionMiddleware :: SessionCfg sess
- -> V.Key SessionId
- -> UserSessions conn sess st
- -> Wai.Middleware
-sessionMiddleware cfg vK sessionRef app req =
- case getCookieFromReq (sc_cookieName cfg) req of
- Just sid ->
- do mSess <- loadSessionImpl cfg sessionRef sid
- case mSess of
- Nothing ->
- mkNew
- Just sess ->
- withSess False sess
- Nothing ->
- mkNew
- where
- defVal = sc_emptySession cfg
- v = Wai.vault req
- addCookie sess responseHeaders =
- let cookieContent =
- renderCookie (sc_cookieName cfg) (sess_id sess) (sess_validUntil sess)
- cookie = ("Set-Cookie", BSL.toStrict $ TL.encodeUtf8 cookieContent)
- in (cookie : responseHeaders)
- withSess shouldSetCookie sess =
- do resp <- app (req { Wai.vault = V.insert vK (sess_id sess) v })
- return $ if shouldSetCookie then Wai.mapHeaders (addCookie sess) resp else resp
- mkNew =
- do newSess <- newSessionImpl cfg sessionRef defVal
- withSess True newSess
-
-newSessionImpl :: SessionCfg sess
- -> UserSessions conn sess st
- -> sess
- -> IO (Session conn sess st)
-newSessionImpl sessCfg sessionRef content =
- do sess <- createSession sessCfg content
- atomically $ modifyTVar sessionRef (\hm -> HM.insert (sess_id sess) sess hm)
- return sess
-
-loadSessionImpl :: SessionCfg sess
- -> UserSessions conn sess st
- -> SessionId
- -> IO (Maybe (Session conn sess st))
-loadSessionImpl sessCfg sessionRef sid =
- do sessHM <- atomically $ readTVar sessionRef
- now <- getCurrentTime
- case HM.lookup sid sessHM of
- Just sess ->
- do if addUTCTime (sc_sessionTTL sessCfg) (sess_validUntil sess) > now
- then return $ Just sess
- else do deleteSessionImpl sessionRef sid
- return Nothing
- Nothing ->
- return Nothing
-
-deleteSessionImpl :: UserSessions conn sess st
- -> SessionId
- -> IO ()
-deleteSessionImpl sessionRef sid =
- do atomically $ modifyTVar sessionRef (\hm -> HM.delete sid hm)
- return ()
-
-createSession :: SessionCfg sess -> sess -> IO (Session conn sess st)
-createSession sessCfg content =
- do sid <- randomHash (sc_sessionIdEntropy sessCfg)
- now <- getCurrentTime
- let validUntil = addUTCTime (sc_sessionTTL sessCfg) now
- emptySafeActions =
- SafeActionStore HM.empty HM.empty
- return (Session sid validUntil content emptySafeActions)
-
-randomHash :: Int -> IO T.Text
-randomHash len =
- do gen <- g
- return $ T.decodeUtf8 $ B64.encode $ BSC.pack $
- take len $ randoms gen
- where
- g = newStdGen :: IO StdGen
diff --git a/Web/Spock/Types.hs b/Web/Spock/Types.hs
deleted file mode 100644
--- a/Web/Spock/Types.hs
+++ /dev/null
@@ -1,146 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ExistentialQuantification #-}
-module Web.Spock.Types where
-
-import Web.Scotty.Trans
-
-import Control.Applicative
-import Control.Concurrent.STM
-import Control.Monad.Base
-import Control.Monad.Reader
-import Control.Monad.Trans.Control
-import Control.Monad.Trans.Resource
-import Data.Hashable
-import Data.Pool
-import Data.Text.Lazy (Text)
-import Data.Time.Clock ( UTCTime(..), NominalDiffTime )
-import Data.Typeable
-import Network.Wai
-import qualified Data.Conduit.Pool as CP
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Text as T
-
-type SpockError e = ScottyError e
-
--- | 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 = ScottyT Text (WebStateM conn sess st)
-
--- | 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 = ActionT Text (WebStateM conn sess st)
-
--- | 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)
- | PCConduitPool (CP.Pool a)
- | PCConn (ConnBuilder a)
-
--- | Configuration for the session manager
-data SessionCfg a
- = SessionCfg
- { sc_cookieName :: T.Text
- , sc_sessionTTL :: NominalDiffTime
- , sc_sessionIdEntropy :: Int
- , sc_emptySession :: a
- }
-
-data ConnectionPool conn
- = DataPool (Pool conn)
- | ConduitPool (CP.Pool conn)
-
-data WebState conn sess st
- = WebState
- { web_dbConn :: ConnectionPool conn
- , web_sessionMgr :: SessionManager conn sess st
- , web_state :: st
- }
-
-class HasSpock m where
- type SpockConn m :: *
- type SpockState m :: *
- type SpockSession m :: *
- -- | Give you access to a database connectin from the connection pool. The connection is
- -- released back to the pool once the function terminates.
- runQuery :: (SpockConn m -> IO a) -> m a
- -- | Read the application's state. If you wish to have mutable state, you could
- -- use a 'TVar' from the STM packge.
- getState :: m (SpockState m)
- -- | Get the session manager
- getSessMgr :: m (SessionManager (SpockConn m) (SpockSession m) (SpockState m))
-
--- | SafeActions are actions that need to be protected from csrf attacks
-class (Hashable a, Eq a, Typeable a) => SafeAction conn sess st a where
- runSafeAction :: a -> SpockAction conn sess st ()
-
-data PackedSafeAction conn sess st
- = forall a. (SafeAction conn sess st a) => PackedSafeAction { unpackSafeAction :: a }
-
-instance Hashable (PackedSafeAction conn sess st) where
- hashWithSalt i (PackedSafeAction a) = hashWithSalt i a
-
-instance Eq (PackedSafeAction conn sess st) where
- (PackedSafeAction a) == (PackedSafeAction b) =
- cast a == Just b
-
-data SafeActionStore conn sess st
- = SafeActionStore
- { sas_forward :: HM.HashMap SafeActionHash (PackedSafeAction conn sess st)
- , sas_reverse :: HM.HashMap (PackedSafeAction conn sess st) SafeActionHash
- }
-
-type SafeActionHash = T.Text
-
-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))
-
-instance MonadBase IO (WebStateM conn sess st) where
- liftBase = WebStateM . liftBase
-
-instance MonadBaseControl IO (WebStateM conn sess st) where
- newtype StM (WebStateM conn sess st) a = WStM { unWStM :: StM (ReaderT (WebState conn sess st) (ResourceT IO)) a }
- liftBaseWith f = WebStateM . liftBaseWith $ \runInBase -> f $ liftM WStM . runInBase . runWebStateM
- restoreM = WebStateM . restoreM . unWStM
-
-type SessionId = T.Text
-data Session conn sess st
- = Session
- { sess_id :: SessionId
- , sess_validUntil :: UTCTime
- , sess_data :: sess
- , sess_safeActions :: SafeActionStore conn sess st
- }
-type UserSessions conn sess st =
- TVar (HM.HashMap SessionId (Session conn sess st))
-
-data SessionManager conn sess st
- = SessionManager
- { sm_readSession :: SpockAction conn sess st sess
- , sm_writeSession :: sess -> SpockAction conn sess st ()
- , sm_modifySession :: (sess -> sess) -> SpockAction conn sess st ()
- , sm_middleware :: Middleware
- , sm_addSafeAction :: (PackedSafeAction conn sess st) -> SpockAction conn sess st SafeActionHash
- , sm_lookupSafeAction :: SafeActionHash -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))
- }
diff --git a/src/Web/Spock.hs b/src/Web/Spock.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Web.Spock
+ ( -- * Spock's core
+ spock, SpockM, SpockAction
+ -- * Database
+ , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)
+ -- * Accessing Database and State
+ , HasSpock (runQuery, getState)
+ -- * Sessions
+ , SessionCfg (..)
+ , readSession, writeSession, modifySession
+ -- * Cookies
+ , setCookie, setCookie', getCookie
+ -- * Safe actions
+ , SafeAction (..)
+ , safeActionPath
+ -- * General Routing
+ , get, post, put, delete, patch, addroute, Http.StdMethod (..)
+ -- * Other reexports from scotty
+ , middleware, matchAny, notFound
+ , request, reqHeader, body, param, params, jsonData, files
+ , status, addHeader, setHeader, redirect
+ , text, html, file, json, source, raw
+ , raise, rescue, next
+ , RoutePattern
+ -- * Spock utilities
+ , paramPathPiece
+ -- * Internals for extending Spock
+ , getSpockHeart, runSpockIO, WebStateM, WebState
+ )
+where
+
+import Web.Spock.SessionManager
+import Web.Spock.Monad
+import Web.Spock.Types
+import Web.Spock.Cookie
+import Web.Spock.SafeActions
+
+import Control.Applicative
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Resource
+import Data.Pool
+import Web.Scotty.Trans
+import Web.PathPieces
+import qualified Network.HTTP.Types as Http
+import qualified Data.Text.Lazy as TL
+
+-- | 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 -> SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO ()
+spock port sessionCfg poolOrConn initialState defs =
+ do sessionMgr <- createSessionManager sessionCfg
+ connectionPool <-
+ case poolOrConn of
+ PCConduitPool p ->
+ return (ConduitPool p)
+ PCPool p ->
+ return (DataPool p)
+ PCConn cb ->
+ let pc = cb_poolConfiguration cb
+ in DataPool <$> createPool (cb_createConn cb) (cb_destroyConn cb)
+ (pc_stripes pc) (pc_keepOpenTime pc)
+ (pc_resPerStripe pc)
+ let internalState =
+ WebState
+ { web_dbConn = connectionPool
+ , web_sessionMgr = sessionMgr
+ , web_state = initialState
+ }
+ runM m = runResourceT $ runReaderT (runWebStateM m) internalState
+ runActionToIO = runM
+
+ scottyT port runM runActionToIO $
+ do middleware (sm_middleware sessionMgr)
+ hookSafeActions
+ defs
+
+-- | Write to the current session. Note that all data is stored on the server.
+-- The user only reciedes a sessionId to be identified.
+writeSession :: sess -> SpockAction conn sess st ()
+writeSession d =
+ do mgr <- getSessMgr
+ (sm_writeSession mgr) d
+
+-- | Modify the stored session
+modifySession :: (sess -> sess) -> SpockAction conn sess st ()
+modifySession f =
+ do mgr <- getSessMgr
+ (sm_modifySession mgr) f
+
+-- | Read the stored session
+readSession :: SpockAction conn sess st sess
+readSession =
+ do mgr <- getSessMgr
+ sm_readSession mgr
+
+-- | Same as "param", but the target type needs to implement "PathPiece"
+paramPathPiece :: PathPiece s => TL.Text -> SpockAction conn sess st s
+paramPathPiece t =
+ do val <- param t
+ case fromPathPiece val of
+ Just x ->
+ return x
+ Nothing ->
+ raise $ stringError $ "Cannot convert param: " ++ TL.unpack t ++ " to path piece!"
diff --git a/src/Web/Spock/Cookie.hs b/src/Web/Spock/Cookie.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Cookie.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Web.Spock.Cookie where
+
+import Web.Spock.Types
+
+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
+
+-- | Read a cookie previously set in the users browser for your site
+getCookie :: (SpockError e, MonadIO m) => T.Text -> ActionT e m (Maybe T.Text)
+getCookie name =
+ do r <- request
+ return $ getCookieFromReq name r
+
+getCookieFromReq :: T.Text -> Wai.Request -> Maybe T.Text
+getCookieFromReq name req =
+ 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 "="
+
+-- | Set a cookie living for a given number of seconds
+setCookie :: (SpockError e, MonadIO m) => T.Text -> T.Text -> NominalDiffTime
+ -> ActionT e m ()
+setCookie name value validSeconds =
+ do now <- liftIO getCurrentTime
+ setCookie' name value (validSeconds `addUTCTime` now)
+
+-- | Set a cookie living until a specific 'UTCTime'
+setCookie' :: (SpockError e, MonadIO m) => T.Text -> T.Text -> UTCTime
+ -> ActionT e m ()
+setCookie' name value validUntil =
+ setHeader "Set-Cookie" (renderCookie name value validUntil)
+
+renderCookie :: T.Text -> T.Text -> UTCTime -> TL.Text
+renderCookie name value validUntil =
+ let formattedTime =
+ TL.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil
+ in TL.concat [ TL.fromStrict name
+ , "="
+ , TL.fromStrict value
+ , "; path=/; expires="
+ , formattedTime
+ , ";"
+ ]
diff --git a/src/Web/Spock/Monad.hs b/src/Web/Spock/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Monad.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+module Web.Spock.Monad where
+
+import Web.Spock.Types
+
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Trans.Resource
+import Data.Pool
+import Data.Time.Clock ( UTCTime(..) )
+import Web.Scotty.Trans
+import qualified Data.Conduit.Pool as CP
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Lazy as TL
+import qualified Text.XML.XSD.DateTime as XSD
+
+webM :: MonadTrans t => WebStateM conn sess st a -> t (WebStateM conn sess st) a
+webM = lift
+
+instance MonadTrans t => HasSpock (t (WebStateM conn sess st)) where
+ type SpockConn (t (WebStateM conn sess st)) = conn
+ type SpockState (t (WebStateM conn sess st)) = st
+ type SpockSession (t (WebStateM conn sess st)) = sess
+ runQuery a = webM $ runQueryImpl a
+ getState = webM $ getStateImpl
+ getSessMgr = webM $ getSessMgrImpl
+
+instance HasSpock (WebStateM conn sess st) where
+ type SpockConn (WebStateM conn sess st) = conn
+ type SpockState (WebStateM conn sess st) = st
+ type SpockSession (WebStateM conn sess st) = sess
+ runQuery = runQueryImpl
+ getState = getStateImpl
+ getSessMgr = getSessMgrImpl
+
+runQueryImpl :: (conn -> IO a) -> WebStateM conn sess st a
+runQueryImpl query =
+ do pool <- asks web_dbConn
+ let fun =
+ case pool of
+ DataPool p ->
+ withResource p
+ ConduitPool p ->
+ CP.withResource p
+ liftIO (fun query)
+
+getStateImpl :: WebStateM conn sess st st
+getStateImpl = asks web_state
+
+-- | Read the heart of Spock. This is useful if you want to construct your own
+-- monads that work with runQuery and getState using "runSpockIO"
+getSpockHeart :: MonadTrans t => t (WebStateM conn sess st) (WebState conn sess st)
+getSpockHeart = webM ask
+
+-- | Run an action inside of Spocks core monad. This allows you to use runQuery and getState
+runSpockIO :: WebState conn sess st -> WebStateM conn sess st a -> IO a
+runSpockIO st (WebStateM action) =
+ runResourceT $
+ runReaderT action st
+
+getSessMgrImpl :: (WebStateM conn sess st) (SessionManager conn sess st)
+getSessMgrImpl = asks web_sessionMgr
+
+instance Parsable BSL.ByteString where
+ parseParam =
+ Right . BSL.fromStrict . T.encodeUtf8 . TL.toStrict
+
+instance Parsable UTCTime where
+ parseParam p =
+ case join $ fmap XSD.toUTCTime $ XSD.dateTime (TL.toStrict p) of
+ Nothing ->
+ Left $ TL.pack $ "Can't parse param (`" ++ show p ++ "`) as UTCTime!"
+ Just x ->
+ Right x
diff --git a/src/Web/Spock/SafeActions.hs b/src/Web/Spock/SafeActions.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/SafeActions.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+module Web.Spock.SafeActions where
+
+import Web.Scotty.Trans
+import Web.Spock.Types
+
+import qualified Data.Text as T
+
+-- | Wire up a safe action: Safe actions are actions that are protected from
+-- csrf attacks. Here's a usage example:
+--
+-- > newtype DeleteUser = DeleteUser Int deriving (Hashable, Typeable, Eq)
+-- >
+-- > instance SafeAction Connection () () DeleteUser where
+-- > runSafeAction (DeleteUser i) =
+-- > do runQuery $ deleteUserFromDb i
+-- > redirect "/user-list"
+-- >
+-- > get "/user-details/:userId" $
+-- > do userId <- param "userId"
+-- > deleteUrl <- safeActionPath (DeleteUser userId)
+-- > html $ TL.concat [ "Click here to delete user!" ]
+--
+-- Note that safeActions currently only support GET and POST requests.
+--
+safeActionPath :: forall conn sess st a.
+ ( SafeAction conn sess st a
+ , HasSpock(SpockAction conn sess st)
+ , SpockConn (SpockAction conn sess st) ~ conn
+ , SpockSession (SpockAction conn sess st) ~ sess
+ , SpockState (SpockAction conn sess st) ~ st)
+ => a
+ -> SpockAction conn sess st T.Text
+safeActionPath safeAction =
+ do mgr <- getSessMgr
+ hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction)
+ return $ T.concat [ "/h/", hash ]
+
+hookSafeActions :: forall conn sess st.
+ ( HasSpock (SpockAction conn sess st)
+ , SpockConn (SpockAction conn sess st) ~ conn
+ , SpockSession (SpockAction conn sess st) ~ sess
+ , SpockState (SpockAction conn sess st) ~ st)
+ => SpockM conn sess st ()
+hookSafeActions =
+ do get "/h/:spock-csurf-protection" run
+ post "/h/:spock-csurf-protection" run
+ where
+ run =
+ do h <- param "spock-csurf-protection"
+ mgr <- getSessMgr
+ mAction <- (sm_lookupSafeAction mgr) h
+ case mAction of
+ Nothing ->
+ next
+ Just (PackedSafeAction action) ->
+ runSafeAction action
diff --git a/src/Web/Spock/SessionManager.hs b/src/Web/Spock/SessionManager.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/SessionManager.hs
@@ -0,0 +1,225 @@
+{-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}
+module Web.Spock.SessionManager
+ ( createSessionManager
+ , SessionId, Session(..), SessionManager(..)
+ )
+where
+
+import Web.Spock.Types
+import Web.Spock.Cookie
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Trans
+import Data.Time
+import System.Random
+import Web.Scotty.Trans
+import qualified Data.ByteString.Base64.URL as B64
+import qualified Data.ByteString.Char8 as BSC
+import qualified Data.ByteString.Lazy as BSL
+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.Encoding as TL
+import qualified Data.Vault.Lazy as V
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Util as Wai
+
+createSessionManager :: SessionCfg sess -> IO (SessionManager conn sess st)
+createSessionManager cfg =
+ do cacheHM <- atomically $ newTVar HM.empty
+ vaultKey <- V.newKey
+ _ <- forkIO (forever (housekeepSessions cacheHM))
+ return $ SessionManager
+ { sm_readSession = readSessionImpl vaultKey cacheHM
+ , sm_writeSession = writeSessionImpl vaultKey cacheHM
+ , sm_modifySession = modifySessionImpl vaultKey cacheHM
+ , sm_middleware = sessionMiddleware cfg vaultKey cacheHM
+ , sm_addSafeAction = addSafeActionImpl vaultKey cacheHM
+ , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM
+ , sm_removeSafeAction = removeSafeActionImpl vaultKey cacheHM
+ }
+
+modifySessionBase :: V.Key SessionId
+ -> UserSessions conn sess st
+ -> (Session conn sess st -> Session conn sess st)
+ -> SpockAction conn sess st ()
+modifySessionBase vK sessionRef modFun =
+ do req <- request
+ case V.lookup vK (Wai.vault req) of
+ Nothing ->
+ error "(3) Internal Spock Session Error. Please report this bug!"
+ Just sid ->
+ liftIO $ atomically $ modifyTVar' sessionRef (HM.adjust modFun sid)
+
+readSessionBase :: V.Key SessionId
+ -> UserSessions conn sess st
+ -> SpockAction conn sess st (Session conn sess st)
+readSessionBase vK sessionRef =
+ do req <- request
+ case V.lookup vK (Wai.vault req) of
+ Nothing ->
+ error "(1) Internal Spock Session Error. Please report this bug!"
+ Just sid ->
+ do sessions <- liftIO $ atomically $ readTVar sessionRef
+ case HM.lookup sid sessions of
+ Nothing ->
+ error "(2) Internal Spock Session Error. Please report this bug!"
+ Just session ->
+ return session
+
+addSafeActionImpl :: V.Key SessionId
+ -> UserSessions conn sess st
+ -> PackedSafeAction conn sess st
+ -> SpockAction conn sess st SafeActionHash
+addSafeActionImpl vaultKey sessionMapVar safeAction =
+ do base <- readSessionBase vaultKey sessionMapVar
+ case HM.lookup safeAction (sas_reverse (sess_safeActions base)) of
+ Just safeActionHash ->
+ return safeActionHash
+ Nothing ->
+ do safeActionHash <- liftIO (randomHash 40)
+ let f sas =
+ sas
+ { sas_forward = HM.insert safeActionHash safeAction (sas_forward sas)
+ , sas_reverse = HM.insert safeAction safeActionHash (sas_reverse sas)
+ }
+ modifySessionBase vaultKey sessionMapVar (\s -> s { sess_safeActions = f (sess_safeActions s) })
+ return safeActionHash
+
+lookupSafeActionImpl :: V.Key SessionId
+ -> UserSessions conn sess st
+ -> SafeActionHash
+ -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))
+lookupSafeActionImpl vaultKey sessionMapVar hash =
+ do base <- readSessionBase vaultKey sessionMapVar
+ return $ HM.lookup hash (sas_forward (sess_safeActions base))
+
+removeSafeActionImpl :: V.Key SessionId
+ -> UserSessions conn sess st
+ -> PackedSafeAction conn sess st
+ -> SpockAction conn sess st ()
+removeSafeActionImpl vaultKey sessionMapVar action =
+ modifySessionBase vaultKey sessionMapVar (\s -> s { sess_safeActions = f (sess_safeActions s ) })
+ where
+ f sas =
+ sas
+ { sas_forward =
+ case HM.lookup action (sas_reverse sas) of
+ Just h -> HM.delete h (sas_forward sas)
+ Nothing -> sas_forward sas
+ , sas_reverse = HM.delete action (sas_reverse sas)
+ }
+
+readSessionImpl :: V.Key SessionId
+ -> UserSessions conn sess st
+ -> SpockAction conn sess st sess
+readSessionImpl vK sessionRef =
+ do base <- readSessionBase vK sessionRef
+ return (sess_data base)
+
+writeSessionImpl :: V.Key SessionId
+ -> UserSessions conn sess st
+ -> sess
+ -> SpockAction conn sess st ()
+writeSessionImpl vK sessionRef value =
+ modifySessionImpl vK sessionRef (const value)
+
+modifySessionImpl :: V.Key SessionId
+ -> UserSessions conn sess st
+ -> (sess -> sess)
+ -> SpockAction conn sess st ()
+modifySessionImpl vK sessionRef f =
+ do let modFun session =
+ session { sess_data = f (sess_data session) }
+ modifySessionBase vK sessionRef modFun
+
+sessionMiddleware :: SessionCfg sess
+ -> V.Key SessionId
+ -> UserSessions conn sess st
+ -> Wai.Middleware
+sessionMiddleware cfg vK sessionRef app req =
+ case getCookieFromReq (sc_cookieName cfg) req of
+ Just sid ->
+ do mSess <- loadSessionImpl sessionRef sid
+ case mSess of
+ Nothing ->
+ mkNew
+ Just sess ->
+ withSess False sess
+ Nothing ->
+ mkNew
+ where
+ defVal = sc_emptySession cfg
+ v = Wai.vault req
+ addCookie sess responseHeaders =
+ let cookieContent =
+ renderCookie (sc_cookieName cfg) (sess_id sess) (sess_validUntil sess)
+ cookie = ("Set-Cookie", BSL.toStrict $ TL.encodeUtf8 cookieContent)
+ in (cookie : responseHeaders)
+ withSess shouldSetCookie sess =
+ do resp <- app (req { Wai.vault = V.insert vK (sess_id sess) v })
+ return $ if shouldSetCookie then Wai.mapHeaders (addCookie sess) resp else resp
+ mkNew =
+ do newSess <- newSessionImpl cfg sessionRef defVal
+ withSess True newSess
+
+newSessionImpl :: SessionCfg sess
+ -> UserSessions conn sess st
+ -> sess
+ -> IO (Session conn sess st)
+newSessionImpl sessCfg sessionRef content =
+ do sess <- createSession sessCfg content
+ atomically $ modifyTVar' sessionRef (\hm -> HM.insert (sess_id sess) sess hm)
+ return $! sess
+
+loadSessionImpl :: UserSessions conn sess st
+ -> SessionId
+ -> IO (Maybe (Session conn sess st))
+loadSessionImpl sessionRef sid =
+ do sessHM <- atomically $ readTVar sessionRef
+ now <- getCurrentTime
+ case HM.lookup sid sessHM of
+ Just sess ->
+ do if (sess_validUntil sess) > now
+ then return $ Just sess
+ else do deleteSessionImpl sessionRef sid
+ return Nothing
+ Nothing ->
+ return Nothing
+
+deleteSessionImpl :: UserSessions conn sess st
+ -> SessionId
+ -> IO ()
+deleteSessionImpl sessionRef sid =
+ do atomically $ modifyTVar' sessionRef (\hm -> HM.delete sid hm)
+ return ()
+
+housekeepSessions :: UserSessions conn sess st -> IO ()
+housekeepSessions sessionRef =
+ do now <- getCurrentTime
+ atomically $ modifyTVar' sessionRef (killOld now)
+ threadDelay (1000 * 1000 * 60) -- 60 seconds
+ where
+ filterOld now (_, sess) =
+ (sess_validUntil sess) > now
+ killOld now hm =
+ HM.fromList $ filter (filterOld now) $ HM.toList hm
+
+createSession :: SessionCfg sess -> sess -> IO (Session conn sess st)
+createSession sessCfg content =
+ do sid <- randomHash (sc_sessionIdEntropy sessCfg)
+ now <- getCurrentTime
+ let validUntil = addUTCTime (sc_sessionTTL sessCfg) now
+ emptySafeActions =
+ SafeActionStore HM.empty HM.empty
+ return (Session sid validUntil content emptySafeActions)
+
+randomHash :: Int -> IO T.Text
+randomHash len =
+ do gen <- g
+ return $ T.replace "=" "" $ T.decodeUtf8 $ B64.encode $ BSC.pack $
+ take len $ randoms gen
+ where
+ g = newStdGen :: IO StdGen
diff --git a/src/Web/Spock/Types.hs b/src/Web/Spock/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Types.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Web.Spock.Types where
+
+import Web.Scotty.Trans
+
+import Control.Applicative
+import Control.Concurrent.STM
+import Control.Monad.Base
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Control.Monad.Trans.Resource
+import Data.Hashable
+import Data.Pool
+import Data.Text.Lazy (Text)
+import Data.Time.Clock ( UTCTime(..), NominalDiffTime )
+import Data.Typeable
+import Network.Wai
+import qualified Data.Conduit.Pool as CP
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Text as T
+
+type SpockError e = ScottyError e
+
+-- | 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 = ScottyT Text (WebStateM conn sess st)
+
+-- | 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 = ActionT Text (WebStateM conn sess st)
+
+-- | 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)
+ | PCConduitPool (CP.Pool a)
+ | PCConn (ConnBuilder a)
+
+-- | Configuration for the session manager
+data SessionCfg a
+ = SessionCfg
+ { sc_cookieName :: T.Text
+ , sc_sessionTTL :: NominalDiffTime
+ , sc_sessionIdEntropy :: Int
+ , sc_emptySession :: a
+ }
+
+data ConnectionPool conn
+ = DataPool (Pool conn)
+ | ConduitPool (CP.Pool conn)
+
+data WebState conn sess st
+ = WebState
+ { web_dbConn :: ConnectionPool conn
+ , web_sessionMgr :: SessionManager conn sess st
+ , web_state :: st
+ }
+
+class HasSpock m where
+ type SpockConn m :: *
+ type SpockState m :: *
+ type SpockSession m :: *
+ -- | Give you access to a database connectin from the connection pool. The connection is
+ -- released back to the pool once the function terminates.
+ runQuery :: (SpockConn m -> IO a) -> m a
+ -- | Read the application's state. If you wish to have mutable state, you could
+ -- use a 'TVar' from the STM packge.
+ getState :: m (SpockState m)
+ -- | Get the session manager
+ getSessMgr :: m (SessionManager (SpockConn m) (SpockSession m) (SpockState m))
+
+-- | SafeActions are actions that need to be protected from csrf attacks
+class (Hashable a, Eq a, Typeable a) => SafeAction conn sess st a where
+ -- | The body of the safe action. Either GET or POST
+ runSafeAction :: a -> SpockAction conn sess st ()
+
+data PackedSafeAction conn sess st
+ = forall a. (SafeAction conn sess st a) => PackedSafeAction { unpackSafeAction :: a }
+
+instance Hashable (PackedSafeAction conn sess st) where
+ hashWithSalt i (PackedSafeAction a) = hashWithSalt i a
+
+instance Eq (PackedSafeAction conn sess st) where
+ (PackedSafeAction a) == (PackedSafeAction b) =
+ cast a == Just b
+
+data SafeActionStore conn sess st
+ = SafeActionStore
+ { sas_forward :: !(HM.HashMap SafeActionHash (PackedSafeAction conn sess st))
+ , sas_reverse :: !(HM.HashMap (PackedSafeAction conn sess st) SafeActionHash)
+ }
+
+type SafeActionHash = T.Text
+
+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))
+
+instance MonadBase IO (WebStateM conn sess st) where
+ liftBase = WebStateM . liftBase
+
+instance MonadBaseControl IO (WebStateM conn sess st) where
+ newtype StM (WebStateM conn sess st) a = WStM { unWStM :: StM (ReaderT (WebState conn sess st) (ResourceT IO)) a }
+ liftBaseWith f = WebStateM . liftBaseWith $ \runInBase -> f $ liftM WStM . runInBase . runWebStateM
+ restoreM = WebStateM . restoreM . unWStM
+
+type SessionId = T.Text
+data Session conn sess st
+ = Session
+ { sess_id :: !SessionId
+ , sess_validUntil :: !UTCTime
+ , sess_data :: !sess
+ , sess_safeActions :: !(SafeActionStore conn sess st)
+ }
+instance Show (Session conn sess st) where
+ show = show . sess_id
+
+type UserSessions conn sess st =
+ TVar (HM.HashMap SessionId (Session conn sess st))
+
+data SessionManager conn sess st
+ = SessionManager
+ { sm_readSession :: SpockAction conn sess st sess
+ , sm_writeSession :: sess -> SpockAction conn sess st ()
+ , sm_modifySession :: (sess -> sess) -> SpockAction conn sess st ()
+ , sm_middleware :: Middleware
+ , sm_addSafeAction :: PackedSafeAction conn sess st -> SpockAction conn sess st SafeActionHash
+ , sm_lookupSafeAction :: SafeActionHash -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))
+ , sm_removeSafeAction :: PackedSafeAction conn sess st -> SpockAction conn sess st ()
+ }