Spock 0.10.0.1 → 0.11.0.0

raw patch · 26 files changed

+914/−2485 lines, 26 filesdep +Spock-coredep +cryptonitedep −aesondep −case-insensitivedep −crypto-randomdep ~http-typesdep ~hvectdep ~reroutePVP ok

version bump matches the API change (PVP)

Dependencies added: Spock-core, cryptonite

Dependencies removed: aeson, case-insensitive, crypto-random, directory, old-locale, path-pieces, random, warp

Dependency ranges changed: http-types, hvect, reroute, vault, wai-extra

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• README.md +26/−9
• Spock.cabal +22/−37
• src/Web/Spock.hs +224/−6
• src/Web/Spock/Config.hs +83/−0
• src/Web/Spock/Internal/Cookies.hs +0/−127
• src/Web/Spock/Internal/Core.hs +0/−82
• src/Web/Spock/Internal/CoreAction.hs +0/−386
• src/Web/Spock/Internal/Monad.hs +17/−5
• src/Web/Spock/Internal/SessionManager.hs +209/−234
• src/Web/Spock/Internal/SessionVault.hs +20/−3
• src/Web/Spock/Internal/Types.hs +56/−86
• src/Web/Spock/Internal/Util.hs +0/−47
• src/Web/Spock/Internal/Wire.hs +0/−411
• src/Web/Spock/Safe.hs +0/−242
• src/Web/Spock/SessionActions.hs +78/−0
• src/Web/Spock/Shared.hs +0/−143
• src/Web/Spock/Simple.hs +0/−208
• test/Web/Spock/CsrfSpec.hs +63/−0
• test/Web/Spock/FrameworkSpecHelper.hs +0/−152
• test/Web/Spock/Internal/CookiesSpec.hs +0/−93
• test/Web/Spock/Internal/SessionManagerSpec.hs +73/−0
• test/Web/Spock/Internal/UtilSpec.hs +0/−26
• test/Web/Spock/SafeSpec.hs +27/−119
• test/Web/Spock/SimpleSpec.hs +0/−68
• test/Web/Spock/TestUtils.hs +15/−0

@@ -1,4 +1,4 @@-Copyright (c) 2013 - 2015, Alexander Thiemann <mail@agrafix.net>+Copyright (c) 2013 - 2016, Alexander Thiemann <mail@athiemann.net>  All rights reserved. 

@@ -27,8 +27,6 @@  ``` -For more examples check the examples/ directory.- ## Install  * Using cabal: `cabal install Spock`@@ -36,12 +34,16 @@ * From Source (cabal): `git clone https://github.com/agrafix/Spock.git && cd Spock && cabal install` * From Source (stack): `git clone https://github.com/agrafix/Spock.git && cd Spock && stack build` +## Mailing list++Please join our mailing list at haskell-spock@googlegroups.com+ ## Features  Another Haskell web framework for rapid development: This toolbox provides everything you need to get a quick start into web hacking with haskell: -* fast routing (both typesafe and "untyped")+* fast typesafe routing * middleware * json * sessions@@ -53,11 +55,12 @@ ## Important Links  * [Tutorial](https://www.spock.li/tutorial/)-* [Type-safe routing in Spock](https://www.spock.li/2015/04/19/type-safe_routing.html) +* [Type-safe routing in Spock](https://www.spock.li/2015/04/19/type-safe_routing.html) * [Taking Authentication to the next Level](https://www.spock.li/2015/08/23/taking_authentication_to_the_next_level.html)  ### Talks +* English: [Spock - Powerful Elegent Web Applications using Haskell](https://www.youtube.com/watch?v=kNqsOBrCbLo) (by Alexander Thiemann) * English: [Beginning Web Programming in Haskell (using Spock)](https://www.youtube.com/watch?v=GobPiGL9jJ4) (by Ollie Charles) * German: [Moderne typsichere Web-Entwicklung mit Haskell](https://dl.dropboxusercontent.com/u/15078797/talks/typesafe-webdev-2015.pdf) (by Alexander Thiemann) * German: [reroute-talk](https://github.com/timjb/reroute-talk) (by Tim Baumann)@@ -78,12 +81,24 @@ * Blaze bootstrap helpers [blaze-bootstrap](http://hackage.haskell.org/package/blaze-bootstrap) * digestive-forms bootstrap helpers [digestive-bootstrap](http://hackage.haskell.org/package/digestive-bootstrap) +### SSL / HTTPS++If you'd like to use your application via HTTPS, there are two options:++* Use nginx/haproxy/... as reverse proxy in front of the Spock application.+* Convert the Spock application to a `wai`-application using the `spockAsApp`. Then use the `warp-tls` package to run it.+ ### Benchmarks -Please note that these benchmarks might not be up to date anymore.+See the [Spock-bench repository](https://github.com/agrafix/Spock-bench) to reproduce. -* https://github.com/philopon/apiary-benchmark-* https://github.com/agrafix/Spock-scotty-benchmark+| Framework | GHC    | Version  | simple route              | route with one param      | deeply nested route |+|-----------|--------|----------|---------------------------|---------------------------|---------------------|+| Spock     | 7.10.2 | 0.11.0.0 | **69243**                 | **65835**                 | **64763**           |+| scotty    | 7.10.2 | 0.10.2   | 66441                     | 65357                     | 9542                |+| snap      | 7.10.2 | 0.9.8.0  | 39964                     | 35566                     | 38356               |+| fn        | 7.10.2 | 0.2.0.2  | 63083                     | 63183                     | 22346               |+| servant   | 7.10.2 | 0.7      | 66041                     | 65590                     | 64606               |  ## Example Projects @@ -93,6 +108,8 @@  ## Notes +Since version 0.11.0.0 Spock drops simple routing in favor of typesafe routing and drops safe actions in favor of the "usual" way of csrf protection with a token.+ Since version 0.7.0.0 Spock supports typesafe routing. If you wish to continue using the untyped version of Spock you can Use `Web.Spock.Simple`. The implementation of the routing is implemented in a separate haskell package called `reroute`.  Since version 0.5.0.0 Spock is no longer built on top of scotty. The@@ -114,11 +131,11 @@  ### Supported GHC Versions -* 7.6.3 * 7.8.4 * 7.10.2+* 8.0  ### License  Released under the BSD3 license.-(c) 2013 - 2015 Alexander Thiemann+(c) 2013 - 2016 Alexander Thiemann

@@ -1,5 +1,5 @@ name:                Spock-version:             0.10.0.1+version:             0.11.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:                      .@@ -18,17 +18,17 @@                      * csrf-protection                      .                      A tutorial is available at <http://www.spock.li/tutorial/ spock.li>-Homepage:            http://www.spock.li+Homepage:            https://www.spock.li Bug-reports:         https://github.com/agrafix/Spock/issues license:             BSD3 license-file:        LICENSE author:              Alexander Thiemann <mail@athiemann.net> maintainer:          Alexander Thiemann <mail@athiemann.net>-copyright:           (c) 2013 - 2015 Alexander Thiemann+copyright:           (c) 2013 - 2016 Alexander Thiemann category:            Web build-type:          Simple cabal-version:       >=1.8-tested-with:         GHC==7.6.3, GHC==7.8.4, GHC==7.10.2+tested-with:         GHC==7.8.4, GHC==7.10.2, GHC==8.0.1  extra-source-files:     README.md@@ -36,39 +36,28 @@ library   hs-source-dirs:      src   exposed-modules:-                       Web.Spock,-                       Web.Spock.Internal.Cookies,-                       Web.Spock.Internal.Util,-                       Web.Spock.Internal.SessionVault,-                       Web.Spock.Safe,-                       Web.Spock.Shared,-                       Web.Spock.Simple+                  Web.Spock,+                  Web.Spock.Config,+                  Web.Spock.SessionActions,+                  Web.Spock.Internal.SessionVault,+                  Web.Spock.Internal.SessionManager   other-modules:-                       Web.Spock.Internal.Core,-                       Web.Spock.Internal.CoreAction,-                       Web.Spock.Internal.Monad,-                       Web.Spock.Internal.SessionManager,-                       Web.Spock.Internal.Types,-                       Web.Spock.Internal.Wire+                Web.Spock.Internal.Monad,+                Web.Spock.Internal.Types   build-depends:-                       aeson >= 0.7,+                       Spock-core >= 0.11,                        base >= 4 && < 5,                        base64-bytestring >=1.0,                        bytestring >=0.10,-                       case-insensitive >=1.1,                        containers >=0.5,-                       crypto-random >= 0.0.8,-                       directory >=1.2,+                       cryptonite >= 0.6,                        focus >=0.1,                        hashable >=1.2,+                       hvect >=0.3,                        http-types >=0.8,-                       hvect >= 0.2,                        list-t >=0.4,                        monad-control >=1.0,                        mtl >=2.1,-                       old-locale >=1.0,-                       path-pieces >=0.1.4,-                       random >=1.0,                        reroute >=0.3.1,                        resource-pool >=0.2,                        resourcet >= 0.4,@@ -80,9 +69,7 @@                        transformers-base >=0.4,                        unordered-containers >=0.2,                        vault >=0.3,-                       wai >=3.0,-                       wai-extra >=3.0,-                       warp >=3.0+                       wai >=3.0   ghc-options: -auto-all -Wall -fno-warn-orphans  test-suite spocktests@@ -90,25 +77,23 @@   hs-source-dirs:      test   main-is:             Spec.hs   other-modules:-                       Web.Spock.FrameworkSpecHelper,-                       Web.Spock.Internal.CookiesSpec,-                       Web.Spock.Internal.UtilSpec,-                       Web.Spock.Internal.SessionVaultSpec,-                       Web.Spock.SafeSpec,-                       Web.Spock.SimpleSpec+                Web.Spock.Internal.SessionVaultSpec,+                Web.Spock.Internal.SessionManagerSpec,+                Web.Spock.SafeSpec,+                Web.Spock.CsrfSpec,+                Web.Spock.TestUtils   build-depends:                        base,                        bytestring,-                       base64-bytestring >=1.0,                        hspec >= 2.0,                        hspec-wai >= 0.6,-                       http-types,                        Spock,+                       Spock-core,                        stm,-                       reroute,                        text,                        time,                        unordered-containers,+                       vault,                        wai,                        wai-extra 

