packages feed

Spock 0.6.6.1 → 0.14.0.0

raw patch · 27 files changed

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013 - 2017, Alexander Thiemann <mail@athiemann.net>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Alexander Thiemann nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,17 @@+Spock+=====++[![Build Status](https://travis-ci.org/agrafix/Spock.svg)](https://travis-ci.org/agrafix/Spock)+[![Hackage](https://img.shields.io/hackage/v/Spock.svg)](http://hackage.haskell.org/package/Spock)++Documentation: [Spock 0.12.0.0](https://spockdocs.s3.eu-central-1.amazonaws.com/Spock-0.12.0.0/Web-Spock.html)++## Intro++Hackage: [Spock](http://hackage.haskell.org/package/Spock)+Stackage: [Spock](https://www.stackage.org/package/Spock)++Another Haskell web framework for rapid development. To get started with Spock, check our [tutorial](https://www.spock.li/tutorial/)+or take a quick look at our example projects.++For more information please visit our homepage at [www.spock.li](https://www.spock.li)
Spock.cabal view
@@ -1,76 +1,106 @@ name:                Spock-version:             0.6.6.1+version:             0.14.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+description:         This toolbox provides everything you need to get a quick start into web hacking with haskell:+                     .+                     * fast routing+                     .+                     * middleware+                     .+                     * json+                     .+                     * sessions+                     .+                     * cookies+                     .+                     * database helper+                     .+                     * csrf-protection+                     .+                     A tutorial is available at <http://www.spock.li/tutorial/ spock.li>+Homepage:            https://www.spock.li Bug-reports:         https://github.com/agrafix/Spock/issues license:             BSD3-author:              Alexander Thiemann <mail@agrafix.net>-maintainer:          mail@agrafix.net-copyright:           (c) 2013 - 2014 Alexander Thiemann+license-file:        LICENSE+author:              Alexander Thiemann <mail@athiemann.net>+maintainer:          Alexander Thiemann <mail@athiemann.net>+copyright:           (c) 2013 - 2020 Alexander Thiemann category:            Web build-type:          Simple-cabal-version:       >=1.8+cabal-version:       >=2.0+tested-with:         GHC==8.8.4 +extra-source-files:+    README.md+ 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-  build-depends:       aeson >= 0.6.2.1 && <0.9,+  exposed-modules:+                  Web.Spock,+                  Web.Spock.Config,+                  Web.Spock.SessionActions,+                  Web.Spock.Internal.SessionVault,+                  Web.Spock.Internal.SessionManager+  other-modules:+                Web.Spock.Internal.Monad,+                Web.Spock.Internal.Types+  build-depends:+                       Spock-core >= 0.14,                        base >= 4 && < 5,-                       base64-bytestring ==1.*,-                       blaze-html ==0.7.*,-                       bytestring ==0.10.*,-                       case-insensitive >=1.1 && <1.3,-                       conduit >= 1.0 && <1.3,-                       containers ==0.5.*,-                       digestive-functors ==0.7.*,-                       directory ==1.2.*,-                       hashable ==1.2.*,-                       http-types ==0.8.*,-                       monad-control ==0.3.*,-                       mtl >=2.1 && <2.3,-                       old-locale ==1.*,-                       path-pieces >=0.1.4,-                       random ==1.*,-                       regex-compat ==0.95.*,-                       resource-pool ==0.2.*,-                       resourcet >= 0.4 && <1.2,-                       stm ==2.4.*,-                       text >= 0.11.3.1 && <1.3,-                       time >=1.4 && <1.6,-                       transformers >=0.3 && <0.5,-                       transformers-base ==0.4.*,-                       unordered-containers ==0.2.*,-                       vault ==0.3.*,-                       vector ==0.10.*,-                       wai >=3.0 && <4.0,-                       wai-extra >=3.0 && <4.0,-                       warp >=3.0 && <4.0,-                       xsd ==0.4.*+                       base64-bytestring >=1.0,+                       bytestring >=0.10,+                       containers >=0.5,+                       cryptonite >= 0.6,+                       focus >=0.1,+                       hashable >=1.2,+                       hvect >=0.3,+                       http-types >=0.8,+                       list-t >=0.4,+                       monad-control >=1.0,+                       mtl >=2.1,+                       reroute >=0.5,+                       resource-pool >=0.2,+                       resourcet >= 1.2.2,+                       stm >=2.4,+                       stm-containers >= 1.1.0.2,+                       text >= 0.11.3.1,+                       time >=1.4,+                       transformers >=0.3,+                       transformers-base >=0.4,+                       unordered-containers >=0.2,+                       vault >=0.3,+                       wai >=3.0   ghc-options: -Wall -fno-warn-orphans+  default-language:    Haskell2010  test-suite spocktests   type:                exitcode-stdio-1.0   hs-source-dirs:      test   main-is:             Spec.hs-  other-modules:       Web.Spock.WireSpec, Web.Spock.RoutingSpec-  build-depends:       QuickCheck,+  other-modules:+                Web.Spock.Internal.SessionVaultSpec,+                Web.Spock.Internal.SessionManagerSpec,+                Web.Spock.SafeSpec,+                Web.Spock.CsrfSpec,+                Web.Spock.TestUtils+  build-depends:+                       base,+                       bytestring,+                       hspec >= 2.0,+                       hspec-wai >= 0.6,                        Spock,-                       base >= 4 && < 5,-                       hspec2 >=0.4 && <0.5,-                       vector ==0.10.*,-                       unordered-containers ==0.2.*+                       Spock-core,+                       stm,+                       text,+                       time,+                       unordered-containers,+                       vault,+                       wai,+                       wai-extra+   ghc-options: -Wall -fno-warn-orphans+  default-language:    Haskell2010  source-repository head   type:     git-  location: git://github.com/agrafix/Spock.git+  location: https://github.com/agrafix/Spock
src/Web/Spock.hs view
@@ -1,64 +1,79 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# 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+    ( -- * Launching Spock+      runSpock, runSpockNoBanner, spockAsApp+      -- * Spock's route definition monad+    , spock, SpockM, SpockCtxM+      -- * Defining routes+    , Path, root, Var, var, static, (<//>), wildcard+      -- * Rendering routes+    , renderRoute+      -- * Hooking routes+    , prehook+    , RouteSpec+    , get, post, getpost, head, put, delete, patch, hookRoute+    , hookRouteCustom, hookAny, hookAnyCustom+    , hookRouteAll+    , hookAnyAll+    , C.StdMethod (..)+      -- * Adding Wai.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+      -- * Actions+    , SpockAction, SpockActionCtx+    , module Web.Spock.Action+    , HasSpock(..), SessionManager+    , module Web.Spock.SessionActions+    , getCsrfToken, getClientCsrfToken, csrfCheck+      -- * Accessing internals+    , WebStateM, WebStateT, WebState+    , getSpockHeart, runSpockIO, getSpockPool     ) 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 Web.Spock.Action+import Web.Spock.Core hiding+       ( hookRoute', hookAny'+       , get, post, getpost, head, put, delete, patch, hookRoute+       , hookRouteCustom, hookAny, hookAnyCustom+       , hookRouteAll, hookAnyAll+       )+import Web.Spock.Internal.Monad+import Web.Spock.Internal.SessionManager+import Web.Spock.Internal.Types+import Web.Spock.SessionActions import qualified Web.Spock.Core as C -import Control.Monad.Trans.Reader+import Control.Applicative+import Control.Monad.Reader import Control.Monad.Trans.Resource import Data.Pool-import qualified Network.HTTP.Types as Http+import Network.HTTP.Types.Status (status403)+import Prelude hiding (head)+import qualified Data.HVect as HV+import qualified Data.Text as T+import qualified Data.Vault.Lazy as V+import qualified Network.Wai as Wai --- | Run a spock application using the warp server, a given db storageLayer and an initial state.++type SpockM conn sess st = SpockCtxM () conn sess st+type SpockCtxM ctx conn sess st = SpockCtxT ctx (WebStateM conn sess st)++-- | 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.-spock :: Int -> SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO ()-spock port sessionCfg poolOrConn initialState defs =-    do sessionMgr <- createSessionManager sessionCfg-       connectionPool <-+-- Use @runSpock@ to run the app or @spockAsApp@ to create a @Wai.Application@+spock :: forall conn sess st. SpockCfg conn sess st -> SpockM conn sess st () -> IO Wai.Middleware+spock spockCfg spockAppl =+    do connectionPool <-            case poolOrConn of+             PCNoDatabase ->+                 createPool (return ()) (const $ return ()) 5 60 5              PCPool p ->                  return p              PCConn cb ->@@ -66,41 +81,161 @@                  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+       internalState <-+           WebState+           <$> pure connectionPool+           <*> (createSessionManager sessionCfg $+                   SessionIf+                   { si_queryVault = queryVault+                   , si_modifyVault = modifyVault+                   , si_setRawMultiHeader = setRawMultiHeader+                   , si_vaultKey = V.newKey+                   }+               )+           <*> pure initialState+           <*> pure spockCfg+       let coreConfig =+               defaultSpockConfig+               { sc_maxRequestSize = spc_maxRequestSize spockCfg+               , sc_errorHandler = spc_errorHandler spockCfg+               , sc_logError = spc_logError spockCfg                }-           runM m = runResourceT $ runReaderT (runWebStateM m) internalState+       spockConfigT coreConfig (\m -> runResourceT $ runReaderT (runWebStateT m) internalState)  $+           do middleware (sm_middleware $ web_sessionMgr internalState)+              spockAppl+    where+        sessionCfg = spc_sessionCfg spockCfg+        poolOrConn = spc_database spockCfg+        initialState = spc_initialState spockCfg -       spockT port runM $-               do hookSafeActions-                  defs-                  middleware (sm_middleware sessionMgr)+-- | Get the CSRF token for the current user. This token must be sent on all non+-- GET requests via a post parameter or HTTP-Header if 'spc_csrfProtection' is turned on.+-- See configuration 'SpockCfg' documentation for more information+getCsrfToken :: SpockActionCtx ctx conn sess st T.Text+getCsrfToken = runInContext () $ sm_getCsrfToken =<< getSessMgr+{-# INLINE getCsrfToken #-} --- | 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+-- | Get the CSRF token sent by the client. You should not need to call this+-- manually if 'spc_csrfProtection' is turned on.+getClientCsrfToken :: SpockActionCtx ctx conn sess st (Maybe T.Text)+getClientCsrfToken =+    do cfg <- getSpockCfg+       mHeader <- header (spc_csrfHeaderName cfg)+       mParam <- param (spc_csrfPostName cfg)+       pure (mHeader <|> mParam)+{-# INLINE getClientCsrfToken #-} --- | Modify the stored session-modifySession :: (sess -> sess) -> SpockAction conn sess st ()-modifySession f =-    do mgr <- getSessMgr-       (sm_modifySession mgr) f+-- | Check that the client sent a valid CSRF token. You should not need to call this+-- manually in non GET requests if 'spc_csrfProtection' is turned on.+csrfCheck :: SpockActionCtx ctx conn sess st ()+csrfCheck =+    do csrf <- getCsrfToken+       clientCsrf <- getClientCsrfToken+       case clientCsrf of+         Nothing -> abort+         Just csrfVal+           | csrfVal == csrf -> pure ()+           | otherwise -> abort+   where+       abort =+         do setStatus status403+            text "Broken/Missing CSRF Token"+{-# INLINE csrfCheck #-} --- | Read the stored session-readSession :: SpockAction conn sess st sess-readSession =-    do mgr <- getSessMgr-       sm_readSession mgr+type RouteSpec xs ps ctx conn sess st =+    Path xs ps -> HV.HVectElim xs (SpockActionCtx ctx conn sess st ()) -> SpockCtxM ctx conn sess st () --- | 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+-- | Specify an action that will be run when a standard HTTP verb and the given route match+hookRoute :: HV.HasRep xs => StdMethod -> RouteSpec xs ps ctx conn sess st+hookRoute = hookRoute' . MethodStandard . HttpMethod++-- | Specify an action that will be run regardless of the HTTP verb+hookRouteAll :: HV.HasRep xs => RouteSpec xs ps ctx conn sess st+hookRouteAll = hookRoute' MethodAny++-- | Specify an action that will be run when the HTTP verb 'GET' and the given route match+get :: HV.HasRep xs => RouteSpec xs ps ctx conn sess st+get = hookRoute GET++-- | Specify an action that will be run when the HTTP verb 'POST' and the given route match+post :: HV.HasRep xs => RouteSpec xs ps ctx conn sess st+post = hookRoute POST++-- | Specify an action that will be run when the HTTP verb 'GET'/'POST' and the given route match+getpost :: HV.HasRep xs => RouteSpec xs ps ctx conn sess st+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 :: HV.HasRep xs => RouteSpec xs ps ctx conn sess st+head = hookRoute HEAD++-- | Specify an action that will be run when the HTTP verb 'PUT' and the given route match+put :: HV.HasRep xs => RouteSpec xs ps ctx conn sess st+put = hookRoute PUT++-- | Specify an action that will be run when the HTTP verb 'DELETE' and the given route match+delete :: HV.HasRep xs => RouteSpec xs ps ctx conn sess st+delete = hookRoute DELETE++-- | Specify an action that will be run when the HTTP verb 'PATCH' and the given route match+patch :: HV.HasRep xs => RouteSpec xs ps ctx conn sess st+patch = hookRoute PATCH++-- | Specify an action that will be run when a custom HTTP verb and the given route match+hookRouteCustom :: HV.HasRep xs => T.Text -> RouteSpec xs ps ctx conn sess st+hookRouteCustom = hookRoute' . MethodCustom++-- | Specify an action that will be run when a standard HTTP verb matches but no defined route matches.+-- The full path is passed as an argument+hookAny :: StdMethod -> ([T.Text] -> SpockActionCtx ctx conn sess st ()) -> SpockCtxM ctx conn sess st ()++hookAny = hookAny' . MethodStandard . HttpMethod++-- | Specify an action that will be run regardless of the HTTP verb and no defined route matches.+-- The full path is passed as an argument+hookAnyAll :: ([T.Text] -> SpockActionCtx ctx conn sess st ()) -> SpockCtxM ctx conn sess st ()+hookAnyAll = hookAny' MethodAny++-- | Specify an action that will be run when a custom HTTP verb matches but no defined route matches.+-- The full path is passed as an argument+hookAnyCustom :: T.Text -> ([T.Text] -> SpockActionCtx ctx conn sess st ()) -> SpockCtxM ctx conn sess st ()++hookAnyCustom = hookAny' . MethodCustom++-- | 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' :: SpockMethod -> ([T.Text] -> SpockActionCtx ctx conn sess st ()) -> SpockCtxM ctx conn sess st ()+hookAny' m action =+    getSpockCfg >>= \cfg ->+    C.hookAny' m $ \t ->+    case m of+      MethodStandard (HttpMethod stdMethod)+          | shouldCheckCsrf stdMethod && spc_csrfProtection cfg -> csrfCheck >> action t+      _ -> action t++-- | Specify an action that will be run when a HTTP verb and the given route match+hookRoute' ::+    forall xs ps ctx conn sess st.+    (HV.HasRep xs)+    => SpockMethod+    -> RouteSpec xs ps ctx conn sess st+hookRoute' m path action =+    do cfg <- getSpockCfg+       checkedAction <-+           case m of+               MethodStandard (HttpMethod stdMethod)+                   | shouldCheckCsrf stdMethod && spc_csrfProtection cfg ->+                         do let unpackedAction :: HV.HVect xs -> SpockActionCtx ctx conn sess st ()+                                unpackedAction args =+                                    csrfCheck >> HV.uncurry action args+                            pure $ HV.curry unpackedAction+               _ -> pure action+       C.hookRoute' m path checkedAction++shouldCheckCsrf :: StdMethod -> Bool+shouldCheckCsrf m =+    case m of+      GET -> False+      HEAD -> False+      OPTIONS -> False+      _ -> True
+ src/Web/Spock/Config.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.Config+    ( SpockCfg (..), defaultSpockCfg+      -- * Database+    , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)+      -- * Sessions+    , defaultSessionCfg, SessionCfg (..)+    , defaultSessionHooks, SessionHooks (..)+    , SessionStore(..), SessionStoreInstance(..)+    , SV.newStmSessionStore+    )+where++import Web.Spock.Action+import Web.Spock.Internal.Types+import qualified Web.Spock.Internal.SessionVault as SV++#if MIN_VERSION_base(4,11,0)+#elif MIN_VERSION_base(4,9,0)+import Data.Semigroup+#else+import Data.Monoid+#endif+import Network.HTTP.Types.Status+import System.IO+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T++-- | NOP session hooks+defaultSessionHooks :: SessionHooks a+defaultSessionHooks =+    SessionHooks+    { sh_removed = const $ return ()+    }++-- | Session configuration with reasonable defaults and an+-- stm based session store+defaultSessionCfg :: a -> IO (SessionCfg conn a st)+defaultSessionCfg emptySession =+  do store <- SV.newStmSessionStore+     return+       SessionCfg+       { sc_cookieName = "spockcookie"+       , sc_cookieEOL = CookieValidForever+       , sc_sessionTTL = 3600+       , sc_sessionIdEntropy = 64+       , sc_sessionExpandTTL = True+       , sc_emptySession = emptySession+       , sc_store = store+       , sc_housekeepingInterval = 60 * 10+       , sc_hooks = defaultSessionHooks+       }++-- | Spock configuration with reasonable defaults such as a basic error page+-- and 5MB request body limit. IMPORTANT: CSRF Protection is turned off by+-- default for now to not break any existing Spock applications. Consider+-- turning it on manually as it will become the default in the future.+defaultSpockCfg :: sess -> PoolOrConn conn -> st -> IO (SpockCfg conn sess st)+defaultSpockCfg sess conn st =+  do defSess <- defaultSessionCfg sess+     return+       SpockCfg+       { spc_initialState = st+       , spc_database = conn+       , spc_sessionCfg = defSess+       , spc_maxRequestSize = Just (5 * 1024 * 1024)+       , spc_logError = T.hPutStrLn stderr+       , spc_errorHandler = errorHandler+       , spc_csrfProtection = False+       , spc_csrfHeaderName = "X-Csrf-Token"+       , spc_csrfPostName = "__csrf_token"+       }++errorHandler :: Status -> ActionCtxT () IO ()+errorHandler status = html $ errorTemplate status++-- Danger! This should better be done using combinators, but we do not+-- want Spock depending on a specific html combinator framework+errorTemplate :: Status -> T.Text+errorTemplate s =+    "<html><head>"+    <> "<title>" <> message <> "</title>"+    <> "</head>"+    <> "<body>"+    <> "<h1>" <> message <> "</h1>"+    <> "<a href='https://www.spock.li'>powered by Spock</a>"+    <> "</body>"+    where+      message =+          showT (statusCode s) <> " - " <> T.decodeUtf8 (statusMessage s)+      showT = T.pack . show
− src/Web/Spock/Core.hs 
@@ -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 "<h1>Authentication required.</h1>"
− src/Web/Spock/Digestive.hs 
@@ -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)
+ src/Web/Spock/Internal/Monad.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+module Web.Spock.Internal.Monad where++import Web.Spock.Internal.Types++import Control.Monad.Reader+import Control.Monad.Trans.Resource+import Data.Pool++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+    getSpockCfg = webM getSpockCfgImpl++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+    getSpockCfg = getSpockCfgImpl++getSpockCfgImpl :: WebStateM conn sess st (SpockCfg conn sess st)+getSpockCfgImpl = asks web_config++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 (WebStateT action) =+    runResourceT $+    runReaderT action st++getSessMgrImpl :: WebStateM conn sess st (SpockSessionManager conn sess st)+getSessMgrImpl = asks web_sessionMgr++-- | Read the connection pool of Spock. This is useful if you want to construct your own+-- monads that work with 'runQuery' and 'getState' using 'runSpockIO'+getSpockPool :: MonadTrans t => t (WebStateM conn sess st) (Pool conn)+getSpockPool = webM $ asks web_dbConn
+ src/Web/Spock/Internal/SessionManager.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}+{-# LANGUAGE GADTs #-}+module Web.Spock.Internal.SessionManager+    ( createSessionManager, withSessionManager+    , SessionId, Session(..), SessionManager(..)+    , SessionIf(..)+    )+where++import Web.Spock.Core+import Web.Spock.Internal.Types+import Web.Spock.Internal.Util+import Web.Spock.Internal.Cookies++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif+import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Trans+import Data.Time+import qualified Crypto.Random as CR+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import qualified Data.HashMap.Strict as HM+import qualified Data.Traversable as T+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vault.Lazy as V+import qualified Network.Wai as Wai++data SessionIf m+    = SessionIf+    { si_queryVault :: forall a. V.Key a -> m (Maybe a)+    , si_modifyVault :: (V.Vault -> V.Vault) -> m ()+    , si_setRawMultiHeader :: MultiHeader -> BS.ByteString -> m ()+    , si_vaultKey :: IO (V.Key SessionId)+    }++withSessionManager ::+    MonadIO m => SessionCfg conn sess st -> SessionIf m -> (SessionManager m conn sess st -> IO a) -> IO a+withSessionManager sessCfg sif =+    bracket (createSessionManager sessCfg sif) sm_closeSessionManager++createSessionManager ::+    MonadIO m => SessionCfg conn sess st -> SessionIf m -> IO (SessionManager m conn sess st)+createSessionManager cfg sif =+    do vaultKey <- si_vaultKey sif+       housekeepThread <- forkIO (forever (housekeepSessions cfg))+       return+          SessionManager+          { sm_getSessionId = getSessionIdImpl vaultKey cfg sif+          , sm_getCsrfToken = getCsrfTokenImpl vaultKey cfg sif+          , sm_regenerateSessionId = regenerateSessionIdImpl vaultKey store cfg sif+          , sm_readSession = readSessionImpl vaultKey cfg sif+          , sm_writeSession = writeSessionImpl vaultKey store cfg sif+          , sm_modifySession = modifySessionImpl vaultKey store cfg sif+          , sm_clearAllSessions = clearAllSessionsImpl store+          , sm_mapSessions = mapAllSessionsImpl store+          , sm_middleware = sessionMiddleware cfg vaultKey+          , sm_closeSessionManager = killThread housekeepThread+          }+    where+      store = sc_store cfg++regenerateSessionIdImpl ::+    MonadIO m+    => V.Key SessionId+    -> SessionStoreInstance (Session conn sess st)+    -> SessionCfg conn sess st+    -> SessionIf m+    -> m ()+regenerateSessionIdImpl vK sessionRef cfg sif =+    do sess <- readSessionBase vK cfg sif+       liftIO $ deleteSessionImpl sessionRef (sess_id sess)+       newSession <- liftIO $ newSessionImpl cfg sessionRef (sess_data sess)+       now <- liftIO getCurrentTime+       si_setRawMultiHeader sif MultiHeaderSetCookie (makeSessionIdCookie cfg newSession now)+       si_modifyVault sif $ V.insert vK (sess_id newSession)++getSessionIdImpl ::+    MonadIO m+    => V.Key SessionId+    -> SessionCfg conn sess st+    -> SessionIf m+    -> m SessionId+getSessionIdImpl vK cfg sif =+    do sess <- readSessionBase vK cfg sif+       return $ sess_id sess++getCsrfTokenImpl ::+    ( MonadIO m )+    => V.Key SessionId+    -> SessionCfg conn sess st+    -> SessionIf m+    -> m T.Text+getCsrfTokenImpl vK cfg sif =+    do sess <- readSessionBase vK cfg sif+       return $ sess_csrfToken sess++modifySessionBase ::+    MonadIO m+    => V.Key SessionId+    -> SessionStoreInstance (Session conn sess st)+    -> SessionCfg conn sess st+    -> SessionIf m+    -> (Session conn sess st -> (Session conn sess st, a))+    -> m a+modifySessionBase vK (SessionStoreInstance sessionRef) cfg sif modFun =+    do mValue <- si_queryVault sif vK+       case mValue of+         Nothing ->+             error "(3) Internal Spock Session Error. Please report this bug!"+         Just sid ->+             do session <- readOrNewSession cfg vK sif (Just sid)+                let (sessionNew, result) = modFun session+                liftIO $ ss_runTx sessionRef $ ss_storeSession sessionRef sessionNew+                return result++readSessionBase ::+    MonadIO m+    => V.Key SessionId+    -> SessionCfg conn sess st+    -> SessionIf m+    -> m (Session conn sess st)+readSessionBase vK cfg sif =+    do mValue <- si_queryVault sif vK+       case mValue of+         Nothing ->+             error "(1) Internal Spock Session Error. Please report this bug!"+         Just sid ->+             readOrNewSession cfg vK sif (Just sid)++readSessionImpl ::+    MonadIO m+    => V.Key SessionId+    -> SessionCfg conn sess st+    -> SessionIf m+    -> m sess+readSessionImpl vK cfg sif =+    do base <- readSessionBase vK cfg sif+       return (sess_data base)++writeSessionImpl ::+    MonadIO m+    => V.Key SessionId+    -> SessionStoreInstance (Session conn sess st)+    -> SessionCfg conn sess st+    -> SessionIf m+    -> sess+    -> m ()+writeSessionImpl vK sessionRef cfg sif value =+    modifySessionImpl vK sessionRef cfg sif (const (value, ()))++modifySessionImpl ::+    MonadIO m+    => V.Key SessionId+    -> SessionStoreInstance (Session conn sess st)+    -> SessionCfg conn sess st+    -> SessionIf m+    -> (sess -> (sess, a))+    -> m a+modifySessionImpl vK sessionRef cfg sif f =+    do let modFun session =+               let (sessData', out) = f (sess_data session)+               in (session { sess_data = sessData' }, out)+       modifySessionBase vK sessionRef cfg sif modFun++makeSessionIdCookie :: SessionCfg conn sess st -> Session conn sess st -> UTCTime -> BS.ByteString+makeSessionIdCookie cfg sess now =+    generateCookieHeaderString name value settings now+    where+      name = sc_cookieName cfg+      value = sess_id sess+      settings =+          defaultCookieSettings+          { cs_EOL = sc_cookieEOL cfg+          , cs_HTTPOnly = True+          }++readOrNewSession ::+    MonadIO m+    => SessionCfg conn sess st+    -> V.Key SessionId+    -> SessionIf m+    -> Maybe SessionId+    -> m (Session conn sess st)+readOrNewSession cfg vK sif mSid =+    do (sess, write) <- loadOrSpanSession cfg mSid+       when write $+           do now <- liftIO getCurrentTime+              si_setRawMultiHeader sif MultiHeaderSetCookie (makeSessionIdCookie cfg sess now)+              si_modifyVault sif $ V.insert vK (sess_id sess)+       return sess++loadOrSpanSession ::+    MonadIO m+    => SessionCfg conn sess st+    -> Maybe SessionId+    -> m (Session conn sess st, Bool)+loadOrSpanSession cfg mSid =+    do mSess <-+           liftIO $+           join <$> T.mapM (loadSessionImpl cfg sessionRef) mSid+       case mSess of+         Nothing ->+             do newSess <-+                    liftIO $+                    newSessionImpl cfg sessionRef (sc_emptySession cfg)+                return (newSess, True)+         Just s -> return (s, False)+    where+        sessionRef = sc_store cfg++sessionMiddleware ::+    SessionCfg conn sess st+    -> V.Key SessionId+    -> Wai.Middleware+sessionMiddleware cfg vK app req respond =+    go $ getCookieFromReq (sc_cookieName cfg)+    where+      go mSid =+          do (sess, shouldWriteCookie) <- loadOrSpanSession cfg mSid+             withSess shouldWriteCookie sess+      getCookieFromReq name =+          lookup "cookie" (Wai.requestHeaders req) >>= lookup name . parseCookies+      v = Wai.vault req+      addCookie sess now responseHeaders =+          let cookieContent = makeSessionIdCookie cfg sess now+              cookieC = ("Set-Cookie", cookieContent)+          in (cookieC : responseHeaders)+      withSess shouldSetCookie sess =+          app (req { Wai.vault = V.insert vK (sess_id sess) v }) $ \unwrappedResp ->+              do now <- getCurrentTime+                 respond $+                   if shouldSetCookie+                   then mapReqHeaders (addCookie sess now) unwrappedResp+                   else unwrappedResp++newSessionImpl ::+    SessionCfg conn sess st+    -> SessionStoreInstance (Session conn sess st)+    -> sess+    -> IO (Session conn sess st)+newSessionImpl sessCfg (SessionStoreInstance sessionRef) content =+    do sess <- createSession sessCfg content+       ss_runTx sessionRef $ ss_storeSession sessionRef sess+       return $! sess++loadSessionImpl ::+    SessionCfg conn sess st+    -> SessionStoreInstance (Session conn sess st)+    -> SessionId+    -> IO (Maybe (Session conn sess st))+loadSessionImpl sessCfg sessionRef@(SessionStoreInstance store) sid =+    do mSess <- ss_runTx store $ ss_loadSession store sid+       now <- getCurrentTime+       case mSess of+         Just sess ->+             do sessWithPossibleExpansion <-+                    if sc_sessionExpandTTL sessCfg+                    then do let expandedSession =+                                    sess+                                    { sess_validUntil =+                                          addUTCTime (sc_sessionTTL sessCfg) now+                                    }+                            ss_runTx store $ ss_storeSession store expandedSession+                            return expandedSession+                    else return sess+                if sess_validUntil sessWithPossibleExpansion > now+                then return $ Just sessWithPossibleExpansion+                else do deleteSessionImpl sessionRef sid+                        return Nothing+         Nothing ->+             return Nothing++deleteSessionImpl ::+    SessionStoreInstance (Session conn sess st)+    -> SessionId+    -> IO ()+deleteSessionImpl (SessionStoreInstance sessionRef) sid =+    ss_runTx sessionRef $ ss_deleteSession sessionRef sid++clearAllSessionsImpl ::+    MonadIO m+    => SessionStoreInstance (Session conn sess st)+    -> m ()+clearAllSessionsImpl (SessionStoreInstance sessionRef) =+    liftIO $ ss_runTx sessionRef $ ss_filterSessions sessionRef (const False)++mapAllSessionsImpl ::+    MonadIO m+    => SessionStoreInstance (Session conn sess st)+    -> (forall n. Monad n => sess -> n sess)+    -> m ()+mapAllSessionsImpl (SessionStoreInstance sessionRef) f =+    liftIO $ ss_runTx sessionRef $ ss_mapSessions sessionRef $ \sess ->+        do newData <- f (sess_data sess)+           return $ sess { sess_data = newData }++housekeepSessions :: SessionCfg conn sess st -> IO ()+housekeepSessions cfg =+    case sc_store cfg of+      SessionStoreInstance store ->+       do now <- getCurrentTime+          (newStatus, oldStatus) <-+            ss_runTx store $+            do oldSt <- ss_toList store+               ss_filterSessions store (\sess -> sess_validUntil sess > now)+               (,) <$> ss_toList store <*> pure oldSt+          let packSessionHm = HM.fromList . map (\v -> (sess_id v, v))+              oldHm = packSessionHm oldStatus+              newHm = packSessionHm newStatus+          sh_removed (sc_hooks cfg) (HM.map sess_data $ oldHm `HM.difference` newHm)+          threadDelay (1000 * 1000 * (round $ sc_housekeepingInterval cfg))++createSession :: SessionCfg conn sess st -> sess -> IO (Session conn sess st)+createSession sessCfg content =+    do sid <- randomHash (sc_sessionIdEntropy sessCfg)+       csrfToken <- randomHash 12+       now <- getCurrentTime+       let validUntil = addUTCTime (sc_sessionTTL sessCfg) now+       return (Session sid csrfToken validUntil content)++randomHash :: Int -> IO T.Text+randomHash len =+    do by <- CR.getRandomBytes len+       return $ T.replace "=" "" $ T.replace "/" "_" $ T.replace "+" "-" $+              T.decodeUtf8 $ B64.encode by
+ src/Web/Spock/Internal/SessionVault.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+module Web.Spock.Internal.SessionVault where++import Web.Spock.Internal.Types++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif+import Control.Concurrent.STM (STM, atomically)+import Control.Monad+import Data.Hashable+import Focus as F+import qualified ListT as L+import qualified StmContainers.Map as STMMap+import qualified Data.Text as T++class (Eq (SessionKey s), Hashable (SessionKey s)) => IsSession s where+    type SessionKey s :: *+    getSessionKey :: s -> SessionKey s++instance IsSession (Session conn sess st) where+    type SessionKey (Session conn sess st) = T.Text+    getSessionKey = sess_id++newtype SessionVault s+    = SessionVault { unSessionVault :: STMMap.Map (SessionKey s) s }++-- | Create a new session vault+newSessionVault :: STM (SessionVault s)+newSessionVault = SessionVault <$> STMMap.new++-- | Load a session+loadSession :: IsSession s => SessionKey s -> SessionVault s -> STM (Maybe s)+loadSession key (SessionVault smap) = STMMap.lookup key smap++-- | Store a session, overwriting any previous values+storeSession :: IsSession s => s -> SessionVault s -> STM ()+storeSession v (SessionVault smap) = STMMap.insert v (getSessionKey v) smap++-- | Removea session+deleteSession :: IsSession s => SessionKey s -> SessionVault s -> STM ()+deleteSession k (SessionVault smap) = STMMap.delete k smap++-- | Get all sessions as list+toList :: SessionVault s -> STM [s]+toList =  liftM (map snd) . L.toList . STMMap.listT . unSessionVault++-- | Remove all sessions that do not match the predicate+filterSessions :: IsSession s => (s -> Bool) -> SessionVault s -> STM ()+filterSessions cond sv =+    do allVals <- toList sv+       let deleteKeys =+               map getSessionKey $+               filter (not . cond) allVals+       forM_ deleteKeys $ flip deleteSession sv++-- | Perform action on all sessions+mapSessions :: IsSession s => (s -> STM s) -> SessionVault s -> STM ()+mapSessions f sv@(SessionVault smap) =+    do allVals <- toList sv+       forM_ allVals $ \sess ->+           STMMap.focus (F.adjustM f) (getSessionKey sess) smap++newStmSessionStore' :: IO (SessionStore (Session conn sess st) STM)+newStmSessionStore' =+  do vault <- atomically newSessionVault+     return $+         SessionStore+         { ss_runTx = atomically+         , ss_loadSession = flip loadSession vault+         , ss_deleteSession = flip deleteSession vault+         , ss_storeSession = flip storeSession vault+         , ss_toList = toList vault+         , ss_filterSessions = flip filterSessions vault+         , ss_mapSessions = flip mapSessions vault+         }++newStmSessionStore :: IO (SessionStoreInstance (Session conn sess st))+newStmSessionStore = SessionStoreInstance <$> newStmSessionStore'
+ src/Web/Spock/Internal/Types.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}+module Web.Spock.Internal.Types where++import Web.Spock.Core++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif+import Control.Monad.Base+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import Data.Pool+import Data.Time.Clock ( UTCTime(..), NominalDiffTime )+import Data.Word+import Network.HTTP.Types.Status+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 conn sess st a = SpockT (WebStateM conn sess st) a++-- | 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, use 'defaultSpockCfg' and change single values if needed+data SpockCfg conn sess st+   = SpockCfg+   { spc_initialState :: st+     -- ^ initial application global state+   , spc_database :: PoolOrConn conn+     -- ^ See 'PoolOrConn'+   , spc_sessionCfg :: SessionCfg conn sess st+     -- ^ See 'SessionCfg'+   , spc_maxRequestSize :: Maybe Word64+     -- ^ Maximum request size in bytes. 'Nothing' means no limit. Defaults to 5 MB in @defaultSpockCfg@.+   , spc_errorHandler :: Status -> ActionCtxT () IO ()+     -- ^ Custom error handlers for implicit errors such as not matching routes or+     -- exceptions during a request handler run.+   , spc_logError :: T.Text -> IO ()+     -- ^ Function that should be called to log errors.+   , spc_csrfProtection :: Bool+     -- ^ When set to true, all non GET request will require+     -- either an HTTP-Header 'spc_csrfHeaderName' or a+     -- POST-Parameter 'spc_csrfPostName' to be set to the value aquired by 'getCsrfToken'+   , spc_csrfHeaderName :: T.Text+     -- ^ see 'spc_csrfHeaderName'+   , spc_csrfPostName :: T.Text+     -- ^ see 'spc_csrfPostName'+   }++-- | 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 where+    PCPool :: Pool a -> PoolOrConn a+    PCConn :: ConnBuilder a -> PoolOrConn a+    PCNoDatabase :: PoolOrConn ()++-- | Configuration for the session manager+data SessionCfg conn a st+   = SessionCfg+   { sc_cookieName :: T.Text+     -- ^ name of the client side cookie+   , sc_cookieEOL :: CookieEOL+     -- ^ how long the client side cookie should live+   , sc_sessionTTL :: NominalDiffTime+     -- ^ how long shoud a client session live+   , sc_sessionIdEntropy :: Int+     -- ^ entropy of the session id sent to the client+   , sc_sessionExpandTTL :: Bool+     -- ^ if this is true, every page reload will renew the session time to live counter+   , sc_emptySession :: a+     -- ^ initial session for visitors+   , sc_store :: SessionStoreInstance (Session conn a st)+     -- ^ storage 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+   }++-- | Hook into the session manager to trigger custom behavior+data SessionHooks a+   = SessionHooks+   { sh_removed :: HM.HashMap SessionId a -> IO ()+   }++data WebState conn sess st+   = WebState+   { web_dbConn :: Pool conn+   , web_sessionMgr :: SpockSessionManager conn sess st+   , web_state :: st+   , web_config :: SpockCfg conn sess 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 (SpockSessionManager (SpockConn m) (SpockSession m) (SpockState m))+    -- | Get the Spock configuration+    getSpockCfg :: m (SpockCfg (SpockConn m) (SpockSession m) (SpockState m))++newtype WebStateT conn sess st m a+    = WebStateT { runWebStateT :: ReaderT (WebState conn sess st) m a }+    deriving ( Monad, Functor, Applicative, MonadIO+             , MonadReader (WebState conn sess st)+             , MonadTrans+             )++instance MonadBase b m => MonadBase b (WebStateT conn sess st m) where+    liftBase = liftBaseDefault++instance MonadTransControl (WebStateT conn sess st) where+    type StT (WebStateT conn sess st) a = a+    liftWith = defaultLiftWith WebStateT runWebStateT+    restoreT = defaultRestoreT WebStateT++instance MonadBaseControl b m => MonadBaseControl b (WebStateT conn sess st m) where+    type StM (WebStateT conn sess st m) a = ComposeSt (WebStateT conn sess st) m a+    restoreM = defaultRestoreM+    liftBaseWith = defaultLiftBaseWith++type WebStateM conn sess st = WebStateT conn sess st (ResourceT IO)++type SessionId = T.Text+data Session conn sess st+    = Session+    { sess_id :: !SessionId+    , sess_csrfToken :: !T.Text+    , sess_validUntil :: !UTCTime+    , sess_data :: !sess+    }++data SessionStoreInstance sess where+    SessionStoreInstance :: forall sess tx. (Monad tx, Functor tx, Applicative tx) => SessionStore sess tx -> SessionStoreInstance sess++data SessionStore sess tx+   = SessionStore+   { ss_runTx :: forall a. tx a -> IO a+   , ss_loadSession :: SessionId -> tx (Maybe sess)+   , ss_deleteSession :: SessionId -> tx ()+   , ss_storeSession :: sess -> tx ()+   , ss_toList :: tx [sess]+   , ss_filterSessions :: (sess -> Bool) -> tx ()+   , ss_mapSessions :: (sess -> tx sess) -> tx ()+   }++instance Show (Session conn sess st) where+    show = show . sess_id++type SpockSessionManager conn sess st = SessionManager (SpockActionCtx () conn sess st) conn sess st++data SessionManager m conn sess st+   = SessionManager+   { sm_getSessionId :: m SessionId+   , sm_getCsrfToken :: m T.Text+   , sm_regenerateSessionId :: m ()+   , sm_readSession :: m sess+   , sm_writeSession :: sess -> m ()+   , sm_modifySession :: forall a. (sess -> (sess, a)) -> m a+   , sm_mapSessions :: (forall n. Monad n => sess -> n sess) -> m ()+   , sm_clearAllSessions :: MonadIO m => m ()+   , sm_middleware :: Middleware+   , sm_closeSessionManager :: IO ()+   }
− src/Web/Spock/Monad.hs 
@@ -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
− src/Web/Spock/Routing.hs 
@@ -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))
− src/Web/Spock/SafeActions.hs 
@@ -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 <a href='" <> deleteUrl <> "'>here</a> 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
+ src/Web/Spock/SessionActions.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Spock.SessionActions+    ( SessionId+    , sessionRegenerateId, getSessionId, readSession, writeSession+    , modifySession, modifySession', modifyReadSession, mapAllSessions, clearAllSessions+    )+where++import Web.Spock.Action+import Web.Spock.Internal.Monad ()+import Web.Spock.Internal.SessionManager+import Web.Spock.Internal.Types++-- | Regenerate the users sessionId. This preserves all stored data. Call this prior+-- to logging in a user to prevent session fixation attacks.+sessionRegenerateId :: SpockActionCtx ctx conn sess st ()+sessionRegenerateId =+    runInContext () $+    getSessMgr >>= sm_regenerateSessionId++-- | Get the current users sessionId. Note that this ID should only be+-- shown to it's owner as otherwise sessions can be hijacked.+getSessionId :: SpockActionCtx ctx conn sess st SessionId+getSessionId =+    runInContext () $+    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 :: forall sess ctx conn st. sess -> SpockActionCtx ctx conn sess st ()+writeSession d =+    do mgr <- getSessMgr+       runInContext () $ sm_writeSession mgr d++-- | Modify the stored session+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)) -> SpockActionCtx ctx conn sess st a+modifySession' f =+    do mgr <- getSessMgr+       runInContext () $ sm_modifySession mgr f++-- | Modify the stored session and return the new value after modification+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 :: SpockActionCtx ctx conn sess st sess+readSession =+    runInContext () $+    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 :: SpockActionCtx ctx conn sess st ()+clearAllSessions =+    do mgr <- getSessMgr+       runInContext () $ sm_clearAllSessions mgr++-- | Apply a transformation to all sessions. Be careful with this, as this+-- may cause many STM transaction retries.+mapAllSessions :: (forall m. Monad m => sess -> m sess) -> SpockActionCtx ctx conn sess st ()+mapAllSessions f =+    do mgr <- getSessMgr+       runInContext () $ sm_mapSessions mgr f
− src/Web/Spock/SessionManager.hs 
@@ -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
− src/Web/Spock/Types.hs 
@@ -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 ()-   }
− src/Web/Spock/Util.hs 
@@ -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)
− src/Web/Spock/Wire.hs 
@@ -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 [ "<html><head><title>"-                   , e-                   , "</title></head><body><h1>"-                   , e-                   , "</h1></body></html>"-                   ]-    }--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
test/Spec.hs view
@@ -1,1 +1,15 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+module Main where++import qualified Web.Spock.CsrfSpec+import qualified Web.Spock.Internal.SessionManagerSpec+import qualified Web.Spock.Internal.SessionVaultSpec+import qualified Web.Spock.SafeSpec++import Test.Hspec++main :: IO ()+main = hspec $+    do Web.Spock.Internal.SessionVaultSpec.spec+       Web.Spock.Internal.SessionManagerSpec.spec+       Web.Spock.SafeSpec.spec+       Web.Spock.CsrfSpec.spec
+ test/Web/Spock/CsrfSpec.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE CPP #-}+module Web.Spock.CsrfSpec (spec) where++import Web.Spock.TestUtils++import Web.Spock+import Web.Spock.Config++#if MIN_VERSION_base(4,11,0)+#else+import Data.Monoid+#endif+import Test.Hspec+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text.Encoding as T+import qualified Network.Wai as Wai+import qualified Network.Wai.Test as Test hiding (request)+import qualified Test.Hspec.Wai as Test++spec :: Spec+spec =+    describe "Csrf" $+    do Test.with (testApp False) $ it "should not step in if turned of" $+          Test.post "/token" "" `Test.shouldRespondWith` 200+       Test.with (testApp True) $ it "should not require tokens on GET requests" $+          Test.get "/no-token" `Test.shouldRespondWith` "ok" { Test.matchStatus = 200 }+       Test.with (testApp True) $ it "should require tokens on POST requests" $+          Test.post "/token" "" `Test.shouldRespondWith` 403+       Test.with (testApp True) $ it "should requect invalid tokens on POST requests" $+          do Test.post "/token" "__csrf_token=foobarbaz" `Test.shouldRespondWith` 403+             Test.request "POST" "/token" [("X-Csrf-Token", "abc")] ""+                 `Test.shouldRespondWith` 403+       Test.with (testApp True) $ it "should accept valid tokens" $+          do resp <- Test.get "/my-token"+             let Just sessCookie = getSessCookie resp+                 tok = Test.simpleBody resp+                 cc =+                     [ ("Cookie", T.encodeUtf8 $ "spockcookie=" <> sessCookie)+                     , ("X-Csrf-Token", BSL.toStrict tok)+                     ]+                 postCC =+                     ( ("Content-Type", "application/x-www-form-urlencoded")+                     : cc+                     )+                 postPayload =+                     "__csrf_token=" <> tok+             Test.request "POST" "/token" cc "" `Test.shouldRespondWith` 200+             Test.request "POST" "/token" postCC postPayload `Test.shouldRespondWith` 200++testApp :: Bool -> IO Wai.Application+testApp protect =+    spockAsApp $+    spockCfg protect >>= \cfg ->+    spock cfg $+    do get "no-token" $ text "ok"+       get "my-token" $ getCsrfToken >>= text+       post "token" $ text "ok"++spockCfg :: Bool -> IO (SpockCfg () Int Bool)+spockCfg protect =+    do cfg <- defaultSpockCfg (0 :: Int) PCNoDatabase True+       return cfg+             { spc_csrfProtection = protect+             }
+ test/Web/Spock/Internal/SessionManagerSpec.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.Internal.SessionManagerSpec (spec) where++import Web.Spock.Config+import Web.Spock.Internal.SessionManager+import Web.Spock.Internal.SessionVault++import Control.Concurrent.STM+import Data.IORef+import Data.Time+import Test.Hspec+import qualified Data.Vault.Lazy as V++spec :: Spec+spec =+    describe "Session Manager" $+    do it "should return the correct csrf token" $+           do mgr <- mkMgr+              sm_getCsrfToken mgr `shouldReturn` "fake-token"+       it "should not loose data on session id regeneration" $+           do mgr <- mkMgr+              sm_writeSession mgr True+              sm_regenerateSessionId mgr+              sm_readSession mgr `shouldReturn` True+       it "should modify session correctly" $+           do mgr <- mkMgr+              x <- sm_modifySession mgr (const (True, True))+              x `shouldBe` True+              sm_readSession mgr `shouldReturn` True+       it "should remember session content" $+           do mgr <- mkMgr+              sm_writeSession mgr True+              sm_readSession mgr `shouldReturn` True+       it "writing to the session after clearing all should not crash" $+           do mgr <- mkMgr+              sm_writeSession mgr True+              sm_clearAllSessions mgr+              sm_writeSession mgr True+       it "should be possible to map over all sessions" $+           do mgr <- mkMgr+              sm_writeSession mgr True+              sm_readSession mgr `shouldReturn` True+              sm_mapSessions mgr (const $ return False)+              sm_readSession mgr `shouldReturn` False++mkMgr :: IO (SessionManager IO conn Bool st)+mkMgr =+    do sessionCfg <- defaultSessionCfg False+       sv <- newStmSessionStore'+       let testSession =+               Session+               { sess_id = "fake-sid"+               , sess_csrfToken = "fake-token"+               , sess_validUntil = UTCTime (fromGregorian 2030 1 1) 0+               , sess_data = False+               }+       atomically $+           ss_storeSession sv testSession+       let sessionCfg' = sessionCfg { sc_store = SessionStoreInstance sv }+       k <- V.newKey+       sessionVaultR <- newIORef $ V.insert k (sess_id testSession) V.empty+       mgr <-+           createSessionManager sessionCfg' $+           SessionIf+           { si_queryVault =+                   \key ->+                   do vault <- readIORef sessionVaultR+                      return $ V.lookup key vault+           , si_modifyVault = modifyIORef sessionVaultR+           , si_setRawMultiHeader = \_ _ -> return ()+           , si_vaultKey = return k+           }+       return mgr
+ test/Web/Spock/Internal/SessionVaultSpec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+module Web.Spock.Internal.SessionVaultSpec (spec) where++import Web.Spock.Internal.SessionVault++import Control.Concurrent.STM+import Test.Hspec++data DummySession+    = DummySession+      { ds_key :: Int+      , ds_value :: Int+      } deriving (Show, Eq)++instance IsSession DummySession where+    type SessionKey DummySession = Int+    getSessionKey = ds_key++spec :: Spec+spec =+     describe "SessionVault" $+     do it "insert works correctly" $+           do let sess = DummySession 1 1+              vault <- atomically newSessionVault+              atomically $ storeSession sess vault+              atomically (loadSession (ds_key sess) vault) `shouldReturn` Just sess+        it "update works correctly" $+           do let sess = DummySession 1 1+                  sess2 = DummySession 1 2+              vault <- atomically newSessionVault+              atomically $ storeSession sess vault+              atomically (loadSession (ds_key sess) vault) `shouldReturn` Just sess+              atomically $ storeSession sess2 vault+              atomically (loadSession (ds_key sess) vault) `shouldReturn` Just sess2+        it "filter and toList works correctly" $+           do let sess = DummySession 1 1+                  sess2 = DummySession 2 2+                  sess3 = DummySession 3 3+              vault <- atomically newSessionVault+              atomically $ mapM_ (`storeSession` vault) [sess, sess2, sess3]+              atomically (toList vault) `shouldReturn` [sess, sess2, sess3]+              atomically $ filterSessions (\s -> ds_value s > 2) vault+              atomically (toList vault) `shouldReturn` [sess3]
− test/Web/Spock/RoutingSpec.hs 
@@ -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}]}]}
+ test/Web/Spock/SafeSpec.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE CPP #-}+module Web.Spock.SafeSpec (spec) where++import Web.Spock.TestUtils++import Web.Spock+import Web.Spock.Config++import Control.Monad+import Data.IORef+#if MIN_VERSION_base(4,11,0)+#else+import Data.Monoid+#endif+import Test.Hspec+import qualified Data.ByteString.Lazy.Char8 as BSLC+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+import qualified Test.Hspec.Wai.Internal as Test++sessionSpec :: Spec+sessionSpec =+    describe "SessionManager" $+    do Test.with sessionApp $+          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 Test.WaiSession (Wai.deleteClientCookie "spockcookie")+                   res <- Test.get "/test"+                   Test.liftIO $ checkCookie ids res `shouldReturn` True+       Test.with sessionApp $+          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 $ "spockcookie=" <> sessCookie)] ""+                           `Test.shouldRespondWith` "5"+       Test.with sessionApp $+           it "should update internal session id correctly" $+           do bdy <- fmap Wai.simpleBody (Test.get "/regenerate-different-sids")+              case BSLC.split '|' bdy of+                [a, b] | a /= b -> pure ()+                xs -> Test.liftIO $ expectationFailure ("Bad result: " ++ show xs)+       Test.with sessionApp $+          it "should regenerate and preserve all content" $+          do res <- Test.get "/set/5"+             case getSessCookie res of+               Nothing ->+                   Test.liftIO $ expectationFailure "Missing spockcookie"+               Just sessCookie ->+                   do res2 <- Test.request "GET" "/regenerate" [("Cookie", T.encodeUtf8 $ "spockcookie=" <> sessCookie)] ""+                      case getSessCookie res2 of+                        Nothing ->+                            Test.liftIO $ expectationFailure "Missing new spockcookie"+                        Just sessCookie2 ->+                            do Test.request "GET" "/check" [("Cookie", T.encodeUtf8 $ "spockcookie=" <> sessCookie2)] ""+                                       `Test.shouldRespondWith` "5"+                               Test.request "GET" "/check" [("Cookie", T.encodeUtf8 $ "spockcookie=" <> sessCookie)] ""+                                       `Test.shouldRespondWith` "0"+    where+      sessionApp =+          spockAsApp $+          spockCfg >>= \cfg ->+          spock cfg $+          do get "test" $ getSessionId >>= text+             get ("set" <//> var) $ \number -> writeSession number >> text "done"+             get "regenerate" $ sessionRegenerateId >> text "done"+             get "regenerate-different-sids" $+                 do s1 <- getSessionId+                    sessionRegenerateId+                    s2 <- getSessionId+                    text $ s1 <> "|" <> s2+             get "check" $+                 do val <- readSession+                    text (T.pack $ show val)+      spockCfg =+          defaultSpockCfg (0 :: Int) PCNoDatabase True++      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 sessionId ->+                   do set <- readIORef setRef+                      if HS.member sessionId set+                          then fail $ "Reused " ++ show sessionId ++ " (" ++ show set ++ ")"+                          else do writeIORef setRef $ HS.insert sessionId set+                                  return True++spec :: Spec+spec =+    describe "SafeRouting" $ sessionSpec
+ test/Web/Spock/TestUtils.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.TestUtils where++import Web.Spock.Internal.Cookies++import Data.List (find)+import qualified Data.Text as T+import qualified Network.Wai.Test as Wai++getSessCookie :: Wai.SResponse -> Maybe T.Text+getSessCookie resp =+    let headers = Wai.simpleHeaders resp+    in lookup "spockcookie" $+       maybe [] (parseCookies . snd) $+       find (\h -> fst h == "Set-Cookie") headers
− test/Web/Spock/WireSpec.hs 
@@ -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"