diff --git a/Spock.cabal b/Spock.cabal
--- a/Spock.cabal
+++ b/Spock.cabal
@@ -1,5 +1,5 @@
name: Spock
-version: 0.6.6.1
+version: 0.7.0.0
synopsis: Another Haskell web framework for rapid development
description: This toolbox provides everything you need to get a quick start into web hacking with haskell: routing, middleware, json, blaze, sessions, cookies, database helper, csrf-protection, global state
Homepage: https://github.com/agrafix/Spock
@@ -14,16 +14,21 @@
library
hs-source-dirs: src
- exposed-modules: Web.Spock,
- Web.Spock.Routing,
- Web.Spock.Wire
- other-modules: Web.Spock.SessionManager,
- Web.Spock.Monad,
- Web.Spock.Types,
- Web.Spock.SafeActions,
- Web.Spock.Digestive,
- Web.Spock.Util,
- Web.Spock.Core
+ exposed-modules: Web.Spock.Simple,
+ Web.Spock.Safe,
+ Web.Spock.Specs.All
+ other-modules: Web.Spock.Internal.SessionManager,
+ Web.Spock.Internal.Monad,
+ Web.Spock.Internal.Types,
+ Web.Spock.Internal.Digestive,
+ Web.Spock.Internal.Util,
+ Web.Spock.Internal.Core,
+ Web.Spock.Internal.CoreAction,
+ Web.Spock.Internal.Wrapper,
+ Web.Spock.Internal.Wire,
+ Web.Spock.Specs.SimpleSpec,
+ Web.Spock.Specs.SafeSpec,
+ Web.Spock.Specs.FrameworkSpecHelper
build-depends: aeson >= 0.6.2.1 && <0.9,
base >= 4 && < 5,
base64-bytestring ==1.*,
@@ -35,6 +40,9 @@
digestive-functors ==0.7.*,
directory ==1.2.*,
hashable ==1.2.*,
+ hspec2 >=0.4 && <0.5,
+ hspec-wai >=0.5 && <0.6,
+ HList >=0.3,
http-types ==0.8.*,
monad-control ==0.3.*,
mtl >=2.1 && <2.3,
@@ -42,8 +50,10 @@
path-pieces >=0.1.4,
random ==1.*,
regex-compat ==0.95.*,
+ reroute >=0.1 && <0.2,
resource-pool ==0.2.*,
resourcet >= 0.4 && <1.2,
+ safe >=0.3,
stm ==2.4.*,
text >= 0.11.3.1 && <1.3,
time >=1.4 && <1.6,
@@ -62,13 +72,9 @@
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Spec.hs
- other-modules: Web.Spock.WireSpec, Web.Spock.RoutingSpec
- build-depends: QuickCheck,
- Spock,
+ build-depends: hspec2 >=0.4 && <0.5,
base >= 4 && < 5,
- hspec2 >=0.4 && <0.5,
- vector ==0.10.*,
- unordered-containers ==0.2.*
+ Spock
ghc-options: -Wall -fno-warn-orphans
source-repository head
diff --git a/src/Web/Spock.hs b/src/Web/Spock.hs
deleted file mode 100644
--- a/src/Web/Spock.hs
+++ /dev/null
@@ -1,106 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Web.Spock
- ( -- * Spock's core
- spock, SpockM, SpockAction
- , spockT, SpockT, ActionT
- -- * Defining routes
- , get, post, C.head, put, delete, patch, defRoute
- , subcomponent, Http.StdMethod (..)
- , combineRoute
- -- * Handeling requests
- , request, header, cookie, body, jsonBody, jsonBody', files, UploadedFile (..)
- , params, param, param'
- -- * Sending responses
- , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', bytes, lazyBytes
- , text, html, file, json, blaze
- -- * Adding middleware
- , middleware
- -- * Database
- , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)
- -- * Accessing Database and State
- , HasSpock (runQuery, getState), SpockConn, SpockState, SpockSession
- -- * Sessions
- , SessionCfg (..)
- , readSession, writeSession, modifySession, clearAllSessions
- -- * Basic HTTP-Auth
- , requireBasicAuth
- -- * Safe actions
- , SafeAction (..)
- , safeActionPath
- -- * Digestive Functors
- , runForm
- -- * Internals for extending Spock
- , getSpockHeart, runSpockIO, WebStateM, WebState
- )
-where
-
-import Web.Spock.Core
-import Web.Spock.Digestive
-import Web.Spock.Monad
-import Web.Spock.SafeActions
-import Web.Spock.SessionManager
-import Web.Spock.Types
-import qualified Web.Spock.Core as C
-
-import Control.Monad.Trans.Reader
-import Control.Monad.Trans.Resource
-import Data.Pool
-import qualified Network.HTTP.Types as Http
-
--- | 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
- 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
- , web_sessionMgr = sessionMgr
- , web_state = initialState
- }
- runM m = runResourceT $ runReaderT (runWebStateM m) internalState
-
- spockT port runM $
- do hookSafeActions
- defs
- middleware (sm_middleware sessionMgr)
-
--- | 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
-
--- | Globally delete all existing sessions. This is useful for example if you want
--- to require all users to relogin
-clearAllSessions :: SpockAction conn sess st ()
-clearAllSessions =
- do mgr <- getSessMgr
- sm_clearAllSessions mgr
diff --git a/src/Web/Spock/Core.hs b/src/Web/Spock/Core.hs
deleted file mode 100644
--- a/src/Web/Spock/Core.hs
+++ /dev/null
@@ -1,279 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DoAndIfThenElse #-}
-module Web.Spock.Core
- ( SpockT, ActionT, spockT
- , middleware, UploadedFile (..)
- , defRoute, get, post, head, put, delete, patch
- , request, header, cookie, body, jsonBody, jsonBody'
- , files, params, param, param', setStatus, setHeader, redirect
- , jumpNext
- , setCookie, setCookie'
- , bytes, lazyBytes, text, html, file, json, blaze
- , combineRoute, subcomponent
- , requireBasicAuth
- )
-where
-
-import Control.Arrow (first)
-import Control.Monad
-import Control.Monad.Error
-import Control.Monad.Reader
-import Control.Monad.State hiding (get, put)
-import Data.Monoid
-import Data.Time
-import Network.HTTP.Types.Method
-import Network.HTTP.Types.Status
-import Prelude hiding (head)
-import System.Locale
-import Text.Blaze.Html (Html)
-import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
-import Web.PathPieces
-import Web.Spock.Routing
-import Web.Spock.Wire
-import qualified Data.Aeson as A
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.CaseInsensitive as CI
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Network.Wai as Wai
-import qualified Network.Wai.Handler.Warp as Warp
-
--- | Run a raw spock server on a defined port. If you don't need
--- a custom base monad you can just supply 'id' as lift function.
-spockT :: MonadIO m
- => Warp.Port
- -> (forall a. m a -> IO a)
- -> SpockT m ()
- -> IO ()
-spockT port liftSpock routeDefs =
- do spockApp <- buildApp liftSpock routeDefs
- putStrLn $ "Spock is up and running on port " ++ show port
- Warp.run port spockApp
-
--- | Specify an action that will be run when the HTTP verb 'GET' and the given route match
-get :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
-get = defRoute GET
-
--- | Specify an action that will be run when the HTTP verb 'POST' and the given route match
-post :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
-post = defRoute POST
-
--- | Specify an action that will be run when the HTTP verb 'HEAD' and the given route match
-head :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
-head = defRoute HEAD
-
--- | Specify an action that will be run when the HTTP verb 'PUT' and the given route match
-put :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
-put = defRoute PUT
-
--- | Specify an action that will be run when the HTTP verb 'DELETE' and the given route match
-delete :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
-delete = defRoute DELETE
-
--- | Specify an action that will be run when the HTTP verb 'PATCH' and the given route match
-patch :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
-patch = defRoute PATCH
-
--- | Get the original Wai Request object
-request :: MonadIO m => ActionT m Wai.Request
-request = asks ri_request
-
--- | Read a header
-header :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)
-header t =
- do req <- request
- return $ fmap T.decodeUtf8 (lookup (CI.mk (T.encodeUtf8 t)) $ Wai.requestHeaders req)
-
--- | Read a cookie
-cookie :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)
-cookie 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 "="
-
--- | Get the raw request body
-body :: MonadIO m => ActionT m BS.ByteString
-body =
- do req <- request
- let parseBody = liftIO $ Wai.requestBody req
- parseAll chunks =
- do bs <- parseBody
- if BS.null bs
- then return chunks
- else parseAll (chunks `BS.append` bs)
- parseAll BS.empty
-
--- | Parse the request body as json
-jsonBody :: (MonadIO m, A.FromJSON a) => ActionT m (Maybe a)
-jsonBody =
- do b <- body
- return $ A.decodeStrict b
-
--- | Parse the request body as json and fails with 500 status code on error
-jsonBody' :: (MonadIO m, A.FromJSON a) => ActionT m a
-jsonBody' =
- do b <- body
- case A.eitherDecodeStrict' b of
- Left err ->
- do setStatus status500
- text (T.pack $ "Failed to parse json: " ++ err)
- Right val ->
- return val
-
--- | Get uploaded files
-files :: MonadIO m => ActionT m (HM.HashMap T.Text UploadedFile)
-files =
- asks ri_files
-
--- | Get all request params
-params :: MonadIO m => ActionT m [(T.Text, T.Text)]
-params =
- do p <- asks ri_params
- qp <- asks ri_queryParams
- return (qp ++ (map (\(k, v) -> (unCaptureVar k, v)) $ HM.toList p))
-
--- | Read a request param. Spock looks in route captures first, then in POST variables and at last in GET variables
-param :: (PathPiece p, MonadIO m) => T.Text -> ActionT m (Maybe p)
-param k =
- do p <- asks ri_params
- qp <- asks ri_queryParams
- case HM.lookup (CaptureVar k) p of
- Just val ->
- case fromPathPiece val of
- Nothing ->
- do liftIO $ putStrLn ("Cannot parse " ++ show k ++ " with value " ++ show val ++ " as path piece!")
- jumpNext
- Just pathPieceVal ->
- return $ Just pathPieceVal
- Nothing ->
- return $ join $ fmap fromPathPiece (lookup k qp)
-
--- | Like 'param', but outputs an error when a param is missing
-param' :: (PathPiece p, MonadIO m) => T.Text -> ActionT m p
-param' k =
- do mParam <- param k
- case mParam of
- Nothing ->
- do setStatus status500
- text (T.concat [ "Missing parameter ", k ])
- Just val ->
- return val
-
--- | Set a response status
-setStatus :: MonadIO m => Status -> ActionT m ()
-setStatus s =
- modify $ \rs -> rs { rs_status = s }
-
--- | Set a response header. Overwrites already defined headers
-setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
-setHeader k v =
- modify $ \rs -> rs { rs_responseHeaders = ((k, v) : filter ((/= k) . fst) (rs_responseHeaders rs)) }
-
--- | Abort the current action and jump the next one matching the route
-jumpNext :: MonadIO m => ActionT m a
-jumpNext = throwError ActionTryNext
-
--- | Redirect to a given url
-redirect :: MonadIO m => T.Text -> ActionT m a
-redirect = throwError . ActionRedirect
-
--- | 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 =
- setHeader "Set-Cookie" rendered
- where
- rendered =
- let formattedTime =
- T.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil
- in T.concat [ name
- , "="
- , value
- , "; path=/; expires="
- , formattedTime
- , ";"
- ]
-
--- | Send a 'ByteString' as response body. Provide your own "Content-Type"
-bytes :: MonadIO m => BS.ByteString -> ActionT m a
-bytes val =
- lazyBytes $ BSL.fromStrict val
-
--- | Send a lazy 'ByteString' as response body. Provide your own "Content-Type"
-lazyBytes :: MonadIO m => BSL.ByteString -> ActionT m a
-lazyBytes val =
- do modify $ \rs -> rs { rs_responseBody = ResponseLBS val }
- throwError ActionDone
-
--- | Send text as a response body. Content-Type will be "text/plain"
-text :: MonadIO m => T.Text -> ActionT m a
-text val =
- do setHeader "Content-Type" "text/plain"
- bytes $ T.encodeUtf8 val
-
--- | Send a text as response body. Content-Type will be "text/plain"
-html :: MonadIO m => T.Text -> ActionT m a
-html val =
- do setHeader "Content-Type" "text/html"
- bytes $ T.encodeUtf8 val
-
--- | Send a file as response
-file :: MonadIO m => T.Text -> FilePath -> ActionT m a
-file contentType filePath =
- do setHeader "Content-Type" contentType
- modify $ \rs -> rs { rs_responseBody = ResponseFile filePath }
- throwError ActionDone
-
--- | Send json as response. Content-Type will be "application/json"
-json :: (A.ToJSON a, MonadIO m) => a -> ActionT m b
-json val =
- do setHeader "Content-Type" "application/json"
- lazyBytes $ A.encode val
-
--- | Send blaze html as response. Content-Type will be "text/html"
-blaze :: MonadIO m => Html -> ActionT m a
-blaze val =
- do setHeader "Content-Type" "text/html"
- lazyBytes $ renderHtml val
-
--- | Basic authentification
--- provide a title for the prompt and a function to validate
--- user and password. Usage example:
---
--- > get "/my-secret-page" $
--- > requireBasicAuth "Secret Page" (\user pass -> return (user == "admin" && pass == "1234")) $
--- > do html "This is top secret content. Login using that secret code I provided ;-)"
---
-requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> m Bool) -> ActionT m a -> ActionT m a
-requireBasicAuth realmTitle authFun cont =
- do mAuthHeader <- header "Authorization"
- case mAuthHeader of
- Nothing ->
- authFailed
- Just authHeader ->
- let (_, rawValue) =
- T.breakOn " " authHeader
- (user, rawPass) =
- (T.breakOn ":" . T.decodeUtf8 . B64.decodeLenient . T.encodeUtf8 . T.strip) rawValue
- pass = T.drop 1 rawPass
- in do isOk <- lift $ authFun user pass
- if isOk
- then cont
- else authFailed
- where
- authFailed =
- do setStatus status401
- setHeader "WWW-Authenticate" ("Basic realm=\"" <> realmTitle <> "\"")
- html "Authentication required.
"
diff --git a/src/Web/Spock/Digestive.hs b/src/Web/Spock/Digestive.hs
deleted file mode 100644
--- a/src/Web/Spock/Digestive.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# LANGUAGE DoAndIfThenElse #-}
-module Web.Spock.Digestive
- ( runForm )
-where
-
-import Web.Spock.Core
-
-import Control.Applicative
-import Control.Monad.Trans
-import Network.HTTP.Types
-import Network.Wai
-import Text.Digestive.Form
-import Text.Digestive.Types
-import Text.Digestive.View
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Text as T
-
--- | Run a digestive functors form
-runForm :: (Functor m, MonadIO m)
- => T.Text -- ^ form name
- -> Form v (ActionT m) a
- -> ActionT m (View v, Maybe a)
-runForm formName form =
- do httpMethod <- requestMethod <$> request
- if httpMethod == methodGet
- then do f <- getForm formName form
- return (f, Nothing)
- else postForm formName form (const $ return localEnv)
- where
- localEnv path =
- do let name = fromPath $ path
- applyParam f =
- map (f . snd) . filter ((== name) . fst)
- vars <- (applyParam (TextInput)) <$> params
- sentFiles <- (applyParam (FileInput . T.unpack . uf_name) . HM.toList) <$> files
- return (vars ++ sentFiles)
diff --git a/src/Web/Spock/Internal/Core.hs b/src/Web/Spock/Internal/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Internal/Core.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Web.Spock.Internal.Core
+ ( SpockAllT
+ , spockAllT
+ , middleware
+ , hookRoute
+ , subcomponent
+ )
+where
+
+import Web.Spock.Internal.Wire
+
+import Control.Monad.Error
+import Prelude hiding (head)
+import Web.Routing.AbstractRouter
+import qualified Network.Wai.Handler.Warp as Warp
+
+-- | Run a raw spock server on a defined port. If you don't need
+-- a custom base monad you can just supply 'id' as lift function.
+spockAllT :: (MonadIO m, AbstractRouter r, RouteAppliedAction r ~ ActionT m ())
+ => r
+ -> Warp.Port
+ -> (forall a. m a -> IO a)
+ -> SpockAllT r m ()
+ -> IO ()
+spockAllT registryIf port liftSpock routeDefs =
+ do spockApp <- buildApp registryIf liftSpock routeDefs
+ putStrLn $ "Spock is up and running on port " ++ show port
+ Warp.run port spockApp
diff --git a/src/Web/Spock/Internal/CoreAction.hs b/src/Web/Spock/Internal/CoreAction.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Internal/CoreAction.hs
@@ -0,0 +1,240 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+module Web.Spock.Internal.CoreAction
+ ( ActionT
+ , UploadedFile (..)
+ , request, header, cookie, body, jsonBody, jsonBody'
+ , files, params, param, param', setStatus, setHeader, redirect
+ , jumpNext
+ , setCookie, setCookie'
+ , bytes, lazyBytes, text, html, file, json, blaze
+ , requireBasicAuth
+ )
+where
+
+import Web.Spock.Internal.Wire
+
+import Control.Arrow (first)
+import Control.Monad
+import Control.Monad.Error
+import Control.Monad.Reader
+import Control.Monad.State hiding (get, put)
+import Data.Monoid
+import Data.Time
+import Network.HTTP.Types.Status
+import Prelude hiding (head)
+import System.Locale
+import Text.Blaze.Html (Html)
+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
+import Web.PathPieces
+import Web.Routing.AbstractRouter
+import qualified Data.Aeson as A
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.CaseInsensitive as CI
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Network.Wai as Wai
+
+-- | Get the original Wai Request object
+request :: MonadIO m => ActionT m Wai.Request
+request = asks ri_request
+
+-- | Read a header
+header :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)
+header t =
+ do req <- request
+ return $ fmap T.decodeUtf8 (lookup (CI.mk (T.encodeUtf8 t)) $ Wai.requestHeaders req)
+
+-- | Read a cookie
+cookie :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)
+cookie 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 "="
+
+-- | Get the raw request body
+body :: MonadIO m => ActionT m BS.ByteString
+body =
+ do req <- request
+ let parseBody = liftIO $ Wai.requestBody req
+ parseAll chunks =
+ do bs <- parseBody
+ if BS.null bs
+ then return chunks
+ else parseAll (chunks `BS.append` bs)
+ parseAll BS.empty
+
+-- | Parse the request body as json
+jsonBody :: (MonadIO m, A.FromJSON a) => ActionT m (Maybe a)
+jsonBody =
+ do b <- body
+ return $ A.decodeStrict b
+
+-- | Parse the request body as json and fails with 500 status code on error
+jsonBody' :: (MonadIO m, A.FromJSON a) => ActionT m a
+jsonBody' =
+ do b <- body
+ case A.eitherDecodeStrict' b of
+ Left err ->
+ do setStatus status500
+ text (T.pack $ "Failed to parse json: " ++ err)
+ Right val ->
+ return val
+
+-- | Get uploaded files
+files :: MonadIO m => ActionT m (HM.HashMap T.Text UploadedFile)
+files =
+ asks ri_files
+
+-- | Get all request params
+params :: MonadIO m => ActionT m [(T.Text, T.Text)]
+params =
+ do p <- asks ri_params
+ qp <- asks ri_queryParams
+ return (qp ++ (map (\(k, v) -> (unCaptureVar k, v)) $ HM.toList p))
+
+-- | Read a request param. Spock looks in route captures first, then in POST variables and at last in GET variables
+param :: (PathPiece p, MonadIO m) => T.Text -> ActionT m (Maybe p)
+param k =
+ do p <- asks ri_params
+ qp <- asks ri_queryParams
+ case HM.lookup (CaptureVar k) p of
+ Just val ->
+ case fromPathPiece val of
+ Nothing ->
+ do liftIO $ putStrLn ("Cannot parse " ++ show k ++ " with value " ++ show val ++ " as path piece!")
+ jumpNext
+ Just pathPieceVal ->
+ return $ Just pathPieceVal
+ Nothing ->
+ return $ join $ fmap fromPathPiece (lookup k qp)
+
+-- | Like 'param', but outputs an error when a param is missing
+param' :: (PathPiece p, MonadIO m) => T.Text -> ActionT m p
+param' k =
+ do mParam <- param k
+ case mParam of
+ Nothing ->
+ do setStatus status500
+ text (T.concat [ "Missing parameter ", k ])
+ Just val ->
+ return val
+
+-- | Set a response status
+setStatus :: MonadIO m => Status -> ActionT m ()
+setStatus s =
+ modify $ \rs -> rs { rs_status = s }
+
+-- | Set a response header. Overwrites already defined headers
+setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
+setHeader k v =
+ modify $ \rs -> rs { rs_responseHeaders = ((k, v) : filter ((/= k) . fst) (rs_responseHeaders rs)) }
+
+-- | Abort the current action and jump the next one matching the route
+jumpNext :: MonadIO m => ActionT m a
+jumpNext = throwError ActionTryNext
+
+-- | Redirect to a given url
+redirect :: MonadIO m => T.Text -> ActionT m a
+redirect = throwError . ActionRedirect
+
+-- | 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 =
+ setHeader "Set-Cookie" rendered
+ where
+ rendered =
+ let formattedTime =
+ T.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil
+ in T.concat [ name
+ , "="
+ , value
+ , "; path=/; expires="
+ , formattedTime
+ , ";"
+ ]
+
+-- | Send a 'ByteString' as response body. Provide your own "Content-Type"
+bytes :: MonadIO m => BS.ByteString -> ActionT m a
+bytes val =
+ lazyBytes $ BSL.fromStrict val
+
+-- | Send a lazy 'ByteString' as response body. Provide your own "Content-Type"
+lazyBytes :: MonadIO m => BSL.ByteString -> ActionT m a
+lazyBytes val =
+ do modify $ \rs -> rs { rs_responseBody = ResponseLBS val }
+ throwError ActionDone
+
+-- | Send text as a response body. Content-Type will be "text/plain"
+text :: MonadIO m => T.Text -> ActionT m a
+text val =
+ do setHeader "Content-Type" "text/plain"
+ bytes $ T.encodeUtf8 val
+
+-- | Send a text as response body. Content-Type will be "text/plain"
+html :: MonadIO m => T.Text -> ActionT m a
+html val =
+ do setHeader "Content-Type" "text/html"
+ bytes $ T.encodeUtf8 val
+
+-- | Send a file as response
+file :: MonadIO m => T.Text -> FilePath -> ActionT m a
+file contentType filePath =
+ do setHeader "Content-Type" contentType
+ modify $ \rs -> rs { rs_responseBody = ResponseFile filePath }
+ throwError ActionDone
+
+-- | Send json as response. Content-Type will be "application/json"
+json :: (A.ToJSON a, MonadIO m) => a -> ActionT m b
+json val =
+ do setHeader "Content-Type" "application/json"
+ lazyBytes $ A.encode val
+
+-- | Send blaze html as response. Content-Type will be "text/html"
+blaze :: MonadIO m => Html -> ActionT m a
+blaze val =
+ do setHeader "Content-Type" "text/html"
+ lazyBytes $ renderHtml val
+
+-- | Basic authentification
+-- provide a title for the prompt and a function to validate
+-- user and password. Usage example:
+--
+-- > get "/my-secret-page" $
+-- > requireBasicAuth "Secret Page" (\user pass -> return (user == "admin" && pass == "1234")) $
+-- > do html "This is top secret content. Login using that secret code I provided ;-)"
+--
+requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> m Bool) -> ActionT m a -> ActionT m a
+requireBasicAuth realmTitle authFun cont =
+ do mAuthHeader <- header "Authorization"
+ case mAuthHeader of
+ Nothing ->
+ authFailed
+ Just authHeader ->
+ let (_, rawValue) =
+ T.breakOn " " authHeader
+ (user, rawPass) =
+ (T.breakOn ":" . T.decodeUtf8 . B64.decodeLenient . T.encodeUtf8 . T.strip) rawValue
+ pass = T.drop 1 rawPass
+ in do isOk <- lift $ authFun user pass
+ if isOk
+ then cont
+ else authFailed
+ where
+ authFailed =
+ do setStatus status401
+ setHeader "WWW-Authenticate" ("Basic realm=\"" <> realmTitle <> "\"")
+ html "Authentication required.
"
diff --git a/src/Web/Spock/Internal/Digestive.hs b/src/Web/Spock/Internal/Digestive.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Internal/Digestive.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DoAndIfThenElse #-}
+module Web.Spock.Internal.Digestive
+ ( runForm )
+where
+
+import Web.Spock.Internal.CoreAction
+
+import Control.Applicative
+import Control.Monad.Trans
+import Network.HTTP.Types
+import Network.Wai
+import Text.Digestive.Form
+import Text.Digestive.Types
+import Text.Digestive.View
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Text as T
+
+-- | Run a digestive functors form
+runForm :: (Functor m, MonadIO m)
+ => T.Text -- ^ form name
+ -> Form v (ActionT m) a
+ -> ActionT m (View v, Maybe a)
+runForm formName form =
+ do httpMethod <- requestMethod <$> request
+ if httpMethod == methodGet
+ then do f <- getForm formName form
+ return (f, Nothing)
+ else postForm formName form (const $ return localEnv)
+ where
+ localEnv path =
+ do let name = fromPath $ path
+ applyParam f =
+ map (f . snd) . filter ((== name) . fst)
+ vars <- (applyParam (TextInput)) <$> params
+ sentFiles <- (applyParam (FileInput . T.unpack . uf_name) . HM.toList) <$> files
+ return (vars ++ sentFiles)
diff --git a/src/Web/Spock/Internal/Monad.hs b/src/Web/Spock/Internal/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Internal/Monad.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+module Web.Spock.Internal.Monad where
+
+import Web.Spock.Internal.Types
+
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Trans.Resource
+import Data.Pool
+import Data.Time.Clock ( UTCTime(..) )
+import Web.PathPieces
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+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
+ liftIO (withResource pool $ 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 PathPiece BSL.ByteString where
+ fromPathPiece =
+ Just . BSL.fromStrict . T.encodeUtf8
+ toPathPiece =
+ T.decodeUtf8 . BSL.toStrict
+
+instance PathPiece UTCTime where
+ fromPathPiece p = join $ fmap XSD.toUTCTime $ XSD.dateTime p
+ toPathPiece = T.pack . show . XSD.fromUTCTime
diff --git a/src/Web/Spock/Internal/SessionManager.hs b/src/Web/Spock/Internal/SessionManager.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Internal/SessionManager.hs
@@ -0,0 +1,253 @@
+{-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}
+module Web.Spock.Internal.SessionManager
+ ( createSessionManager
+ , SessionId, Session(..), SessionManager(..)
+ )
+where
+
+import Web.Spock.Internal.Types
+import Web.Spock.Internal.CoreAction
+import Web.Spock.Internal.Util
+
+import Control.Arrow (first)
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Trans
+import Data.Time
+import System.Locale
+import System.Random
+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 as TL
+import qualified Data.Text.Lazy.Encoding as TL
+import qualified Data.Vault.Lazy as V
+import qualified Network.Wai 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_clearAllSessions = clearAllSessionsImpl 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 respond =
+ case getCookieFromReq (sc_cookieName cfg) of
+ Just sid ->
+ do mSess <- loadSessionImpl sessionRef sid
+ case mSess of
+ Nothing ->
+ mkNew
+ Just sess ->
+ withSess False sess
+ Nothing ->
+ mkNew
+ where
+ getCookieFromReq name =
+ lookup "cookie" (Wai.requestHeaders req) >>=
+ lookup name . parseCookies . T.decodeUtf8
+ 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
+ , ";"
+ ]
+ parseCookies :: T.Text -> [(T.Text, T.Text)]
+ parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words
+ parseCookie = first T.init . T.breakOnEnd "="
+
+ defVal = sc_emptySession cfg
+ v = Wai.vault req
+ addCookie sess responseHeaders =
+ let cookieContent =
+ renderCookie (sc_cookieName cfg) (sess_id sess) (sess_validUntil sess)
+ cookieC = ("Set-Cookie", BSL.toStrict $ TL.encodeUtf8 cookieContent)
+ in (cookieC : responseHeaders)
+ withSess shouldSetCookie sess =
+ app (req { Wai.vault = V.insert vK (sess_id sess) v }) $ \unwrappedResp ->
+ respond $
+ if shouldSetCookie
+ then mapReqHeaders (addCookie sess) unwrappedResp
+ else unwrappedResp
+ 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 ()
+
+clearAllSessionsImpl :: UserSessions conn sess st
+ -> SpockAction conn sess st ()
+clearAllSessionsImpl sessionRef =
+ liftIO $ atomically $ modifyTVar' sessionRef (const HM.empty)
+
+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/Internal/Types.hs b/src/Web/Spock/Internal/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Internal/Types.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Web.Spock.Internal.Types where
+
+import Web.Spock.Internal.Core
+import Web.Spock.Internal.CoreAction
+
+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.Time.Clock ( UTCTime(..), NominalDiffTime )
+import Data.Typeable
+import Network.Wai
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Text as T
+
+-- | Inside the SpockAllM monad, you may define routes and middleware.
+type SpockAllM r conn sess st a =
+ SpockAllT r (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 = ActionT (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)
+ | 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 WebState conn sess st
+ = WebState
+ { web_dbConn :: Pool 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_clearAllSessions :: 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 ()
+ }
diff --git a/src/Web/Spock/Internal/Util.hs b/src/Web/Spock/Internal/Util.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Internal/Util.hs
@@ -0,0 +1,12 @@
+module Web.Spock.Internal.Util where
+
+import Network.HTTP.Types
+import Network.Wai.Internal
+
+mapReqHeaders :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response
+mapReqHeaders f resp =
+ case resp of
+ (ResponseFile s h b1 b2) -> ResponseFile s (f h) b1 b2
+ (ResponseBuilder s h b) -> ResponseBuilder s (f h) b
+ (ResponseStream s h b) -> ResponseStream s (f h) b
+ (ResponseRaw x r) -> ResponseRaw x (mapReqHeaders f r)
diff --git a/src/Web/Spock/Internal/Wire.hs b/src/Web/Spock/Internal/Wire.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Internal/Wire.hs
@@ -0,0 +1,190 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Web.Spock.Internal.Wire where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad.RWS.Strict
+import Control.Monad.Error
+import Control.Monad.Reader.Class ()
+import Control.Monad.Trans.Resource
+import Data.Hashable
+import Data.Maybe
+import Network.HTTP.Types.Method
+import Network.HTTP.Types.Status
+#if MIN_VERSION_base(4,6,0)
+import Prelude
+#else
+import Prelude hiding (catch)
+#endif
+import System.Directory
+import Web.Routing.AbstractRouter
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.CaseInsensitive as CI
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Parse as P
+
+instance Hashable StdMethod where
+ hashWithSalt = hashUsing fromEnum
+
+data UploadedFile
+ = UploadedFile
+ { uf_name :: T.Text
+ , uf_contentType :: T.Text
+ , uf_tempLocation :: FilePath
+ }
+
+data RequestInfo
+ = RequestInfo
+ { ri_request :: Wai.Request
+ , ri_params :: HM.HashMap CaptureVar T.Text
+ , ri_queryParams :: [(T.Text, T.Text)]
+ , ri_files :: HM.HashMap T.Text UploadedFile
+ }
+
+data ResponseBody
+ = ResponseFile FilePath
+ | ResponseLBS BSL.ByteString
+ | ResponseRedirect T.Text
+ deriving (Show, Eq)
+
+data ResponseState
+ = ResponseState
+ { rs_responseHeaders :: [(T.Text, T.Text)]
+ , rs_status :: Status
+ , rs_responseBody :: ResponseBody
+ } deriving (Show, Eq)
+
+data ActionInterupt
+ = ActionRedirect T.Text
+ | ActionTryNext
+ | ActionError String
+ | ActionDone
+ deriving (Show)
+
+instance Error ActionInterupt where
+ noMsg = ActionError "Unkown Internal Action Error"
+ strMsg = ActionError
+
+newtype ActionT m a
+ = ActionT { runActionT :: ErrorT ActionInterupt (RWST RequestInfo () ResponseState m) a }
+ deriving (Monad, Functor, Applicative, MonadIO, MonadReader RequestInfo, MonadState ResponseState, MonadError ActionInterupt)
+
+instance MonadTrans ActionT where
+ lift = ActionT . lift . lift
+
+respStateToResponse :: ResponseState -> Wai.Response
+respStateToResponse (ResponseState headers status body) =
+ case body of
+ ResponseFile fp ->
+ Wai.responseFile status waiHeaders fp Nothing
+ ResponseLBS bsl ->
+ Wai.responseLBS status waiHeaders bsl
+ ResponseRedirect target ->
+ Wai.responseLBS status302 (("Location", T.encodeUtf8 target) : waiHeaders) BSL.empty
+ where
+ waiHeaders = map (\(k, v) -> (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v)) headers
+
+errorResponse :: Status -> BSL.ByteString -> ResponseState
+errorResponse s e =
+ ResponseState
+ { rs_responseHeaders = [("Content-Type", "text/html")]
+ , rs_status = s
+ , rs_responseBody =
+ ResponseLBS $
+ BSL.concat [ ""
+ , e
+ , ""
+ , e
+ , "
"
+ ]
+ }
+
+notFound :: Wai.Response
+notFound =
+ respStateToResponse $ errorResponse status404 "404 - File not found"
+
+invalidReq :: Wai.Response
+invalidReq =
+ respStateToResponse $ errorResponse status400 "400 - Bad request"
+
+serverError :: ResponseState
+serverError =
+ errorResponse status500 "500 - Internal Server Error!"
+
+type SpockAllT r m a =
+ RegistryT r Wai.Middleware StdMethod m a
+
+buildApp :: forall m r. (MonadIO m, AbstractRouter r, RouteAppliedAction r ~ ActionT m ())
+ => r
+ -> (forall a. m a -> IO a)
+ -> SpockAllT r m ()
+ -> IO Wai.Application
+buildApp registryIf registryLift spockActions =
+ do (_, getMatchingRoutes, middlewares) <-
+ registryLift $ runRegistry registryIf spockActions
+ let spockMiddleware = foldl (.) id middlewares
+ app :: Wai.Application
+ app req respond =
+ case parseMethod $ Wai.requestMethod req of
+ Left _ ->
+ respond invalidReq
+ Right stdMethod ->
+ runResourceT $
+ withInternalState $ \st ->
+ do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req
+ let uploadedFiles =
+ HM.fromList $
+ map (\(k, fileInfo) ->
+ ( T.decodeUtf8 k
+ , UploadedFile (T.decodeUtf8 $ P.fileName fileInfo) (T.decodeUtf8 $ P.fileContentType fileInfo) (P.fileContent fileInfo)
+ )
+ ) bodyFiles
+ postParams =
+ map (\(k, v) -> (T.decodeUtf8 k, T.decodeUtf8 v)) bodyParams
+ getParams =
+ map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req
+ queryParams = postParams ++ getParams
+ resp = errorResponse status200 ""
+ allActions = getMatchingRoutes stdMethod (Wai.pathInfo req)
+ applyAction :: [(ParamMap, ActionT m ())] -> m ResponseState
+ applyAction [] =
+ return $ errorResponse status404 "404 - File not found"
+ applyAction ((captures, selectedAction) : xs) =
+ do let env = RequestInfo req captures queryParams uploadedFiles
+ (r, respState, _) <-
+ runRWST (runErrorT $ runActionT $ selectedAction) env resp
+ case r of
+ Left (ActionRedirect loc) ->
+ return $ ResponseState (rs_responseHeaders respState)
+ status302 (ResponseRedirect loc)
+ Left ActionTryNext ->
+ applyAction xs
+ Left (ActionError errorMsg) ->
+ do liftIO $ putStrLn $ "Spock Error while handeling "
+ ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg
+ return serverError
+ Left ActionDone ->
+ return respState
+ Right () ->
+ return respState
+ respState <-
+ liftIO $ (registryLift $ applyAction allActions)
+ `catch` \(e :: SomeException) ->
+ do putStrLn $ "Spock Error while handeling " ++ show (Wai.pathInfo req) ++ ": " ++ show e
+ return serverError
+ forM_ (HM.elems uploadedFiles) $ \uploadedFile ->
+ do stillThere <- doesFileExist (uf_tempLocation uploadedFile)
+ when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile)
+ liftIO $ respond $ respStateToResponse respState
+ return $ spockMiddleware $ app
diff --git a/src/Web/Spock/Internal/Wrapper.hs b/src/Web/Spock/Internal/Wrapper.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Internal/Wrapper.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+module Web.Spock.Internal.Wrapper where
+
+import Web.Spock.Internal.Core
+import Web.Spock.Internal.Wire
+import Web.Spock.Internal.SessionManager
+import Web.Spock.Internal.Types
+
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Resource
+import Data.Pool
+import Web.Routing.AbstractRouter
+
+-- | 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.
+spockAll :: forall r conn sess st.
+ ( AbstractRouter r
+ , RouteAppliedAction r ~ ActionT (WebStateM conn sess st) ()
+ )
+ => r
+ -> Int
+ -> SessionCfg sess
+ -> PoolOrConn conn
+ -> st
+ -> SpockAllM r conn sess st ()
+ -> IO ()
+spockAll regIf port sessionCfg poolOrConn initialState defs =
+ do sessionMgr <- createSessionManager sessionCfg
+ 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
+ , web_sessionMgr = sessionMgr
+ , web_state = initialState
+ }
+ spockAllT regIf port (\m -> runResourceT $ runReaderT (runWebStateM m) internalState) $
+ do defs
+ middleware (sm_middleware sessionMgr)
diff --git a/src/Web/Spock/Monad.hs b/src/Web/Spock/Monad.hs
deleted file mode 100644
--- a/src/Web/Spock/Monad.hs
+++ /dev/null
@@ -1,69 +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.PathPieces
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-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
- liftIO (withResource pool $ 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 PathPiece BSL.ByteString where
- fromPathPiece =
- Just . BSL.fromStrict . T.encodeUtf8
- toPathPiece =
- T.decodeUtf8 . BSL.toStrict
-
-instance PathPiece UTCTime where
- fromPathPiece p = join $ fmap XSD.toUTCTime $ XSD.dateTime p
- toPathPiece = T.pack . show . XSD.fromUTCTime
diff --git a/src/Web/Spock/Routing.hs b/src/Web/Spock/Routing.hs
deleted file mode 100644
--- a/src/Web/Spock/Routing.hs
+++ /dev/null
@@ -1,169 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Web.Spock.Routing where
-
-import Data.Hashable
-import Data.Maybe
-import qualified Data.Text as T
-import qualified Data.Vector as V
-import qualified Data.Vector.Mutable as VM
-import qualified Text.Regex as Regex
-import qualified Data.HashMap.Strict as HM
-
-type ParamMap = HM.HashMap CaptureVar T.Text
-
-newtype CaptureVar
- = CaptureVar { unCaptureVar :: T.Text }
- deriving (Show, Eq, Hashable)
-
-data RegexWrapper
- = RegexWrapper
- { rw_regex :: !Regex.Regex
- , rw_original :: !T.Text
- }
-
-instance Eq RegexWrapper where
- r1 == r2 =
- rw_original r1 == rw_original r2
-
-instance Show RegexWrapper where
- show (RegexWrapper _ x) = show x
-
-data RouteNode
- = RouteNodeRegex !CaptureVar !RegexWrapper
- | RouteNodeCapture !CaptureVar
- | RouteNodeText !T.Text
- | RouteNodeRoot
- deriving (Show, Eq)
-
-data RouteData a
- = RouteData
- { rd_node :: !RouteNode
- , rd_data :: Maybe a
- }
- deriving (Show, Eq)
-
-data RoutingTree a
- = RoutingTree
- { rt_node :: !(RouteData a)
- , rt_children :: !(V.Vector (RoutingTree a))
- }
- deriving (Show, Eq)
-
-buildRegex :: T.Text -> RegexWrapper
-buildRegex t =
- RegexWrapper (Regex.mkRegex $ T.unpack t) t
-
-emptyRoutingTree :: RoutingTree a
-emptyRoutingTree =
- RoutingTree (RouteData RouteNodeRoot Nothing) V.empty
-
-mergeData :: Maybe a -> Maybe a -> Maybe a
-mergeData (Just _) (Just _) =
- error "Spock error: Don't define the same route twice!"
-mergeData (Just a) _ = Just a
-mergeData _ (Just b) = Just b
-mergeData _ _ = Nothing
-
-addToRoutingTree :: T.Text -> a -> RoutingTree a -> RoutingTree a
-addToRoutingTree route dat currTree =
- let applyTree [] tree = tree
- applyTree (current:xs) tree =
- let children = V.map (\(RoutingTree d _) -> rd_node d) (rt_children tree)
- currentDat =
- case xs of
- [] -> Just dat
- _ -> Nothing
- children' =
- case V.findIndex (==current) children of
- Nothing ->
- let h = applyTree xs $ RoutingTree (RouteData current currentDat) V.empty
- in V.cons h (rt_children tree)
- Just idx ->
- let origNode = (V.!) (rt_children tree) idx
- matchingNode = rt_node $ origNode
- appliedNode = matchingNode { rd_data = mergeData (rd_data matchingNode) currentDat }
- in V.modify (\v -> VM.write v idx (applyTree xs $ RoutingTree appliedNode (rt_children origNode))) (rt_children tree)
- in tree { rt_children = children' }
- in case filter (not . T.null) $ T.splitOn "/" route of
- [] ->
- let currNode = rt_node currTree
- currNode' = currNode { rd_data = mergeData (rd_data currNode) (Just dat) }
- in currTree { rt_node = currNode' }
- xs -> applyTree (map parseRouteNode xs) currTree
-
-parseRouteNode :: T.Text -> RouteNode
-parseRouteNode node =
- case T.uncons node of
- Just (':', var) ->
- RouteNodeCapture $ CaptureVar var
- Just ('{', rest) ->
- case T.uncons (T.reverse rest) of
- Just ('}', def) ->
- let (var, xs) = T.breakOn ":" (T.reverse def)
- in case T.uncons xs of
- Just (':', regex) ->
- RouteNodeRegex (CaptureVar var) (buildRegex regex)
- _ ->
- nodeError
- _ -> nodeError
- Just _ ->
- RouteNodeText node
- Nothing ->
- nodeError
- where
- nodeError = error ("Spock route error: " ++ (show node) ++ " is not a valid route node.")
-
-emptyParamMap :: ParamMap
-emptyParamMap = HM.empty
-
-matchRoute :: T.Text -> RoutingTree a -> [(ParamMap, a)]
-matchRoute route globalTree =
- matchRoute' (T.splitOn "/" route) globalTree
-
-matchRoute' :: [T.Text] -> RoutingTree a -> [(ParamMap, a)]
-matchRoute' routeParts globalTree =
- case filter (not . T.null) routeParts of
- [] ->
- case rd_data $ rt_node globalTree of
- Nothing -> []
- Just action -> [(emptyParamMap, action)]
- xs ->
- findRoute xs (rt_children globalTree)
- where
- findRoute :: [T.Text] -> V.Vector (RoutingTree a) -> [(ParamMap, a)]
- findRoute fullPath trees =
- let foundPaths = V.foldl' (matchTree fullPath emptyParamMap) V.empty trees
- in V.toList foundPaths
- where
- matchTree :: [T.Text] -> ParamMap -> V.Vector (ParamMap, a) -> RoutingTree a -> V.Vector (ParamMap, a)
- matchTree [] _ vec _ = vec
- matchTree (textNode : xs) paramMap vec rt =
- case matchNode textNode (rd_node $ rt_node rt) of
- (False, _) ->
- vec
- (True, mCapture) ->
- let paramMap' =
- case mCapture of
- Nothing -> paramMap
- Just (var, value) ->
- HM.insert var value paramMap
- nodeData = rd_data $ rt_node rt
- nodeChildren = rt_children rt
- in case xs of
- [] | isJust nodeData ->
- V.snoc vec (paramMap', fromJust nodeData)
- | otherwise ->
- vec
- _ ->
- let foundPaths = V.foldl' (matchTree xs paramMap') V.empty nodeChildren
- in V.concat [foundPaths, vec]
-
-matchNode :: T.Text -> RouteNode -> (Bool, Maybe (CaptureVar, T.Text))
-matchNode _ RouteNodeRoot = (False, Nothing)
-matchNode t (RouteNodeText m) = (m == t, Nothing)
-matchNode t (RouteNodeCapture var) = (True, Just (var, t))
-matchNode t (RouteNodeRegex var regex) =
- case Regex.matchRegex (rw_regex regex) (T.unpack t) of
- Nothing -> (False, Nothing)
- Just _ -> (True, Just (var, t))
diff --git a/src/Web/Spock/Safe.hs b/src/Web/Spock/Safe.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Safe.hs
@@ -0,0 +1,226 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+module Web.Spock.Safe
+ ( -- * Spock's core
+ spock, SpockM, SpockAction
+ , spockT, SpockT, ActionT
+ , spockApp
+ -- * Defining routes
+ , Path, root, var, static, ()
+ -- * Rendering routes
+ , renderRoute
+ -- * Hooking routes
+ , subcomponent
+ , get, post, head, put, delete, patch, hookRoute
+ , Http.StdMethod (..)
+ -- * Handeling requests
+ , request, header, cookie, body, jsonBody, jsonBody', files, UploadedFile (..)
+ , params, param, param'
+ -- * Sending responses
+ , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', bytes, lazyBytes
+ , text, html, file, json, blaze
+ -- * Adding middleware
+ , middleware
+ -- * Database
+ , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)
+ -- * Accessing Database and State
+ , HasSpock (runQuery, getState), SpockConn, SpockState, SpockSession
+ -- * Sessions
+ , SessionCfg (..)
+ , readSession, writeSession, modifySession, clearAllSessions
+ -- * Basic HTTP-Auth
+ , requireBasicAuth
+ -- * Safe actions
+ , SafeAction (..)
+ , safeActionPath
+ -- * Digestive Functors
+ , runForm
+ -- * Internals for extending Spock
+ , getSpockHeart, runSpockIO, WebStateM, WebState
+ )
+where
+
+
+import Web.Spock.Internal.CoreAction
+import Web.Spock.Internal.Digestive
+import Web.Spock.Internal.Monad
+import Web.Spock.Internal.SessionManager
+import Web.Spock.Internal.Types
+import Web.Spock.Internal.Wrapper
+import qualified Web.Spock.Internal.Wire as W
+import qualified Web.Spock.Internal.Core as C
+
+import Control.Applicative
+import Control.Monad.Trans
+import Data.Monoid
+import Network.HTTP.Types.Method
+import Prelude hiding (head)
+import Web.Routing.SafeRouting
+import qualified Data.Text as T
+import qualified Network.HTTP.Types as Http
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+
+type SpockM conn sess st a = SpockT (WebStateM conn sess st) a
+
+newtype SpockT m a
+ = SpockT { runSpockT :: C.SpockAllT (SafeRouter (ActionT m) ()) m a
+ } deriving (Monad, Functor, Applicative, MonadIO)
+
+instance MonadTrans SpockT where
+ lift = SpockT . lift
+
+-- | 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 sessCfg poolOrConn initSt spockAppl =
+ spockAll SafeRouter port sessCfg poolOrConn initSt (runSpockT spockAppl')
+ where
+ spockAppl' =
+ do hookSafeActions
+ spockAppl
+
+-- | Run a raw spock application with custom underlying monad
+spockT :: (MonadIO m)
+ => Warp.Port
+ -> (forall a. m a -> IO a)
+ -> SpockT m ()
+ -> IO ()
+spockT port liftFun (SpockT app) =
+ C.spockAllT SafeRouter port liftFun app
+
+-- | Convert a Spock-App to a wai-application
+spockApp :: (MonadIO m) => (forall a. m a -> IO a) -> SpockT m () -> IO Wai.Application
+spockApp liftFun (SpockT app) =
+ W.buildApp SafeRouter liftFun app
+
+-- | Specify an action that will be run when the HTTP verb 'GET' and the given route match
+get :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()
+get = hookRoute GET
+
+-- | Specify an action that will be run when the HTTP verb 'POST' and the given route match
+post :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()
+post = hookRoute POST
+
+-- | Specify an action that will be run when the HTTP verb 'HEAD' and the given route match
+head :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()
+head = hookRoute HEAD
+
+-- | Specify an action that will be run when the HTTP verb 'PUT' and the given route match
+put :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()
+put = hookRoute PUT
+
+-- | Specify an action that will be run when the HTTP verb 'DELETE' and the given route match
+delete :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()
+delete = hookRoute DELETE
+
+-- | Specify an action that will be run when the HTTP verb 'PATCH' and the given route match
+patch :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()
+patch = hookRoute PATCH
+
+-- | Specify an action that will be run when a HTTP verb and the given route match
+hookRoute :: Monad m => StdMethod -> Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()
+hookRoute m path action = SpockT $ C.hookRoute m (SafeRouterPath path) (HListElim' action)
+
+-- | Define a subcomponent. Usage example:
+--
+-- > subcomponent "site" $
+-- > do get "home" homeHandler
+-- > get ("misc" <> var) $ -- ...
+-- > subcomponent "admin" $
+-- > do get "home" adminHomeHandler
+--
+-- The request "/site/home" will be routed to homeHandler and the
+-- request "/admin/home" will be routed to adminHomeHandler
+subcomponent :: Monad m => Path '[] -> SpockT m () -> SpockT m ()
+subcomponent p (SpockT subapp) = SpockT $ C.subcomponent (SafeRouterPath p) subapp
+
+-- | Hook wai middleware into Spock
+middleware :: Monad m => Wai.Middleware -> SpockT m ()
+middleware = SpockT . C.middleware
+
+
+-- | 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
+
+-- | Globally delete all existing sessions. This is useful for example if you want
+-- to require all users to relogin
+clearAllSessions :: SpockAction conn sess st ()
+clearAllSessions =
+ do mgr <- getSessMgr
+ sm_clearAllSessions mgr
+
+-- | 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 $ "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 $ "/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 (static "h" var) run
+ post (static "h" var) run
+ where
+ run h =
+ do mgr <- getSessMgr
+ mAction <- (sm_lookupSafeAction mgr) h
+ case mAction of
+ Nothing ->
+ do setStatus Http.status404
+ text "File not found"
+ Just p@(PackedSafeAction action) ->
+ do runSafeAction action
+ (sm_removeSafeAction mgr) p
diff --git a/src/Web/Spock/SafeActions.hs b/src/Web/Spock/SafeActions.hs
deleted file mode 100644
--- a/src/Web/Spock/SafeActions.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-module Web.Spock.SafeActions where
-
-import Web.Spock.Core
-import Web.Spock.Types
-
-import Data.Monoid
-import Network.HTTP.Types.Status
-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 $ "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 $ "/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 Just h <- param "spock-csurf-protection"
- mgr <- getSessMgr
- mAction <- (sm_lookupSafeAction mgr) h
- case mAction of
- Nothing ->
- do setStatus status404
- text "File not found"
- Just p@(PackedSafeAction action) ->
- do runSafeAction action
- (sm_removeSafeAction mgr) p
diff --git a/src/Web/Spock/SessionManager.hs b/src/Web/Spock/SessionManager.hs
deleted file mode 100644
--- a/src/Web/Spock/SessionManager.hs
+++ /dev/null
@@ -1,253 +0,0 @@
-{-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}
-module Web.Spock.SessionManager
- ( createSessionManager
- , SessionId, Session(..), SessionManager(..)
- )
-where
-
-import Web.Spock.Types
-import Web.Spock.Core
-import Web.Spock.Util
-
-import Control.Arrow (first)
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Monad
-import Control.Monad.Trans
-import Data.Time
-import System.Locale
-import System.Random
-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 as TL
-import qualified Data.Text.Lazy.Encoding as TL
-import qualified Data.Vault.Lazy as V
-import qualified Network.Wai 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_clearAllSessions = clearAllSessionsImpl 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 respond =
- case getCookieFromReq (sc_cookieName cfg) of
- Just sid ->
- do mSess <- loadSessionImpl sessionRef sid
- case mSess of
- Nothing ->
- mkNew
- Just sess ->
- withSess False sess
- Nothing ->
- mkNew
- where
- getCookieFromReq name =
- lookup "cookie" (Wai.requestHeaders req) >>=
- lookup name . parseCookies . T.decodeUtf8
- 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
- , ";"
- ]
- parseCookies :: T.Text -> [(T.Text, T.Text)]
- parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words
- parseCookie = first T.init . T.breakOnEnd "="
-
- defVal = sc_emptySession cfg
- v = Wai.vault req
- addCookie sess responseHeaders =
- let cookieContent =
- renderCookie (sc_cookieName cfg) (sess_id sess) (sess_validUntil sess)
- cookieC = ("Set-Cookie", BSL.toStrict $ TL.encodeUtf8 cookieContent)
- in (cookieC : responseHeaders)
- withSess shouldSetCookie sess =
- app (req { Wai.vault = V.insert vK (sess_id sess) v }) $ \unwrappedResp ->
- respond $
- if shouldSetCookie
- then mapReqHeaders (addCookie sess) unwrappedResp
- else unwrappedResp
- 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 ()
-
-clearAllSessionsImpl :: UserSessions conn sess st
- -> SpockAction conn sess st ()
-clearAllSessionsImpl sessionRef =
- liftIO $ atomically $ modifyTVar' sessionRef (const HM.empty)
-
-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/Simple.hs b/src/Web/Spock/Simple.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Simple.hs
@@ -0,0 +1,235 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+module Web.Spock.Simple
+ ( -- * Spock's core
+ spock, SpockM, SpockAction
+ , spockT, SpockT, ActionT
+ , spockApp
+ -- * Defining routes
+ , SpockRoute, (<#>)
+ -- * Hooking routes
+ , subcomponent
+ , get, post, head, put, delete, patch, hookRoute
+ , Http.StdMethod (..)
+ -- * Handeling requests
+ , request, header, cookie, body, jsonBody, jsonBody', files, UploadedFile (..)
+ , params, param, param'
+ -- * Sending responses
+ , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', bytes, lazyBytes
+ , text, html, file, json, blaze
+ -- * Adding middleware
+ , middleware
+ -- * Database
+ , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)
+ -- * Accessing Database and State
+ , HasSpock (runQuery, getState), SpockConn, SpockState, SpockSession
+ -- * Sessions
+ , SessionCfg (..)
+ , readSession, writeSession, modifySession, clearAllSessions
+ -- * Basic HTTP-Auth
+ , requireBasicAuth
+ -- * Safe actions
+ , SafeAction (..)
+ , safeActionPath
+ -- * Digestive Functors
+ , runForm
+ -- * Internals for extending Spock
+ , getSpockHeart, runSpockIO, WebStateM, WebState
+ )
+where
+
+
+import Web.Spock.Internal.CoreAction
+import Web.Spock.Internal.Digestive
+import Web.Spock.Internal.Monad
+import Web.Spock.Internal.SessionManager
+import Web.Spock.Internal.Types
+import Web.Spock.Internal.Wrapper
+import qualified Web.Spock.Internal.Wire as W
+import qualified Web.Spock.Internal.Core as C
+
+import Control.Applicative
+import Control.Monad.Trans
+import Data.Monoid
+import Data.String
+import Network.HTTP.Types.Method
+import Prelude hiding (head)
+import Web.Routing.TextRouting
+import qualified Data.Text as T
+import qualified Network.HTTP.Types as Http
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+
+type SpockM conn sess st a = SpockT (WebStateM conn sess st) a
+
+newtype SpockT m a
+ = SpockT { runSpockT :: C.SpockAllT (TextRouter (ActionT m) ()) m a
+ } deriving (Monad, Functor, Applicative, MonadIO)
+
+instance MonadTrans SpockT where
+ lift = SpockT . lift
+
+newtype SpockRoute
+ = SpockRoute { _unSpockRoute :: T.Text }
+ deriving (Eq, Ord, Show, Read, IsString)
+
+-- | 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 sessCfg poolOrConn initSt spockAppl =
+ spockAll TextRouter port sessCfg poolOrConn initSt (runSpockT spockAppl')
+ where
+ spockAppl' =
+ do hookSafeActions
+ spockAppl
+
+-- | Run a raw spock application with custom underlying monad
+spockT :: (MonadIO m)
+ => Warp.Port
+ -> (forall a. m a -> IO a)
+ -> SpockT m ()
+ -> IO ()
+spockT port liftFun (SpockT app) =
+ C.spockAllT TextRouter port liftFun app
+
+-- | Convert a Spock-App to a wai-application
+spockApp :: (MonadIO m) => (forall a. m a -> IO a) -> SpockT m () -> IO Wai.Application
+spockApp liftFun (SpockT app) =
+ W.buildApp TextRouter liftFun app
+
+-- | Combine two route components safely
+-- "/foo" <#> "/bar" ===> "/foo/bar"
+-- "foo" <#> "bar" ===> "/foo/bar"
+-- "foo <#> "/bar" ===> "/foo/bar"
+(<#>) :: SpockRoute -> SpockRoute -> SpockRoute
+(SpockRoute t) <#> (SpockRoute t') = SpockRoute $ combineRoute t t'
+
+-- | Specify an action that will be run when the HTTP verb 'GET' and the given route match
+get :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()
+get = hookRoute GET
+
+-- | Specify an action that will be run when the HTTP verb 'POST' and the given route match
+post :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()
+post = hookRoute POST
+
+-- | Specify an action that will be run when the HTTP verb 'HEAD' and the given route match
+head :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()
+head = hookRoute HEAD
+
+-- | Specify an action that will be run when the HTTP verb 'PUT' and the given route match
+put :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()
+put = hookRoute PUT
+
+-- | Specify an action that will be run when the HTTP verb 'DELETE' and the given route match
+delete :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()
+delete = hookRoute DELETE
+
+-- | Specify an action that will be run when the HTTP verb 'PATCH' and the given route match
+patch :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()
+patch = hookRoute PATCH
+
+-- | Specify an action that will be run when a HTTP verb and the given route match
+hookRoute :: Monad m => StdMethod -> SpockRoute -> ActionT m () -> SpockT m ()
+hookRoute m (SpockRoute path) action = SpockT $ C.hookRoute m (TextRouterPath path) (TAction action)
+
+-- | Define a subcomponent. Usage example:
+--
+-- > subcomponent "/site" $
+-- > do get "/home" homeHandler
+-- > get "/misc/:param" $ -- ...
+-- > subcomponent "/admin" $
+-- > do get "/home" adminHomeHandler
+--
+-- The request /site/home will be routed to homeHandler and the
+-- request /admin/home will be routed to adminHomeHandler
+subcomponent :: Monad m => SpockRoute -> SpockT m () -> SpockT m ()
+subcomponent (SpockRoute p) (SpockT subapp) = SpockT $ C.subcomponent (TextRouterPath p) subapp
+
+-- | Hook wai middleware into Spock
+middleware :: Monad m => Wai.Middleware -> SpockT m ()
+middleware = SpockT . C.middleware
+
+-- | 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
+
+-- | Globally delete all existing sessions. This is useful for example if you want
+-- to require all users to relogin
+clearAllSessions :: SpockAction conn sess st ()
+clearAllSessions =
+ do mgr <- getSessMgr
+ sm_clearAllSessions mgr
+
+-- | 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 $ "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 $ "/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 Just h <- param "spock-csurf-protection"
+ mgr <- getSessMgr
+ mAction <- (sm_lookupSafeAction mgr) h
+ case mAction of
+ Nothing ->
+ do setStatus Http.status404
+ text "File not found"
+ Just p@(PackedSafeAction action) ->
+ do runSafeAction action
+ (sm_removeSafeAction mgr) p
diff --git a/src/Web/Spock/Specs/All.hs b/src/Web/Spock/Specs/All.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Specs/All.hs
@@ -0,0 +1,11 @@
+module Web.Spock.Specs.All where
+
+import qualified Web.Spock.Specs.SimpleSpec
+import qualified Web.Spock.Specs.SafeSpec
+
+import Test.Hspec
+
+allSpecs :: Spec
+allSpecs =
+ do Web.Spock.Specs.SimpleSpec.spec
+ Web.Spock.Specs.SafeSpec.spec
diff --git a/src/Web/Spock/Specs/FrameworkSpecHelper.hs b/src/Web/Spock/Specs/FrameworkSpecHelper.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Specs/FrameworkSpecHelper.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Web.Spock.Specs.FrameworkSpecHelper where
+
+import Test.Hspec
+import Test.Hspec.Wai
+
+import qualified Network.Wai as Wai
+
+frameworkSpec :: IO Wai.Application -> Spec
+frameworkSpec app =
+ with app $
+ do routingSpec
+ actionSpec
+
+routingSpec :: SpecWith Wai.Application
+routingSpec =
+ describe "Routing Framework" $
+ do it "allows root actions" $
+ get "/" `shouldRespondWith` "root" { matchStatus = 200 }
+ it "routes different HTTP-verbs to different actions" $
+ do verbTest get "GET"
+ verbTest (\p -> post p "") "POST"
+ verbTest (\p -> put p "") "PUT"
+ verbTest delete "DELETE"
+ verbTest (\p -> patch p "") "PATCH"
+ it "can extract params from routes" $
+ get "/param-test/42" `shouldRespondWith` "int42" { matchStatus = 200 }
+ it "can handle multiple matching routes" $
+ get "/param-test/static" `shouldRespondWith` "static" { matchStatus = 200 }
+ where
+ verbTest verb verbVerbose =
+ (verb "/verb-test")
+ `shouldRespondWith` (verbVerbose { matchStatus = 200 })
+
+actionSpec :: SpecWith Wai.Application
+actionSpec =
+ describe "Action Framework" $ return ()
diff --git a/src/Web/Spock/Specs/SafeSpec.hs b/src/Web/Spock/Specs/SafeSpec.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Specs/SafeSpec.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Web.Spock.Specs.SafeSpec where
+
+import Web.Spock.Safe
+import Web.Spock.Specs.FrameworkSpecHelper
+
+import Data.Monoid
+import Test.Hspec
+import qualified Data.Text as T
+
+app :: SpockT IO ()
+app =
+ do get root $ text "root"
+ get "verb-test" $ text "GET"
+ post "verb-test" $ text "POST"
+ put "verb-test" $ text "PUT"
+ delete "verb-test" $ text "DELETE"
+ patch "verb-test" $ text "PATCH"
+ get ("param-test" var) $ \(i :: Int) ->
+ text $ "int" <> (T.pack $ show i)
+ get ("param-test" "static") $
+ text "static"
+
+spec :: Spec
+spec = describe "SafeRouting" $ frameworkSpec (spockApp id app)
diff --git a/src/Web/Spock/Specs/SimpleSpec.hs b/src/Web/Spock/Specs/SimpleSpec.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Spock/Specs/SimpleSpec.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Web.Spock.Specs.SimpleSpec where
+
+import Web.Spock.Simple
+import Web.Spock.Specs.FrameworkSpecHelper
+
+import Data.Monoid
+import Test.Hspec
+import qualified Data.Text as T
+
+app :: SpockT IO ()
+app =
+ do get "/" $ text "root"
+ get "/verb-test" $ text "GET"
+ post "/verb-test" $ text "POST"
+ put "/verb-test" $ text "PUT"
+ delete "/verb-test" $ text "DELETE"
+ patch "/verb-test" $ text "PATCH"
+ get "/param-test/:int" $
+ do Just (i :: Int) <- param "int"
+ text $ "int" <> (T.pack $ show i)
+ get "/param-test/static" $
+ text "static"
+spec :: Spec
+spec = describe "SimpleRouting" $ frameworkSpec (spockApp id app)
diff --git a/src/Web/Spock/Types.hs b/src/Web/Spock/Types.hs
deleted file mode 100644
--- a/src/Web/Spock/Types.hs
+++ /dev/null
@@ -1,142 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ExistentialQuantification #-}
-module Web.Spock.Types where
-
-import Web.Spock.Core
-
-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.Time.Clock ( UTCTime(..), NominalDiffTime )
-import Data.Typeable
-import Network.Wai
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Text as T
-
--- | Inside the SpockM monad, you may define routes and middleware.
-type SpockM conn sess st = SpockT (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 (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)
- | 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 WebState conn sess st
- = WebState
- { web_dbConn :: Pool 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_clearAllSessions :: 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 ()
- }
diff --git a/src/Web/Spock/Util.hs b/src/Web/Spock/Util.hs
deleted file mode 100644
--- a/src/Web/Spock/Util.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Web.Spock.Util where
-
-import Network.HTTP.Types
-import Network.Wai.Internal
-
-mapReqHeaders :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response
-mapReqHeaders f resp =
- case resp of
- (ResponseFile s h b1 b2) -> ResponseFile s (f h) b1 b2
- (ResponseBuilder s h b) -> ResponseBuilder s (f h) b
- (ResponseStream s h b) -> ResponseStream s (f h) b
- (ResponseRaw x r) -> ResponseRaw x (mapReqHeaders f r)
diff --git a/src/Web/Spock/Wire.hs b/src/Web/Spock/Wire.hs
deleted file mode 100644
--- a/src/Web/Spock/Wire.hs
+++ /dev/null
@@ -1,285 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Web.Spock.Wire where
-
-import Web.Spock.Routing
-
-import Control.Applicative
-import Control.Exception
-import Control.Monad.RWS.Strict
-import Control.Monad.Error
-import Control.Monad.Reader.Class ()
-import Control.Monad.Trans.Resource
-import Data.Hashable
-import Data.Maybe
-import Network.HTTP.Types.Method
-import Network.HTTP.Types.Status
-#if MIN_VERSION_base(4,6,0)
-import Prelude
-#else
-import Prelude hiding (catch)
-#endif
-import System.Directory
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.CaseInsensitive as CI
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Network.Wai as Wai
-import qualified Network.Wai.Parse as P
-
-instance Hashable StdMethod where
- hashWithSalt = hashUsing fromEnum
-
-type SpockRoutingTree m = RoutingTree (ActionT m ())
-type SpockTreeMap m = HM.HashMap StdMethod (SpockRoutingTree m)
-
-type SpockRouteMap m = HM.HashMap StdMethod (HM.HashMap T.Text (ActionT m ()))
-
-data SpockState m
- = SpockState
- { ss_treeMap :: !(SpockRouteMap m)
- , ss_middleware :: [Wai.Middleware]
- , ss_spockLift :: forall a. m a -> IO a
- }
-
-data UploadedFile
- = UploadedFile
- { uf_name :: T.Text
- , uf_contentType :: T.Text
- , uf_tempLocation :: FilePath
- }
-
-data RequestInfo
- = RequestInfo
- { ri_request :: Wai.Request
- , ri_params :: HM.HashMap CaptureVar T.Text
- , ri_queryParams :: [(T.Text, T.Text)]
- , ri_files :: HM.HashMap T.Text UploadedFile
- }
-
-data ResponseBody
- = ResponseFile FilePath
- | ResponseLBS BSL.ByteString
- | ResponseRedirect T.Text
- deriving (Show, Eq)
-
-data ResponseState
- = ResponseState
- { rs_responseHeaders :: [(T.Text, T.Text)]
- , rs_status :: Status
- , rs_responseBody :: ResponseBody
- } deriving (Show, Eq)
-
-type BaseRoute = T.Text
-
-data ActionInterupt
- = ActionRedirect T.Text
- | ActionTryNext
- | ActionError String
- | ActionDone
- deriving (Show)
-
-instance Error ActionInterupt where
- noMsg = ActionError "Unkown Internal Action Error"
- strMsg = ActionError
-
-newtype ActionT m a
- = ActionT { runActionT :: ErrorT ActionInterupt (RWST RequestInfo () ResponseState m) a }
- deriving (Monad, Functor, Applicative, MonadIO, MonadReader RequestInfo, MonadState ResponseState, MonadError ActionInterupt)
-
-instance MonadTrans ActionT where
- lift = ActionT . lift . lift
-
-newtype SpockT (m :: * -> *) a
- = SpockT { runSpockT :: RWST BaseRoute () (SpockState m) m a }
- deriving (Monad, Functor, Applicative, MonadIO, MonadReader BaseRoute, MonadState (SpockState m))
-
-instance MonadTrans SpockT where
- lift = SpockT . lift
-
-respStateToResponse :: ResponseState -> Wai.Response
-respStateToResponse (ResponseState headers status body) =
- case body of
- ResponseFile fp ->
- Wai.responseFile status waiHeaders fp Nothing
- ResponseLBS bsl ->
- Wai.responseLBS status waiHeaders bsl
- ResponseRedirect target ->
- Wai.responseLBS status302 (("Location", T.encodeUtf8 target) : waiHeaders) BSL.empty
- where
- waiHeaders = map (\(k, v) -> (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v)) headers
-
-errorResponse :: Status -> BSL.ByteString -> ResponseState
-errorResponse s e =
- ResponseState
- { rs_responseHeaders = [("Content-Type", "text/html")]
- , rs_status = s
- , rs_responseBody =
- ResponseLBS $
- BSL.concat [ ""
- , e
- , ""
- , e
- , "
"
- ]
- }
-
-notFound :: Wai.Response
-notFound =
- respStateToResponse $ errorResponse status404 "404 - File not found"
-
-invalidReq :: Wai.Response
-invalidReq =
- respStateToResponse $ errorResponse status400 "400 - Bad request"
-
-serverError :: ResponseState
-serverError =
- errorResponse status500 "500 - Internal Server Error!"
-
-buildApp :: forall m. (MonadIO m)
- => (forall a. m a -> IO a)
- -> SpockT m ()
- -> IO Wai.Application
-buildApp spockLift spockActions =
- do let initState =
- SpockState
- { ss_treeMap = HM.empty
- , ss_middleware = []
- , ss_spockLift = spockLift
- }
- (spockState, ()) <- spockLift $ execRWST (runSpockT spockActions) "/" initState
- let spockMiddleware = foldl (.) id (ss_middleware spockState)
- routingTreeMap = buildRoutingTree (ss_treeMap spockState)
- app :: Wai.Application
- app req respond =
- case parseMethod $ Wai.requestMethod req of
- Left _ ->
- respond invalidReq
- Right stdMethod ->
- case HM.lookup stdMethod routingTreeMap of
- Just routeTree ->
- runResourceT $
- withInternalState $ \st ->
- do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req
- let uploadedFiles =
- HM.fromList $
- map (\(k, fileInfo) ->
- ( T.decodeUtf8 k
- , UploadedFile (T.decodeUtf8 $ P.fileName fileInfo) (T.decodeUtf8 $ P.fileContentType fileInfo) (P.fileContent fileInfo)
- )
- ) bodyFiles
- postParams =
- map (\(k, v) -> (T.decodeUtf8 k, T.decodeUtf8 v)) bodyParams
- getParams =
- map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req
- queryParams = postParams ++ getParams
- resp = errorResponse status200 ""
- allActions = matchRoute' (Wai.pathInfo req) routeTree
-
- applyAction :: [(ParamMap, ActionT m ())] -> m ResponseState
- applyAction [] =
- return $ errorResponse status404 "404 - File not found"
- applyAction ((captures, selectedAction) : xs) =
- do let env = RequestInfo req captures queryParams uploadedFiles
- (r, respState, _) <-
- runRWST (runErrorT $ runActionT $ selectedAction) env resp
- case r of
- Left (ActionRedirect loc) ->
- return $ ResponseState (rs_responseHeaders respState)
- status302 (ResponseRedirect loc)
- Left ActionTryNext ->
- applyAction xs
- Left (ActionError errorMsg) ->
- do liftIO $ putStrLn $ "Spock Error while handeling "
- ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg
- return serverError
- Left ActionDone ->
- return respState
- Right () ->
- return respState
- respState <-
- liftIO $
- (spockLift $ applyAction allActions)
- `catch` \(e :: SomeException) ->
- do putStrLn $ "Spock Error while handeling " ++ show (Wai.pathInfo req) ++ ": " ++ show e
- return serverError
- forM_ (HM.elems uploadedFiles) $ \uploadedFile ->
- do stillThere <- doesFileExist (uf_tempLocation uploadedFile)
- when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile)
- liftIO $ respond $ respStateToResponse respState
- Nothing ->
- respond notFound
- return $ spockMiddleware $ app
-
--- | Hook up a 'Wai.Middleware'
-middleware :: MonadIO m => Wai.Middleware -> SpockT m ()
-middleware mw =
- modify $ \st -> st { ss_middleware = (ss_middleware st ++ [mw]) }
-
--- | Define a route matching a provided 'StdMethod' and route
-defRoute :: (MonadIO m) => StdMethod -> T.Text -> ActionT m () -> SpockT m ()
-defRoute method route action =
- do baseRoute <- ask
- let fullRoute = baseRoute `combineRoute` route
- modify $ \st -> st { ss_treeMap = HM.insertWith HM.union method (HM.singleton fullRoute action) (ss_treeMap st) }
-
--- | Combine two routes, ensuring that the slashes don't get messed up
-combineRoute :: T.Text -> T.Text -> T.Text
-combineRoute r1 r2 =
- case T.uncons r1 of
- Nothing -> T.concat ["/", r2']
- Just ('/', _) -> T.concat [r1', r2']
- Just _ -> T.concat ["/", r1', r2']
- where
- r1' =
- if T.last r1 == '/'
- then r1
- else if T.null r2
- then r1
- else T.concat [r1, "/"]
- r2' =
- if T.null r2
- then ""
- else if T.head r2 == '/' then T.drop 1 r2 else r2
-
--- | Define a subcomponent
---
--- > subcomponent "/api" $
--- > do get "/user" $ text "USER"
--- > post "/new-user" $ text "OK!"
---
--- >>> curl http://localhost:8080/api/user
--- USER
---
-subcomponent :: (MonadIO m) => T.Text -> SpockT m a -> SpockT m a
-subcomponent baseRoute defs =
- do parentState <- get
- parentRoute <- ask
- let initState =
- parentState
- { ss_treeMap = HM.empty
- , ss_middleware = []
- }
- (a, finalState, ()) <-
- liftIO $ (ss_spockLift parentState) $
- runRWST (runSpockT defs) (parentRoute `combineRoute` baseRoute) initState
- modify $ \st ->
- st
- { ss_treeMap = HM.unionWith HM.union (ss_treeMap st) (ss_treeMap finalState)
- , ss_middleware = (ss_middleware st) ++ (ss_middleware finalState)
- }
- return a
-
-buildRoutingTree :: SpockRouteMap m -> SpockTreeMap m
-buildRoutingTree routeMap =
- HM.map (\v -> foldl treeBuilder emptyRoutingTree $ HM.toList v) routeMap
- where
- treeBuilder tree (route, action) =
- addToRoutingTree route action tree
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,1 +1,5 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+import Test.Hspec
+import Web.Spock.Specs.All
+
+main :: IO ()
+main = hspec allSpecs
diff --git a/test/Web/Spock/RoutingSpec.hs b/test/Web/Spock/RoutingSpec.hs
deleted file mode 100644
--- a/test/Web/Spock/RoutingSpec.hs
+++ /dev/null
@@ -1,109 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Web.Spock.RoutingSpec (spec) where
-
-import Test.Hspec
-
-import Web.Spock.Routing
-import qualified Data.Vector as V
-import qualified Data.HashMap.Strict as HM
-
-spec :: Spec
-spec =
- do matchNodeDesc
- matchRouteDesc
- parseRouteNodeDesc
- addToRoutingTreeDesc
-
-matchNodeDesc :: Spec
-matchNodeDesc =
- describe "matchNode" $
- do it "shouldn't match to root node" $
- matchNode "foo" RouteNodeRoot `shouldBe` (False, Nothing)
- it "should capture basic variables" $
- matchNode "123" (RouteNodeCapture (CaptureVar "x")) `shouldBe` (True, Just (CaptureVar "x", "123"))
- it "should work with regex" $
- matchNode "123" (RouteNodeRegex (CaptureVar "x") (buildRegex "^[0-9]+$")) `shouldBe` (True, Just (CaptureVar "x", "123"))
-
-matchRouteDesc :: Spec
-matchRouteDesc =
- describe "matchRoute" $
- do it "shouldn't match unknown routes" $
- do matchRoute "random" routingTree `shouldBe` noMatches
- matchRoute "/baz" routingTree `shouldBe` noMatches
- it "should match known routes" $
- do matchRoute "/" routingTree `shouldBe` oneMatch emptyParamMap [1]
- matchRoute "/bar" routingTree `shouldBe` oneMatch emptyParamMap [2]
- it "should capture variables in routes" $
- do matchRoute "/bar/5" routingTree `shouldBe` oneMatch (vMap [("baz", "5")]) [3]
- matchRoute "/bar/23/baz" routingTree `shouldBe` oneMatch (vMap [("baz", "23")]) [4]
- matchRoute "/bar/23/baz/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4]
- matchRoute "/ba/23/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4]
- matchRoute "/entry/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [6]
- matchRoute "/entry/bytags/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [7]
- matchRoute "/entry/2/rel/3" routingTree `shouldBe` oneMatch (vMap [("eid", "2"), ("cid", "3")]) [9]
- it "should handle multiple possibile matches correctly" $
- do matchRoute "/bar/bingo" routingTree `shouldBe` multiMatch
- matchRoute "/entry/1/audit" routingTree `shouldBe` multiMatch'
- where
- vMap kv =
- HM.fromList $ map (\(k, v) -> (CaptureVar k, v)) kv
- multiMatch =
- ((oneMatch emptyParamMap [5])
- ++ oneMatch (vMap [("baz", "bingo")]) [3])
- multiMatch' =
- ((oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6])
- ++ (oneMatch (vMap [("eid", "1")]) [8]))
- noMatches = []
- oneMatch pm m = [(pm, m)]
- routingTree =
- foldl (\tree (route, action) -> addToRoutingTree route action tree) emptyRoutingTree routes
- routes =
- [ ("/", [1])
- , ("/bar", [2 :: Int])
- , ("/bar/:baz", [3])
- , ("/bar/bingo", [5])
- , ("/bar/:baz/baz", [4])
- , ("/bar/:baz/baz/:bim", [4])
- , ("/ba/:baz/:bim", [4])
- , ("/entry/:cid/:since", [6])
- , ("/entry/bytags/:cid/:since", [7])
- , ("/entry/:eid/audit", [8])
- , ("/entry/:eid/rel/:cid", [9])
- ]
-
-parseRouteNodeDesc :: Spec
-parseRouteNodeDesc =
- describe "parseRouteNode" $
- do it "parses text nodes correctly" $
- parseRouteNode "foo" `shouldBe` RouteNodeText "foo"
- it "parses capture variables" $
- parseRouteNode ":bar" `shouldBe` RouteNodeCapture (CaptureVar "bar")
- it "parses regex capture variables" $
- parseRouteNode "{bar:^[0-9]$}" `shouldBe` RouteNodeRegex (CaptureVar "bar") (buildRegex "^[0-9]$")
-
-addToRoutingTreeDesc :: Spec
-addToRoutingTreeDesc =
- describe "addToRoutingTree" $
- do it "adds the root node correctly" $
- addToRoutingTree "/" [True] emptyT `shouldBe` baseRoute
- it "adds a new branch correctly" $
- addToRoutingTree "/foo/:bar" [True] emptyT `shouldBe` fooBar []
- it "add a new subbranch correctly" $
- addToRoutingTree "/foo/:bar/baz" [True] (fooBar []) `shouldBe` fooBar baz
- where
- emptyT = emptyRoutingTree
- baseRoute = RoutingTree { rt_node = RouteData{rd_node = RouteNodeRoot, rd_data = Just [True]}, rt_children = V.empty}
- baz = [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeText "baz", rd_data = Just [True] },rt_children = V.empty }]
- fooBar xs =
- RoutingTree
- { rt_node =
- RouteData {rd_node = RouteNodeRoot, rd_data = Nothing }
- , rt_children =
- V.fromList
- [ RoutingTree { rt_node = RouteData{rd_node = RouteNodeText "foo", rd_data = Nothing}
- , rt_children =
- V.fromList
- [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeCapture (CaptureVar "bar")
- , rd_data = Just [True]
- }
- , rt_children = V.fromList xs}]}]}
diff --git a/test/Web/Spock/WireSpec.hs b/test/Web/Spock/WireSpec.hs
deleted file mode 100644
--- a/test/Web/Spock/WireSpec.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Web.Spock.WireSpec (spec) where
-
-import Web.Spock.Wire
-import Test.Hspec
-
-spec :: Spec
-spec =
- do describe "combineRoute" $
- do it "handles slashes correctly" $
- do ("/" `combineRoute` "foo") `shouldBe` "/foo"
- ("" `combineRoute` "foo") `shouldBe` "/foo"
- ("/" `combineRoute` "/foo") `shouldBe` "/foo"
- ("" `combineRoute` "/foo") `shouldBe` "/foo"
- ("/test" `combineRoute` "foo") `shouldBe` "/test/foo"
- ("/test" `combineRoute` "") `shouldBe` "/test"