@@ -1,10 +1,228 @@-{- |-This module reexports type safe routing aproach which should be the default for all Spock applications. To learn more about-the routing, read the corresponding blog post available at <http://www.spock.li/2015/04/19/type-safe_routing.html>--}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Web.Spock-    ( module Web.Spock.Safe+    ( -- * Lauching Spock+      runSpock, runSpockNoBanner, spockAsApp+      -- * Spock's route definition monad+    , spock, SpockM, SpockCtxM+      -- * Defining routes+    , Path, root, Var, var, static, (<//>)+      -- * Rendering routes+    , renderRoute+      -- * Hooking routes+    , subcomponent, prehook+    , RouteSpec+    , get, post, getpost, head, put, delete, patch, hookRoute+    , hookRouteCustom, hookAny, hookAnyCustom+    , C.StdMethod (..)+      -- * Adding Wai.Middleware+    , middleware+      -- * 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.Safe+import Web.Spock.Action+import Web.Spock.Core hiding+       ( hookRoute', hookAny'+       , get, post, getpost, head, put, delete, patch, hookRoute+       , hookRouteCustom, hookAny, hookAnyCustom+       )+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.Applicative+import Control.Monad.Reader+import Control.Monad.Trans.Resource+import Network.HTTP.Types.Status (status403)+import Data.Pool+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+++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.+-- 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 ->+                 let pc = cb_poolConfiguration cb+                 in createPool (cb_createConn cb) (cb_destroyConn cb)+                        (pc_stripes pc) (pc_keepOpenTime pc)+                        (pc_resPerStripe pc)+       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+               }+       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++-- | 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 #-}++-- | 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 #-}++-- | Check that the client sent a valid CSRF token. You should not need to call this+-- manually 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 #-}++type RouteSpec xs ps ctx conn sess st =+    Path xs ps -> HV.HVectElim xs (SpockActionCtx ctx conn sess st ()) -> SpockCtxM ctx conn sess st ()++-- | 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 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 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

@@ -0,0 +1,83 @@+{-# 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++import Data.Monoid+import Network.HTTP.Types.Status+import qualified Data.Text as T+import qualified Data.Text.Encoding 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_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_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

@@ -1,127 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-module Web.Spock.Internal.Cookies-    ( CookieSettings(..)-    , defaultCookieSettings-    , CookieEOL(..)-    , generateCookieHeaderString-    , parseCookies-    )-where--import Data.Maybe-import Data.Monoid ((<>))-import Data.Time-import qualified Data.ByteString.Char8 as BS-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Network.HTTP.Types.URI as URI (urlEncode, urlDecode)-#if MIN_VERSION_time(1,5,0)-#else-import System.Locale (defaultTimeLocale)-#endif---- | Cookie settings-data CookieSettings-   = CookieSettings-   { cs_EOL :: CookieEOL-     -- ^ cookie expiration setting, see 'CookieEOL'-   , cs_path :: Maybe BS.ByteString-     -- ^ a path for the cookie-   , cs_domain :: Maybe BS.ByteString-     -- ^ a domain for the cookie. 'Nothing' means no domain is set-   , cs_HTTPOnly :: Bool-     -- ^ whether the cookie should be set as HttpOnly-   , cs_secure :: Bool-     -- ^ whether the cookie should be marked secure (sent over HTTPS only)-   }---- | Setting cookie expiration-data CookieEOL-   = CookieValidUntil UTCTime-   -- ^ a point in time in UTC until the cookie is valid-   | CookieValidFor NominalDiffTime-   -- ^ a period (in seconds) for which the cookie is valid-   | CookieValidForSession-   -- ^ the cookie expires with the browser session---- | Default cookie settings, equals------ > CookieSettings--- >   { cs_EOL      = CookieValidForSession--- >   , cs_HTTPOnly = False--- >   , cs_secure   = False--- >   , cs_domain   = Nothing--- >   , cs_path     = Just "/"--- >   }----defaultCookieSettings :: CookieSettings-defaultCookieSettings =-    CookieSettings-    { cs_EOL      = CookieValidForSession-    , cs_HTTPOnly = False-    , cs_secure   = False-    , cs_domain   = Nothing-    , cs_path     = Just "/"-    }--generateCookieHeaderString ::-    T.Text-    -> T.Text-    -> CookieSettings-    -> UTCTime-    -> BS.ByteString-generateCookieHeaderString name value CookieSettings{..} now =-    BS.intercalate "; " fullCookie-    where-      fullCookie =-          catMaybes-          [ nv-          , domain-          , path-          , maxAge-          , expires-          , httpOnly-          , secure-          ]-      nv = Just $ BS.concat [T.encodeUtf8 name, "=", urlEncode value]-      path = flip fmap cs_path $ \p -> BS.concat ["path=", p]-      domain =-          flip fmap cs_domain $ \d ->-          BS.concat ["domain=", d]-      httpOnly = if cs_HTTPOnly then Just "HttpOnly" else Nothing-      secure = if cs_secure then Just "Secure" else Nothing--      maxAge =-          case cs_EOL of-            CookieValidForSession -> Nothing-            CookieValidFor n -> Just $ "max-age=" <> maxAgeValue n-            CookieValidUntil t -> Just $ "max-age=" <> maxAgeValue (diffUTCTime t now)--      expires =-          case cs_EOL of-            CookieValidForSession -> Nothing-            CookieValidFor n -> Just $ "expires=" <> expiresValue (addUTCTime n now)-            CookieValidUntil t -> Just $ "expires=" <> expiresValue t--      maxAgeValue :: NominalDiffTime -> BS.ByteString-      maxAgeValue nrOfSeconds =-          let v = round (max nrOfSeconds 0) :: Integer-          in  BS.pack (show v)--      expiresValue :: UTCTime -> BS.ByteString-      expiresValue t =-          BS.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" t--      urlEncode :: T.Text -> BS.ByteString-      urlEncode = URI.urlEncode True . T.encodeUtf8--parseCookies :: BS.ByteString -> [(T.Text, T.Text)]-parseCookies =-    map parseCookie . BS.split ';'-    where-      parseCookie :: BS.ByteString -> (T.Text, T.Text)-      parseCookie cstr =-          let (name, urlEncValue) = BS.break (== '=') cstr-          in  (T.strip $ T.decodeUtf8 name, T.decodeUtf8 . URI.urlDecode True . BS.drop 1 $ urlEncValue)

@@ -1,82 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-module Web.Spock.Internal.Core-    ( SpockAllT-    , spockAll-    , spockAllT-    , middleware-    , hookRoute-    , hookAny-    , subcomponent-    )-where--import Web.Spock.Internal.SessionManager-import Web.Spock.Internal.Types-import Web.Spock.Internal.Wire--#if MIN_VERSION_mtl(2,2,0)-import Control.Monad.Except-#else-import Control.Monad.Error-#endif-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Resource-import Data.Pool-import Data.Word-import Prelude hiding (head)-import Web.Routing.AbstractRouter-import qualified Network.Wai as Wai---- | Run a spock application using the warp server, a given db storageLayer and an initial state.--- Spock works with database libraries that already implement connection pooling and--- with those that don't come with it out of the box. For more see the 'PoolOrConn' type.-spockAll :: forall r conn sess st.-            ( AbstractRouter r-            , RouteAppliedAction r ~ ActionT (WebStateM conn sess st) ()-            )-         => r-         -> SpockCfg conn sess st-         -> SpockAllM r conn sess st ()-         -> IO Wai.Middleware-spockAll regIf spockCfg defs =-    do sessionMgr <- createSessionManager sessionCfg-       connectionPool <--           case poolOrConn of-             PCNoDatabase ->-                 createPool (return ()) (const $ return ()) 5 60 5-             PCPool p ->-                 return p-             PCConn cb ->-                 let pc = cb_poolConfiguration cb-                 in createPool (cb_createConn cb) (cb_destroyConn cb)-                        (pc_stripes pc) (pc_keepOpenTime pc)-                        (pc_resPerStripe pc)-       let internalState =-               WebState-               { web_dbConn = connectionPool-               , web_sessionMgr = sessionMgr-               , web_state = initialState-               }-       spockAllT (spc_maxRequestSize spockCfg) regIf (\m -> runResourceT $ runReaderT (runWebStateT m) internalState)  $-               do defs-                  middleware (sm_middleware sessionMgr)-    where-      sessionCfg = spc_sessionCfg spockCfg-      poolOrConn = spc_database spockCfg-      initialState = spc_initialState spockCfg---- | Run a raw spock server on a defined port. If you don't need--- a custom base monad you can just supply 'id' as lift function.-spockAllT :: (MonadIO m, AbstractRouter r, RouteAppliedAction r ~ ActionT m ())-       => Maybe Word64-       -> r-       -> (forall a. m a -> IO a)-       -> SpockAllT r m ()-       -> IO Wai.Middleware-spockAllT = buildMiddleware

@@ -1,386 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE RecordWildCards #-}-module Web.Spock.Internal.CoreAction-    ( ActionT-    , UploadedFile (..)-    , request, header, rawHeader, cookie, body, jsonBody, jsonBody'-    , reqMethod-    , files, params, param, param', setStatus, setHeader, redirect-    , setRawMultiHeader-    , CookieSettings(..), CookieEOL(..), defaultCookieSettings-    , setCookie, deleteCookie-    , jumpNext, middlewarePass, modifyVault, queryVault-    , bytes, lazyBytes, text, html, file, json, stream, response-    , requireBasicAuth, withBasicAuthData-    , getContext, runInContext-    , preferredFormat, ClientPreferredFormat(..)-    )-where--import Web.Spock.Internal.Cookies-import Web.Spock.Internal.Util-import Web.Spock.Internal.Wire--import Control.Arrow (first)-import Control.Monad-#if MIN_VERSION_mtl(2,2,0)-import Control.Monad.Except-#else-import Control.Monad.Error-#endif-import Control.Monad.Reader-import Control.Monad.RWS.Strict (runRWST)-import Control.Monad.State hiding (get, put)-import qualified Control.Monad.State as ST-import Data.Maybe-import Data.Monoid-import Data.Time-import Network.HTTP.Types.Header (HeaderName, ResponseHeaders)-import Network.HTTP.Types.Method-import Network.HTTP.Types.Status-import Prelude hiding (head)-import Web.PathPieces-import Web.Routing.AbstractRouter-import qualified Data.Aeson as A-import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Lazy as BSL-import qualified Data.CaseInsensitive as CI-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Vault.Lazy as V-import qualified Network.Wai as Wai---- | Get the original Wai Request object-request :: MonadIO m => ActionCtxT ctx m Wai.Request-request = asks ri_request-{-# INLINE request #-}---- | Read a header-header :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)-header t =-    liftM (fmap T.decodeUtf8) $ rawHeader (CI.mk (T.encodeUtf8 t))-{-# INLINE header #-}---- | Read a header without converting it to text-rawHeader :: MonadIO m => HeaderName -> ActionCtxT ctx m (Maybe BS.ByteString)-rawHeader t =-    liftM (lookup t . Wai.requestHeaders) request-{-# INLINE rawHeader #-}---- | Read a cookie. The cookie value will already be urldecoded.-cookie :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)-cookie name =-    do req <- request-       return $ lookup "cookie" (Wai.requestHeaders req) >>= lookup name . parseCookies-{-# INLINE cookie #-}---- | Tries to dected the preferred format of the response using the Accept header-preferredFormat :: MonadIO m => ActionCtxT ctx m ClientPreferredFormat-preferredFormat =-  do mAccept <- header "accept"-     case mAccept of-       Nothing -> return PrefUnknown-       Just t ->-         return $ detectPreferredFormat t-{-# INLINE preferredFormat #-}---- | Returns the current request method, e.g. 'GET'-reqMethod :: MonadIO m => ActionCtxT ctx m StdMethod-reqMethod = asks ri_method-{-# INLINE reqMethod #-}---- | Get the raw request body-body :: MonadIO m => ActionCtxT ctx 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-{-# INLINE body #-}---- | Parse the request body as json-jsonBody :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m (Maybe a)-jsonBody =-    do b <- body-       return $ A.decodeStrict b-{-# INLINE jsonBody #-}---- | Parse the request body as json and fails with 400 status code on error-jsonBody' :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m a-jsonBody' =-    do b <- body-       case A.eitherDecodeStrict' b of-         Left err ->-             do setStatus status400-                text (T.pack $ "Failed to parse json: " ++ err)-         Right val ->-             return val-{-# INLINE jsonBody' #-}---- | Get uploaded files-files :: MonadIO m => ActionCtxT ctx m (HM.HashMap T.Text UploadedFile)-files =-    asks ri_files-{-# INLINE files #-}---- | Get all request params-params :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]-params =-    do p <- asks ri_params-       qp <- asks ri_queryParams-       return (qp ++ map (first unCaptureVar) (HM.toList p))-{-# INLINE params #-}---- | Read a request param. Spock looks in route captures first (in simple routing), then in POST variables and at last in GET variables-param :: (PathPiece p, MonadIO m) => T.Text -> ActionCtxT ctx m (Maybe p)-param k =-    do p <- asks ri_params-       qp <- asks ri_queryParams-       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)-{-# INLINE param #-}---- | Like 'param', but outputs an error when a param is missing-param' :: (PathPiece p, MonadIO m) => T.Text -> ActionCtxT ctx 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-{-# INLINE param' #-}---- | Set a response status-setStatus :: MonadIO m => Status -> ActionCtxT ctx m ()-setStatus s =-    modify $ \rs -> rs { rs_status = s }-{-# INLINE setStatus #-}---- | Set a response header. If the response header--- is allowed to occur multiple times (as in RFC 2616), it will--- be appended. Otherwise the previous value is overwritten.--- See 'setMultiHeader'.-setHeader :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()-setHeader k v = setRawHeader (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v)-{-# INLINE setHeader #-}--setRawHeader :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()-setRawHeader k v =-    do case HM.lookup k multiHeaderMap of-         Just mhk ->-             setRawMultiHeader mhk v-         Nothing ->-             setRawHeaderUnsafe k v---- | INTERNAL: Set a response header that can occur multiple times. (eg: Cache-Control)-setMultiHeader :: MonadIO m => MultiHeader -> T.Text -> ActionCtxT ctx m ()-setMultiHeader k v = setRawMultiHeader k (T.encodeUtf8 v)-{-# INLINE setMultiHeader #-}--setRawMultiHeader :: MonadIO m => MultiHeader -> BS.ByteString -> ActionCtxT ctx m ()-setRawMultiHeader k v =-    modify $ \rs ->-        rs-        { rs_multiResponseHeaders =-              HM.insertWith (++) k [v] (rs_multiResponseHeaders rs)-        }---- | INTERNAL: Unsafely set a header (no checking if the header can occur multiple times)-setHeaderUnsafe :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()-setHeaderUnsafe k v = setRawHeaderUnsafe (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v)-{-# INLINE setHeaderUnsafe #-}---- | INTERNAL: Unsafely set a header (no checking if the header can occur multiple times)-setRawHeaderUnsafe :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()-setRawHeaderUnsafe k v =-    modify $ \rs ->-        rs-        { rs_responseHeaders =-              HM.insert k v (rs_responseHeaders rs)-        }---- | Abort the current action and jump the next one matching the route-jumpNext :: MonadIO m => ActionCtxT ctx m a-jumpNext = throwError ActionTryNext-{-# INLINE jumpNext #-}---- | Redirect to a given url-redirect :: MonadIO m => T.Text -> ActionCtxT ctx m a-redirect = throwError . ActionRedirect-{-# INLINE redirect #-}---- | If the Spock application is used as a middleware, you can use--- this to pass request handling to the underlying application.--- If Spock is not uses as a middleware, or there is no underlying application--- this will result in 404 error.-middlewarePass :: MonadIO m => ActionCtxT ctx m a-middlewarePass = throwError ActionMiddlewarePass-{-# INLINE middlewarePass #-}---- | Modify the vault (useful for sharing data between middleware and app)-modifyVault :: MonadIO m => (V.Vault -> V.Vault) -> ActionCtxT ctx m ()-modifyVault f =-    do vaultIf <- asks ri_vaultIf-       liftIO $ vi_modifyVault vaultIf f-{-# INLINE modifyVault #-}---- | Query the vault-queryVault :: MonadIO m => V.Key a -> ActionCtxT ctx m (Maybe a)-queryVault k =-    do vaultIf <- asks ri_vaultIf-       liftIO $ vi_lookupKey vaultIf k-{-# INLINE queryVault #-}---- | Use a custom 'Wai.Response' generator as response body.-response :: MonadIO m => (Status -> ResponseHeaders -> Wai.Response) -> ActionCtxT ctx m a-response val =-    do modify $ \rs -> rs { rs_responseBody = ResponseBody val }-       throwError ActionDone-{-# INLINE response #-}---- | Send a 'ByteString' as response body. Provide your own "Content-Type"-bytes :: MonadIO m => BS.ByteString -> ActionCtxT ctx m a-bytes val =-    lazyBytes $ BSL.fromStrict val-{-# INLINE bytes #-}---- | Send a lazy 'ByteString' as response body. Provide your own "Content-Type"-lazyBytes :: MonadIO m => BSL.ByteString -> ActionCtxT ctx m a-lazyBytes val =-    response $ \status headers -> Wai.responseLBS status headers val-{-# INLINE lazyBytes #-}---- | Send text as a response body. Content-Type will be "text/plain"-text :: MonadIO m => T.Text -> ActionCtxT ctx m a-text val =-    do setHeaderUnsafe "Content-Type" "text/plain; charset=utf-8"-       bytes $ T.encodeUtf8 val-{-# INLINE text #-}---- | Send a text as response body. Content-Type will be "text/html"-html :: MonadIO m => T.Text -> ActionCtxT ctx m a-html val =-    do setHeaderUnsafe "Content-Type" "text/html; charset=utf-8"-       bytes $ T.encodeUtf8 val-{-# INLINE html #-}---- | Send a file as response-file :: MonadIO m => T.Text -> FilePath -> ActionCtxT ctx m a-file contentType filePath =-     do setHeaderUnsafe "Content-Type" contentType-        response $ \status headers -> Wai.responseFile status headers filePath Nothing-{-# INLINE file #-}---- | Send json as response. Content-Type will be "application/json"-json :: (A.ToJSON a, MonadIO m) => a -> ActionCtxT ctx m b-json val =-    do setHeaderUnsafe "Content-Type" "application/json; charset=utf-8"-       lazyBytes $ A.encode val-{-# INLINE json #-}---- | Use a 'Wai.StreamingBody' to generate a response.-stream :: MonadIO m => Wai.StreamingBody -> ActionCtxT ctx m a-stream val =-    response $ \status headers -> Wai.responseStream status headers val-{-# INLINE stream #-}---- | Convenience Basic authentification--- provide a title for the prompt and a function to validate--- user and password. Usage example:------ > get ("auth" <//> var <//> var) $ \user pass ->--- >       let checker user' pass' =--- >               unless (user == user' && pass == pass') $--- >               do setStatus status401--- >                  text "err"--- >       in requireBasicAuth "Foo" checker $ \() -> text "ok"----requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> ActionCtxT ctx m b) -> (b -> ActionCtxT ctx m a) -> ActionCtxT ctx m a-requireBasicAuth realmTitle authFun cont =-    withBasicAuthData $ \mAuthHeader ->-    case mAuthHeader of-      Nothing ->-          authFailed Nothing-      Just (user, pass) ->-          authFun user pass >>= cont-    where-      authFailed mMore =-          do setStatus status401-             setMultiHeader MultiHeaderWWWAuth ("Basic realm=\"" <> realmTitle <> "\"")-             text $ "Authentication required. " <> fromMaybe "" mMore---- | "Lower level" basic authentification handeling. Does not set any headers that will promt--- browser users, only looks for an "Authorization" header in the request and breaks it into--- username and passwort component if present-withBasicAuthData :: MonadIO m => (Maybe (T.Text, T.Text) -> ActionCtxT ctx m a) -> ActionCtxT ctx m a-withBasicAuthData handler =-    do mAuthHeader <- header "Authorization"-       case mAuthHeader of-         Nothing ->-             handler Nothing-         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 handler (Just (user, pass))---- | Get the context of the current request-getContext :: MonadIO m => ActionCtxT ctx m ctx-getContext = asks ri_context-{-# INLINE getContext #-}---- | Run an Action in a different context-runInContext :: MonadIO m => ctx' -> ActionCtxT ctx' m a -> ActionCtxT ctx m a-runInContext newCtx action =-    do currentEnv <- ask-       currentRespState <- ST.get-       (r, newRespState, _) <--          lift $-          do let env =-                     currentEnv-                     { ri_context = newCtx-                     }-             runRWST (runErrorT $ runActionCtxT action) env currentRespState-       ST.put newRespState-       case r of-         Left interupt ->-             throwError interupt-         Right d -> return d-{-# INLINE runInContext #-}---- | Set a cookie. The cookie value will be urlencoded.-setCookie :: MonadIO m => T.Text -> T.Text -> CookieSettings -> ActionCtxT ctx m ()-setCookie name value cs =-    do now <- liftIO getCurrentTime-       let cookieHeaderString = generateCookieHeaderString name value cs now-       setRawMultiHeader MultiHeaderSetCookie cookieHeaderString-{-# INLINE setCookie #-}---- | Delete a cookie-deleteCookie :: MonadIO m => T.Text -> ActionCtxT ctx m ()-deleteCookie name = setCookie name T.empty cs-  where-    cs = defaultCookieSettings { cs_EOL = CookieValidUntil epoch }-    epoch = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0)-{-# INLINE deleteCookie #-}

@@ -1,7 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-} module Web.Spock.Internal.Monad where  import Web.Spock.Internal.Types@@ -13,13 +14,14 @@ 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+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@@ -28,7 +30,11 @@     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@@ -38,15 +44,21 @@ 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"+-- 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+-- | 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) (SessionManager conn sess 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

@@ -1,221 +1,175 @@ {-# 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.CoreAction-import Web.Spock.Internal.Wire import Web.Spock.Internal.Util import Web.Spock.Internal.Cookies-import qualified Web.Spock.Internal.SessionVault as SV  #if MIN_VERSION_base(4,8,0) #else import Control.Applicative #endif import Control.Concurrent-import Control.Concurrent.STM import Control.Exception import Control.Monad import Control.Monad.Trans import Data.Time-#if MIN_VERSION_time(1,5,0)-#else-import System.Locale (defaultTimeLocale)-#endif 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 -withSessionManager :: SessionCfg sess -> (SessionManager conn sess st -> IO a) -> IO a-withSessionManager sessCfg =-    bracket (createSessionManager sessCfg) sm_closeSessionManager+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)+    } -createSessionManager :: SessionCfg sess -> IO (SessionManager conn sess st)-createSessionManager cfg =-    do pool <- CR.createEntropyPool-       oldSess <- loadSessions-       cacheHM <--           atomically $-           do mapV <- SV.newSessionVault-              forM_ oldSess $ \v -> SV.storeSession v mapV-              return mapV-       vaultKey <- V.newKey-       housekeepThread <- forkIO (forever (housekeepSessions cfg cacheHM storeSessions))+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 cacheHM-          , sm_regenerateSessionId = regenerateSessionIdImpl vaultKey cacheHM pool cfg-          , sm_readSession = readSessionImpl vaultKey cacheHM-          , sm_writeSession = writeSessionImpl vaultKey cacheHM-          , sm_modifySession = modifySessionImpl vaultKey cacheHM-          , sm_clearAllSessions = clearAllSessionsImpl cacheHM-          , sm_mapSessions = mapAllSessionsImpl cacheHM-          , sm_middleware = sessionMiddleware pool cfg vaultKey cacheHM-          , sm_addSafeAction = addSafeActionImpl pool vaultKey cacheHM-          , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM-          , sm_removeSafeAction = removeSafeActionImpl vaultKey cacheHM+          { sm_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-      (loadSessions, storeSessions) =-          case sc_persistCfg cfg of-            Nothing ->-                ( return []-                , const $ return ()-                )-            Just spc ->-                ( do sessions <- spc_load spc-                     return (map genSession sessions)-                , spc_store spc . map mkSerializable . HM.elems-                )-      mkSerializable sess =-          (sess_id sess, sess_validUntil sess, sess_data sess)-      genSession (sid, validUntil, theData) =-          Session-          { sess_id = sid-          , sess_validUntil = validUntil-          , sess_data = theData-          , sess_safeActions = SafeActionStore HM.empty HM.empty-          }+      store = sc_store cfg  regenerateSessionIdImpl ::-    V.Key SessionId-    -> SV.SessionVault (Session conn sess st)-    -> CR.EntropyPool-    -> SessionCfg sess-    -> SpockActionCtx ctx conn sess st ()-regenerateSessionIdImpl vK sessionRef entropyPool cfg =-    do sess <- readSessionBase vK sessionRef+    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 entropyPool cfg sessionRef (sess_data sess)+       newSession <- liftIO $ newSessionImpl cfg sessionRef (sess_data sess)        now <- liftIO getCurrentTime-       setRawMultiHeader MultiHeaderSetCookie $ makeSessionIdCookie cfg newSession now-       modifyVault $ V.insert vK (sess_id newSession)+       si_setRawMultiHeader sif MultiHeaderSetCookie (makeSessionIdCookie cfg newSession now)+       si_modifyVault sif $ V.insert vK (sess_id newSession) -getSessionIdImpl :: V.Key SessionId-                 -> SV.SessionVault (Session conn sess st)-                 -> SpockActionCtx ctx conn sess st SessionId-getSessionIdImpl vK sessionRef =-    do sess <- readSessionBase vK sessionRef+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 -modifySessionBase :: V.Key SessionId-                  -> SV.SessionVault (Session conn sess st)-                  -> (Session conn sess st -> (Session conn sess st, a))-                  -> SpockActionCtx ctx conn sess st a-modifySessionBase vK sessionRef modFun =-    do mValue <- queryVault vK+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 ->-             liftIO $ atomically $-             do mSession <- SV.loadSession sid sessionRef-                case mSession of-                  Nothing ->-                      fail "Internal Spock Session Error: Unknown SessionId"-                  Just session ->-                      do let (sessionNew, result) = modFun session-                         SV.storeSession sessionNew sessionRef-                         return result+             do session <- readOrNewSession cfg vK sif (Just sid)+                let (sessionNew, result) = modFun session+                liftIO $ ss_runTx sessionRef $ ss_storeSession sessionRef sessionNew+                return result -readSessionBase :: V.Key SessionId-                -> SV.SessionVault (Session conn sess st)-                -> SpockActionCtx ctx conn sess st (Session conn sess st)-readSessionBase vK sessionRef =-    do mValue <- queryVault vK+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 ->-             do mSession <- liftIO $ atomically $ SV.loadSession sid sessionRef-                case mSession of-                  Nothing ->-                      error "(2) Internal Spock Session Error. Please report this bug!"-                  Just session ->-                      return session--addSafeActionImpl ::-    CR.EntropyPool-    -> V.Key SessionId-    -> SV.SessionVault (Session conn sess st)-    -> PackedSafeAction conn sess st-    -> SpockActionCtx ctx conn sess st SafeActionHash-addSafeActionImpl pool vaultKey sessionMapVar safeAction =-    do base <- readSessionBase vaultKey sessionMapVar-       case HM.lookup safeAction (sas_reverse (sess_safeActions base)) of-         Just safeActionHash ->-             return safeActionHash-         Nothing ->-             do safeActionHash <- liftIO (randomHash pool 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-                     -> SV.SessionVault (Session conn sess st)-                     -> SafeActionHash-                     -> SpockActionCtx ctx conn sess st (Maybe (PackedSafeAction conn sess st))-lookupSafeActionImpl vaultKey sessionMapVar hash =-    do base <- readSessionBase vaultKey sessionMapVar-       return $ HM.lookup hash (sas_forward (sess_safeActions base))--removeSafeActionImpl ::-    V.Key SessionId-    -> SV.SessionVault (Session conn sess st)-    -> PackedSafeAction conn sess st-    -> SpockActionCtx ctx 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)-          }+             readOrNewSession cfg vK sif (Just sid) -readSessionImpl :: V.Key SessionId-                -> SV.SessionVault (Session conn sess st)-                -> SpockActionCtx ctx conn sess st sess-readSessionImpl vK sessionRef =-    do base <- readSessionBase vK sessionRef+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 :: V.Key SessionId-                 -> SV.SessionVault (Session conn sess st)-                 -> sess-                 -> SpockActionCtx ctx conn sess st ()-writeSessionImpl vK sessionRef value =-    modifySessionImpl vK sessionRef (const (value, ()))+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 :: V.Key SessionId-                  -> SV.SessionVault (Session conn sess st)-                  -> (sess -> (sess, a))-                  -> SpockActionCtx ctx conn sess st a-modifySessionImpl vK sessionRef f =+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 modFun+       modifySessionBase vK sessionRef cfg sif modFun -makeSessionIdCookie :: SessionCfg sess -> Session conn sess st -> UTCTime -> BS.ByteString+makeSessionIdCookie :: SessionCfg conn sess st -> Session conn sess st -> UTCTime -> BS.ByteString makeSessionIdCookie cfg sess now =     generateCookieHeaderString name value settings now     where@@ -223,32 +177,56 @@       value = sess_id sess       settings =           defaultCookieSettings-          { cs_EOL = CookieValidUntil (sess_validUntil sess)+          { cs_EOL = CookieValidForever           , 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 ::-    CR.EntropyPool-    -> SessionCfg sess+    SessionCfg conn sess st     -> V.Key SessionId-    -> SV.SessionVault (Session conn sess st)     -> Wai.Middleware-sessionMiddleware pool cfg vK sessionRef app req respond =-    case getCookieFromReq (sc_cookieName cfg) of-      Just sid ->-          do mSess <- loadSessionImpl cfg sessionRef sid-             case mSess of-               Nothing ->-                   mkNew-               Just sess ->-                   withSess False sess-      Nothing ->-          mkNew+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-      defVal = sc_emptySession cfg+          lookup "cookie" (Wai.requestHeaders req) >>= lookup name . parseCookies       v = Wai.vault req       addCookie sess now responseHeaders =           let cookieContent = makeSessionIdCookie cfg sess now@@ -261,27 +239,24 @@                    if shouldSetCookie                    then mapReqHeaders (addCookie sess now) unwrappedResp                    else unwrappedResp-      mkNew =-          do newSess <- newSessionImpl pool cfg sessionRef defVal-             withSess True newSess  newSessionImpl ::-    CR.EntropyPool-    -> SessionCfg sess-    -> SV.SessionVault (Session conn sess st)+    SessionCfg conn sess st+    -> SessionStoreInstance (Session conn sess st)     -> sess     -> IO (Session conn sess st)-newSessionImpl pool sessCfg sessionRef content =-    do sess <- createSession pool sessCfg content-       atomically $ SV.storeSession sess sessionRef+newSessionImpl sessCfg (SessionStoreInstance sessionRef) content =+    do sess <- createSession sessCfg content+       ss_runTx sessionRef $ ss_storeSession sessionRef sess        return $! sess -loadSessionImpl :: SessionCfg sess-                -> SV.SessionVault (Session conn sess st)-                -> SessionId-                -> IO (Maybe (Session conn sess st))-loadSessionImpl sessCfg sessionRef sid =-    do mSess <- atomically $ SV.loadSession sid sessionRef+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 ->@@ -292,7 +267,7 @@                                     { sess_validUntil =                                           addUTCTime (sc_sessionTTL sessCfg) now                                     }-                            atomically $ SV.storeSession expandedSession sessionRef+                            ss_runTx store $ ss_storeSession store expandedSession                             return expandedSession                     else return sess                 if sess_validUntil sessWithPossibleExpansion > now@@ -302,56 +277,56 @@          Nothing ->              return Nothing -deleteSessionImpl :: SV.SessionVault (Session conn sess st)-                  -> SessionId-                  -> IO ()-deleteSessionImpl sessionRef sid =-    atomically $ SV.deleteSession sid sessionRef+deleteSessionImpl ::+    SessionStoreInstance (Session conn sess st)+    -> SessionId+    -> IO ()+deleteSessionImpl (SessionStoreInstance sessionRef) sid =+    ss_runTx sessionRef $ ss_deleteSession sessionRef sid -clearAllSessionsImpl :: SV.SessionVault (Session conn sess st)-                     -> SpockActionCtx ctx conn sess st ()-clearAllSessionsImpl sessionRef =-    liftIO $ atomically $ SV.filterSessions (const False) sessionRef+clearAllSessionsImpl ::+    MonadIO m+    => SessionStoreInstance (Session conn sess st)+    -> m ()+clearAllSessionsImpl (SessionStoreInstance sessionRef) =+    liftIO $ ss_runTx sessionRef $ ss_filterSessions sessionRef (const False)  mapAllSessionsImpl ::-    SV.SessionVault (Session conn sess st)-    -> (sess -> STM sess)-    -> SpockActionCtx ctx conn sess st ()-mapAllSessionsImpl sessionRef f =-    liftIO $ atomically $ flip SV.mapSessions sessionRef $ \sess ->+    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 sess-                  -> SV.SessionVault (Session conn sess st)-                  -> (HM.HashMap SessionId (Session conn sess st) -> IO ())-                  -> IO ()-housekeepSessions cfg sessionRef storeSessions =-    do now <- getCurrentTime-       (newStatus, oldStatus) <--           atomically $-           do oldSt <- SV.toList sessionRef-              SV.filterSessions (\sess -> sess_validUntil sess > now) sessionRef-              (,) <$> SV.toList sessionRef <*> pure oldSt-       let packSessionHm = HM.fromList . map (\v -> (SV.getSessionKey v, v))-           oldHm = packSessionHm oldStatus-           newHm = packSessionHm newStatus-       storeSessions newHm-       sh_removed (sc_hooks cfg) (HM.map sess_data $ oldHm `HM.difference` newHm)-       threadDelay (1000 * 1000 * (round $ sc_housekeepingInterval cfg))+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 :: CR.EntropyPool -> SessionCfg sess -> sess -> IO (Session conn sess st)-createSession pool sessCfg content =-    do sid <- randomHash pool (sc_sessionIdEntropy sessCfg)+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-           emptySafeActions =-               SafeActionStore HM.empty HM.empty-       return (Session sid validUntil content emptySafeActions)+       return (Session sid csrfToken validUntil content) -randomHash :: CR.EntropyPool -> Int -> IO T.Text-randomHash pool len =-    do let sys :: CR.SystemRNG-           sys = CR.cprgCreate pool+randomHash :: Int -> IO T.Text+randomHash len =+    do by <- CR.getRandomBytes len        return $ T.replace "=" "" $ T.replace "/" "_" $ T.replace "+" "-" $-              T.decodeUtf8 $ B64.encode $ fst $ CR.cprgGenerateWithEntropy len sys+              T.decodeUtf8 $ B64.encode by

@@ -9,7 +9,7 @@ #else import Control.Applicative #endif-import Control.Concurrent.STM (STM)+import Control.Concurrent.STM (STM, atomically) import Control.Monad import Data.Hashable import Focus as F@@ -29,7 +29,7 @@     = SessionVault { unSessionVault :: STMMap.Map (SessionKey s) s }  -- | Create a new session vault-newSessionVault :: IsSession s => STM (SessionVault s)+newSessionVault :: STM (SessionVault s) newSessionVault = SessionVault <$> STMMap.new  -- | Load a session@@ -45,7 +45,7 @@ deleteSession k (SessionVault smap) = STMMap.delete k smap  -- | Get all sessions as list-toList :: IsSession s => SessionVault s -> STM [s]+toList :: SessionVault s -> STM [s] toList =  liftM (map snd) . L.toList . STMMap.stream . unSessionVault  -- | Remove all sessions that do not match the predicate@@ -63,3 +63,20 @@     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'

@@ -8,31 +8,29 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-} module Web.Spock.Internal.Types where -import Web.Spock.Internal.Wire+import Web.Spock.Core  #if MIN_VERSION_base(4,8,0) #else import Control.Applicative #endif-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 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 r conn sess st a =-    SpockAllT r (WebStateM conn sess st) a+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.@@ -48,22 +46,23 @@      -- ^ initial application global state    , spc_database :: PoolOrConn conn      -- ^ See 'PoolOrConn'-   , spc_sessionCfg :: SessionCfg sess+   , 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_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'    } --- | Spock configuration with reasonable defaults-defaultSpockCfg :: sess -> PoolOrConn conn -> st -> SpockCfg conn sess st-defaultSpockCfg sess conn st =-    SpockCfg-    { spc_initialState = st-    , spc_database = conn-    , spc_sessionCfg = defaultSessionCfg sess-    , spc_maxRequestSize = Just (5 * 1024 * 1024)-    }- -- | If Spock should take care of connection pooling, you need to configure -- it depending on what you need. data PoolCfg@@ -88,22 +87,8 @@     PCConn :: ConnBuilder a -> PoolOrConn a     PCNoDatabase :: PoolOrConn () --- | Session configuration with reasonable defaults-defaultSessionCfg :: a -> SessionCfg a-defaultSessionCfg emptySession =-    SessionCfg-    { sc_cookieName = "spockcookie"-    , sc_sessionTTL = 3600-    , sc_sessionIdEntropy = 64-    , sc_sessionExpandTTL = True-    , sc_emptySession = emptySession-    , sc_persistCfg = Nothing-    , sc_housekeepingInterval = 60 * 10-    , sc_hooks = defaultSessionHooks-    }- -- | Configuration for the session manager-data SessionCfg a+data SessionCfg conn a st    = SessionCfg    { sc_cookieName :: T.Text      -- ^ name of the client side cookie@@ -115,38 +100,26 @@      -- ^ if this is true, every page reload will renew the session time to live counter    , sc_emptySession :: a      -- ^ initial session for visitors-   , sc_persistCfg :: Maybe (SessionPersistCfg a)-     -- ^ persistence interface for sessions+   , 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    } --- | NOP session hooks-defaultSessionHooks :: SessionHooks a-defaultSessionHooks =-    SessionHooks-    { sh_removed = const $ return ()-    }- -- | Hook into the session manager to trigger custom behavior data SessionHooks a    = SessionHooks    { sh_removed :: HM.HashMap SessionId a -> IO ()    } -data SessionPersistCfg a-   = SessionPersistCfg-   { spc_load :: IO [(SessionId, UTCTime, a)]-   , spc_store :: [(SessionId, UTCTime, a)] -> IO ()-   }- data WebState conn sess st    = WebState    { web_dbConn :: Pool conn-   , web_sessionMgr :: SessionManager conn sess st+   , web_sessionMgr :: SpockSessionManager conn sess st    , web_state :: st+   , web_config :: SpockCfg conn sess st    }  class HasSpock m where@@ -160,33 +133,16 @@     -- 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+    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)+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@@ -207,26 +163,40 @@ data Session conn sess st     = Session     { sess_id :: !SessionId+    , sess_csrfToken :: !T.Text     , sess_validUntil :: !UTCTime     , sess_data :: !sess-    , sess_safeActions :: !(SafeActionStore conn sess st)     } +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 -data SessionManager conn sess st+type SpockSessionManager conn sess st = SessionManager (SpockActionCtx () conn sess st) conn sess st++data SessionManager m conn sess st    = SessionManager-   { sm_getSessionId :: forall ctx. SpockActionCtx ctx conn sess st SessionId-   , sm_regenerateSessionId :: forall ctx. SpockActionCtx ctx conn sess st ()-   , sm_readSession :: forall ctx. SpockActionCtx ctx conn sess st sess-   , sm_writeSession :: forall ctx. sess -> SpockActionCtx ctx conn sess st ()-   , sm_modifySession :: forall a ctx. (sess -> (sess, a)) -> SpockActionCtx ctx conn sess st a-   , sm_mapSessions :: forall ctx. (sess -> STM sess) -> SpockActionCtx ctx conn sess st ()-   , sm_clearAllSessions :: forall ctx. SpockActionCtx ctx conn sess st ()+   { sm_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_addSafeAction :: forall ctx. PackedSafeAction conn sess st -> SpockActionCtx ctx conn sess st SafeActionHash-   , sm_lookupSafeAction :: forall ctx. SafeActionHash -> SpockActionCtx ctx conn sess st (Maybe (PackedSafeAction conn sess st))-   , sm_removeSafeAction :: forall ctx. PackedSafeAction conn sess st -> SpockActionCtx ctx conn sess st ()    , sm_closeSessionManager :: IO ()    }

@@ -1,47 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Web.Spock.Internal.Util where--import Data.Maybe-import Network.HTTP.Types-import Network.Wai.Internal-import qualified Data.Text as T-import qualified Data.HashMap.Strict as HM--data ClientPreferredFormat-   = PrefJSON-   | PrefXML-   | PrefHTML-   | PrefText-   | PrefUnknown-   deriving (Show, Eq)--mimeMapping :: HM.HashMap T.Text ClientPreferredFormat-mimeMapping =-    HM.fromList-    [ ("application/json", PrefJSON)-    , ("text/javascript", PrefJSON)-    , ("text/json", PrefJSON)-    , ("application/javascript", PrefJSON)-    , ("application/xml", PrefXML)-    , ("text/xml", PrefXML)-    , ("text/plain", PrefText)-    , ("text/html", PrefHTML)-    , ("application/xhtml+xml", PrefHTML)-    ]--detectPreferredFormat :: T.Text -> ClientPreferredFormat-detectPreferredFormat t =-    let (mimeTypeStr, _) = T.breakOn ";" t-        mimeTypes = map (T.toLower . T.strip) $ T.splitOn "," mimeTypeStr-        firstMatch [] = PrefUnknown-        firstMatch (x:xs) = fromMaybe (firstMatch xs) (HM.lookup x mimeMapping)-    in firstMatch mimeTypes---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)

