Spock 0.8.1.0 → 0.9.0.0

raw patch · 14 files changed

+470/−236 lines, 14 filesdep +crypto-randomdep ~basedep ~reroutedep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: crypto-random

Dependency ranges changed: base, reroute, unordered-containers, wai-extra

API changes (from Hackage documentation)

Files

• README.md +53/−46
• Spock.cabal +7/−13
• examples/simple/Main.hs +0/−12
• src/Web/Spock/Internal/Core.hs +4/−1
• src/Web/Spock/Internal/CoreAction.hs +68/−34
• src/Web/Spock/Internal/Monad.hs +1/−0
• src/Web/Spock/Internal/SessionManager.hs +61/−48
• src/Web/Spock/Internal/Types.hs +37/−17
• src/Web/Spock/Internal/Wire.hs +36/−25
• src/Web/Spock/Safe.hs +71/−30
• src/Web/Spock/Shared.hs +13/−10
• test/Web/Spock/FrameworkSpecHelper.hs +21/−0
• test/Web/Spock/SafeSpec.hs +91/−0
• test/Web/Spock/SimpleSpec.hs +7/−0

@@ -2,33 +2,17 @@ =====  [![Build Status](https://travis-ci.org/agrafix/Spock.svg)](https://travis-ci.org/agrafix/Spock)--[![Hackage Deps](https://img.shields.io/hackage-deps/v/Spock.svg)](http://packdeps.haskellers.com/reverse/Spock)--For more information and tutorials, visit [spock.li](http://www.spock.li)+[![Hackage](https://img.shields.io/hackage/v/Spock.svg)](http://hackage.haskell.org/package/Spock)  ## Intro  Hackage: [Spock](http://hackage.haskell.org/package/Spock)-Tutorial: [Spock Tutorial](https://www.spock.li/tutorial/)+Stackage: [Spock](https://www.stackage.org/package/Spock) -Another Haskell web framework for rapid development: This toolbox provides-everything you need to get a quick start into web hacking with haskell:+Another Haskell web framework for rapid development -* fast routing (both typesafe and "untyped")-* middleware-* json-* sessions-* cookies-* database helper-* csrf-protection -Benchmarks:--* https://github.com/philopon/apiary-benchmark-* https://github.com/agrafix/Spock-scotty-benchmark--## Usage (Typesafe, recommended)+## Library Usage Example  ```haskell {-# LANGUAGE OverloadedStrings #-}@@ -40,33 +24,47 @@     runSpock 3000 $ spockT id $     do get ("echo" <//> var) $ \something ->         text $ T.concat ["Echo: ", something]+ ``` -(read more at [Type-safe routing in Spock](https://www.spock.li/2015/04/19/type-safe_routing.html))+For more examples check the examples/ directory. -## Usage (Simple)+## Install -```haskell-{-# LANGUAGE OverloadedStrings #-}-import Web.Spock.Simple+* Using cabal: `cabal install Spock`+* Using Stack: `stack install Spock`+* From Source (cabal): `git clone https://github.com/agrafix/Spock.git && cd Spock && cabal install`+* From Source (stack): `git clone https://github.com/agrafix/Spock.git && cd Spock && stack build` -import qualified Data.Text as T+## Features -main =-    runSpock 3000 $ spockT id $-    do get ("echo" <//> ":something") $-        do Just something <- param "something"-           text $ T.concat ["Echo: ", something]-       get ("regex" <//> "{number:^[0-9]+$}") $-        do Just number <- param "number"-           text $ T.concat ["Just a number: ", number]-```+Another Haskell web framework for rapid development: This toolbox provides+everything you need to get a quick start into web hacking with haskell: -## Install+* fast routing (both typesafe and "untyped")+* middleware+* json+* sessions+* cookies+* database helper+* csrf-protection+* typesafe contexts -* Using cabal: `cabal install Spock`-* From Source: `git clone https://github.com/agrafix/Spock.git && cd Spock && cabal install`+Benchmarks: +* https://github.com/philopon/apiary-benchmark+* https://github.com/agrafix/Spock-scotty-benchmark++## Important Links++* [Tutorial](https://www.spock.li/tutorial/)+* [Type-safe routing in Spock](https://www.spock.li/2015/04/19/type-safe_routing.html) ++### Talks++* German: [Moderne typsichere Web-Entwicklung mit Haskell](https://dl.dropboxusercontent.com/u/15078797/talks/typesafe-webdev-2015.pdf) (by Alexander Thiemann)+* German: [reroute-talk](https://github.com/timjb/reroute-talk) (by Tim Baumann)+ ## Candy  ### Extensions@@ -89,16 +87,11 @@ * [makeci](https://github.com/openbrainsrc/makeci) * [curry-recipes](https://github.com/timjb/reroute-talk/tree/06574561918b50c1809f1e24ec7faeff731fddcf/curry-recipes) -## Talks--* German: [Moderne typsichere Web-Entwicklung mit Haskell](https://dl.dropboxusercontent.com/u/15078797/talks/typesafe-webdev-2015.pdf) (by Alexander Thiemann)-* German: [reroute-talk](https://github.com/timjb/reroute-talk) (by Tim Baumann)- ## Companies / Projects using Spock -* http://cp-med.com/-* http://openbrain.co.uk/-* http://findmelike.com/+* http://cp-med.com+* http://openbrain.co.uk+* http://findmelike.com * https://www.tramcloud.net * http://thitp.de @@ -114,3 +107,17 @@  * Tim Baumann [Github](https://github.com/timjb) (lot's of help with typesafe routing) * Tom Nielsen [Github](https://github.com/glutamate)  (much feedback and small improvements)+++## Misc++### Supported GHC Versions++* 7.6.3+* 7.8.4+* 7.10.2++### License++Released under the BSD3 license.+(c) 2013 - 2015 Alexander Thiemann

@@ -1,5 +1,5 @@ name:                Spock-version:             0.8.1.0+version:             0.9.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:                      .@@ -56,6 +56,7 @@                        bytestring >=0.10,                        case-insensitive >=1.1,                        containers >=0.5,+                       crypto-random >= 0.0.8,                        directory >=1.2,                        focus >=0.1,                        hashable >=1.2,@@ -67,7 +68,7 @@                        old-locale >=1.0,                        path-pieces >=0.1.4,                        random >=1.0,-                       reroute >=0.3,+                       reroute >=0.3.1,                        resource-pool >=0.2,                        resourcet >= 0.4,                        stm >=2.4,@@ -103,19 +104,12 @@                        stm,                        reroute,                        text,-                       wai+                       unordered-containers,+                       wai,+                       wai-extra    ghc-options: -Wall -fno-warn-orphans -benchmark spock-simple-example-  type:                exitcode-stdio-1.0-  ghc-options:         -auto-all -Wall -O2-  hs-source-dirs:      examples/simple-  main-is:             Main.hs-  build-depends:-    base,-    Spock- source-repository head   type:     git-  location: git://github.com/agrafix/Spock.git+  location: https://github.com/agrafix/Spock

@@ -1,12 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where--import Web.Spock.Safe--main :: IO ()-main =-    runSpock 8080 $ spockT id $-    do get "foo" $-           text "bar"-       get ("hello" <//> var) $ \name ->-           text name

@@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Web.Spock.Internal.Core@@ -47,6 +48,8 @@     do sessionMgr <- createSessionManager sessionCfg        connectionPool <-            case poolOrConn of+             PCNoDatabase ->+                 createPool (return ()) (const $ return ()) 5 60 5              PCPool p ->                  return p              PCConn cb ->

@@ -6,11 +6,13 @@     ( ActionT     , UploadedFile (..)     , request, header, rawHeader, cookie, body, jsonBody, jsonBody'+    , reqMethod     , files, params, param, param', setStatus, setHeader, redirect     , jumpNext, middlewarePass, modifyVault, queryVault     , setCookie, setCookie', deleteCookie     , bytes, lazyBytes, text, html, file, json, stream, response     , requireBasicAuth+    , getContext, runInContext     , preferredFormat, ClientPreferredFormat(..)     ) where@@ -26,10 +28,13 @@ import Control.Monad.Error #endif import Control.Monad.Reader+import Control.Monad.RWS.Strict (runRWST) import Control.Monad.State hiding (get, put)+import qualified Control.Monad.State as ST import Data.Monoid import Data.Time import Network.HTTP.Types.Header (HeaderName, ResponseHeaders)+import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Prelude hiding (head) #if MIN_VERSION_time(1,5,0)@@ -50,24 +55,24 @@ import qualified Network.Wai as Wai  -- | Get the original Wai Request object-request :: MonadIO m => ActionT m Wai.Request+request :: MonadIO m => ActionCtxT ctx m Wai.Request request = asks ri_request {-# INLINE request #-}  -- | Read a header-header :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)+header :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text) header t =     liftM (fmap T.decodeUtf8) $ rawHeader (CI.mk (T.encodeUtf8 t)) {-# INLINE header #-}  -- | Read a header without converting it to text-rawHeader :: MonadIO m => HeaderName -> ActionT m (Maybe BS.ByteString)+rawHeader :: MonadIO m => HeaderName -> ActionCtxT ctx m (Maybe BS.ByteString) rawHeader t =     liftM (lookup t . Wai.requestHeaders) request {-# INLINE rawHeader #-}  -- | Read a cookie-cookie :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)+cookie :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text) cookie name =     do req <- request        return $ lookup "cookie" (Wai.requestHeaders req) >>= lookup name . parseCookies . T.decodeUtf8@@ -78,7 +83,7 @@ {-# INLINE cookie #-}  -- | Tries to dected the preferred format of the response using the Accept header-preferredFormat :: MonadIO m => ActionT m ClientPreferredFormat+preferredFormat :: MonadIO m => ActionCtxT ctx m ClientPreferredFormat preferredFormat =   do mAccept <- header "accept"      case mAccept of@@ -87,8 +92,13 @@          return $ detectPreferredFormat t {-# INLINE preferredFormat #-} +-- | Returns the current request method, e.g. 'GET'+reqMethod :: MonadIO m => ActionCtxT ctx m StdMethod+reqMethod = asks ri_method+{-# INLINE reqMethod #-}+ -- | Get the raw request body-body :: MonadIO m => ActionT m BS.ByteString+body :: MonadIO m => ActionCtxT ctx m BS.ByteString body =     do req <- request        let parseBody = liftIO $ Wai.requestBody req@@ -101,14 +111,14 @@ {-# INLINE body #-}  -- | Parse the request body as json-jsonBody :: (MonadIO m, A.FromJSON a) => ActionT m (Maybe a)+jsonBody :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m (Maybe a) jsonBody =     do b <- body        return $ A.decodeStrict b {-# INLINE jsonBody #-}  -- | Parse the request body as json and fails with 500 status code on error-jsonBody' :: (MonadIO m, A.FromJSON a) => ActionT m a+jsonBody' :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m a jsonBody' =     do b <- body        case A.eitherDecodeStrict' b of@@ -120,21 +130,21 @@ {-# INLINE jsonBody' #-}  -- | Get uploaded files-files :: MonadIO m => ActionT m (HM.HashMap T.Text UploadedFile)+files :: MonadIO m => ActionCtxT ctx m (HM.HashMap T.Text UploadedFile) files =     asks ri_files {-# INLINE files #-}  -- | Get all request params-params :: MonadIO m => ActionT m [(T.Text, T.Text)]+params :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)] params =     do p <- asks ri_params        qp <- asks ri_queryParams        return (qp ++ map (first unCaptureVar) (HM.toList p)) {-# INLINE params #-} --- | 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)+-- | Read a request param. Spock looks in route captures first (in simple routing), then in POST variables and at last in GET variables+param :: (PathPiece p, MonadIO m) => T.Text -> ActionCtxT ctx m (Maybe p) param k =     do p <- asks ri_params        qp <- asks ri_queryParams@@ -151,7 +161,7 @@ {-# INLINE param #-}  -- | Like 'param', but outputs an error when a param is missing-param' :: (PathPiece p, MonadIO m) => T.Text -> ActionT m p+param' :: (PathPiece p, MonadIO m) => T.Text -> ActionCtxT ctx m p param' k =     do mParam <- param k        case mParam of@@ -163,7 +173,7 @@ {-# INLINE param' #-}  -- | Set a response status-setStatus :: MonadIO m => Status -> ActionT m ()+setStatus :: MonadIO m => Status -> ActionCtxT ctx m () setStatus s =     modify $ \rs -> rs { rs_status = s } {-# INLINE setStatus #-}@@ -172,7 +182,7 @@ -- is allowed to occur multiple times (as in RFC 2616), it will -- be appended. Otherwise the previous value is overwritten. -- See 'setMultiHeader'.-setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()+setHeader :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m () setHeader k v =     do let ciVal = CI.mk $ T.encodeUtf8 k        case HM.lookup ciVal multiHeaderMap of@@ -183,7 +193,7 @@ {-# INLINE setHeader #-}  -- | INTERNAL: Set a response header that can occur multiple times. (eg: Cache-Control)-setMultiHeader :: MonadIO m => MultiHeader -> T.Text -> ActionT m ()+setMultiHeader :: MonadIO m => MultiHeader -> T.Text -> ActionCtxT ctx m () setMultiHeader k v =     modify $ \rs ->         rs@@ -193,7 +203,7 @@ {-# INLINE setMultiHeader #-}  -- | INTERNAL: Unsafely set a header (no checking if the header can occur multiple times)-setHeaderUnsafe :: MonadIO m => T.Text -> T.Text -> ActionT m ()+setHeaderUnsafe :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m () setHeaderUnsafe k v =     modify $ \rs ->         rs@@ -204,12 +214,12 @@   -- | Abort the current action and jump the next one matching the route-jumpNext :: MonadIO m => ActionT m a+jumpNext :: MonadIO m => ActionCtxT ctx m a jumpNext = throwError ActionTryNext {-# INLINE jumpNext #-}  -- | Redirect to a given url-redirect :: MonadIO m => T.Text -> ActionT m a+redirect :: MonadIO m => T.Text -> ActionCtxT ctx m a redirect = throwError . ActionRedirect {-# INLINE redirect #-} @@ -217,39 +227,39 @@ -- this to pass request handling to the underlying application. -- If Spock is not uses as a middleware, or there is no underlying application -- this will result in 404 error.-middlewarePass :: MonadIO m => ActionT m a+middlewarePass :: MonadIO m => ActionCtxT ctx m a middlewarePass = throwError ActionMiddlewarePass {-# INLINE middlewarePass #-}  -- | Modify the vault (useful for sharing data between middleware and app)-modifyVault :: MonadIO m => (V.Vault -> V.Vault) -> ActionT m ()+modifyVault :: MonadIO m => (V.Vault -> V.Vault) -> ActionCtxT ctx m () modifyVault f =     do vaultIf <- asks ri_vaultIf        liftIO $ vi_modifyVault vaultIf f {-# INLINE modifyVault #-}  -- | Query the vault-queryVault :: MonadIO m => V.Key a -> ActionT m (Maybe a)+queryVault :: MonadIO m => V.Key a -> ActionCtxT ctx m (Maybe a) queryVault k =     do vaultIf <- asks ri_vaultIf        liftIO $ vi_lookupKey vaultIf k {-# INLINE queryVault #-}  -- | Set a cookie living for a given number of seconds-setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionT m ()+setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionCtxT ctx m () setCookie name value validSeconds =     do now <- liftIO getCurrentTime        setCookie' name value (validSeconds `addUTCTime` now) {-# INLINE setCookie #-} -deleteCookie :: MonadIO m => T.Text -> ActionT m ()+deleteCookie :: MonadIO m => T.Text -> ActionCtxT ctx m () deleteCookie name = setCookie' name T.empty epoch   where     epoch = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0) {-# INLINE deleteCookie #-}  -- | Set a cookie living until a specific 'UTCTime'-setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionT m ()+setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionCtxT ctx m () setCookie' name value validUntil =     setMultiHeader MultiHeaderSetCookie rendered     where@@ -266,54 +276,54 @@ {-# INLINE setCookie' #-}  -- | Use a custom 'Wai.Response' generator as response body.-response :: MonadIO m => (Status -> ResponseHeaders -> Wai.Response) -> ActionT m a+response :: MonadIO m => (Status -> ResponseHeaders -> Wai.Response) -> ActionCtxT ctx m a response val =     do modify $ \rs -> rs { rs_responseBody = ResponseBody val }        throwError ActionDone {-# INLINE response #-}  -- | Send a 'ByteString' as response body. Provide your own "Content-Type"-bytes :: MonadIO m => BS.ByteString -> ActionT m a+bytes :: MonadIO m => BS.ByteString -> ActionCtxT ctx m a bytes val =     lazyBytes $ BSL.fromStrict val {-# INLINE bytes #-}  -- | Send a lazy 'ByteString' as response body. Provide your own "Content-Type"-lazyBytes :: MonadIO m => BSL.ByteString -> ActionT m a+lazyBytes :: MonadIO m => BSL.ByteString -> ActionCtxT ctx m a lazyBytes val =     response $ \status headers -> Wai.responseLBS status headers val {-# INLINE lazyBytes #-}  -- | Send text as a response body. Content-Type will be "text/plain"-text :: MonadIO m => T.Text -> ActionT m a+text :: MonadIO m => T.Text -> ActionCtxT ctx m a text val =     do setHeaderUnsafe "Content-Type" "text/plain; charset=utf-8"        bytes $ T.encodeUtf8 val {-# INLINE text #-}  -- | Send a text as response body. Content-Type will be "text/html"-html :: MonadIO m => T.Text -> ActionT m a+html :: MonadIO m => T.Text -> ActionCtxT ctx m a html val =     do setHeaderUnsafe "Content-Type" "text/html; charset=utf-8"        bytes $ T.encodeUtf8 val {-# INLINE html #-}  -- | Send a file as response-file :: MonadIO m => T.Text -> FilePath -> ActionT m a+file :: MonadIO m => T.Text -> FilePath -> ActionCtxT ctx m a file contentType filePath =      do setHeaderUnsafe "Content-Type" contentType         response $ \status headers -> Wai.responseFile status headers filePath Nothing {-# INLINE file #-}  -- | Send json as response. Content-Type will be "application/json"-json :: (A.ToJSON a, MonadIO m) => a -> ActionT m b+json :: (A.ToJSON a, MonadIO m) => a -> ActionCtxT ctx m b json val =     do setHeaderUnsafe "Content-Type" "application/json; charset=utf-8"        lazyBytes $ A.encode val {-# INLINE json #-}  -- | Use a 'Wai.StreamingBody' to generate a response.-stream :: MonadIO m => Wai.StreamingBody -> ActionT m a+stream :: MonadIO m => Wai.StreamingBody -> ActionCtxT ctx m a stream val =     response $ \status headers -> Wai.responseStream status headers val {-# INLINE stream #-}@@ -326,7 +336,7 @@ -- >   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 :: MonadIO m => T.Text -> (T.Text -> T.Text -> m Bool) -> ActionCtxT ctx m a -> ActionCtxT ctx m a requireBasicAuth realmTitle authFun cont =     do mAuthHeader <- header "Authorization"        case mAuthHeader of@@ -347,3 +357,27 @@           do setStatus status401              setMultiHeader MultiHeaderWWWAuth ("Basic realm=\"" <> realmTitle <> "\"")              html "<h1>Authentication required.</h1>"++-- | Get the context of the current request+getContext :: MonadIO m => ActionCtxT ctx m ctx+getContext = asks ri_context+{-# INLINE getContext #-}++-- | Run an Action in a different context+runInContext :: MonadIO m => ctx' -> ActionCtxT ctx' m a -> ActionCtxT ctx m a+runInContext newCtx action =+    do currentEnv <- ask+       currentRespState <- ST.get+       (r, newRespState, _) <-+          lift $+          do let env =+                     currentEnv+                     { ri_context = newCtx+                     }+             runRWST (runErrorT $ runActionCtxT action) env currentRespState+       ST.put newRespState+       case r of+         Left interupt ->+             throwError interupt+         Right d -> return d+{-# INLINE runInContext #-}

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}

@@ -12,6 +12,10 @@ import qualified Web.Spock.Internal.SessionVault as SV  import Control.Arrow (first)+#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif import Control.Concurrent import Control.Concurrent.STM import Control.Exception@@ -22,9 +26,8 @@ #else import System.Locale (defaultTimeLocale) #endif-import System.Random-import qualified Data.ByteString.Base64.URL as B64-import qualified Data.ByteString.Char8 as BSC+import qualified Crypto.Random as CR+import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BSL import qualified Data.HashMap.Strict as HM import qualified Data.Text as T@@ -40,7 +43,8 @@  createSessionManager :: SessionCfg sess -> IO (SessionManager conn sess st) createSessionManager cfg =-    do oldSess <- loadSessions+    do pool <- CR.createEntropyPool+       oldSess <- loadSessions        cacheHM <-            atomically $            do mapV <- SV.newSessionVault@@ -56,8 +60,8 @@           , sm_modifySession = modifySessionImpl vaultKey cacheHM           , sm_clearAllSessions = clearAllSessionsImpl cacheHM           , sm_mapSessions = mapAllSessionsImpl cacheHM-          , sm_middleware = sessionMiddleware cfg vaultKey cacheHM-          , sm_addSafeAction = addSafeActionImpl vaultKey cacheHM+          , sm_middleware = sessionMiddleware pool cfg vaultKey cacheHM+          , sm_addSafeAction = addSafeActionImpl pool vaultKey cacheHM           , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM           , sm_removeSafeAction = removeSafeActionImpl vaultKey cacheHM           , sm_closeSessionManager = killThread housekeepThread@@ -86,7 +90,7 @@  getSessionIdImpl :: V.Key SessionId                  -> SV.SessionVault (Session conn sess st)-                 -> SpockAction conn sess st SessionId+                 -> SpockActionCtx ctx conn sess st SessionId getSessionIdImpl vK sessionRef =     do sess <- readSessionBase vK sessionRef        return $ sess_id sess@@ -94,7 +98,7 @@ modifySessionBase :: V.Key SessionId                   -> SV.SessionVault (Session conn sess st)                   -> (Session conn sess st -> (Session conn sess st, a))-                  -> SpockAction conn sess st a+                  -> SpockActionCtx ctx conn sess st a modifySessionBase vK sessionRef modFun =     do req <- request        case V.lookup vK (Wai.vault req) of@@ -113,7 +117,7 @@  readSessionBase :: V.Key SessionId                 -> SV.SessionVault (Session conn sess st)-                -> SpockAction conn sess st (Session conn sess st)+                -> SpockActionCtx ctx conn sess st (Session conn sess st) readSessionBase vK sessionRef =     do req <- request        case V.lookup vK (Wai.vault req) of@@ -127,17 +131,19 @@                   Just session ->                       return session -addSafeActionImpl :: V.Key SessionId-                  -> SV.SessionVault (Session conn sess st)-                  -> PackedSafeAction conn sess st-                  -> SpockAction conn sess st SafeActionHash-addSafeActionImpl vaultKey sessionMapVar safeAction =+addSafeActionImpl ::+    CR.EntropyPool+    -> V.Key SessionId+    -> SV.SessionVault (Session conn sess st)+    -> PackedSafeAction conn sess st+    -> SpockActionCtx ctx conn sess st SafeActionHash+addSafeActionImpl pool 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)+             do safeActionHash <- liftIO (randomHash pool 40)                 let f sas =                         sas                         { sas_forward = HM.insert safeActionHash safeAction (sas_forward sas)@@ -149,7 +155,7 @@ lookupSafeActionImpl :: V.Key SessionId                      -> SV.SessionVault (Session conn sess st)                      -> SafeActionHash-                     -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))+                     -> SpockActionCtx ctx 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))@@ -157,7 +163,7 @@ removeSafeActionImpl :: V.Key SessionId                      -> SV.SessionVault (Session conn sess st)                      -> PackedSafeAction conn sess st-                     -> SpockAction conn sess st ()+                     -> SpockActionCtx ctx conn sess st () removeSafeActionImpl vaultKey sessionMapVar action =     modifySessionBase vaultKey sessionMapVar (\s -> (s { sess_safeActions = f (sess_safeActions s ) }, ()))     where@@ -172,7 +178,7 @@  readSessionImpl :: V.Key SessionId                 -> SV.SessionVault (Session conn sess st)-                -> SpockAction conn sess st sess+                -> SpockActionCtx ctx conn sess st sess readSessionImpl vK sessionRef =     do base <- readSessionBase vK sessionRef        return (sess_data base)@@ -180,25 +186,27 @@ writeSessionImpl :: V.Key SessionId                  -> SV.SessionVault (Session conn sess st)                  -> sess-                 -> SpockAction conn sess st ()+                 -> SpockActionCtx ctx conn sess st () writeSessionImpl vK sessionRef value =     modifySessionImpl vK sessionRef (const (value, ()))  modifySessionImpl :: V.Key SessionId                   -> SV.SessionVault (Session conn sess st)                   -> (sess -> (sess, a))-                  -> SpockAction conn sess st a+                  -> SpockActionCtx ctx conn sess st a modifySessionImpl vK sessionRef f =     do let modFun session =                let (sessData', out) = f (sess_data session)                in (session { sess_data = sessData' }, out)        modifySessionBase vK sessionRef modFun -sessionMiddleware :: SessionCfg sess-                  -> V.Key SessionId-                  -> SV.SessionVault (Session conn sess st)-                  -> Wai.Middleware-sessionMiddleware cfg vK sessionRef app req respond =+sessionMiddleware ::+    CR.EntropyPool+    -> SessionCfg sess+    -> V.Key SessionId+    -> SV.SessionVault (Session conn sess st)+    -> Wai.Middleware+sessionMiddleware pool cfg vK sessionRef app req respond =     case getCookieFromReq (sc_cookieName cfg) of       Just sid ->           do mSess <- loadSessionImpl cfg sessionRef sid@@ -241,15 +249,17 @@               then mapReqHeaders (addCookie sess) unwrappedResp               else unwrappedResp       mkNew =-          do newSess <- newSessionImpl cfg sessionRef defVal+          do newSess <- newSessionImpl pool cfg sessionRef defVal              withSess True newSess -newSessionImpl :: SessionCfg sess-               -> SV.SessionVault (Session conn sess st)-               -> sess-               -> IO (Session conn sess st)-newSessionImpl sessCfg sessionRef content =-    do sess <- createSession sessCfg content+newSessionImpl ::+    CR.EntropyPool+    -> SessionCfg sess+    -> SV.SessionVault (Session conn sess st)+    -> sess+    -> IO (Session conn sess st)+newSessionImpl pool sessCfg sessionRef content =+    do sess <- createSession pool sessCfg content        atomically $ SV.storeSession sess sessionRef        return $! sess @@ -286,14 +296,14 @@     atomically $ SV.deleteSession sid sessionRef  clearAllSessionsImpl :: SV.SessionVault (Session conn sess st)-                     -> SpockAction conn sess st ()+                     -> SpockActionCtx ctx conn sess st () clearAllSessionsImpl sessionRef =     liftIO $ atomically $ SV.filterSessions (const False) sessionRef  mapAllSessionsImpl ::     SV.SessionVault (Session conn sess st)     -> (sess -> STM sess)-    -> SpockAction conn sess st ()+    -> SpockActionCtx ctx conn sess st () mapAllSessionsImpl sessionRef f =     liftIO $ atomically $ flip SV.mapSessions sessionRef $ \sess ->         do newData <- f (sess_data sess)@@ -305,26 +315,29 @@                   -> IO () housekeepSessions cfg sessionRef storeSessions =     do now <- getCurrentTime-       newStatus <-+       (newStatus, oldStatus) <-            atomically $-           do SV.filterSessions (\sess -> sess_validUntil sess > now) sessionRef-              SV.toList sessionRef-       storeSessions (HM.fromList $ map (\v -> (SV.getSessionKey v, v)) newStatus)+           do oldSt <- SV.toList sessionRef+              SV.filterSessions (\sess -> sess_validUntil sess > now) sessionRef+              (,) <$> SV.toList sessionRef <*> pure oldSt+       let packSessionHm = HM.fromList . map (\v -> (SV.getSessionKey v, v))+           oldHm = packSessionHm oldStatus+           newHm = packSessionHm newStatus+       storeSessions newHm+       sh_removed (sc_hooks cfg) (HM.map sess_data $ oldHm `HM.difference` newHm)        threadDelay (1000 * 1000 * (round $ sc_housekeepingInterval cfg)) -createSession :: SessionCfg sess -> sess -> IO (Session conn sess st)-createSession sessCfg content =-    do sid <- randomHash (sc_sessionIdEntropy sessCfg)+createSession :: CR.EntropyPool -> SessionCfg sess -> sess -> IO (Session conn sess st)+createSession pool sessCfg content =+    do sid <- randomHash pool (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+randomHash :: CR.EntropyPool -> Int -> IO T.Text+randomHash pool len =+    do let sys :: CR.SystemRNG+           sys = CR.cprgCreate pool+       return $ T.replace "=" "" $ T.decodeUtf8 $ B64.encode $ fst $ CR.cprgGenerateWithEntropy len sys

@@ -1,15 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} module Web.Spock.Internal.Types where -import Web.Spock.Internal.CoreAction import Web.Spock.Internal.Wire  #if MIN_VERSION_base(4,8,0)@@ -34,10 +34,13 @@ 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)+-- | The 'SpockActionCtx' is the monad of all route-actions. You have access+-- to the context of the request and database, session and state of your application.+type SpockActionCtx ctx conn sess st = ActionCtxT ctx (WebStateM conn sess st) +-- | The 'SpockAction' is a specialisation of 'SpockActionCtx' with a '()' context.+type SpockAction conn sess st = SpockActionCtx () conn sess st+ -- | Spock configuration data SpockCfg conn sess st    = SpockCfg@@ -80,9 +83,10 @@  -- | You can feed Spock with either a connection pool, or instructions on how to build -- a connection pool. See 'ConnBuilder'-data PoolOrConn a-   = PCPool (Pool a)-   | PCConn (ConnBuilder a)+data PoolOrConn a where+    PCPool :: Pool a -> PoolOrConn a+    PCConn :: ConnBuilder a -> PoolOrConn a+    PCNoDatabase :: PoolOrConn ()  -- | Session configuration with reasonable defaults defaultSessionCfg :: a -> SessionCfg a@@ -95,6 +99,7 @@     , sc_emptySession = emptySession     , sc_persistCfg = Nothing     , sc_housekeepingInterval = 60 * 10+    , sc_hooks = defaultSessionHooks     }  -- | Configuration for the session manager@@ -114,8 +119,23 @@      -- ^ persistence interface for sessions    , sc_housekeepingInterval :: NominalDiffTime      -- ^ how often should the session manager check for dangeling dead sessions+   , sc_hooks :: SessionHooks a+     -- ^ hooks into the session manager    } +-- | NOP session hooks+defaultSessionHooks :: SessionHooks a+defaultSessionHooks =+    SessionHooks+    { sh_removed = const $ return ()+    }++-- | Hook into the session manager to trigger custom behavior+data SessionHooks a+   = SessionHooks+   { sh_removed :: HM.HashMap SessionId a -> IO ()+   }+ data SessionPersistCfg a    = SessionPersistCfg    { spc_load :: IO [(SessionId, UTCTime, a)]@@ -197,15 +217,15 @@  data SessionManager conn sess st    = SessionManager-   { sm_getSessionId :: SpockAction conn sess st SessionId-   , sm_readSession :: SpockAction conn sess st sess-   , sm_writeSession :: sess -> SpockAction conn sess st ()-   , sm_modifySession :: forall a. (sess -> (sess, a)) -> SpockAction conn sess st a-   , sm_mapSessions :: (sess -> STM sess) -> SpockAction conn sess st ()-   , sm_clearAllSessions :: SpockAction conn sess st ()+   { sm_getSessionId :: forall ctx. SpockActionCtx ctx conn sess st SessionId+   , sm_readSession :: forall ctx. SpockActionCtx ctx conn sess st sess+   , sm_writeSession :: forall ctx. sess -> SpockActionCtx ctx conn sess st ()+   , sm_modifySession :: forall a ctx. (sess -> (sess, a)) -> SpockActionCtx ctx conn sess st a+   , sm_mapSessions :: forall ctx. (sess -> STM sess) -> SpockActionCtx ctx conn sess st ()+   , sm_clearAllSessions :: forall ctx. SpockActionCtx ctx 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 ()+   , sm_addSafeAction :: forall ctx. PackedSafeAction conn sess st -> SpockActionCtx ctx conn sess st SafeActionHash+   , sm_lookupSafeAction :: forall ctx. SafeActionHash -> SpockActionCtx ctx conn sess st (Maybe (PackedSafeAction conn sess st))+   , sm_removeSafeAction :: forall ctx. PackedSafeAction conn sess st -> SpockActionCtx ctx conn sess st ()    , sm_closeSessionManager :: IO ()    }

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -66,13 +67,15 @@    , vi_lookupKey :: forall a. V.Key a -> IO (Maybe a)    } -data RequestInfo+data RequestInfo ctx    = RequestInfo-   { ri_request :: Wai.Request-   , ri_params :: HM.HashMap CaptureVar T.Text+   { ri_method :: !StdMethod+   , ri_request :: !Wai.Request+   , ri_params :: !(HM.HashMap CaptureVar T.Text)    , ri_queryParams :: [(T.Text, T.Text)]-   , ri_files :: HM.HashMap T.Text UploadedFile-   , ri_vaultIf :: VaultIf+   , ri_files :: !(HM.HashMap T.Text UploadedFile)+   , ri_vaultIf :: !VaultIf+   , ri_context :: !ctx    }  newtype ResponseBody = ResponseBody (Status -> ResponseHeaders -> Wai.Response)@@ -147,13 +150,15 @@     strMsg = ActionError #endif -newtype ActionT m a-    = ActionT { runActionT :: ErrorT ActionInterupt (RWST RequestInfo () ResponseState m) a }-      deriving (Monad, Functor, Applicative, Alternative, MonadIO, MonadReader RequestInfo, MonadState ResponseState, MonadError ActionInterupt)+type ActionT = ActionCtxT () -instance MonadTrans ActionT where-    lift = ActionT . lift . lift+newtype ActionCtxT ctx m a+    = ActionCtxT { runActionCtxT :: ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a }+      deriving (Monad, Functor, Applicative, Alternative, MonadIO, MonadReader (RequestInfo ctx), MonadState ResponseState, MonadError ActionInterupt) +instance MonadTrans (ActionCtxT ctx) where+    lift = ActionCtxT . lift . lift+ respStateToResponse :: ResponseState -> Wai.Response respStateToResponse (ResponseState headers multiHeaders status (ResponseBody body)) =     let mkMultiHeader (k, vals) =@@ -209,8 +214,8 @@       fallbackApp :: Wai.Application       fallbackApp _ respond = respond notFound -makeActionEnvironment :: InternalState -> Wai.Request -> IO (ParamMap -> RequestInfo, TVar V.Vault, IO ())-makeActionEnvironment st req =+makeActionEnvironment :: InternalState -> StdMethod -> Wai.Request -> IO (ParamMap -> RequestInfo (), TVar V.Vault, IO ())+makeActionEnvironment st stdMethod req =     do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req        vaultVar <- liftIO $ newTVarIO (Wai.vault req)        let vaultIf =@@ -232,11 +237,13 @@            queryParams = postParams ++ getParams        return ( \params ->                     RequestInfo-                    { ri_request = req+                    { ri_method = stdMethod+                    , ri_request = req                     , ri_params = params                     , ri_queryParams = queryParams                     , ri_files = uploadedFiles                     , ri_vaultIf = vaultIf+                    , ri_context = ()                     }               , vaultVar               , removeUploadedFiles uploadedFiles@@ -250,7 +257,7 @@  applyAction :: MonadIO m             => Wai.Request-            -> (ParamMap -> RequestInfo)+            -> (ParamMap -> RequestInfo ())             -> [(ParamMap, ActionT m ())]             -> m (Maybe ResponseState) applyAction _ _ [] =@@ -259,7 +266,7 @@     do let env = mkEnv captures            defResp = errorResponse status200 ""        (r, respState, _) <--           runRWST (runErrorT $ runActionT selectedAction) env defResp+           runRWST (runErrorT $ runActionCtxT selectedAction) env defResp        case r of          Left (ActionRedirect loc) ->              return $ Just $@@ -284,25 +291,29 @@  handleRequest     :: MonadIO m-    => Maybe Word64+    => StdMethod+    -> Maybe Word64     -> (forall a. m a -> IO a)     -> [(ParamMap, ActionT m ())]     -> InternalState     -> Wai.Application -> Wai.Application-handleRequest mLimit registryLift allActions st coreApp req respond =+handleRequest stdMethod mLimit registryLift allActions st coreApp req respond =     do reqGo <-            case mLimit of              Nothing -> return req              Just lim -> requestSizeCheck lim req-       handleRequest' registryLift allActions st coreApp reqGo respond+       handleRequest' stdMethod registryLift allActions st coreApp reqGo respond -handleRequest' :: MonadIO m => (forall a. m a -> IO a)-               -> [(ParamMap, ActionT m ())]-               -> InternalState-               -> Wai.Application -> Wai.Application-handleRequest' registryLift allActions st coreApp req respond =+handleRequest' ::+    MonadIO m+    => StdMethod+    -> (forall a. m a -> IO a)+    -> [(ParamMap, ActionT m ())]+    -> InternalState+    -> Wai.Application -> Wai.Application+handleRequest' stdMethod registryLift allActions st coreApp req respond =     do actEnv <--           (Left <$> makeActionEnvironment st req)+           (Left <$> makeActionEnvironment st stdMethod req)            `catch` \(_ :: SizeException) ->                return (Right sizeError)        case actEnv of@@ -365,5 +376,5 @@               Right stdMethod ->                   do let allActions = getMatchingRoutes stdMethod (Wai.pathInfo req)                      runResourceT $ withInternalState $ \st ->-                         handleRequest mLimit registryLift allActions st coreApp req respond+                         handleRequest stdMethod mLimit registryLift allActions st coreApp req respond        return $ spockMiddleware . app

@@ -13,14 +13,14 @@ -} module Web.Spock.Safe     ( -- * Spock's route definition monad-      spock, SpockM-    , spockT, spockLimT, SpockT+      spock, SpockM, SpockCtxM+    , spockT, spockLimT, SpockT, SpockCtxT      -- * Defining routes     , Path, root, Var, var, static, (<//>)      -- * Rendering routes     , renderRoute      -- * Hooking routes-    , subcomponent+    , subcomponent, prehook     , get, post, getpost, head, put, delete, patch, hookRoute, hookAny     , Http.StdMethod (..)       -- * Adding Wai.Middleware@@ -38,34 +38,46 @@ import qualified Web.Spock.Internal.Core as C  import Control.Applicative-import Control.Monad.Trans+import Control.Monad.Reader import Data.HVect hiding (head) import Data.Monoid import Data.Word import Network.HTTP.Types.Method-import Prelude hiding (head)+import Prelude hiding (head, uncurry, curry)+import Web.Routing.AbstractRouter (swapMonad) import Web.Routing.SafeRouting hiding (renderRoute) import qualified Data.Text as T import qualified Network.HTTP.Types as Http import qualified Network.Wai as Wai import qualified Web.Routing.SafeRouting as SR -type SpockM conn sess st a = SpockT (WebStateM conn sess st) a+type SpockM conn sess st = SpockCtxM () conn sess st+type SpockCtxM ctx conn sess st = SpockCtxT ctx (WebStateM conn sess st) -newtype SpockT m a-    = SpockT { runSpockT :: C.SpockAllT (SafeRouter (ActionT m) ()) m a-             } deriving (Monad, Functor, Applicative, MonadIO)+type SpockT = SpockCtxT () -instance MonadTrans SpockT where-    lift = SpockT . lift+newtype LiftHooked ctx m =+    LiftHooked { unLiftHooked :: forall a. ActionCtxT ctx m a -> ActionCtxT () m a } +injectHook :: LiftHooked ctx m -> (forall a. ActionCtxT ctx' m a -> ActionCtxT ctx m a) -> LiftHooked ctx' m+injectHook (LiftHooked baseHook) nextHook =+    LiftHooked $ baseHook . nextHook++newtype SpockCtxT ctx m a+    = SpockCtxT+    { runSpockT :: C.SpockAllT (SafeRouter (ActionT m) ()) (ReaderT (LiftHooked ctx m) m) a+    } deriving (Monad, Functor, Applicative, MonadIO)++instance MonadTrans (SpockCtxT ctx) where+    lift = SpockCtxT . lift . lift+ -- | Create a spock application using 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. -- Use @runSpock@ to run the app or @spockAsApp@ to create a @Wai.Application@ spock :: SpockCfg conn sess st -> SpockM conn sess st () -> IO Wai.Middleware spock spockCfg spockAppl =-    C.spockAll SafeRouter spockCfg (runSpockT spockAppl')+    C.spockAll SafeRouter spockCfg (baseAppHook spockAppl')     where       spockAppl' =           do hookSafeActions@@ -81,50 +93,79 @@ spockT = spockLimT Nothing  -- | Like @spockT@, but first argument is request size limit in bytes. Set to 'Nothing' to disable.-spockLimT :: (MonadIO m)+spockLimT :: forall m .MonadIO m        => Maybe Word64        -> (forall a. m a -> IO a)        -> SpockT m ()        -> IO Wai.Middleware-spockLimT mSizeLimit liftFun (SpockT app) =-    C.spockAllT mSizeLimit SafeRouter liftFun app+spockLimT mSizeLimit liftFun app =+    C.spockAllT mSizeLimit SafeRouter liftFun (baseAppHook app) +baseAppHook :: forall m. MonadIO m => SpockT m () -> C.SpockAllT (SafeRouter (ActionT m) ()) m ()+baseAppHook app =+    swapMonad lifter (runSpockT app)+    where+      lifter :: forall b. ReaderT (LiftHooked () m) m b -> m b+      lifter action = runReaderT action (LiftHooked id)+ -- | Specify an action that will be run when the HTTP verb 'GET' and the given route match-get :: MonadIO m => Path xs -> HVectElim xs (ActionT m ()) -> SpockT m ()+get :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx 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 -> HVectElim xs (ActionT m ()) -> SpockT m ()+post :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m () post = hookRoute POST  -- | Specify an action that will be run when the HTTP verb 'GET'/'POST' and the given route match-getpost :: MonadIO m => Path xs -> HVectElim xs (ActionT m ()) -> SpockT m ()+getpost :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m () getpost r a = hookRoute POST r a >> hookRoute GET r a  -- | Specify an action that will be run when the HTTP verb 'HEAD' and the given route match-head :: MonadIO m => Path xs -> HVectElim xs (ActionT m ()) -> SpockT m ()+head :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx 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 -> HVectElim xs (ActionT m ()) -> SpockT m ()+put :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx 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 -> HVectElim xs (ActionT m ()) -> SpockT m ()+delete :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx 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 -> HVectElim xs (ActionT m ()) -> SpockT m ()+patch :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m () patch = hookRoute PATCH +-- | Specify an action that will be run before all subroutes. It can modify the requests current context+prehook :: forall m ctx ctx'. MonadIO m => ActionCtxT ctx m ctx' -> SpockCtxT ctx' m () -> SpockCtxT ctx m ()+prehook hook (SpockCtxT hookBody) =+    SpockCtxT $+    do prevHook <- lift ask+       let newHook :: ActionCtxT ctx' m a -> ActionCtxT ctx m a+           newHook act =+               do newCtx <- hook+                  runInContext newCtx act+           hookLift :: forall a. ReaderT (LiftHooked ctx' m) m a -> ReaderT (LiftHooked ctx m) m a+           hookLift a =+               lift $ runReaderT a (injectHook prevHook newHook)+       swapMonad hookLift hookBody+ -- | Specify an action that will be run when a HTTP verb and the given route match-hookRoute :: Monad m => StdMethod -> Path xs -> HVectElim xs (ActionT m ()) -> SpockT m ()-hookRoute m path action = SpockT $ C.hookRoute m (SafeRouterPath path) (HVectElim' action)+hookRoute :: forall xs ctx m. (HasRep xs, Monad m) => StdMethod -> Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+hookRoute m path action =+    SpockCtxT $+    do hookLift <- lift $ asks unLiftHooked+       let actionPacker :: HVectElim xs (ActionCtxT ctx m ()) -> HVect xs -> ActionCtxT () m ()+           actionPacker act captures = hookLift (uncurry act captures)+       C.hookRoute m (SafeRouterPath path) (HVectElim' $ curry $ actionPacker action)  -- | Specify an action that will be run when a HTTP verb matches but no defined route matches. -- The full path is passed as an argument-hookAny :: Monad m => StdMethod -> ([T.Text] -> ActionT m ()) -> SpockT m ()-hookAny m action = SpockT $ C.hookAny m action+hookAny :: Monad m => StdMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+hookAny m action =+    SpockCtxT $+    do hookLift <- lift $ asks unLiftHooked+       C.hookAny m (hookLift . action)  -- | Define a subcomponent. Usage example: --@@ -136,12 +177,12 @@ -- -- 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+subcomponent :: Monad m => Path '[] -> SpockCtxT ctx m () -> SpockCtxT ctx m ()+subcomponent p (SpockCtxT subapp) = SpockCtxT $ C.subcomponent (SafeRouterPath p) subapp  -- | Hook wai middleware into Spock-middleware :: Monad m => Wai.Middleware -> SpockT m ()-middleware = SpockT . C.middleware+middleware :: Monad m => Wai.Middleware -> SpockCtxT ctx m ()+middleware = SpockCtxT . C.middleware  -- | Wire up a safe action: Safe actions are actions that are protected from -- csrf attacks. Here's a usage example:

@@ -9,13 +9,15 @@     (-- * Helpers for running Spock       runSpock, spockAsApp      -- * Action types-    , SpockAction, ActionT+    , SpockAction, SpockActionCtx, ActionT, W.ActionCtxT      -- * Handling requests-    , request, header, rawHeader, cookie+    , request, header, rawHeader, cookie, reqMethod     , preferredFormat, ClientPreferredFormat(..)     , body, jsonBody, jsonBody'     , files, UploadedFile (..)     , params, param, param'+     -- * Working with context+    , getContext, runInContext      -- * Sending responses     , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', deleteCookie, bytes, lazyBytes     , text, html, file, json, stream, response@@ -31,6 +33,7 @@     , requireBasicAuth      -- * Sessions     , defaultSessionCfg, SessionCfg (..)+    , defaultSessionHooks, SessionHooks (..)     , SessionPersistCfg(..), readShowSessionPersist     , SessionId     , getSessionId, readSession, writeSession@@ -65,51 +68,51 @@  -- | Get the current users sessionId. Note that this ID should only be -- shown to it's owner as otherwise sessions can be hijacked.-getSessionId :: SpockAction conn sess st SessionId+getSessionId :: SpockActionCtx ctx conn sess st SessionId getSessionId =     getSessMgr >>= sm_getSessionId  -- | 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 :: sess -> SpockActionCtx ctx conn sess st () writeSession d =     do mgr <- getSessMgr        sm_writeSession mgr d  -- | Modify the stored session-modifySession :: (sess -> sess) -> SpockAction conn sess st ()+modifySession :: (sess -> sess) -> SpockActionCtx ctx conn sess st () modifySession f =     modifySession' $ \sess -> (f sess, ())  -- | Modify the stored session and return a value-modifySession' :: (sess -> (sess, a)) -> SpockAction conn sess st a+modifySession' :: (sess -> (sess, a)) -> SpockActionCtx ctx conn sess st a modifySession' f =     do mgr <- getSessMgr        sm_modifySession mgr f  -- | Modify the stored session and return the new value after modification-modifyReadSession :: (sess -> sess) -> SpockAction conn sess st sess+modifyReadSession :: (sess -> sess) -> SpockActionCtx ctx conn sess st sess modifyReadSession f =     modifySession' $ \sess ->         let x = f sess         in (x, x)  -- | Read the stored session-readSession :: SpockAction conn sess st sess+readSession :: SpockActionCtx ctx 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 :: SpockActionCtx ctx conn sess st () clearAllSessions =     do mgr <- getSessMgr        sm_clearAllSessions mgr  -- | Apply a transformation to all sessions. Be careful with this, as this -- may cause many STM transaction retries.-mapAllSessions :: (sess -> STM sess) -> SpockAction conn sess st ()+mapAllSessions :: (sess -> STM sess) -> SpockActionCtx ctx conn sess st () mapAllSessions f =     do mgr <- getSessMgr        sm_mapSessions mgr f

@@ -38,6 +38,7 @@     with app $     do routingSpec        actionSpec+       headerTest        cookieTest  routingSpec :: SpecWith Wai.Application@@ -99,6 +100,26 @@                   , matchHeaders =                       [ matchCookie "multiple1" "test1"                       , matchCookie "multiple2" "test2"+                      ]+                  }+headerTest :: SpecWith Wai.Application+headerTest =+    describe "Headers" $+    do it "supports custom headers" $+          get "/set-header" `shouldRespondWith`+                  "ok"+                  { matchStatus = 200+                  , matchHeaders =+                      [ "X-FooBar" <:> "Baz"+                      ]+                  }+       it "supports multi headers" $+          get "/set-multi-header" `shouldRespondWith`+                  "ok"+                  { matchStatus = 200+                  , matchHeaders =+                      [ "Content-Language" <:> "de"+                      , "Content-Language" <:> "en"                       ]                   } 

@@ -1,13 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DoAndIfThenElse #-} module Web.Spock.SafeSpec (spec) where  import Web.Spock.Safe import Web.Spock.FrameworkSpecHelper +import Control.Arrow (second)+import Control.Monad+import Data.IORef+import Data.List (find) import Data.Monoid import Test.Hspec+import qualified Data.HashSet as HS import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.Wai.Test as Wai+import qualified Test.Hspec.Wai as Test  app :: SpockT IO () app =@@ -31,6 +40,13 @@            do setCookie "multiple1" "test1" 3600               setCookie "multiple2" "test2" 3600               text "set"+       get "set-header" $+           do setHeader "X-FooBar" "Baz"+              text "ok"+       get "set-multi-header" $+           do setHeader "Content-Language" "de"+              setHeader "Content-Language" "en"+              text "ok"        subcomponent "/subcomponent" $          do get "foo" $ text "foo"             subcomponent "/subcomponent2" $@@ -58,10 +74,85 @@              let r3 = "blog" <//> (var :: Var Int) <//> (var :: Var T.Text)              renderRoute r3 2 "BIIM" `shouldBe` "/blog/2/BIIM" +ctxApp :: SpockT IO ()+ctxApp =+    prehook hook $+    do get "test" $ getContext >>= text+       post "test" $ getContext >>= text+    where+      hook =+          do sid <- header "X-ApiKey"+             case sid of+               Just s -> return s+               Nothing -> text "Missing ApiKey"++ctxSpec :: Spec+ctxSpec =+    describe "Contexts" $+    Test.with (spockAsApp $ spockT id ctxApp) $+    it "should work" $+       do Test.request "GET" "/test" [] "" `Test.shouldRespondWith` "Missing ApiKey"+          Test.request "GET" "/test" [("X-ApiKey", "foo")] "" `Test.shouldRespondWith` "foo"+          Test.request "POST" "/test" [("X-ApiKey", "foo")] "" `Test.shouldRespondWith` "foo"++sessionSpec :: Spec+sessionSpec =+    describe "SessionManager" $+    Test.with sessionApp $+    do it "should generate random session ids" $+          do ids <- Test.liftIO $ newIORef HS.empty+             -- of course this sample is too small to prove anything, but it's a good+             -- smoke test...+             replicateM_ 500 $+                do res <- Test.get "/test"+                   Test.liftIO $ checkCookie ids res `shouldReturn` True+       it "should remember a session" $+          do res <- Test.get "/set/5"+             case getSessCookie res of+               Nothing ->+                   Test.liftIO $ expectationFailure "Missing spockcookie"+               Just sessCookie ->+                   Test.request "GET" "/check" [("Cookie", T.encodeUtf8 sessCookie)] ""+                           `Test.shouldRespondWith` "5"+    where+      sessionApp =+          spockAsApp $+          spock spockCfg $+          do get "test" $ text "text"+             get ("set" <//> var) $ \number -> writeSession number >> text "done"+             get "check" $+                 do val <- readSession+                    text (T.pack $ show val)+      spockCfg =+          defaultSpockCfg (0 :: Int) PCNoDatabase True++      getSessCookie :: Wai.SResponse -> Maybe T.Text+      getSessCookie resp =+          let headers = Wai.simpleHeaders resp+          in fmap snd $ find (\h -> fst h == "Set-Cookie" && "spockcookie" `T.isPrefixOf` snd h) $+             map (second T.decodeUtf8) headers++      checkCookie :: IORef (HS.HashSet T.Text) -> Wai.SResponse -> IO Bool+      checkCookie setRef resp =+          do let mSessCookie = getSessCookie resp+             case mSessCookie of+               Nothing ->+                   do expectationFailure "Missing spockcookie"+                      return False+               Just sessCookie ->+                   let (_, cval) = T.breakOn "=" $ fst $ T.breakOn ";" sessCookie+                   in do set <- readIORef setRef+                         if HS.member cval set+                         then return False+                         else do writeIORef setRef $ HS.insert cval set+                                 return True+ spec :: Spec spec =     describe "SafeRouting" $     do frameworkSpec (spockAsApp $ spockT id app)+       ctxSpec+       sessionSpec        routeRenderingSpec        sizeLimitSpec $ \lim -> spockAsApp $ spockLimT (Just lim) id $           post "size" $ body >>= bytes

@@ -41,6 +41,13 @@            do setCookie "multiple1" "test1" 3600               setCookie "multiple2" "test2" 3600               text "set"+       get "set-header" $+           do setHeader "X-FooBar" "Baz"+              text "ok"+       get "set-multi-header" $+           do setHeader "Content-Language" "de"+              setHeader "Content-Language" "en"+              text "ok"        hookAny GET $ text . T.intercalate "/"  spec :: Spec