@@ -1,411 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-module Web.Spock.Internal.Wire where--import Control.Arrow ((***))-import Control.Applicative-import Control.Concurrent.STM-import Control.Exception-import Control.Monad.RWS.Strict-#if MIN_VERSION_mtl(2,2,0)-import Control.Monad.Except-#else-import Control.Monad.Error-#endif-import Control.Monad.Reader.Class ()-import Control.Monad.Trans.Resource-import Data.Hashable-import Data.IORef-import Data.Maybe-import Data.Typeable-import Data.Word-import GHC.Generics-import Network.HTTP.Types.Header (ResponseHeaders)-import Network.HTTP.Types.Method-import Network.HTTP.Types.Status-#if MIN_VERSION_base(4,6,0)-import Prelude-#else-import Prelude hiding (catch)-#endif-import System.Directory-import Web.Routing.AbstractRouter-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import qualified Data.CaseInsensitive as CI-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Vault.Lazy as V-import qualified Network.Wai as Wai-import qualified Network.Wai.Parse as P--instance Hashable StdMethod where-    hashWithSalt = hashUsing fromEnum--data UploadedFile-   = UploadedFile-   { uf_name :: !T.Text-   , uf_contentType :: !T.Text-   , uf_tempLocation :: !FilePath-   }--data VaultIf-   = VaultIf-   { vi_modifyVault :: (V.Vault -> V.Vault) -> IO ()-   , vi_lookupKey :: forall a. V.Key a -> IO (Maybe a)-   }--data RequestInfo ctx-   = RequestInfo-   { ri_method :: !StdMethod-   , ri_request :: !Wai.Request-   , ri_params :: !(HM.HashMap CaptureVar T.Text)-   , ri_queryParams :: [(T.Text, T.Text)]-   , ri_files :: !(HM.HashMap T.Text UploadedFile)-   , ri_vaultIf :: !VaultIf-   , ri_context :: !ctx-   }--newtype ResponseBody = ResponseBody (Status -> ResponseHeaders -> Wai.Response)--data MultiHeader-   = MultiHeaderCacheControl-   | MultiHeaderConnection-   | MultiHeaderContentEncoding-   | MultiHeaderContentLanguage-   | MultiHeaderPragma-   | MultiHeaderProxyAuthenticate-   | MultiHeaderTrailer-   | MultiHeaderTransferEncoding-   | MultiHeaderUpgrade-   | MultiHeaderVia-   | MultiHeaderWarning-   | MultiHeaderWWWAuth-   | MultiHeaderSetCookie-     deriving (Show, Eq, Enum, Bounded, Generic)--instance Hashable MultiHeader--multiHeaderCI :: MultiHeader -> CI.CI BS.ByteString-multiHeaderCI mh =-    case mh of-      MultiHeaderCacheControl -> "Cache-Control"-      MultiHeaderConnection -> "Connection"-      MultiHeaderContentEncoding -> "Content-Encoding"-      MultiHeaderContentLanguage -> "Content-Language"-      MultiHeaderPragma -> "Pragma"-      MultiHeaderProxyAuthenticate -> "Proxy-Authenticate"-      MultiHeaderTrailer -> "Trailer"-      MultiHeaderTransferEncoding -> "Transfer-Encoding"-      MultiHeaderUpgrade -> "Upgrade"-      MultiHeaderVia -> "Via"-      MultiHeaderWarning -> "Warning"-      MultiHeaderWWWAuth -> "WWW-Authenticate"-      MultiHeaderSetCookie -> "Set-Cookie"--multiHeaderMap :: HM.HashMap (CI.CI BS.ByteString) MultiHeader-multiHeaderMap =-    HM.fromList $ flip map allHeaders $ \mh ->-    (multiHeaderCI mh, mh)-    where-      -- this is a nasty hack until we know more about the origin of-      -- uncaught exception: ErrorCall (toEnum{MultiHeader}: tag (-12565) is outside of enumeration's range (0,12))-      -- see: https://ghc.haskell.org/trac/ghc/ticket/10792 and https://github.com/agrafix/Spock/issues/44-      allHeaders =-          [ MultiHeaderCacheControl-          , MultiHeaderConnection-          , MultiHeaderContentEncoding-          , MultiHeaderContentLanguage-          , MultiHeaderPragma-          , MultiHeaderProxyAuthenticate-          , MultiHeaderTrailer-          , MultiHeaderTransferEncoding-          , MultiHeaderUpgrade-          , MultiHeaderVia-          , MultiHeaderWarning-          , MultiHeaderWWWAuth-          , MultiHeaderSetCookie-          ]--data ResponseState-   = ResponseState-   { rs_responseHeaders :: !(HM.HashMap (CI.CI BS.ByteString) BS.ByteString)-   , rs_multiResponseHeaders :: !(HM.HashMap MultiHeader [BS.ByteString])-   , rs_status :: !Status-   , rs_responseBody :: !ResponseBody-   }--data ActionInterupt-    = ActionRedirect !T.Text-    | ActionTryNext-    | ActionError String-    | ActionDone-    | ActionMiddlewarePass-    deriving (Show, Typeable)--instance Monoid ActionInterupt where-    mempty = ActionDone-    mappend _ a = a--#if MIN_VERSION_mtl(2,2,0)-type ErrorT = ExceptT-runErrorT :: ExceptT e m a -> m (Either e a)-runErrorT = runExceptT-#else-instance Error ActionInterupt where-    noMsg = ActionError "Unkown Internal Action Error"-    strMsg = ActionError-#endif--type ActionT = ActionCtxT ()--newtype ActionCtxT ctx m a-    = ActionCtxT { runActionCtxT :: ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a }-      deriving (Monad, Functor, Applicative, Alternative, MonadIO, MonadReader (RequestInfo ctx), MonadState ResponseState, MonadError ActionInterupt)--instance MonadTrans (ActionCtxT ctx) where-    lift = ActionCtxT . lift . lift--respStateToResponse :: ResponseState -> Wai.Response-respStateToResponse (ResponseState headers multiHeaders status (ResponseBody body)) =-    let mkMultiHeader (k, vals) =-            let kCi = multiHeaderCI k-            in map (\v -> (kCi, v)) vals-        outHeaders =-            HM.toList headers-            ++ (concatMap mkMultiHeader $ HM.toList multiHeaders)-    in body status outHeaders--errorResponse :: Status -> BSL.ByteString -> ResponseState-errorResponse s e =-    ResponseState-    { rs_responseHeaders =-          HM.singleton "Content-Type" "text/html"-    , rs_multiResponseHeaders =-          HM.empty-    , rs_status = s-    , rs_responseBody = ResponseBody $ \status headers ->-        Wai.responseLBS status headers $-        BSL.concat [ "<html><head><title>"-                   , e-                   , "</title></head><body><h1>"-                   , e-                   , "</h1></body></html>"-                   ]-    }--defResponse :: ResponseState-defResponse =-    ResponseState-    { rs_responseHeaders =-          HM.empty-    , rs_multiResponseHeaders =-          HM.empty-    , rs_status = status200-    , rs_responseBody = ResponseBody $ \status headers ->-        Wai.responseLBS status headers $-        BSL.empty-    }--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!"--sizeError :: ResponseState-sizeError =-    errorResponse status413 "413 - Request body too large!"--type SpockAllT r m a =-    RegistryT r Wai.Middleware StdMethod m a--middlewareToApp :: Wai.Middleware-                -> Wai.Application-middlewareToApp mw =-    mw fallbackApp-    where-      fallbackApp :: Wai.Application-      fallbackApp _ respond = respond notFound--makeActionEnvironment :: InternalState -> StdMethod -> Wai.Request -> IO (ParamMap -> RequestInfo (), TVar V.Vault, IO ())-makeActionEnvironment st stdMethod req =-    do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req-       vaultVar <- liftIO $ newTVarIO (Wai.vault req)-       let vaultIf =-               VaultIf-               { vi_modifyVault = atomically . modifyTVar' vaultVar-               , vi_lookupKey = \k -> V.lookup k <$> atomically (readTVar vaultVar)-               }-           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 (T.decodeUtf8 *** T.decodeUtf8) bodyParams-           getParams =-               map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req-           queryParams = postParams ++ getParams-       return ( \params ->-                    RequestInfo-                    { ri_method = stdMethod-                    , ri_request = req-                    , ri_params = params-                    , ri_queryParams = queryParams-                    , ri_files = uploadedFiles-                    , ri_vaultIf = vaultIf-                    , ri_context = ()-                    }-              , vaultVar-              , removeUploadedFiles uploadedFiles-              )--removeUploadedFiles :: HM.HashMap k UploadedFile -> IO ()-removeUploadedFiles uploadedFiles =-    forM_ (HM.elems uploadedFiles) $ \uploadedFile ->-    do stillThere <- doesFileExist (uf_tempLocation uploadedFile)-       when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile)--applyAction :: MonadIO m-            => Wai.Request-            -> (ParamMap -> RequestInfo ())-            -> [(ParamMap, ActionT m ())]-            -> m (Maybe ResponseState)-applyAction _ _ [] =-    return $ Just $ errorResponse status404 "404 - File not found"-applyAction req mkEnv ((captures, selectedAction) : xs) =-    do let env = mkEnv captures-       (r, respState, _) <--           runRWST (runErrorT $ runActionCtxT selectedAction) env defResponse-       case r of-         Left (ActionRedirect loc) ->-             return $ Just $-                    respState-                    { rs_status = status302-                    , rs_responseBody =-                        ResponseBody $ \status headers ->-                            Wai.responseLBS status (("Location", T.encodeUtf8 loc) : headers) BSL.empty-                    }-         Left ActionTryNext ->-             applyAction req mkEnv xs-         Left (ActionError errorMsg) ->-             do liftIO $ putStrLn $ "Spock Error while handling "-                             ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg-                return $ Just serverError-         Left ActionDone ->-             return $ Just respState-         Left ActionMiddlewarePass ->-             return Nothing-         Right () ->-             return $ Just respState--handleRequest-    :: MonadIO m-    => StdMethod-    -> Maybe Word64-    -> (forall a. m a -> IO a)-    -> [(ParamMap, ActionT m ())]-    -> InternalState-    -> Wai.Application -> Wai.Application-handleRequest stdMethod mLimit registryLift allActions st coreApp req respond =-    do reqGo <--           case mLimit of-             Nothing -> return req-             Just lim -> requestSizeCheck lim req-       handleRequest' stdMethod registryLift allActions st coreApp reqGo respond--handleRequest' ::-    MonadIO m-    => StdMethod-    -> (forall a. m a -> IO a)-    -> [(ParamMap, ActionT m ())]-    -> InternalState-    -> Wai.Application -> Wai.Application-handleRequest' stdMethod registryLift allActions st coreApp req respond =-    do actEnv <--           (Left <$> makeActionEnvironment st stdMethod req)-           `catch` \(_ :: SizeException) ->-               return (Right sizeError)-       case actEnv of-         Left (mkEnv, vaultVar, cleanUp) ->-             do mRespState <--                    registryLift (applyAction req mkEnv allActions)-                    `catch` \(_ :: SizeException) ->-                        return (Just sizeError)-                    `catch` \(e :: SomeException) ->-                        do putStrLn $ "Spock Error while handling " ++ show (Wai.pathInfo req) ++ ": " ++ show e-                           return $ Just serverError-                cleanUp-                case mRespState of-                  Just respState ->-                      respond $ respStateToResponse respState-                  Nothing ->-                      do newVault <- atomically $ readTVar vaultVar-                         let req' = req { Wai.vault = V.union newVault (Wai.vault req) }-                         coreApp req' respond-         Right respState ->-             respond $ respStateToResponse respState--data SizeException-    = SizeException-    deriving (Show, Typeable)--instance Exception SizeException--requestSizeCheck :: Word64 -> Wai.Request -> IO Wai.Request-requestSizeCheck maxSize req =-    do currentSize <- newIORef 0-       return $ req-                  { Wai.requestBody =-                        do bs <- Wai.requestBody req-                           total <--                               atomicModifyIORef currentSize $ \sz ->-                               let !nextSize = sz + fromIntegral (BS.length bs)-                               in (nextSize, nextSize)-                           if total > maxSize-                           then throwIO SizeException-                           else return bs-                  }---buildMiddleware :: forall m r. (MonadIO m, AbstractRouter r, RouteAppliedAction r ~ ActionT m ())-         => Maybe Word64-         -> r-         -> (forall a. m a -> IO a)-         -> SpockAllT r m ()-         -> IO Wai.Middleware-buildMiddleware mLimit registryIf registryLift spockActions =-    do (_, getMatchingRoutes, middlewares) <--           registryLift $ runRegistry registryIf spockActions-       let spockMiddleware = foldl (.) id middlewares-           app :: Wai.Application -> Wai.Application-           app coreApp req respond =-            case parseMethod $ Wai.requestMethod req of-              Left _ ->-                  respond invalidReq-              Right stdMethod ->-                  do let allActions = getMatchingRoutes stdMethod (Wai.pathInfo req)-                     runResourceT $ withInternalState $ \st ->-                         handleRequest stdMethod mLimit registryLift allActions st coreApp req respond-       return $ spockMiddleware . app

@@ -1,242 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--{- |-This module implements the type safe routing aproach. It should be used by all new Spock powered applications. To learn more about-the routing, read the corresponding blog post available at <http://www.spock.li/2015/04/19/type-safe_routing.html>--}-module Web.Spock.Safe-    ( -- * Spock's route definition monad-      spock, SpockM, SpockCtxM-    , spockT, spockLimT, SpockT, SpockCtxT-     -- * Defining routes-    , Path, root, Var, var, static, (<//>)-     -- * Rendering routes-    , renderRoute-     -- * Hooking routes-    , subcomponent, prehook-    , get, post, getpost, head, put, delete, patch, hookRoute, hookAny-    , Http.StdMethod (..)-      -- * Adding Wai.Middleware-    , middleware-      -- * Safe actions-    , SafeAction (..)-    , safeActionPath-    , module Web.Spock.Shared-    )-where---import Web.Spock.Shared-import Web.Spock.Internal.Types-import qualified Web.Spock.Internal.Core as C--import Control.Applicative-import Control.Monad.Reader-import Data.HVect hiding (head)-import Data.Monoid-import Data.Word-import Network.HTTP.Types.Method-import Prelude hiding (head, uncurry, curry)-import Web.Routing.AbstractRouter (swapMonad)-import Web.Routing.SafeRouting hiding (renderRoute)-import qualified Data.Text as T-import qualified Network.HTTP.Types as Http-import qualified Network.Wai as Wai-import qualified Web.Routing.SafeRouting as SR--type SpockM conn sess st = SpockCtxM () conn sess st-type SpockCtxM ctx conn sess st = SpockCtxT ctx (WebStateM conn sess st)--type SpockT = SpockCtxT ()--newtype LiftHooked ctx m =-    LiftHooked { unLiftHooked :: forall a. ActionCtxT ctx m a -> ActionCtxT () m a }--injectHook :: LiftHooked ctx m -> (forall a. ActionCtxT ctx' m a -> ActionCtxT ctx m a) -> LiftHooked ctx' m-injectHook (LiftHooked baseHook) nextHook =-    LiftHooked $ baseHook . nextHook--newtype SpockCtxT ctx m a-    = SpockCtxT-    { runSpockT :: C.SpockAllT (SafeRouter (ActionT m) ()) (ReaderT (LiftHooked ctx m) m) a-    } deriving (Monad, Functor, Applicative, MonadIO)--instance MonadTrans (SpockCtxT ctx) where-    lift = SpockCtxT . lift . lift---- | Create a spock application using a given db storageLayer and an initial state.--- Spock works with database libraries that already implement connection pooling and--- with those that don't come with it out of the box. For more see the 'PoolOrConn' type.--- Use @runSpock@ to run the app or @spockAsApp@ to create a @Wai.Application@-spock :: SpockCfg conn sess st -> SpockM conn sess st () -> IO Wai.Middleware-spock spockCfg spockAppl =-    C.spockAll SafeRouter spockCfg (baseAppHook spockAppl')-    where-      spockAppl' =-          do hookSafeActions-             spockAppl---- | Create a raw spock application with custom underlying monad--- Use @runSpock@ to run the app or @spockAsApp@ to create a @Wai.Application@--- The first argument is request size limit in bytes. Set to 'Nothing' to disable.-spockT :: (MonadIO m)-       => (forall a. m a -> IO a)-       -> SpockT m ()-       -> IO Wai.Middleware-spockT = spockLimT Nothing---- | Like @spockT@, but first argument is request size limit in bytes. Set to 'Nothing' to disable.-spockLimT :: forall m .MonadIO m-       => Maybe Word64-       -> (forall a. m a -> IO a)-       -> SpockT m ()-       -> IO Wai.Middleware-spockLimT mSizeLimit liftFun app =-    C.spockAllT mSizeLimit SafeRouter liftFun (baseAppHook app)--baseAppHook :: forall m. MonadIO m => SpockT m () -> C.SpockAllT (SafeRouter (ActionT m) ()) m ()-baseAppHook app =-    swapMonad lifter (runSpockT app)-    where-      lifter :: forall b. ReaderT (LiftHooked () m) m b -> m b-      lifter action = runReaderT action (LiftHooked id)---- | Specify an action that will be run when the HTTP verb 'GET' and the given route match-get :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()-get = hookRoute GET---- | Specify an action that will be run when the HTTP verb 'POST' and the given route match-post :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()-post = hookRoute POST---- | Specify an action that will be run when the HTTP verb 'GET'/'POST' and the given route match-getpost :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()-getpost r a = hookRoute POST r a >> hookRoute GET r a---- | Specify an action that will be run when the HTTP verb 'HEAD' and the given route match-head :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()-head = hookRoute HEAD---- | Specify an action that will be run when the HTTP verb 'PUT' and the given route match-put :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()-put = hookRoute PUT---- | Specify an action that will be run when the HTTP verb 'DELETE' and the given route match-delete :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()-delete = hookRoute DELETE---- | Specify an action that will be run when the HTTP verb 'PATCH' and the given route match-patch :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()-patch = hookRoute PATCH---- | Specify an action that will be run before all subroutes. It can modify the requests current context-prehook :: forall m ctx ctx'. MonadIO m => ActionCtxT ctx m ctx' -> SpockCtxT ctx' m () -> SpockCtxT ctx m ()-prehook hook (SpockCtxT hookBody) =-    SpockCtxT $-    do prevHook <- lift ask-       let newHook :: ActionCtxT ctx' m a -> ActionCtxT ctx m a-           newHook act =-               do newCtx <- hook-                  runInContext newCtx act-           hookLift :: forall a. ReaderT (LiftHooked ctx' m) m a -> ReaderT (LiftHooked ctx m) m a-           hookLift a =-               lift $ runReaderT a (injectHook prevHook newHook)-       swapMonad hookLift hookBody---- | Specify an action that will be run when a HTTP verb and the given route match-hookRoute :: forall xs ctx m. (HasRep xs, Monad m) => StdMethod -> Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()-hookRoute m path action =-    SpockCtxT $-    do hookLift <- lift $ asks unLiftHooked-       let actionPacker :: HVectElim xs (ActionCtxT ctx m ()) -> HVect xs -> ActionCtxT () m ()-           actionPacker act captures = hookLift (uncurry act captures)-       C.hookRoute m (SafeRouterPath path) (HVectElim' $ curry $ actionPacker action)---- | Specify an action that will be run when a HTTP verb matches but no defined route matches.--- The full path is passed as an argument-hookAny :: Monad m => StdMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> SpockCtxT ctx m ()-hookAny m action =-    SpockCtxT $-    do hookLift <- lift $ asks unLiftHooked-       C.hookAny m (hookLift . action)---- | Define a subcomponent. Usage example:------ > subcomponent "site" $--- >   do get "home" homeHandler--- >      get ("misc" <//> var) $ -- ...--- > subcomponent "admin" $--- >   do get "home" adminHomeHandler------ The request \/site\/home will be routed to homeHandler and the--- request \/admin\/home will be routed to adminHomeHandler-subcomponent :: Monad m => Path '[] -> SpockCtxT ctx m () -> SpockCtxT ctx m ()-subcomponent p (SpockCtxT subapp) = SpockCtxT $ C.subcomponent (SafeRouterPath p) subapp---- | Hook wai middleware into Spock-middleware :: Monad m => Wai.Middleware -> SpockCtxT ctx m ()-middleware = SpockCtxT . C.middleware---- | Wire up a safe action: Safe actions are actions that are protected from--- csrf attacks. Here's a usage example:------ > 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" <//> var) $ \userId ->--- >   do 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 =-    getpost (static "h" </> var) run-    where-      run h =-          do mgr <- getSessMgr-             mAction <- sm_lookupSafeAction mgr h-             case mAction of-               Nothing ->-                   do setStatus Http.status404-                      text "File not found"-               Just p@(PackedSafeAction action) ->-                   do runSafeAction action-                      sm_removeSafeAction mgr p---- | Combine two path components-(<//>) :: Path as -> Path bs -> Path (Append as bs)-(<//>) = (</>)---- | Render a route applying path pieces-renderRoute :: Path as -> HVectElim as T.Text-renderRoute route = curryExpl (pathToRep route) (T.cons '/' . SR.renderRoute route)

@@ -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

@@ -1,143 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Web.Spock.Shared-    (-- * Helpers for running Spock-      runSpock, runSpockNoBanner, spockAsApp-     -- * Action types-    , SpockAction, SpockActionCtx, ActionT, W.ActionCtxT-     -- * Handling requests-    , request, header, rawHeader, cookie, reqMethod-    , preferredFormat, ClientPreferredFormat(..)-    , body, jsonBody, jsonBody'-    , files, UploadedFile (..)-    , params, param, param'-     -- * Working with context-    , getContext, runInContext-     -- * Sending responses-    , setStatus, setHeader, redirect, jumpNext, CookieSettings(..), defaultCookieSettings, CookieEOL(..), setCookie, deleteCookie, bytes, lazyBytes-    , text, html, file, json, stream, response-      -- * Middleware helpers-    , middlewarePass, modifyVault, queryVault-      -- * Configuration-    , SpockCfg (..), defaultSpockCfg-      -- * Database-    , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)-      -- * Accessing Database and State-    , HasSpock (runQuery, getState), SpockConn, SpockState, SpockSession-      -- * Basic HTTP-Auth-    , requireBasicAuth, withBasicAuthData-     -- * Sessions-    , defaultSessionCfg, SessionCfg (..)-    , defaultSessionHooks, SessionHooks (..)-    , SessionPersistCfg(..), readShowSessionPersist-    , SessionId-    , sessionRegenerateId, getSessionId, readSession, writeSession-    , modifySession, modifySession', modifyReadSession, mapAllSessions, clearAllSessions-     -- * Internals for extending Spock-    , getSpockHeart, runSpockIO, WebStateM, WebState-    )-where--import Web.Spock.Internal.Monad-import Web.Spock.Internal.SessionManager-import Web.Spock.Internal.Types-import Web.Spock.Internal.CoreAction-import Control.Monad-import Control.Concurrent.STM (STM)-import System.Directory-import qualified Web.Spock.Internal.Wire as W-import qualified Network.Wai as Wai-import qualified Network.Wai.Handler.Warp as Warp---- | Run a Spock application. Basically just a wrapper aroung 'Warp.run'.-runSpock :: Warp.Port -> IO Wai.Middleware -> IO ()-runSpock port mw =-    do putStrLn ("Spock is running on port " ++ show port)-       app <- spockAsApp mw-       Warp.run port app---- | Like 'runSpock', but does not display the banner "Spock is running on port XXX" on stdout.-runSpockNoBanner :: Warp.Port -> IO Wai.Middleware -> IO ()-runSpockNoBanner port mw =-    do app <- spockAsApp mw-       Warp.run port app---- | Convert a middleware to an application. All failing requests will--- result in a 404 page-spockAsApp :: IO Wai.Middleware -> IO Wai.Application-spockAsApp = liftM W.middlewareToApp---- | 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 =-    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 =-    getSessMgr >>= sm_getSessionId---- | Write to the current session. Note that all data is stored on the server.--- The user only reciedes a sessionId to be identified.-writeSession :: sess -> SpockActionCtx ctx conn sess st ()-writeSession d =-    do mgr <- getSessMgr-       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-       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 =-    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-       sm_clearAllSessions mgr---- | Apply a transformation to all sessions. Be careful with this, as this--- may cause many STM transaction retries.-mapAllSessions :: (sess -> STM sess) -> SpockActionCtx ctx conn sess st ()-mapAllSessions f =-    do mgr <- getSessMgr-       sm_mapSessions mgr f---- | Simple session persisting configuration. DO NOT USE IN PRODUCTION-readShowSessionPersist :: (Read a, Show a) => FilePath -> SessionPersistCfg a-readShowSessionPersist fp =-    SessionPersistCfg-    { spc_load =-         do isThere <- doesFileExist fp-            if isThere-            then do str <- readFile fp-                    return (read str)-            else return []-    , spc_store = writeFile fp . show-    }

@@ -1,208 +0,0 @@-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{- |-Since version 0.7 Spock features a new routing system that enables more type-safe code while still being relatively simple and lightweight.-You should consider using that (see "Web.Spock.Safe") instead of this module. This module is not yet deprecated, but this may happen anytime soon.--}-module Web.Spock.Simple-    ( -- * Spock's route definition monad-      spock, SpockM-    , spockT, spockLimT, SpockT-     -- * Defining routes-    , SpockRoute, (<//>)-     -- * Hooking routes-    , subcomponent-    , get, post, getpost, head, put, delete, patch, hookRoute, hookAny-    , Http.StdMethod (..)-     -- * Adding Wai.Middleware-    , middleware-      -- * Safe actions-    , SafeAction (..)-    , safeActionPath-    , module Web.Spock.Shared-    )-where--import Web.Spock.Shared-import Web.Spock.Internal.Types-import qualified Web.Spock.Internal.Core as C--import Control.Applicative-import Control.Monad.Trans-import Data.Monoid-import Data.String-import Data.Word-import Network.HTTP.Types.Method-import Prelude hiding (head)-import Web.Routing.TextRouting-import qualified Data.Text as T-import qualified Network.HTTP.Types as Http-import qualified Network.Wai as Wai--type SpockM conn sess st a = SpockT (WebStateM conn sess st) a--newtype SpockT m a-    = SpockT { runSpockT :: C.SpockAllT (TextRouter (ActionT m) ()) m a-             } deriving (Monad, Functor, Applicative, MonadIO)--instance MonadTrans SpockT where-    lift = SpockT . lift--newtype SpockRoute-    = SpockRoute { _unSpockRoute :: T.Text }-    deriving (Eq, Ord, Show, Read)--instance IsString SpockRoute where-    fromString str = SpockRoute $ combineRoute (T.pack str) ""---- | Create a spock application using a given db storageLayer and an initial state.--- Spock works with database libraries that already implement connection pooling and--- with those that don't come with it out of the box. For more see the 'PoolOrConn' type.--- Use @runSpock@ to run the app or @spockAsApp@ to create a @Wai.Application@-spock :: SpockCfg conn sess st -> SpockM conn sess st () -> IO Wai.Middleware-spock cfg spockAppl =-    C.spockAll TextRouter cfg (runSpockT spockAppl')-    where-      spockAppl' =-          do hookSafeActions-             spockAppl---- | Create a raw spock application with custom underlying monad--- Use @runSpock@ to run the app or @spockAsApp@ to create a @Wai.Application@.-spockT :: (MonadIO m)-       => (forall a. m a -> IO a)-       -> SpockT m ()-       -> IO Wai.Middleware-spockT = spockLimT Nothing---- | Like @spockT@, but the first argument is request size limit in bytes. Set to 'Nothing' to disable.-spockLimT :: (MonadIO m)-       => Maybe Word64-       -> (forall a. m a -> IO a)-       -> SpockT m ()-       -> IO Wai.Middleware-spockLimT mSizeLimit liftFun (SpockT app) =-    C.spockAllT mSizeLimit TextRouter liftFun app---- | Combine two route components safely------ >>> "/foo" <//> "/bar"--- "/foo/bar"------ >>> "foo" <//> "bar"--- "/foo/bar"------ >>> "foo <//> "/bar"--- "/foo/bar"-(<//>) :: SpockRoute -> SpockRoute -> SpockRoute-(SpockRoute t) <//> (SpockRoute t') = SpockRoute $ combineRoute t t'---- | Specify an action that will be run when the HTTP verb 'GET' and the given route match-get :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()-get = hookRoute GET---- | Specify an action that will be run when the HTTP verb 'POST' and the given route match-post :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()-post = hookRoute POST---- | Specify an action that will be run when the HTTP verb 'GET'/'POST' and the given route match-getpost :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()-getpost r a = hookRoute POST r a >> hookRoute GET r a---- | Specify an action that will be run when the HTTP verb 'HEAD' and the given route match-head :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()-head = hookRoute HEAD---- | Specify an action that will be run when the HTTP verb 'PUT' and the given route match-put :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()-put = hookRoute PUT---- | Specify an action that will be run when the HTTP verb 'DELETE' and the given route match-delete :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()-delete = hookRoute DELETE---- | Specify an action that will be run when the HTTP verb 'PATCH' and the given route match-patch :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()-patch = hookRoute PATCH---- | Specify an action that will be run when a HTTP verb and the given route match-hookRoute :: Monad m => StdMethod -> SpockRoute -> ActionT m () -> SpockT m ()-hookRoute m (SpockRoute path) action = SpockT $ C.hookRoute m (TextRouterPath path) (TAction action)---- | Specify an action that will be run when a HTTP verb matches but no defined route matches.--- The full path is passed as an argument-hookAny :: Monad m => StdMethod -> ([T.Text] -> ActionT m ()) -> SpockT m ()-hookAny m action = SpockT $ C.hookAny m action---- | Define a subcomponent. Usage example:------ > subcomponent "site" $--- >   do get "home" homeHandler--- >      get ("misc" <//> ":param") $ -- ...--- > subcomponent "/admin" $--- >   get "home" adminHomeHandler------ The request \/site\/home will be routed to homeHandler and the--- request \/admin\/home will be routed to adminHomeHandler-subcomponent :: Monad m => SpockRoute -> SpockT m () -> SpockT m ()-subcomponent (SpockRoute p) (SpockT subapp) = SpockT $ C.subcomponent (TextRouterPath p) subapp---- | Hook wai middleware into Spock-middleware :: Monad m => Wai.Middleware -> SpockT m ()-middleware = SpockT . C.middleware---- | 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 =-    getpost ("h" <//> ":spock-csurf-protection") run-    where-      run =-          do Just h <- param "spock-csurf-protection"-             mgr <- getSessMgr-             mAction <- sm_lookupSafeAction mgr h-             case mAction of-               Nothing ->-                   do setStatus Http.status404-                      text "File not found"-               Just p@(PackedSafeAction action) ->-                   do runSafeAction action-                      sm_removeSafeAction mgr p

@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DoAndIfThenElse #-}+module Web.Spock.CsrfSpec (spec) where++import Web.Spock.TestUtils++import Web.Spock+import Web.Spock.Config++import Data.Monoid+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+             }

@@ -1,152 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Web.Spock.FrameworkSpecHelper where--import Test.Hspec-import Test.Hspec.Wai--import Data.Monoid-import Data.Word-import Network.HTTP.Types.Header-import Network.HTTP.Types.Method-import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Lazy.Char8 as BSLC-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Network.Wai as Wai--sizeLimitSpec :: (Word64 -> IO Wai.Application) -> Spec-sizeLimitSpec app =-    with (app maxSize) $-    describe "Request size limit" $-    do it "allows small enough requests the way" $-          do post "/size" okBs `shouldRespondWith` matcher 200 okBs-             post "/size" okBs2 `shouldRespondWith` matcher 200 okBs2-       it "denys large requests the way" $-          post "/size" tooLongBs `shouldRespondWith` 413-    where-      matcher s b =-          ResponseMatcher-          { matchStatus = s-          , matchBody = Just b-          , matchHeaders = []-          }-      maxSize = 1024-      okBs = BSLC.replicate (fromIntegral maxSize - 50) 'i'-      okBs2 = BSLC.replicate (fromIntegral maxSize) 'j'-      tooLongBs = BSLC.replicate (fromIntegral maxSize + 100) 'k'---frameworkSpec :: IO Wai.Application -> Spec-frameworkSpec app =-    with app $-    do routingSpec-       actionSpec-       headerTest-       cookieTest--routingSpec :: SpecWith Wai.Application-routingSpec =-    describe "Routing Framework" $-      do it "allows root actions" $-            get "/" `shouldRespondWith` "root" { matchStatus = 200 }-         it "routes different HTTP-verbs to different actions" $-            do verbTest get "GET"-               verbTest (`post` "") "POST"-               verbTest (`put` "") "PUT"-               verbTest delete "DELETE"-               verbTest (`patch` "") "PATCH"-               verbTestGp get "GETPOST"-               verbTestGp (`post` "") "GETPOST"-         it "can extract params from routes" $-            get "/param-test/42" `shouldRespondWith` "int42" { matchStatus = 200 }-         it "can handle multiple matching routes" $-            get "/param-test/static" `shouldRespondWith` "static" { matchStatus = 200 }-         it "ignores trailing slashes" $-            get "/param-test/static/" `shouldRespondWith` "static" { matchStatus = 200 }-         it "works with subcomponents" $-            do get "/subcomponent/foo" `shouldRespondWith` "foo" { matchStatus = 200 }-               get "/subcomponent/subcomponent2/bar" `shouldRespondWith` "bar" { matchStatus = 200 }-         it "allows the definition of a fallback handler" $-            get "/askldjas/aklsdj" `shouldRespondWith` "askldjas/aklsdj" { matchStatus = 200 }-         it "detected the preferred format" $-            request "GET" "/preferred-format" [("Accept", "text/html,application/xml;q=0.9,image/webp,*/*;q=0.8")] "" `shouldRespondWith` "html" { matchStatus = 200 }-         it "/test-slash and test-noslash are the same thing" $-            do get "/test-slash" `shouldRespondWith` "ok" { matchStatus = 200 }-               get "test-slash" `shouldRespondWith` "ok" { matchStatus = 200 }-               get "/test-noslash" `shouldRespondWith` "ok" { matchStatus = 200 }-               get "test-noslash" `shouldRespondWith` "ok" { matchStatus = 200 }-    where-      verbTestGp verb verbVerbose =-          verb "/verb-test-gp" `shouldRespondWith` (verbVerbose { matchStatus = 200 })-      verbTest verb verbVerbose =-          verb "/verb-test" `shouldRespondWith` (verbVerbose { matchStatus = 200 })--actionSpec :: SpecWith Wai.Application-actionSpec =-    describe "Action Framework" $-      do it "handles auth correctly" $-            do request methodGet "/auth/user/pass" [mkAuthHeader "user" "pass"] "" `shouldRespondWith` "ok" { matchStatus = 200 }-               request methodGet "/auth/user/pass" [mkAuthHeader "user" ""] "" `shouldRespondWith` "err" { matchStatus = 401 }-               request methodGet "/auth/user/pass" [mkAuthHeader "" ""] "" `shouldRespondWith` "err" { matchStatus = 401 }-               request methodGet "/auth/user/pass" [mkAuthHeader "asd" "asd"] "" `shouldRespondWith` "err" { matchStatus = 401 }-               request methodGet "/auth/user/pass" [] "" `shouldRespondWith` "Authentication required. " { matchStatus = 401 }-    where-      mkAuthHeader :: BS.ByteString -> BS.ByteString -> Header-      mkAuthHeader user pass =-          ("Authorization", "Basic " <> (B64.encode $ user <> ":" <> pass))--cookieTest :: SpecWith Wai.Application-cookieTest =-    describe "Cookies" $-    do it "sets single cookies correctly" $-          get "/cookie/single" `shouldRespondWith`-                  "set"-                  { matchStatus = 200-                  , matchHeaders =-                      [ matchCookie "single" "test"-                      ]-                  }-       it "sets multiple cookies correctly" $-          get "/cookie/multiple" `shouldRespondWith`-                  "set"-                  { matchStatus = 200-                  , matchHeaders =-                      [ matchCookie "multiple1" "test1"-                      , matchCookie "multiple2" "test2"-                      ]-                  }-headerTest :: SpecWith Wai.Application-headerTest =-    describe "Headers" $-    do it "supports custom headers" $-          get "/set-header" `shouldRespondWith`-                  "ok"-                  { matchStatus = 200-                  , matchHeaders =-                      [ "X-FooBar" <:> "Baz"-                      ]-                  }-       it "supports multi headers" $-          get "/set-multi-header" `shouldRespondWith`-                  "ok"-                  { matchStatus = 200-                  , matchHeaders =-                      [ "Content-Language" <:> "de"-                      , "Content-Language" <:> "en"-                      ]-                  }--matchCookie :: T.Text -> T.Text -> MatchHeader-matchCookie name val =-    MatchHeader $ \headers ->-        let relevantHeaders = filter (\h -> fst h == "Set-Cookie") headers-            loop [] =-                Just ("No cookie named " ++ T.unpack name ++ " with value "-                      ++ T.unpack val ++ " found")-            loop (x:xs) =-                let (cname, cval) = T.breakOn "=" $ fst $ T.breakOn ";" $ T.decodeUtf8 $ snd x-                in if cname == name && cval == "=" <> val-                   then Nothing-                   else loop xs-        in loop relevantHeaders

@@ -1,93 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Web.Spock.Internal.CookiesSpec (spec) where--import Web.Spock.Internal.Cookies--import Data.Time-import Test.Hspec-import qualified Data.ByteString as BS--spec :: Spec-spec =-    do describe "Generating Cookies" $-        do describe "with the default settings" $-            do let generated = g "foo" "bar" def--               it "should generate the name-value pair" $-                   generated `shouldContainOnce` "foo=bar"--               it "should not generate a max-age key" $-                   generated `shouldNotContain'` "max-age="--               it "should not generate an expires key" $-                   generated `shouldNotContain'` "expires="--               it "should generate a root path" $-                   generated `shouldContainOnce` "path=/"--               it "should not generate a domain pair" $-                   generated `shouldNotContain'` "domain="--               it "should not generate a httponly key" $-                   generated `shouldNotContain'` "HttpOnly"--               it "should not generate a secure key" $-                   generated `shouldNotContain'` "Secure"--           describe "when setting an expiration time in the future" $-            do let generated = g "foo" "bar" def { cs_EOL = CookieValidUntil (UTCTime (fromGregorian 2016 1 1) 0) }--               it "should set the correct expires key" $-                   generated `shouldContainOnce` "expires=Fri, 01-Jan-2016 00:00:00 UTC"--               it "should set the correct max-age key" $-                   generated `shouldContainOnce` "max-age=10465200"--           describe "when setting an expiration time in the past" $-            do let generated = g "foo" "bar" def { cs_EOL = CookieValidUntil (UTCTime (fromGregorian 1970 1 1) 0) }--               it "should set the correct expires key" $-                   generated `shouldContainOnce` "expires=Thu, 01-Jan-1970 00:00:00 UTC"--               it "should set the max-age key to 0" $-                   generated `shouldContainOnce` "max-age=0"--           describe "when setting the path" $-               it "should generate the correct path pair" $-                   g "foo" "bar" def { cs_path = Just "/the-path" } `shouldContainOnce` "path=/the-path"--           describe "when setting the domain" $-               it "should generate the correct domain pair" $-                   g "foo" "bar" def { cs_domain = Just "example.org" } `shouldContainOnce` "domain=example.org"--           describe "when setting the httponly option" $-               it "should generate the httponly key" $-                   g "foo" "bar" def { cs_HTTPOnly = True } `shouldContainOnce` "HttpOnly"--           describe "when setting the secure option" $-               it "should generate the secure key" $-                   g "foo" "bar" def { cs_secure = True } `shouldContainOnce` "Secure"--           describe "cookie value" $-               it "should be urlencoded" $-                   g "foo" "most+special chars;%бисквитки" def `shouldContainOnce`-                     "foo=most%2Bspecial%20chars%3B%25%D0%B1%D0%B8%D1%81%D0%BA%D0%B2%D0%B8%D1%82%D0%BA%D0%B8"--       describe "Parsing cookies" $-           do it "should parse urlencoded multiple cookies" $-                  parseCookies "foo=bar;quux=h&m" `shouldBe` [("foo", "bar"), ("quux", "h&m")]-              it "should handle spacing between cookies" $-                  parseCookies "foo=bar; quux=bim" `shouldBe` [("foo", "bar"), ("quux", "bim")]-              it "should parse urlencoded values" $-                 parseCookies "foo=most%2Bspecial%20chars%3B%25" `shouldBe` [("foo", "most+special chars;%")]--              it "should parse urlencoded utf-8 content" $-                 parseCookies "foo=%D0%B1%D0%B8%D1%81%D0%BA%D0%B2%D0%B8%D1%82%D0%BA%D0%B8" `shouldBe` [("foo", "бисквитки")]-    where-      g n v cs = generateCookieHeaderString n v cs t-      def = defaultCookieSettings-      t = UTCTime (fromGregorian 2015 9 1) (21*60*60)-      shouldContainOnce haystack needle =-          snd (BS.breakSubstring needle haystack) `shouldNotBe` BS.empty-      shouldNotContain' haystack needle =-          snd (BS.breakSubstring needle haystack) `shouldBe` BS.empty

@@ -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

@@ -1,26 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Web.Spock.Internal.UtilSpec (spec) where--import Web.Spock.Internal.Util--import Test.Hspec--spec :: Spec-spec =-     describe "Utils" $-     do describe "detectPreferredFormat" $-          do it "should detect json-only requests" $-               do detectPreferredFormat "application/json, text/javascript, */*; q=0.01" `shouldBe` PrefJSON-                  detectPreferredFormat "application/json;" `shouldBe` PrefJSON-                  detectPreferredFormat "text/javascript;" `shouldBe` PrefJSON-             it "should detect browsers as html clients" $-                do detectPreferredFormat "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8" `shouldBe` PrefHTML-                   detectPreferredFormat "text/html;" `shouldBe` PrefHTML-                   detectPreferredFormat "application/xhtml+xml;" `shouldBe` PrefHTML-             it "should detect xml-only requests" $-                do detectPreferredFormat "application/xml, text/xml, */*; q=0.01" `shouldBe` PrefXML-                   detectPreferredFormat "application/xml;" `shouldBe` PrefXML-                   detectPreferredFormat "text/xml;" `shouldBe` PrefXML-             it "should detect text-only requests" $-                do detectPreferredFormat "text/plain, */*; q=0.01" `shouldBe` PrefText-                   detectPreferredFormat "text/plain;" `shouldBe` PrefText

@@ -3,144 +3,65 @@ {-# LANGUAGE DoAndIfThenElse #-} module Web.Spock.SafeSpec (spec) where -import Web.Spock.Safe-import Web.Spock.FrameworkSpecHelper+import Web.Spock.TestUtils -import Control.Arrow (second)+import Web.Spock+import Web.Spock.Config+ import Control.Monad import Data.IORef-import Data.List (find) import Data.Monoid-import Network.HTTP.Types.Status import Test.Hspec import qualified Data.HashSet as HS import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.Wai.Test as Wai import qualified Test.Hspec.Wai as Test--app :: SpockT IO ()-app =-    do get root $ text "root"-       get "verb-test" $ text "GET"-       post "verb-test" $ text "POST"-       getpost "verb-test-gp" $ text "GETPOST"-       put "verb-test" $ text "PUT"-       delete "verb-test" $ text "DELETE"-       patch "verb-test" $ text "PATCH"-       get "test-slash" $ text "ok"-       get "/test-noslash" $ text "ok"-       get ("param-test" <//> var) $ \(i :: Int) ->-           text $ "int" <> T.pack (show i)-       get ("param-test" <//> "static") $-           text "static"-       get ("cookie" <//> "single") $-           do setCookie "single" "test" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }-              text "set"-       get ("cookie" <//> "multiple") $-           do setCookie "multiple1" "test1" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }-              setCookie "multiple2" "test2" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }-              text "set"-       get "set-header" $-           do setHeader "X-FooBar" "Baz"-              text "ok"-       get "set-multi-header" $-           do setHeader "Content-Language" "de"-              setHeader "Content-Language" "en"-              text "ok"-       subcomponent "/subcomponent" $-         do get "foo" $ text "foo"-            subcomponent "/subcomponent2" $-              get "bar" $ text "bar"-       get "preferred-format" $-         do fmt <- preferredFormat-            case fmt of-              PrefHTML -> text "html"-              x -> text (T.pack (show x))-       get ("auth" <//> var <//> var) $ \user pass ->-           let checker user' pass' =-                   unless (user == user' && pass == pass') $-                   do setStatus status401-                      text "err"-           in requireBasicAuth "Foo" checker $ \() -> text "ok"-       hookAny GET $ text . T.intercalate "/"--routeRenderingSpec :: Spec-routeRenderingSpec =-    describe "Route Rendering" $-    do it "should work with argument-less routes" $-          do renderRoute "foo" `shouldBe` "/foo"-             renderRoute "/foo" `shouldBe` "/foo"-             renderRoute "/foo/" `shouldBe` "/foo"-             renderRoute ("foo" <//> "bar") `shouldBe` "/foo/bar"-       it "should work with routes with args" $-          do let r1 = var :: Var Int-             renderRoute r1 1 `shouldBe` "/1"-             let r2 = "blog" <//> (var :: Var Int)-             renderRoute r2 2 `shouldBe` "/blog/2"-             let r3 = "blog" <//> (var :: Var Int) <//> (var :: Var T.Text)-             renderRoute r3 2 "BIIM" `shouldBe` "/blog/2/BIIM"--ctxApp :: SpockT IO ()-ctxApp =-    prehook hook $-    do get "test" $ getContext >>= text-       post "test" $ getContext >>= text-    where-      hook =-          do sid <- header "X-ApiKey"-             case sid of-               Just s -> return s-               Nothing -> text "Missing ApiKey"--ctxSpec :: Spec-ctxSpec =-    describe "Contexts" $-    Test.with (spockAsApp $ spockT id ctxApp) $-    it "should work" $-       do Test.request "GET" "/test" [] "" `Test.shouldRespondWith` "Missing ApiKey"-          Test.request "GET" "/test" [("X-ApiKey", "foo")] "" `Test.shouldRespondWith` "foo"-          Test.request "POST" "/test" [("X-ApiKey", "foo")] "" `Test.shouldRespondWith` "foo"+import qualified Test.Hspec.Wai.Internal as Test  sessionSpec :: Spec sessionSpec =     describe "SessionManager" $-    Test.with sessionApp $-    do it "should generate random session ids" $+    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 res <- Test.get "/test"+                do Test.WaiSession (Wai.deleteClientCookie "spockcookie")+                   res <- Test.get "/test"                    Test.liftIO $ checkCookie ids res `shouldReturn` True-       it "should remember a session" $+       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 sessCookie)] ""+                   Test.request "GET" "/check" [("Cookie", T.encodeUtf8 $ "spockcookie=" <> sessCookie)] ""                            `Test.shouldRespondWith` "5"-       it "should regenerate and preserve all content" $+       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 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 sessCookie2)] ""+                            do Test.request "GET" "/check" [("Cookie", T.encodeUtf8 $ "spockcookie=" <> sessCookie2)] ""                                        `Test.shouldRespondWith` "5"-                               Test.request "GET" "/check" [("Cookie", T.encodeUtf8 sessCookie)] ""+                               Test.request "GET" "/check" [("Cookie", T.encodeUtf8 $ "spockcookie=" <> sessCookie)] ""                                        `Test.shouldRespondWith` "0"     where       sessionApp =           spockAsApp $-          spock spockCfg $-          do get "test" $ text "text"+          spockCfg >>= \cfg ->+          spock cfg $+          do get "test" $ getSessionId >>= text              get ("set" <//> var) $ \number -> writeSession number >> text "done"              get "regenerate" $ sessionRegenerateId >> text "done"              get "check" $@@ -149,12 +70,6 @@       spockCfg =           defaultSpockCfg (0 :: Int) PCNoDatabase True -      getSessCookie :: Wai.SResponse -> Maybe T.Text-      getSessCookie resp =-          let headers = Wai.simpleHeaders resp-          in fmap snd $ find (\h -> fst h == "Set-Cookie" && "spockcookie" `T.isPrefixOf` snd h) $-             map (second T.decodeUtf8) headers-       checkCookie :: IORef (HS.HashSet T.Text) -> Wai.SResponse -> IO Bool       checkCookie setRef resp =           do let mSessCookie = getSessCookie resp@@ -162,20 +77,13 @@                Nothing ->                    do expectationFailure "Missing spockcookie"                       return False-               Just sessCookie ->-                   let (_, cval) = T.breakOn "=" $ fst $ T.breakOn ";" sessCookie-                   in do set <- readIORef setRef-                         if HS.member cval set-                         then return False-                         else do writeIORef setRef $ HS.insert cval set-                                 return True+               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" $-    do frameworkSpec (spockAsApp $ spockT id app)-       ctxSpec-       sessionSpec-       routeRenderingSpec-       sizeLimitSpec $ \lim -> spockAsApp $ spockLimT (Just lim) id $-          post "size" $ body >>= bytes+    describe "SafeRouting" $ sessionSpec

@@ -1,68 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Web.Spock.SimpleSpec (spec) where--import Web.Spock.Simple-import Web.Spock.FrameworkSpecHelper--import Control.Monad-import Data.Monoid-import Network.HTTP.Types.Status-import Test.Hspec-import qualified Data.Text as T--app :: SpockT IO ()-app =-    do get "/" $ text "root"-       get "/verb-test" $ text "GET"-       post "/verb-test" $ text "POST"-       getpost "/verb-test-gp" $ text "GETPOST"-       put "/verb-test" $ text "PUT"-       delete "/verb-test" $ text "DELETE"-       patch "/verb-test" $ text "PATCH"-       get "test-slash" $ text "ok"-       get "/test-noslash" $ text "ok"-       get "/param-test/:int" $-           do Just (i :: Int) <- param "int"-              text $ "int" <> T.pack (show i)-       get "/param-test/static" $-           text "static"-       subcomponent "/subcomponent" $-         do get "foo" $ text "foo"-            subcomponent "/subcomponent2" $-              get "bar" $ text "bar"-       get "/preferred-format" $-         do fmt <- preferredFormat-            case fmt of-              PrefHTML -> text "html"-              x -> text (T.pack (show x))-       get "/cookie/single" $-           do setCookie "single" "test" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }-              text "set"-       get "/cookie/multiple" $-           do setCookie "multiple1" "test1" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }-              setCookie "multiple2" "test2" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }-              text "set"-       get "set-header" $-           do setHeader "X-FooBar" "Baz"-              text "ok"-       get "set-multi-header" $-           do setHeader "Content-Language" "de"-              setHeader "Content-Language" "en"-              text "ok"-       get ("/auth/:user/:pass") $-           do user <- param' "user"-              pass <- param' "pass"-              let checker user' pass' =-                   unless (user == user' && pass == pass') $-                   do setStatus status401-                      text "err"-              requireBasicAuth "Foo" checker $ \() -> text "ok"-       hookAny GET $ text . T.intercalate "/"--spec :: Spec-spec =-    describe "SimpleRouting" $-    do frameworkSpec (spockAsApp $ spockT id app)-       sizeLimitSpec $ \lim -> spockAsApp $ spockLimT (Just lim) id $-          post "/size" $ body >>= bytes

@@ -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