Spock 0.6.6.1 → 0.7.0.0

raw patch · 29 files changed

+1616/−1559 lines, 29 filesdep +HListdep +hspec-waidep +reroutedep −QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies added: HList, hspec-wai, reroute, safe

Dependencies removed: QuickCheck

API changes (from Hackage documentation)

Files

• Spock.cabal +23/−17
• src/Web/Spock.hs +0/−106
• src/Web/Spock/Core.hs +0/−279
• src/Web/Spock/Digestive.hs +0/−36
• src/Web/Spock/Internal/Core.hs +33/−0
• src/Web/Spock/Internal/CoreAction.hs +240/−0
• src/Web/Spock/Internal/Digestive.hs +36/−0
• src/Web/Spock/Internal/Monad.hs +69/−0
• src/Web/Spock/Internal/SessionManager.hs +253/−0
• src/Web/Spock/Internal/Types.hs +144/−0
• src/Web/Spock/Internal/Util.hs +12/−0
• src/Web/Spock/Internal/Wire.hs +190/−0
• src/Web/Spock/Internal/Wrapper.hs +50/−0
• src/Web/Spock/Monad.hs +0/−69
• src/Web/Spock/Routing.hs +0/−169
• src/Web/Spock/Safe.hs +226/−0
• src/Web/Spock/SafeActions.hs +0/−65
• src/Web/Spock/SessionManager.hs +0/−253
• src/Web/Spock/Simple.hs +235/−0
• src/Web/Spock/Specs/All.hs +11/−0
• src/Web/Spock/Specs/FrameworkSpecHelper.hs +37/−0
• src/Web/Spock/Specs/SafeSpec.hs +26/−0
• src/Web/Spock/Specs/SimpleSpec.hs +26/−0
• src/Web/Spock/Types.hs +0/−142
• src/Web/Spock/Util.hs +0/−12
• src/Web/Spock/Wire.hs +0/−285
• test/Spec.hs +5/−1
• test/Web/Spock/RoutingSpec.hs +0/−109
• test/Web/Spock/WireSpec.hs +0/−16

@@ -1,5 +1,5 @@ name:                Spock-version:             0.6.6.1+version:             0.7.0.0 synopsis:            Another Haskell web framework for rapid development description:         This toolbox provides everything you need to get a quick start into web hacking with haskell: routing, middleware, json, blaze, sessions, cookies, database helper, csrf-protection, global state Homepage:            https://github.com/agrafix/Spock@@ -14,16 +14,21 @@  library   hs-source-dirs:      src-  exposed-modules:     Web.Spock,-                       Web.Spock.Routing,-                       Web.Spock.Wire-  other-modules:       Web.Spock.SessionManager,-                       Web.Spock.Monad,-                       Web.Spock.Types,-                       Web.Spock.SafeActions,-                       Web.Spock.Digestive,-                       Web.Spock.Util,-                       Web.Spock.Core+  exposed-modules:     Web.Spock.Simple,+                       Web.Spock.Safe,+                       Web.Spock.Specs.All+  other-modules:       Web.Spock.Internal.SessionManager,+                       Web.Spock.Internal.Monad,+                       Web.Spock.Internal.Types,+                       Web.Spock.Internal.Digestive,+                       Web.Spock.Internal.Util,+                       Web.Spock.Internal.Core,+                       Web.Spock.Internal.CoreAction,+                       Web.Spock.Internal.Wrapper,+                       Web.Spock.Internal.Wire,+                       Web.Spock.Specs.SimpleSpec,+                       Web.Spock.Specs.SafeSpec,+                       Web.Spock.Specs.FrameworkSpecHelper   build-depends:       aeson >= 0.6.2.1 && <0.9,                        base >= 4 && < 5,                        base64-bytestring ==1.*,@@ -35,6 +40,9 @@                        digestive-functors ==0.7.*,                        directory ==1.2.*,                        hashable ==1.2.*,+                       hspec2 >=0.4 && <0.5,+                       hspec-wai >=0.5 && <0.6,+                       HList >=0.3,                        http-types ==0.8.*,                        monad-control ==0.3.*,                        mtl >=2.1 && <2.3,@@ -42,8 +50,10 @@                        path-pieces >=0.1.4,                        random ==1.*,                        regex-compat ==0.95.*,+                       reroute >=0.1 && <0.2,                        resource-pool ==0.2.*,                        resourcet >= 0.4 && <1.2,+                       safe >=0.3,                        stm ==2.4.*,                        text >= 0.11.3.1 && <1.3,                        time >=1.4 && <1.6,@@ -62,13 +72,9 @@   type:                exitcode-stdio-1.0   hs-source-dirs:      test   main-is:             Spec.hs-  other-modules:       Web.Spock.WireSpec, Web.Spock.RoutingSpec-  build-depends:       QuickCheck,-                       Spock,+  build-depends:       hspec2 >=0.4 && <0.5,                        base >= 4 && < 5,-                       hspec2 >=0.4 && <0.5,-                       vector ==0.10.*,-                       unordered-containers ==0.2.*+                       Spock   ghc-options: -Wall -fno-warn-orphans  source-repository head

@@ -1,106 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Web.Spock-    ( -- * Spock's core-      spock, SpockM, SpockAction-    , spockT, SpockT, ActionT-     -- * Defining routes-    , get, post, C.head, put, delete, patch, defRoute-    , subcomponent, Http.StdMethod (..)-    , combineRoute-     -- * Handeling requests-    , request, header, cookie, body, jsonBody, jsonBody', files, UploadedFile (..)-    , params, param, param'-     -- * Sending responses-    , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', bytes, lazyBytes-    , text, html, file, json, blaze-     -- * Adding middleware-    , middleware-      -- * Database-    , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)-      -- * Accessing Database and State-    , HasSpock (runQuery, getState), SpockConn, SpockState, SpockSession-      -- * Sessions-    , SessionCfg (..)-    , readSession, writeSession, modifySession, clearAllSessions-      -- * Basic HTTP-Auth-    , requireBasicAuth-      -- * Safe actions-    , SafeAction (..)-    , safeActionPath-      -- * Digestive Functors-    , runForm-      -- * Internals for extending Spock-    , getSpockHeart, runSpockIO, WebStateM, WebState-    )-where--import Web.Spock.Core-import Web.Spock.Digestive-import Web.Spock.Monad-import Web.Spock.SafeActions-import Web.Spock.SessionManager-import Web.Spock.Types-import qualified Web.Spock.Core as C--import Control.Monad.Trans.Reader-import Control.Monad.Trans.Resource-import Data.Pool-import qualified Network.HTTP.Types as Http---- | Run a spock application using the warp server, a given db storageLayer and an initial state.--- Spock works with database libraries that already implement connection pooling and--- with those that don't come with it out of the box. For more see the 'PoolOrConn' type.-spock :: Int -> SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO ()-spock port sessionCfg poolOrConn initialState defs =-    do sessionMgr <- createSessionManager sessionCfg-       connectionPool <--           case poolOrConn of-             PCPool p ->-                 return p-             PCConn cb ->-                 let pc = cb_poolConfiguration cb-                 in createPool (cb_createConn cb) (cb_destroyConn cb)-                        (pc_stripes pc) (pc_keepOpenTime pc)-                        (pc_resPerStripe pc)-       let internalState =-               WebState-               { web_dbConn = connectionPool-               , web_sessionMgr = sessionMgr-               , web_state = initialState-               }-           runM m = runResourceT $ runReaderT (runWebStateM m) internalState--       spockT port runM $-               do hookSafeActions-                  defs-                  middleware (sm_middleware sessionMgr)---- | Write to the current session. Note that all data is stored on the server.--- The user only reciedes a sessionId to be identified.-writeSession :: sess -> SpockAction conn sess st ()-writeSession d =-    do mgr <- getSessMgr-       (sm_writeSession mgr) d---- | Modify the stored session-modifySession :: (sess -> sess) -> SpockAction conn sess st ()-modifySession f =-    do mgr <- getSessMgr-       (sm_modifySession mgr) f---- | Read the stored session-readSession :: SpockAction conn sess st sess-readSession =-    do mgr <- getSessMgr-       sm_readSession mgr---- | Globally delete all existing sessions. This is useful for example if you want--- to require all users to relogin-clearAllSessions :: SpockAction conn sess st ()-clearAllSessions =-    do mgr <- getSessMgr-       sm_clearAllSessions mgr

@@ -1,279 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DoAndIfThenElse #-}-module Web.Spock.Core-    ( SpockT, ActionT, spockT-    , middleware, UploadedFile (..)-    , defRoute, get, post, head, put, delete, patch-    , request, header, cookie, body, jsonBody, jsonBody'-    , files, params, param, param', setStatus, setHeader, redirect-    , jumpNext-    , setCookie, setCookie'-    , bytes, lazyBytes, text, html, file, json, blaze-    , combineRoute, subcomponent-    , requireBasicAuth-    )-where--import Control.Arrow (first)-import Control.Monad-import Control.Monad.Error-import Control.Monad.Reader-import Control.Monad.State hiding (get, put)-import Data.Monoid-import Data.Time-import Network.HTTP.Types.Method-import Network.HTTP.Types.Status-import Prelude hiding (head)-import System.Locale-import Text.Blaze.Html (Html)-import Text.Blaze.Html.Renderer.Utf8 (renderHtml)-import Web.PathPieces-import Web.Spock.Routing-import Web.Spock.Wire-import qualified Data.Aeson as A-import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Lazy as BSL-import qualified Data.CaseInsensitive as CI-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Network.Wai as Wai-import qualified Network.Wai.Handler.Warp as Warp---- | Run a raw spock server on a defined port. If you don't need--- a custom base monad you can just supply 'id' as lift function.-spockT :: MonadIO m-       => Warp.Port-       -> (forall a. m a -> IO a)-       -> SpockT m ()-       -> IO ()-spockT port liftSpock routeDefs =-    do spockApp <- buildApp liftSpock routeDefs-       putStrLn $ "Spock is up and running on port " ++ show port-       Warp.run port spockApp---- | Specify an action that will be run when the HTTP verb 'GET' and the given route match-get :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()-get = defRoute GET---- | Specify an action that will be run when the HTTP verb 'POST' and the given route match-post :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()-post = defRoute POST---- | Specify an action that will be run when the HTTP verb 'HEAD' and the given route match-head :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()-head = defRoute HEAD---- | Specify an action that will be run when the HTTP verb 'PUT' and the given route match-put :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()-put = defRoute PUT---- | Specify an action that will be run when the HTTP verb 'DELETE' and the given route match-delete :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()-delete = defRoute DELETE---- | Specify an action that will be run when the HTTP verb 'PATCH' and the given route match-patch :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()-patch = defRoute PATCH---- | Get the original Wai Request object-request :: MonadIO m => ActionT m Wai.Request-request = asks ri_request---- | Read a header-header :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)-header t =-    do req <- request-       return $ fmap T.decodeUtf8 (lookup (CI.mk (T.encodeUtf8 t)) $ Wai.requestHeaders req)---- | Read a cookie-cookie :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)-cookie name =-    do req <- request-       return $ lookup "cookie" (Wai.requestHeaders req) >>= lookup name . parseCookies . T.decodeUtf8-    where-      parseCookies :: T.Text -> [(T.Text, T.Text)]-      parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words-      parseCookie = first T.init . T.breakOnEnd "="---- | Get the raw request body-body :: MonadIO m => ActionT m BS.ByteString-body =-    do req <- request-       let parseBody = liftIO $ Wai.requestBody req-           parseAll chunks =-               do bs <- parseBody-                  if BS.null bs-                  then return chunks-                  else parseAll (chunks `BS.append` bs)-       parseAll BS.empty---- | Parse the request body as json-jsonBody :: (MonadIO m, A.FromJSON a) => ActionT m (Maybe a)-jsonBody =-    do b <- body-       return $ A.decodeStrict b---- | Parse the request body as json and fails with 500 status code on error-jsonBody' :: (MonadIO m, A.FromJSON a) => ActionT m a-jsonBody' =-    do b <- body-       case A.eitherDecodeStrict' b of-         Left err ->-             do setStatus status500-                text (T.pack $ "Failed to parse json: " ++ err)-         Right val ->-             return val---- | Get uploaded files-files :: MonadIO m => ActionT m (HM.HashMap T.Text UploadedFile)-files =-    asks ri_files---- | Get all request params-params :: MonadIO m => ActionT m [(T.Text, T.Text)]-params =-    do p <- asks ri_params-       qp <- asks ri_queryParams-       return (qp ++ (map (\(k, v) -> (unCaptureVar k, v)) $ HM.toList p))---- | Read a request param. Spock looks in route captures first, then in POST variables and at last in GET variables-param :: (PathPiece p, MonadIO m) => T.Text -> ActionT m (Maybe p)-param k =-    do p <- asks ri_params-       qp <- asks ri_queryParams-       case HM.lookup (CaptureVar k) p of-         Just val ->-             case fromPathPiece val of-               Nothing ->-                   do liftIO $ putStrLn ("Cannot parse " ++ show k ++ " with value " ++ show val ++ " as path piece!")-                      jumpNext-               Just pathPieceVal ->-                   return $ Just pathPieceVal-         Nothing ->-             return $ join $ fmap fromPathPiece (lookup k qp)---- | Like 'param', but outputs an error when a param is missing-param' :: (PathPiece p, MonadIO m) => T.Text -> ActionT m p-param' k =-    do mParam <- param k-       case mParam of-         Nothing ->-             do setStatus status500-                text (T.concat [ "Missing parameter ", k ])-         Just val ->-             return val---- | Set a response status-setStatus :: MonadIO m => Status -> ActionT m ()-setStatus s =-    modify $ \rs -> rs { rs_status = s }---- | Set a response header. Overwrites already defined headers-setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()-setHeader k v =-    modify $ \rs -> rs { rs_responseHeaders = ((k, v) : filter ((/= k) . fst) (rs_responseHeaders rs)) }---- | Abort the current action and jump the next one matching the route-jumpNext :: MonadIO m => ActionT m a-jumpNext = throwError ActionTryNext---- | Redirect to a given url-redirect :: MonadIO m => T.Text -> ActionT m a-redirect = throwError . ActionRedirect---- | Set a cookie living for a given number of seconds-setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionT m ()-setCookie name value validSeconds =-    do now <- liftIO getCurrentTime-       setCookie' name value (validSeconds `addUTCTime` now)---- | Set a cookie living until a specific 'UTCTime'-setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionT m ()-setCookie' name value validUntil =-    setHeader "Set-Cookie" rendered-    where-      rendered =-          let formattedTime =-                  T.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil-          in T.concat [ name-                      , "="-                      , value-                      , "; path=/; expires="-                      , formattedTime-                      , ";"-                      ]---- | Send a 'ByteString' as response body. Provide your own "Content-Type"-bytes :: MonadIO m => BS.ByteString -> ActionT m a-bytes val =-    lazyBytes $ BSL.fromStrict val---- | Send a lazy 'ByteString' as response body. Provide your own "Content-Type"-lazyBytes :: MonadIO m => BSL.ByteString -> ActionT m a-lazyBytes val =-    do modify $ \rs -> rs { rs_responseBody = ResponseLBS val }-       throwError ActionDone---- | Send text as a response body. Content-Type will be "text/plain"-text :: MonadIO m => T.Text -> ActionT m a-text val =-    do setHeader "Content-Type" "text/plain"-       bytes $ T.encodeUtf8 val---- | Send a text as response body. Content-Type will be "text/plain"-html :: MonadIO m => T.Text -> ActionT m a-html val =-    do setHeader "Content-Type" "text/html"-       bytes $ T.encodeUtf8 val---- | Send a file as response-file :: MonadIO m => T.Text -> FilePath -> ActionT m a-file contentType filePath =-     do setHeader "Content-Type" contentType-        modify $ \rs -> rs { rs_responseBody = ResponseFile filePath }-        throwError ActionDone---- | Send json as response. Content-Type will be "application/json"-json :: (A.ToJSON a, MonadIO m) => a -> ActionT m b-json val =-    do setHeader "Content-Type" "application/json"-       lazyBytes $ A.encode val---- | Send blaze html as response. Content-Type will be "text/html"-blaze :: MonadIO m => Html -> ActionT m a-blaze val =-    do setHeader "Content-Type" "text/html"-       lazyBytes $ renderHtml val---- | Basic authentification--- provide a title for the prompt and a function to validate--- user and password. Usage example:------ > get "/my-secret-page" $--- >   requireBasicAuth "Secret Page" (\user pass -> return (user == "admin" && pass == "1234")) $--- >   do html "This is top secret content. Login using that secret code I provided ;-)"----requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> m Bool) -> ActionT m a -> ActionT m a-requireBasicAuth realmTitle authFun cont =-    do mAuthHeader <- header "Authorization"-       case mAuthHeader of-         Nothing ->-             authFailed-         Just authHeader ->-             let (_, rawValue) =-                     T.breakOn " " authHeader-                 (user, rawPass) =-                     (T.breakOn ":" . T.decodeUtf8 . B64.decodeLenient . T.encodeUtf8 . T.strip) rawValue-                 pass = T.drop 1 rawPass-             in do isOk <- lift $ authFun user pass-                   if isOk-                   then cont-                   else authFailed-    where-      authFailed =-          do setStatus status401-             setHeader "WWW-Authenticate" ("Basic realm=\"" <> realmTitle <> "\"")-             html "<h1>Authentication required.</h1>"

@@ -1,36 +0,0 @@-{-# LANGUAGE DoAndIfThenElse #-}-module Web.Spock.Digestive-    ( runForm )-where--import Web.Spock.Core--import Control.Applicative-import Control.Monad.Trans-import Network.HTTP.Types-import Network.Wai-import Text.Digestive.Form-import Text.Digestive.Types-import Text.Digestive.View-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T---- | Run a digestive functors form-runForm :: (Functor m, MonadIO m)-        => T.Text -- ^ form name-        -> Form v (ActionT m) a-        -> ActionT m (View v, Maybe a)-runForm formName form =-    do httpMethod <- requestMethod <$> request-       if httpMethod == methodGet-       then do f <- getForm formName form-               return (f, Nothing)-       else postForm formName form (const $ return localEnv)-    where-      localEnv path =-          do let name = fromPath $ path-                 applyParam f =-                     map (f . snd) . filter ((== name) . fst)-             vars <- (applyParam (TextInput)) <$> params-             sentFiles <- (applyParam (FileInput . T.unpack . uf_name) . HM.toList) <$> files-             return (vars ++ sentFiles)

@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Web.Spock.Internal.Core+    ( SpockAllT+    , spockAllT+    , middleware+    , hookRoute+    , subcomponent+    )+where++import Web.Spock.Internal.Wire++import Control.Monad.Error+import Prelude hiding (head)+import Web.Routing.AbstractRouter+import qualified Network.Wai.Handler.Warp as Warp++-- | Run a raw spock server on a defined port. If you don't need+-- a custom base monad you can just supply 'id' as lift function.+spockAllT :: (MonadIO m, AbstractRouter r, RouteAppliedAction r ~ ActionT m ())+       => r+       -> Warp.Port+       -> (forall a. m a -> IO a)+       -> SpockAllT r m ()+       -> IO ()+spockAllT registryIf port liftSpock routeDefs =+    do spockApp <- buildApp registryIf liftSpock routeDefs+       putStrLn $ "Spock is up and running on port " ++ show port+       Warp.run port spockApp

@@ -0,0 +1,240 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DoAndIfThenElse #-}+module Web.Spock.Internal.CoreAction+    ( ActionT+    , UploadedFile (..)+    , request, header, cookie, body, jsonBody, jsonBody'+    , files, params, param, param', setStatus, setHeader, redirect+    , jumpNext+    , setCookie, setCookie'+    , bytes, lazyBytes, text, html, file, json, blaze+    , requireBasicAuth+    )+where++import Web.Spock.Internal.Wire++import Control.Arrow (first)+import Control.Monad+import Control.Monad.Error+import Control.Monad.Reader+import Control.Monad.State hiding (get, put)+import Data.Monoid+import Data.Time+import Network.HTTP.Types.Status+import Prelude hiding (head)+import System.Locale+import Text.Blaze.Html (Html)+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import Web.PathPieces+import Web.Routing.AbstractRouter+import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as BSL+import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.Wai as Wai++-- | Get the original Wai Request object+request :: MonadIO m => ActionT m Wai.Request+request = asks ri_request++-- | Read a header+header :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)+header t =+    do req <- request+       return $ fmap T.decodeUtf8 (lookup (CI.mk (T.encodeUtf8 t)) $ Wai.requestHeaders req)++-- | Read a cookie+cookie :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)+cookie name =+    do req <- request+       return $ lookup "cookie" (Wai.requestHeaders req) >>= lookup name . parseCookies . T.decodeUtf8+    where+      parseCookies :: T.Text -> [(T.Text, T.Text)]+      parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words+      parseCookie = first T.init . T.breakOnEnd "="++-- | Get the raw request body+body :: MonadIO m => ActionT m BS.ByteString+body =+    do req <- request+       let parseBody = liftIO $ Wai.requestBody req+           parseAll chunks =+               do bs <- parseBody+                  if BS.null bs+                  then return chunks+                  else parseAll (chunks `BS.append` bs)+       parseAll BS.empty++-- | Parse the request body as json+jsonBody :: (MonadIO m, A.FromJSON a) => ActionT m (Maybe a)+jsonBody =+    do b <- body+       return $ A.decodeStrict b++-- | Parse the request body as json and fails with 500 status code on error+jsonBody' :: (MonadIO m, A.FromJSON a) => ActionT m a+jsonBody' =+    do b <- body+       case A.eitherDecodeStrict' b of+         Left err ->+             do setStatus status500+                text (T.pack $ "Failed to parse json: " ++ err)+         Right val ->+             return val++-- | Get uploaded files+files :: MonadIO m => ActionT m (HM.HashMap T.Text UploadedFile)+files =+    asks ri_files++-- | Get all request params+params :: MonadIO m => ActionT m [(T.Text, T.Text)]+params =+    do p <- asks ri_params+       qp <- asks ri_queryParams+       return (qp ++ (map (\(k, v) -> (unCaptureVar k, v)) $ HM.toList p))++-- | Read a request param. Spock looks in route captures first, then in POST variables and at last in GET variables+param :: (PathPiece p, MonadIO m) => T.Text -> ActionT m (Maybe p)+param k =+    do p <- asks ri_params+       qp <- asks ri_queryParams+       case HM.lookup (CaptureVar k) p of+         Just val ->+             case fromPathPiece val of+               Nothing ->+                   do liftIO $ putStrLn ("Cannot parse " ++ show k ++ " with value " ++ show val ++ " as path piece!")+                      jumpNext+               Just pathPieceVal ->+                   return $ Just pathPieceVal+         Nothing ->+             return $ join $ fmap fromPathPiece (lookup k qp)++-- | Like 'param', but outputs an error when a param is missing+param' :: (PathPiece p, MonadIO m) => T.Text -> ActionT m p+param' k =+    do mParam <- param k+       case mParam of+         Nothing ->+             do setStatus status500+                text (T.concat [ "Missing parameter ", k ])+         Just val ->+             return val++-- | Set a response status+setStatus :: MonadIO m => Status -> ActionT m ()+setStatus s =+    modify $ \rs -> rs { rs_status = s }++-- | Set a response header. Overwrites already defined headers+setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()+setHeader k v =+    modify $ \rs -> rs { rs_responseHeaders = ((k, v) : filter ((/= k) . fst) (rs_responseHeaders rs)) }++-- | Abort the current action and jump the next one matching the route+jumpNext :: MonadIO m => ActionT m a+jumpNext = throwError ActionTryNext++-- | Redirect to a given url+redirect :: MonadIO m => T.Text -> ActionT m a+redirect = throwError . ActionRedirect++-- | Set a cookie living for a given number of seconds+setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionT m ()+setCookie name value validSeconds =+    do now <- liftIO getCurrentTime+       setCookie' name value (validSeconds `addUTCTime` now)++-- | Set a cookie living until a specific 'UTCTime'+setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionT m ()+setCookie' name value validUntil =+    setHeader "Set-Cookie" rendered+    where+      rendered =+          let formattedTime =+                  T.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil+          in T.concat [ name+                      , "="+                      , value+                      , "; path=/; expires="+                      , formattedTime+                      , ";"+                      ]++-- | Send a 'ByteString' as response body. Provide your own "Content-Type"+bytes :: MonadIO m => BS.ByteString -> ActionT m a+bytes val =+    lazyBytes $ BSL.fromStrict val++-- | Send a lazy 'ByteString' as response body. Provide your own "Content-Type"+lazyBytes :: MonadIO m => BSL.ByteString -> ActionT m a+lazyBytes val =+    do modify $ \rs -> rs { rs_responseBody = ResponseLBS val }+       throwError ActionDone++-- | Send text as a response body. Content-Type will be "text/plain"+text :: MonadIO m => T.Text -> ActionT m a+text val =+    do setHeader "Content-Type" "text/plain"+       bytes $ T.encodeUtf8 val++-- | Send a text as response body. Content-Type will be "text/plain"+html :: MonadIO m => T.Text -> ActionT m a+html val =+    do setHeader "Content-Type" "text/html"+       bytes $ T.encodeUtf8 val++-- | Send a file as response+file :: MonadIO m => T.Text -> FilePath -> ActionT m a+file contentType filePath =+     do setHeader "Content-Type" contentType+        modify $ \rs -> rs { rs_responseBody = ResponseFile filePath }+        throwError ActionDone++-- | Send json as response. Content-Type will be "application/json"+json :: (A.ToJSON a, MonadIO m) => a -> ActionT m b+json val =+    do setHeader "Content-Type" "application/json"+       lazyBytes $ A.encode val++-- | Send blaze html as response. Content-Type will be "text/html"+blaze :: MonadIO m => Html -> ActionT m a+blaze val =+    do setHeader "Content-Type" "text/html"+       lazyBytes $ renderHtml val++-- | Basic authentification+-- provide a title for the prompt and a function to validate+-- user and password. Usage example:+--+-- > get "/my-secret-page" $+-- >   requireBasicAuth "Secret Page" (\user pass -> return (user == "admin" && pass == "1234")) $+-- >   do html "This is top secret content. Login using that secret code I provided ;-)"+--+requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> m Bool) -> ActionT m a -> ActionT m a+requireBasicAuth realmTitle authFun cont =+    do mAuthHeader <- header "Authorization"+       case mAuthHeader of+         Nothing ->+             authFailed+         Just authHeader ->+             let (_, rawValue) =+                     T.breakOn " " authHeader+                 (user, rawPass) =+                     (T.breakOn ":" . T.decodeUtf8 . B64.decodeLenient . T.encodeUtf8 . T.strip) rawValue+                 pass = T.drop 1 rawPass+             in do isOk <- lift $ authFun user pass+                   if isOk+                   then cont+                   else authFailed+    where+      authFailed =+          do setStatus status401+             setHeader "WWW-Authenticate" ("Basic realm=\"" <> realmTitle <> "\"")+             html "<h1>Authentication required.</h1>"

@@ -0,0 +1,36 @@+{-# LANGUAGE DoAndIfThenElse #-}+module Web.Spock.Internal.Digestive+    ( runForm )+where++import Web.Spock.Internal.CoreAction++import Control.Applicative+import Control.Monad.Trans+import Network.HTTP.Types+import Network.Wai+import Text.Digestive.Form+import Text.Digestive.Types+import Text.Digestive.View+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T++-- | Run a digestive functors form+runForm :: (Functor m, MonadIO m)+        => T.Text -- ^ form name+        -> Form v (ActionT m) a+        -> ActionT m (View v, Maybe a)+runForm formName form =+    do httpMethod <- requestMethod <$> request+       if httpMethod == methodGet+       then do f <- getForm formName form+               return (f, Nothing)+       else postForm formName form (const $ return localEnv)+    where+      localEnv path =+          do let name = fromPath $ path+                 applyParam f =+                     map (f . snd) . filter ((== name) . fst)+             vars <- (applyParam (TextInput)) <$> params+             sentFiles <- (applyParam (FileInput . T.unpack . uf_name) . HM.toList) <$> files+             return (vars ++ sentFiles)

@@ -0,0 +1,69 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+module Web.Spock.Internal.Monad where++import Web.Spock.Internal.Types++import Control.Monad+import Control.Monad.Reader+import Control.Monad.Trans.Resource+import Data.Pool+import Data.Time.Clock ( UTCTime(..) )+import Web.PathPieces+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Text.XML.XSD.DateTime as XSD++webM :: MonadTrans t => WebStateM conn sess st a -> t (WebStateM conn sess st) a+webM = lift++instance MonadTrans t => HasSpock (t (WebStateM conn sess st)) where+    type SpockConn (t (WebStateM conn sess st)) = conn+    type SpockState (t (WebStateM conn sess st)) = st+    type SpockSession (t (WebStateM conn sess st)) = sess+    runQuery a = webM $ runQueryImpl a+    getState = webM $ getStateImpl+    getSessMgr = webM $ getSessMgrImpl++instance HasSpock (WebStateM conn sess st) where+    type SpockConn (WebStateM conn sess st) = conn+    type SpockState (WebStateM conn sess st) = st+    type SpockSession (WebStateM conn sess st) = sess+    runQuery = runQueryImpl+    getState = getStateImpl+    getSessMgr = getSessMgrImpl++runQueryImpl :: (conn -> IO a) -> WebStateM conn sess st a+runQueryImpl query =+    do pool <- asks web_dbConn+       liftIO (withResource pool $ query)++getStateImpl :: WebStateM conn sess st st+getStateImpl = asks web_state++-- | Read the heart of Spock. This is useful if you want to construct your own+-- monads that work with runQuery and getState using "runSpockIO"+getSpockHeart :: MonadTrans t => t (WebStateM conn sess st) (WebState conn sess st)+getSpockHeart = webM ask++-- | Run an action inside of Spocks core monad. This allows you to use runQuery and getState+runSpockIO :: WebState conn sess st -> WebStateM conn sess st a -> IO a+runSpockIO st (WebStateM action) =+    runResourceT $+    runReaderT action st++getSessMgrImpl :: (WebStateM conn sess st) (SessionManager conn sess st)+getSessMgrImpl = asks web_sessionMgr++instance PathPiece BSL.ByteString where+    fromPathPiece =+        Just . BSL.fromStrict . T.encodeUtf8+    toPathPiece =+        T.decodeUtf8 . BSL.toStrict++instance PathPiece UTCTime where+    fromPathPiece p = join $ fmap XSD.toUTCTime $ XSD.dateTime p+    toPathPiece = T.pack . show . XSD.fromUTCTime

@@ -0,0 +1,253 @@+{-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}+module Web.Spock.Internal.SessionManager+    ( createSessionManager+    , SessionId, Session(..), SessionManager(..)+    )+where++import Web.Spock.Internal.Types+import Web.Spock.Internal.CoreAction+import Web.Spock.Internal.Util++import Control.Arrow (first)+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Trans+import Data.Time+import System.Locale+import System.Random+import qualified Data.ByteString.Base64.URL as B64+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Vault.Lazy as V+import qualified Network.Wai as Wai++createSessionManager :: SessionCfg sess -> IO (SessionManager conn sess st)+createSessionManager cfg =+    do cacheHM <- atomically $ newTVar HM.empty+       vaultKey <- V.newKey+       _ <- forkIO (forever (housekeepSessions cacheHM))+       return $ SessionManager+                  { sm_readSession = readSessionImpl vaultKey cacheHM+                  , sm_writeSession = writeSessionImpl vaultKey cacheHM+                  , sm_modifySession = modifySessionImpl vaultKey cacheHM+                  , sm_clearAllSessions = clearAllSessionsImpl cacheHM+                  , sm_middleware = sessionMiddleware cfg vaultKey cacheHM+                  , sm_addSafeAction = addSafeActionImpl vaultKey cacheHM+                  , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM+                  , sm_removeSafeAction = removeSafeActionImpl vaultKey cacheHM+                  }++modifySessionBase :: V.Key SessionId+                  -> UserSessions conn sess st+                  -> (Session conn sess st -> Session conn sess st)+                  -> SpockAction conn sess st ()+modifySessionBase vK sessionRef modFun =+    do req <- request+       case V.lookup vK (Wai.vault req) of+         Nothing ->+             error "(3) Internal Spock Session Error. Please report this bug!"+         Just sid ->+             liftIO $ atomically $ modifyTVar' sessionRef (HM.adjust modFun sid)++readSessionBase :: V.Key SessionId+                -> UserSessions conn sess st+                -> SpockAction conn sess st (Session conn sess st)+readSessionBase vK sessionRef =+    do req <- request+       case V.lookup vK (Wai.vault req) of+         Nothing ->+             error "(1) Internal Spock Session Error. Please report this bug!"+         Just sid ->+             do sessions <- liftIO $ atomically $ readTVar sessionRef+                case HM.lookup sid sessions of+                  Nothing ->+                      error "(2) Internal Spock Session Error. Please report this bug!"+                  Just session ->+                      return session++addSafeActionImpl :: V.Key SessionId+                  -> UserSessions conn sess st+                  -> PackedSafeAction conn sess st+                  -> SpockAction conn sess st SafeActionHash+addSafeActionImpl vaultKey sessionMapVar safeAction =+    do base <- readSessionBase vaultKey sessionMapVar+       case HM.lookup safeAction (sas_reverse (sess_safeActions base)) of+         Just safeActionHash ->+             return safeActionHash+         Nothing ->+             do safeActionHash <- liftIO (randomHash 40)+                let f sas =+                        sas+                        { sas_forward = HM.insert safeActionHash safeAction (sas_forward sas)+                        , sas_reverse = HM.insert safeAction safeActionHash (sas_reverse sas)+                        }+                modifySessionBase vaultKey sessionMapVar (\s -> s { sess_safeActions = f (sess_safeActions s) })+                return safeActionHash++lookupSafeActionImpl :: V.Key SessionId+                     -> UserSessions conn sess st+                     -> SafeActionHash+                     -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))+lookupSafeActionImpl vaultKey sessionMapVar hash =+    do base <- readSessionBase vaultKey sessionMapVar+       return $ HM.lookup hash (sas_forward (sess_safeActions base))++removeSafeActionImpl :: V.Key SessionId+                     -> UserSessions conn sess st+                     -> PackedSafeAction conn sess st+                     -> SpockAction conn sess st ()+removeSafeActionImpl vaultKey sessionMapVar action =+    modifySessionBase vaultKey sessionMapVar (\s -> s { sess_safeActions = f (sess_safeActions s ) })+    where+      f sas =+          sas+          { sas_forward =+              case HM.lookup action (sas_reverse sas) of+                Just h -> HM.delete h (sas_forward sas)+                Nothing -> sas_forward sas+          , sas_reverse = HM.delete action (sas_reverse sas)+          }++readSessionImpl :: V.Key SessionId+                -> UserSessions conn sess st+                -> SpockAction conn sess st sess+readSessionImpl vK sessionRef =+    do base <- readSessionBase vK sessionRef+       return (sess_data base)++writeSessionImpl :: V.Key SessionId+                 -> UserSessions conn sess st+                 -> sess+                 -> SpockAction conn sess st ()+writeSessionImpl vK sessionRef value =+    modifySessionImpl vK sessionRef (const value)++modifySessionImpl :: V.Key SessionId+                  -> UserSessions conn sess st+                  -> (sess -> sess)+                  -> SpockAction conn sess st ()+modifySessionImpl vK sessionRef f =+    do let modFun session =+                        session { sess_data = f (sess_data session) }+       modifySessionBase vK sessionRef modFun++sessionMiddleware :: SessionCfg sess+                  -> V.Key SessionId+                  -> UserSessions conn sess st+                  -> Wai.Middleware+sessionMiddleware cfg vK sessionRef app req respond =+    case getCookieFromReq (sc_cookieName cfg) of+      Just sid ->+          do mSess <- loadSessionImpl sessionRef sid+             case mSess of+               Nothing ->+                   mkNew+               Just sess ->+                   withSess False sess+      Nothing ->+          mkNew+    where+      getCookieFromReq name =+          lookup "cookie" (Wai.requestHeaders req) >>=+                 lookup name . parseCookies . T.decodeUtf8+      renderCookie name value validUntil =+          let formattedTime =+                  TL.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil+          in TL.concat [ TL.fromStrict name+                       , "="+                       , TL.fromStrict value+                       , "; path=/; expires="+                       , formattedTime+                       , ";"+                       ]+      parseCookies :: T.Text -> [(T.Text, T.Text)]+      parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words+      parseCookie = first T.init . T.breakOnEnd "="++      defVal = sc_emptySession cfg+      v = Wai.vault req+      addCookie sess responseHeaders =+          let cookieContent =+                  renderCookie (sc_cookieName cfg) (sess_id sess) (sess_validUntil sess)+              cookieC = ("Set-Cookie", BSL.toStrict $ TL.encodeUtf8 cookieContent)+          in (cookieC : responseHeaders)+      withSess shouldSetCookie sess =+          app (req { Wai.vault = V.insert vK (sess_id sess) v }) $ \unwrappedResp ->+              respond $+              if shouldSetCookie+              then mapReqHeaders (addCookie sess) unwrappedResp+              else unwrappedResp+      mkNew =+          do newSess <- newSessionImpl cfg sessionRef defVal+             withSess True newSess++newSessionImpl :: SessionCfg sess+               -> UserSessions conn sess st+               -> sess+               -> IO (Session conn sess st)+newSessionImpl sessCfg sessionRef content =+    do sess <- createSession sessCfg content+       atomically $ modifyTVar' sessionRef (\hm -> HM.insert (sess_id sess) sess hm)+       return $! sess++loadSessionImpl :: UserSessions conn sess st+                -> SessionId+                -> IO (Maybe (Session conn sess st))+loadSessionImpl sessionRef sid =+    do sessHM <- atomically $ readTVar sessionRef+       now <- getCurrentTime+       case HM.lookup sid sessHM of+         Just sess ->+             do if (sess_validUntil sess) > now+                then return $ Just sess+                else do deleteSessionImpl sessionRef sid+                        return Nothing+         Nothing ->+             return Nothing++deleteSessionImpl :: UserSessions conn sess st+                  -> SessionId+                  -> IO ()+deleteSessionImpl sessionRef sid =+    do atomically $ modifyTVar' sessionRef (\hm -> HM.delete sid hm)+       return ()++clearAllSessionsImpl :: UserSessions conn sess st+                     -> SpockAction conn sess st ()+clearAllSessionsImpl sessionRef =+    liftIO $ atomically $ modifyTVar' sessionRef (const HM.empty)++housekeepSessions :: UserSessions conn sess st -> IO ()+housekeepSessions sessionRef =+    do now <- getCurrentTime+       atomically $ modifyTVar' sessionRef (killOld now)+       threadDelay (1000 * 1000 * 60) -- 60 seconds+    where+      filterOld now (_, sess) =+          (sess_validUntil sess) > now+      killOld now hm =+          HM.fromList $ filter (filterOld now) $ HM.toList hm++createSession :: SessionCfg sess -> sess -> IO (Session conn sess st)+createSession sessCfg content =+    do sid <- randomHash (sc_sessionIdEntropy sessCfg)+       now <- getCurrentTime+       let validUntil = addUTCTime (sc_sessionTTL sessCfg) now+           emptySafeActions =+               SafeActionStore HM.empty HM.empty+       return (Session sid validUntil content emptySafeActions)++randomHash :: Int -> IO T.Text+randomHash len =+    do gen <- g+       return $ T.replace "=" "" $ T.decodeUtf8 $ B64.encode $ BSC.pack $+              take len $ randoms gen+    where+      g = newStdGen :: IO StdGen

@@ -0,0 +1,144 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+module Web.Spock.Internal.Types where++import Web.Spock.Internal.Core+import Web.Spock.Internal.CoreAction++import Control.Applicative+import Control.Concurrent.STM+import Control.Monad.Base+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import Data.Hashable+import Data.Pool+import Data.Time.Clock ( UTCTime(..), NominalDiffTime )+import Data.Typeable+import Network.Wai+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T++-- | Inside the SpockAllM monad, you may define routes and middleware.+type SpockAllM r conn sess st a =+    SpockAllT r (WebStateM conn sess st) a++-- | The SpockAction is the monad of all route-actions. You have access+-- to the database, session and state of your application.+type SpockAction conn sess st = ActionT (WebStateM conn sess st)++-- | If Spock should take care of connection pooling, you need to configure+-- it depending on what you need.+data PoolCfg+   = PoolCfg+   { pc_stripes :: Int+   , pc_resPerStripe :: Int+   , pc_keepOpenTime :: NominalDiffTime+   }++-- | The ConnBuilder instructs Spock how to create or close a database connection.+data ConnBuilder a+   = ConnBuilder+   { cb_createConn :: IO a+   , cb_destroyConn :: a -> IO ()+   , cb_poolConfiguration :: PoolCfg+   }++-- | You can feed Spock with either a connection pool, or instructions on how to build+-- a connection pool. See 'ConnBuilder'+data PoolOrConn a+   = PCPool (Pool a)+   | PCConn (ConnBuilder a)++-- | Configuration for the session manager+data SessionCfg a+   = SessionCfg+   { sc_cookieName :: T.Text+   , sc_sessionTTL :: NominalDiffTime+   , sc_sessionIdEntropy :: Int+   , sc_emptySession :: a+   }++data WebState conn sess st+   = WebState+   { web_dbConn :: Pool conn+   , web_sessionMgr :: SessionManager conn sess st+   , web_state :: st+   }++class HasSpock m where+    type SpockConn m :: *+    type SpockState m :: *+    type SpockSession m :: *+    -- | Give you access to a database connectin from the connection pool. The connection is+    -- released back to the pool once the function terminates.+    runQuery :: (SpockConn m -> IO a) -> m a+    -- | Read the application's state. If you wish to have mutable state, you could+    -- use a 'TVar' from the STM packge.+    getState :: m (SpockState m)+    -- | Get the session manager+    getSessMgr :: m (SessionManager (SpockConn m) (SpockSession m) (SpockState m))++-- | SafeActions are actions that need to be protected from csrf attacks+class (Hashable a, Eq a, Typeable a) => SafeAction conn sess st a where+    -- | The body of the safe action. Either GET or POST+    runSafeAction :: a -> SpockAction conn sess st ()++data PackedSafeAction conn sess st+    = forall a. (SafeAction conn sess st a) => PackedSafeAction { unpackSafeAction :: a }++instance Hashable (PackedSafeAction conn sess st) where+    hashWithSalt i (PackedSafeAction a) = hashWithSalt i a++instance Eq (PackedSafeAction conn sess st) where+   (PackedSafeAction a) == (PackedSafeAction b) =+       cast a == Just b++data SafeActionStore conn sess st+   = SafeActionStore+   { sas_forward :: !(HM.HashMap SafeActionHash (PackedSafeAction conn sess st))+   , sas_reverse :: !(HM.HashMap (PackedSafeAction conn sess st) SafeActionHash)+   }++type SafeActionHash = T.Text++newtype WebStateM conn sess st a = WebStateM { runWebStateM :: ReaderT (WebState conn sess st) (ResourceT IO) a }+    deriving (Monad, Functor, Applicative, MonadIO, MonadReader (WebState conn sess st))++instance MonadBase IO (WebStateM conn sess st) where+    liftBase = WebStateM . liftBase++instance MonadBaseControl IO (WebStateM conn sess st) where+    newtype StM (WebStateM conn sess st) a = WStM { unWStM :: StM (ReaderT (WebState conn sess st) (ResourceT IO)) a }+    liftBaseWith f = WebStateM . liftBaseWith $ \runInBase -> f $ liftM WStM . runInBase . runWebStateM+    restoreM = WebStateM . restoreM . unWStM++type SessionId = T.Text+data Session conn sess st+    = Session+    { sess_id :: !SessionId+    , sess_validUntil :: !UTCTime+    , sess_data :: !sess+    , sess_safeActions :: !(SafeActionStore conn sess st)+    }+instance Show (Session conn sess st) where+    show = show . sess_id++type UserSessions conn sess st =+    TVar (HM.HashMap SessionId (Session conn sess st))++data SessionManager conn sess st+   = SessionManager+   { sm_readSession :: SpockAction conn sess st sess+   , sm_writeSession :: sess -> SpockAction conn sess st ()+   , sm_modifySession :: (sess -> sess) -> SpockAction conn sess st ()+   , sm_clearAllSessions :: SpockAction conn sess st ()+   , sm_middleware :: Middleware+   , sm_addSafeAction :: PackedSafeAction conn sess st -> SpockAction conn sess st SafeActionHash+   , sm_lookupSafeAction :: SafeActionHash -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))+   , sm_removeSafeAction :: PackedSafeAction conn sess st -> SpockAction conn sess st ()+   }

@@ -0,0 +1,12 @@+module Web.Spock.Internal.Util where++import Network.HTTP.Types+import Network.Wai.Internal++mapReqHeaders :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response+mapReqHeaders f resp =+    case resp of+      (ResponseFile s h b1 b2) -> ResponseFile s (f h) b1 b2+      (ResponseBuilder s h b) -> ResponseBuilder s (f h) b+      (ResponseStream s h b) -> ResponseStream s (f h) b+      (ResponseRaw x r) -> ResponseRaw x (mapReqHeaders f r)

@@ -0,0 +1,190 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Web.Spock.Internal.Wire where++import Control.Applicative+import Control.Exception+import Control.Monad.RWS.Strict+import Control.Monad.Error+import Control.Monad.Reader.Class ()+import Control.Monad.Trans.Resource+import Data.Hashable+import Data.Maybe+import Network.HTTP.Types.Method+import Network.HTTP.Types.Status+#if MIN_VERSION_base(4,6,0)+import Prelude+#else+import Prelude hiding (catch)+#endif+import System.Directory+import Web.Routing.AbstractRouter+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.Wai as Wai+import qualified Network.Wai.Parse as P++instance Hashable StdMethod where+    hashWithSalt = hashUsing fromEnum++data UploadedFile+   = UploadedFile+   { uf_name :: T.Text+   , uf_contentType :: T.Text+   , uf_tempLocation :: FilePath+   }++data RequestInfo+   = RequestInfo+   { ri_request :: Wai.Request+   , ri_params :: HM.HashMap CaptureVar T.Text+   , ri_queryParams :: [(T.Text, T.Text)]+   , ri_files :: HM.HashMap T.Text UploadedFile+   }++data ResponseBody+   = ResponseFile FilePath+   | ResponseLBS BSL.ByteString+   | ResponseRedirect T.Text+   deriving (Show, Eq)++data ResponseState+   = ResponseState+   { rs_responseHeaders :: [(T.Text, T.Text)]+   , rs_status :: Status+   , rs_responseBody :: ResponseBody+   } deriving (Show, Eq)++data ActionInterupt+    = ActionRedirect T.Text+    | ActionTryNext+    | ActionError String+    | ActionDone+    deriving (Show)++instance Error ActionInterupt where+    noMsg = ActionError "Unkown Internal Action Error"+    strMsg = ActionError++newtype ActionT m a+    = ActionT { runActionT :: ErrorT ActionInterupt (RWST RequestInfo () ResponseState m) a }+      deriving (Monad, Functor, Applicative, MonadIO, MonadReader RequestInfo, MonadState ResponseState, MonadError ActionInterupt)++instance MonadTrans ActionT where+    lift = ActionT . lift . lift++respStateToResponse :: ResponseState -> Wai.Response+respStateToResponse (ResponseState headers status body) =+    case body of+      ResponseFile fp ->+          Wai.responseFile status waiHeaders fp Nothing+      ResponseLBS bsl ->+          Wai.responseLBS status waiHeaders bsl+      ResponseRedirect target ->+          Wai.responseLBS status302 (("Location", T.encodeUtf8 target) : waiHeaders) BSL.empty+    where+      waiHeaders = map (\(k, v) -> (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v)) headers++errorResponse :: Status -> BSL.ByteString -> ResponseState+errorResponse s e =+    ResponseState+    { rs_responseHeaders = [("Content-Type", "text/html")]+    , rs_status = s+    , rs_responseBody =+        ResponseLBS $+        BSL.concat [ "<html><head><title>"+                   , e+                   , "</title></head><body><h1>"+                   , e+                   , "</h1></body></html>"+                   ]+    }++notFound :: Wai.Response+notFound =+    respStateToResponse $ errorResponse status404 "404 - File not found"++invalidReq :: Wai.Response+invalidReq =+    respStateToResponse $ errorResponse status400 "400 - Bad request"++serverError :: ResponseState+serverError =+    errorResponse status500 "500 - Internal Server Error!"++type SpockAllT r m a =+    RegistryT r Wai.Middleware StdMethod m a++buildApp :: forall m r. (MonadIO m, AbstractRouter r, RouteAppliedAction r ~ ActionT m ())+         => r+         -> (forall a. m a -> IO a)+         -> SpockAllT r m ()+         -> IO Wai.Application+buildApp registryIf registryLift spockActions =+    do (_, getMatchingRoutes, middlewares) <-+           registryLift $ runRegistry registryIf spockActions+       let spockMiddleware = foldl (.) id middlewares+           app :: Wai.Application+           app req respond =+            case parseMethod $ Wai.requestMethod req of+              Left _ ->+                  respond invalidReq+              Right stdMethod ->+                  runResourceT $+                  withInternalState $ \st ->+                      do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req+                         let uploadedFiles =+                                 HM.fromList $+                                   map (\(k, fileInfo) ->+                                            ( T.decodeUtf8 k+                                            , UploadedFile (T.decodeUtf8 $ P.fileName fileInfo) (T.decodeUtf8 $ P.fileContentType fileInfo) (P.fileContent fileInfo)+                                            )+                                       ) bodyFiles+                             postParams =+                                 map (\(k, v) -> (T.decodeUtf8 k, T.decodeUtf8 v)) bodyParams+                             getParams =+                                 map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req+                             queryParams = postParams ++ getParams+                             resp = errorResponse status200 ""+                             allActions = getMatchingRoutes stdMethod (Wai.pathInfo req)+                             applyAction :: [(ParamMap, ActionT m ())] -> m ResponseState+                             applyAction [] =+                                 return $ errorResponse status404 "404 - File not found"+                             applyAction ((captures, selectedAction) : xs) =+                                       do let env = RequestInfo req captures queryParams uploadedFiles+                                          (r, respState, _) <-+                                              runRWST (runErrorT $ runActionT $ selectedAction) env resp+                                          case r of+                                            Left (ActionRedirect loc) ->+                                                return $ ResponseState (rs_responseHeaders respState)+                                                       status302 (ResponseRedirect loc)+                                            Left ActionTryNext ->+                                                applyAction xs+                                            Left (ActionError errorMsg) ->+                                                do liftIO $ putStrLn $ "Spock Error while handeling "+                                                              ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg+                                                   return serverError+                                            Left ActionDone ->+                                                return respState+                                            Right () ->+                                                return respState+                         respState <-+                             liftIO $ (registryLift $ applyAction allActions)+                                        `catch` \(e :: SomeException) ->+                                            do putStrLn $ "Spock Error while handeling " ++ show (Wai.pathInfo req) ++ ": " ++ show e+                                               return serverError+                         forM_ (HM.elems uploadedFiles) $ \uploadedFile ->+                             do stillThere <- doesFileExist (uf_tempLocation uploadedFile)+                                when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile)+                         liftIO $ respond $ respStateToResponse respState+       return $ spockMiddleware $ app

@@ -0,0 +1,50 @@+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+module Web.Spock.Internal.Wrapper where++import Web.Spock.Internal.Core+import Web.Spock.Internal.Wire+import Web.Spock.Internal.SessionManager+import Web.Spock.Internal.Types++import Control.Monad.Trans.Reader+import Control.Monad.Trans.Resource+import Data.Pool+import Web.Routing.AbstractRouter++-- | Run a spock application using the warp server, a given db storageLayer and an initial state.+-- Spock works with database libraries that already implement connection pooling and+-- with those that don't come with it out of the box. For more see the 'PoolOrConn' type.+spockAll :: forall r conn sess st.+            ( AbstractRouter r+            , RouteAppliedAction r ~ ActionT (WebStateM conn sess st) ()+            )+         => r+         -> Int+         -> SessionCfg sess+         -> PoolOrConn conn+         -> st+         -> SpockAllM r conn sess st ()+         -> IO ()+spockAll regIf port sessionCfg poolOrConn initialState defs =+    do sessionMgr <- createSessionManager sessionCfg+       connectionPool <-+           case poolOrConn of+             PCPool p ->+                 return p+             PCConn cb ->+                 let pc = cb_poolConfiguration cb+                 in createPool (cb_createConn cb) (cb_destroyConn cb)+                        (pc_stripes pc) (pc_keepOpenTime pc)+                        (pc_resPerStripe pc)+       let internalState =+               WebState+               { web_dbConn = connectionPool+               , web_sessionMgr = sessionMgr+               , web_state = initialState+               }+       spockAllT regIf port (\m -> runResourceT $ runReaderT (runWebStateM m) internalState) $+               do defs+                  middleware (sm_middleware sessionMgr)

@@ -1,69 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-module Web.Spock.Monad where--import Web.Spock.Types--import Control.Monad-import Control.Monad.Reader-import Control.Monad.Trans.Resource-import Data.Pool-import Data.Time.Clock ( UTCTime(..) )-import Web.PathPieces-import qualified Data.ByteString.Lazy as BSL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Text.XML.XSD.DateTime as XSD--webM :: MonadTrans t => WebStateM conn sess st a -> t (WebStateM conn sess st) a-webM = lift--instance MonadTrans t => HasSpock (t (WebStateM conn sess st)) where-    type SpockConn (t (WebStateM conn sess st)) = conn-    type SpockState (t (WebStateM conn sess st)) = st-    type SpockSession (t (WebStateM conn sess st)) = sess-    runQuery a = webM $ runQueryImpl a-    getState = webM $ getStateImpl-    getSessMgr = webM $ getSessMgrImpl--instance HasSpock (WebStateM conn sess st) where-    type SpockConn (WebStateM conn sess st) = conn-    type SpockState (WebStateM conn sess st) = st-    type SpockSession (WebStateM conn sess st) = sess-    runQuery = runQueryImpl-    getState = getStateImpl-    getSessMgr = getSessMgrImpl--runQueryImpl :: (conn -> IO a) -> WebStateM conn sess st a-runQueryImpl query =-    do pool <- asks web_dbConn-       liftIO (withResource pool $ query)--getStateImpl :: WebStateM conn sess st st-getStateImpl = asks web_state---- | Read the heart of Spock. This is useful if you want to construct your own--- monads that work with runQuery and getState using "runSpockIO"-getSpockHeart :: MonadTrans t => t (WebStateM conn sess st) (WebState conn sess st)-getSpockHeart = webM ask---- | Run an action inside of Spocks core monad. This allows you to use runQuery and getState-runSpockIO :: WebState conn sess st -> WebStateM conn sess st a -> IO a-runSpockIO st (WebStateM action) =-    runResourceT $-    runReaderT action st--getSessMgrImpl :: (WebStateM conn sess st) (SessionManager conn sess st)-getSessMgrImpl = asks web_sessionMgr--instance PathPiece BSL.ByteString where-    fromPathPiece =-        Just . BSL.fromStrict . T.encodeUtf8-    toPathPiece =-        T.decodeUtf8 . BSL.toStrict--instance PathPiece UTCTime where-    fromPathPiece p = join $ fmap XSD.toUTCTime $ XSD.dateTime p-    toPathPiece = T.pack . show . XSD.fromUTCTime

@@ -1,169 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Web.Spock.Routing where--import Data.Hashable-import Data.Maybe-import qualified Data.Text as T-import qualified Data.Vector as V-import qualified Data.Vector.Mutable as VM-import qualified Text.Regex as Regex-import qualified Data.HashMap.Strict as HM--type ParamMap = HM.HashMap CaptureVar T.Text--newtype CaptureVar-      = CaptureVar { unCaptureVar :: T.Text }-      deriving (Show, Eq, Hashable)--data RegexWrapper-   = RegexWrapper-   { rw_regex :: !Regex.Regex-   , rw_original :: !T.Text-   }--instance Eq RegexWrapper where-    r1 == r2 =-        rw_original r1 == rw_original r2--instance Show RegexWrapper where-    show (RegexWrapper _ x) = show x--data RouteNode-   = RouteNodeRegex !CaptureVar !RegexWrapper-   | RouteNodeCapture !CaptureVar-   | RouteNodeText !T.Text-   | RouteNodeRoot-   deriving (Show, Eq)--data RouteData a-   = RouteData-   { rd_node :: !RouteNode-   , rd_data :: Maybe a-   }-   deriving (Show, Eq)--data RoutingTree a-   = RoutingTree-   { rt_node :: !(RouteData a)-   , rt_children :: !(V.Vector (RoutingTree a))-   }-   deriving (Show, Eq)--buildRegex :: T.Text -> RegexWrapper-buildRegex t =-    RegexWrapper (Regex.mkRegex $ T.unpack t) t--emptyRoutingTree :: RoutingTree a-emptyRoutingTree =-    RoutingTree (RouteData RouteNodeRoot Nothing) V.empty--mergeData :: Maybe a -> Maybe a -> Maybe a-mergeData (Just _) (Just _) =-    error "Spock error: Don't define the same route twice!"-mergeData (Just a) _ = Just a-mergeData _ (Just b) = Just b-mergeData _ _ = Nothing--addToRoutingTree :: T.Text -> a -> RoutingTree a -> RoutingTree a-addToRoutingTree route dat currTree =-    let applyTree [] tree = tree-        applyTree (current:xs) tree =-            let children = V.map (\(RoutingTree d _) -> rd_node d) (rt_children tree)-                currentDat =-                    case xs of-                      [] -> Just dat-                      _ -> Nothing-                children' =-                    case V.findIndex (==current) children of-                      Nothing ->-                          let h = applyTree xs $ RoutingTree (RouteData current currentDat) V.empty-                          in V.cons h (rt_children tree)-                      Just idx ->-                          let origNode = (V.!) (rt_children tree) idx-                              matchingNode = rt_node $ origNode-                              appliedNode = matchingNode { rd_data = mergeData (rd_data matchingNode) currentDat }-                          in V.modify (\v -> VM.write v idx (applyTree xs $ RoutingTree appliedNode (rt_children origNode))) (rt_children tree)-            in tree { rt_children = children' }-    in case filter (not . T.null) $ T.splitOn "/" route of-         [] ->-             let currNode = rt_node currTree-                 currNode' = currNode { rd_data = mergeData (rd_data currNode) (Just dat) }-             in currTree { rt_node = currNode' }-         xs -> applyTree (map parseRouteNode xs) currTree--parseRouteNode :: T.Text -> RouteNode-parseRouteNode node =-    case T.uncons node of-      Just (':', var) ->-          RouteNodeCapture $ CaptureVar var-      Just ('{', rest) ->-          case T.uncons (T.reverse rest) of-            Just ('}', def) ->-                let (var, xs) = T.breakOn ":" (T.reverse def)-                in case T.uncons xs of-                     Just (':', regex) ->-                         RouteNodeRegex (CaptureVar var) (buildRegex regex)-                     _ ->-                         nodeError-            _ -> nodeError-      Just _ ->-          RouteNodeText node-      Nothing ->-          nodeError-    where-      nodeError = error ("Spock route error: " ++ (show node) ++ " is not a valid route node.")--emptyParamMap :: ParamMap-emptyParamMap = HM.empty--matchRoute :: T.Text -> RoutingTree a -> [(ParamMap, a)]-matchRoute route globalTree =-    matchRoute' (T.splitOn "/" route) globalTree--matchRoute' :: [T.Text] -> RoutingTree a -> [(ParamMap, a)]-matchRoute' routeParts globalTree =-    case filter (not . T.null) routeParts of-      [] ->-          case rd_data $ rt_node globalTree of-            Nothing -> []-            Just action -> [(emptyParamMap, action)]-      xs ->-          findRoute xs (rt_children globalTree)-    where-      findRoute :: [T.Text] -> V.Vector (RoutingTree a) -> [(ParamMap, a)]-      findRoute fullPath trees =-          let foundPaths = V.foldl' (matchTree fullPath emptyParamMap) V.empty trees-          in V.toList foundPaths-          where-            matchTree :: [T.Text] -> ParamMap -> V.Vector (ParamMap, a) -> RoutingTree a -> V.Vector (ParamMap, a)-            matchTree [] _ vec _ = vec-            matchTree (textNode : xs) paramMap vec rt =-                case matchNode textNode (rd_node $ rt_node rt) of-                  (False, _) ->-                      vec-                  (True, mCapture) ->-                      let paramMap' =-                              case mCapture of-                                Nothing -> paramMap-                                Just (var, value) ->-                                    HM.insert var value paramMap-                          nodeData = rd_data $ rt_node rt-                          nodeChildren = rt_children rt-                      in case xs of-                           [] | isJust nodeData ->-                                  V.snoc vec (paramMap', fromJust nodeData)-                              | otherwise ->-                                  vec-                           _ ->-                               let foundPaths = V.foldl' (matchTree xs paramMap') V.empty nodeChildren-                               in V.concat [foundPaths, vec]--matchNode :: T.Text -> RouteNode -> (Bool, Maybe (CaptureVar, T.Text))-matchNode _ RouteNodeRoot = (False, Nothing)-matchNode t (RouteNodeText m) = (m == t, Nothing)-matchNode t (RouteNodeCapture var) = (True, Just (var, t))-matchNode t (RouteNodeRegex var regex) =-    case Regex.matchRegex (rw_regex regex) (T.unpack t) of-      Nothing -> (False, Nothing)-      Just _ -> (True, Just (var, t))

@@ -0,0 +1,226 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+module Web.Spock.Safe+    ( -- * Spock's core+      spock, SpockM, SpockAction+    , spockT, SpockT, ActionT+    , spockApp+     -- * Defining routes+    , Path, root, var, static, (</>)+     -- * Rendering routes+    , renderRoute+     -- * Hooking routes+    , subcomponent+    , get, post, head, put, delete, patch, hookRoute+    , Http.StdMethod (..)+     -- * Handeling requests+    , request, header, cookie, body, jsonBody, jsonBody', files, UploadedFile (..)+    , params, param, param'+     -- * Sending responses+    , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', bytes, lazyBytes+    , text, html, file, json, blaze+     -- * Adding middleware+    , middleware+      -- * Database+    , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)+      -- * Accessing Database and State+    , HasSpock (runQuery, getState), SpockConn, SpockState, SpockSession+      -- * Sessions+    , SessionCfg (..)+    , readSession, writeSession, modifySession, clearAllSessions+      -- * Basic HTTP-Auth+    , requireBasicAuth+      -- * Safe actions+    , SafeAction (..)+    , safeActionPath+      -- * Digestive Functors+    , runForm+      -- * Internals for extending Spock+    , getSpockHeart, runSpockIO, WebStateM, WebState+    )+where+++import Web.Spock.Internal.CoreAction+import Web.Spock.Internal.Digestive+import Web.Spock.Internal.Monad+import Web.Spock.Internal.SessionManager+import Web.Spock.Internal.Types+import Web.Spock.Internal.Wrapper+import qualified Web.Spock.Internal.Wire as W+import qualified Web.Spock.Internal.Core as C++import Control.Applicative+import Control.Monad.Trans+import Data.Monoid+import Network.HTTP.Types.Method+import Prelude hiding (head)+import Web.Routing.SafeRouting+import qualified Data.Text as T+import qualified Network.HTTP.Types as Http+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp++type SpockM conn sess st a = SpockT (WebStateM conn sess st) a++newtype SpockT m a+    = SpockT { runSpockT :: C.SpockAllT (SafeRouter (ActionT m) ()) m a+             } deriving (Monad, Functor, Applicative, MonadIO)++instance MonadTrans SpockT where+    lift = SpockT . lift++-- | Run a spock application using the warp server, a given db storageLayer and an initial state.+-- Spock works with database libraries that already implement connection pooling and+-- with those that don't come with it out of the box. For more see the 'PoolOrConn' type.+spock :: Int -> SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO ()+spock port sessCfg poolOrConn initSt spockAppl =+    spockAll SafeRouter port sessCfg poolOrConn initSt (runSpockT spockAppl')+    where+      spockAppl' =+          do hookSafeActions+             spockAppl++-- | Run a raw spock application with custom underlying monad+spockT :: (MonadIO m)+       => Warp.Port+       -> (forall a. m a -> IO a)+       -> SpockT m ()+       -> IO ()+spockT port liftFun (SpockT app) =+    C.spockAllT SafeRouter port liftFun app++-- | Convert a Spock-App to a wai-application+spockApp :: (MonadIO m) => (forall a. m a -> IO a) -> SpockT m () -> IO Wai.Application+spockApp liftFun (SpockT app) =+    W.buildApp SafeRouter liftFun app++-- | Specify an action that will be run when the HTTP verb 'GET' and the given route match+get :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()+get = hookRoute GET++-- | Specify an action that will be run when the HTTP verb 'POST' and the given route match+post :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()+post = hookRoute POST++-- | Specify an action that will be run when the HTTP verb 'HEAD' and the given route match+head :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()+head = hookRoute HEAD++-- | Specify an action that will be run when the HTTP verb 'PUT' and the given route match+put :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()+put = hookRoute PUT++-- | Specify an action that will be run when the HTTP verb 'DELETE' and the given route match+delete :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()+delete = hookRoute DELETE++-- | Specify an action that will be run when the HTTP verb 'PATCH' and the given route match+patch :: MonadIO m => Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()+patch = hookRoute PATCH++-- | Specify an action that will be run when a HTTP verb and the given route match+hookRoute :: Monad m => StdMethod -> Path xs -> HListElim xs (ActionT m ()) -> SpockT m ()+hookRoute m path action = SpockT $ C.hookRoute m (SafeRouterPath path) (HListElim' action)++-- | Define a subcomponent. Usage example:+--+-- > subcomponent "site" $+-- >   do get "home" homeHandler+-- >      get ("misc" <> var) $ -- ...+-- > subcomponent "admin" $+-- >   do get "home" adminHomeHandler+--+-- The request "/site/home" will be routed to homeHandler and the+-- request "/admin/home" will be routed to adminHomeHandler+subcomponent :: Monad m => Path '[] -> SpockT m () -> SpockT m ()+subcomponent p (SpockT subapp) = SpockT $ C.subcomponent (SafeRouterPath p) subapp++-- | Hook wai middleware into Spock+middleware :: Monad m => Wai.Middleware -> SpockT m ()+middleware = SpockT . C.middleware+++-- | Write to the current session. Note that all data is stored on the server.+-- The user only reciedes a sessionId to be identified.+writeSession :: sess -> SpockAction conn sess st ()+writeSession d =+    do mgr <- getSessMgr+       (sm_writeSession mgr) d++-- | Modify the stored session+modifySession :: (sess -> sess) -> SpockAction conn sess st ()+modifySession f =+    do mgr <- getSessMgr+       (sm_modifySession mgr) f++-- | Read the stored session+readSession :: SpockAction conn sess st sess+readSession =+    do mgr <- getSessMgr+       sm_readSession mgr++-- | Globally delete all existing sessions. This is useful for example if you want+-- to require all users to relogin+clearAllSessions :: SpockAction conn sess st ()+clearAllSessions =+    do mgr <- getSessMgr+       sm_clearAllSessions mgr++-- | Wire up a safe action: Safe actions are actions that are protected from+-- csrf attacks. Here's a usage example:+--+-- > newtype DeleteUser = DeleteUser Int deriving (Hashable, Typeable, Eq)+-- >+-- > instance SafeAction Connection () () DeleteUser where+-- >    runSafeAction (DeleteUser i) =+-- >       do runQuery $ deleteUserFromDb i+-- >          redirect "/user-list"+-- >+-- > get "/user-details/:userId" $+-- >   do userId <- param' "userId"+-- >      deleteUrl <- safeActionPath (DeleteUser userId)+-- >      html $ "Click <a href='" <> deleteUrl <> "'>here</a> to delete user!"+--+-- Note that safeActions currently only support GET and POST requests.+--+safeActionPath :: forall conn sess st a.+                  ( SafeAction conn sess st a+                  , HasSpock(SpockAction conn sess st)+                  , SpockConn (SpockAction conn sess st) ~ conn+                  , SpockSession (SpockAction conn sess st) ~ sess+                  , SpockState (SpockAction conn sess st) ~ st)+               => a+               -> SpockAction conn sess st T.Text+safeActionPath safeAction =+    do mgr <- getSessMgr+       hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction)+       return $ "/h/" <> hash++hookSafeActions :: forall conn sess st.+                   ( HasSpock (SpockAction conn sess st)+                   , SpockConn (SpockAction conn sess st) ~ conn+                   , SpockSession (SpockAction conn sess st) ~ sess+                   , SpockState (SpockAction conn sess st) ~ st)+                => SpockM conn sess st ()+hookSafeActions =+    do get (static "h" </> var) run+       post (static "h" </> var) run+    where+      run h =+          do mgr <- getSessMgr+             mAction <- (sm_lookupSafeAction mgr) h+             case mAction of+               Nothing ->+                   do setStatus Http.status404+                      text "File not found"+               Just p@(PackedSafeAction action) ->+                   do runSafeAction action+                      (sm_removeSafeAction mgr) p

@@ -1,65 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-module Web.Spock.SafeActions where--import Web.Spock.Core-import Web.Spock.Types--import Data.Monoid-import Network.HTTP.Types.Status-import qualified Data.Text as T---- | Wire up a safe action: Safe actions are actions that are protected from--- csrf attacks. Here's a usage example:------ > newtype DeleteUser = DeleteUser Int deriving (Hashable, Typeable, Eq)--- >--- > instance SafeAction Connection () () DeleteUser where--- >    runSafeAction (DeleteUser i) =--- >       do runQuery $ deleteUserFromDb i--- >          redirect "/user-list"--- >--- > get "/user-details/:userId" $--- >   do userId <- param' "userId"--- >      deleteUrl <- safeActionPath (DeleteUser userId)--- >      html $ "Click <a href='" <> deleteUrl <> "'>here</a> to delete user!"------ Note that safeActions currently only support GET and POST requests.----safeActionPath :: forall conn sess st a.-                  ( SafeAction conn sess st a-                  , HasSpock(SpockAction conn sess st)-                  , SpockConn (SpockAction conn sess st) ~ conn-                  , SpockSession (SpockAction conn sess st) ~ sess-                  , SpockState (SpockAction conn sess st) ~ st)-               => a-               -> SpockAction conn sess st T.Text-safeActionPath safeAction =-    do mgr <- getSessMgr-       hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction)-       return $ "/h/" <> hash--hookSafeActions :: forall conn sess st.-                   ( HasSpock (SpockAction conn sess st)-                   , SpockConn (SpockAction conn sess st) ~ conn-                   , SpockSession (SpockAction conn sess st) ~ sess-                   , SpockState (SpockAction conn sess st) ~ st)-                => SpockM conn sess st ()-hookSafeActions =-    do get "/h/:spock-csurf-protection" run-       post "/h/:spock-csurf-protection" run-    where-      run =-          do Just h <- param "spock-csurf-protection"-             mgr <- getSessMgr-             mAction <- (sm_lookupSafeAction mgr) h-             case mAction of-               Nothing ->-                   do setStatus status404-                      text "File not found"-               Just p@(PackedSafeAction action) ->-                   do runSafeAction action-                      (sm_removeSafeAction mgr) p

@@ -1,253 +0,0 @@-{-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}-module Web.Spock.SessionManager-    ( createSessionManager-    , SessionId, Session(..), SessionManager(..)-    )-where--import Web.Spock.Types-import Web.Spock.Core-import Web.Spock.Util--import Control.Arrow (first)-import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad-import Control.Monad.Trans-import Data.Time-import System.Locale-import System.Random-import qualified Data.ByteString.Base64.URL as B64-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Lazy as BSL-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import qualified Data.Vault.Lazy as V-import qualified Network.Wai as Wai--createSessionManager :: SessionCfg sess -> IO (SessionManager conn sess st)-createSessionManager cfg =-    do cacheHM <- atomically $ newTVar HM.empty-       vaultKey <- V.newKey-       _ <- forkIO (forever (housekeepSessions cacheHM))-       return $ SessionManager-                  { sm_readSession = readSessionImpl vaultKey cacheHM-                  , sm_writeSession = writeSessionImpl vaultKey cacheHM-                  , sm_modifySession = modifySessionImpl vaultKey cacheHM-                  , sm_clearAllSessions = clearAllSessionsImpl cacheHM-                  , sm_middleware = sessionMiddleware cfg vaultKey cacheHM-                  , sm_addSafeAction = addSafeActionImpl vaultKey cacheHM-                  , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM-                  , sm_removeSafeAction = removeSafeActionImpl vaultKey cacheHM-                  }--modifySessionBase :: V.Key SessionId-                  -> UserSessions conn sess st-                  -> (Session conn sess st -> Session conn sess st)-                  -> SpockAction conn sess st ()-modifySessionBase vK sessionRef modFun =-    do req <- request-       case V.lookup vK (Wai.vault req) of-         Nothing ->-             error "(3) Internal Spock Session Error. Please report this bug!"-         Just sid ->-             liftIO $ atomically $ modifyTVar' sessionRef (HM.adjust modFun sid)--readSessionBase :: V.Key SessionId-                -> UserSessions conn sess st-                -> SpockAction conn sess st (Session conn sess st)-readSessionBase vK sessionRef =-    do req <- request-       case V.lookup vK (Wai.vault req) of-         Nothing ->-             error "(1) Internal Spock Session Error. Please report this bug!"-         Just sid ->-             do sessions <- liftIO $ atomically $ readTVar sessionRef-                case HM.lookup sid sessions of-                  Nothing ->-                      error "(2) Internal Spock Session Error. Please report this bug!"-                  Just session ->-                      return session--addSafeActionImpl :: V.Key SessionId-                  -> UserSessions conn sess st-                  -> PackedSafeAction conn sess st-                  -> SpockAction conn sess st SafeActionHash-addSafeActionImpl vaultKey sessionMapVar safeAction =-    do base <- readSessionBase vaultKey sessionMapVar-       case HM.lookup safeAction (sas_reverse (sess_safeActions base)) of-         Just safeActionHash ->-             return safeActionHash-         Nothing ->-             do safeActionHash <- liftIO (randomHash 40)-                let f sas =-                        sas-                        { sas_forward = HM.insert safeActionHash safeAction (sas_forward sas)-                        , sas_reverse = HM.insert safeAction safeActionHash (sas_reverse sas)-                        }-                modifySessionBase vaultKey sessionMapVar (\s -> s { sess_safeActions = f (sess_safeActions s) })-                return safeActionHash--lookupSafeActionImpl :: V.Key SessionId-                     -> UserSessions conn sess st-                     -> SafeActionHash-                     -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))-lookupSafeActionImpl vaultKey sessionMapVar hash =-    do base <- readSessionBase vaultKey sessionMapVar-       return $ HM.lookup hash (sas_forward (sess_safeActions base))--removeSafeActionImpl :: V.Key SessionId-                     -> UserSessions conn sess st-                     -> PackedSafeAction conn sess st-                     -> SpockAction conn sess st ()-removeSafeActionImpl vaultKey sessionMapVar action =-    modifySessionBase vaultKey sessionMapVar (\s -> s { sess_safeActions = f (sess_safeActions s ) })-    where-      f sas =-          sas-          { sas_forward =-              case HM.lookup action (sas_reverse sas) of-                Just h -> HM.delete h (sas_forward sas)-                Nothing -> sas_forward sas-          , sas_reverse = HM.delete action (sas_reverse sas)-          }--readSessionImpl :: V.Key SessionId-                -> UserSessions conn sess st-                -> SpockAction conn sess st sess-readSessionImpl vK sessionRef =-    do base <- readSessionBase vK sessionRef-       return (sess_data base)--writeSessionImpl :: V.Key SessionId-                 -> UserSessions conn sess st-                 -> sess-                 -> SpockAction conn sess st ()-writeSessionImpl vK sessionRef value =-    modifySessionImpl vK sessionRef (const value)--modifySessionImpl :: V.Key SessionId-                  -> UserSessions conn sess st-                  -> (sess -> sess)-                  -> SpockAction conn sess st ()-modifySessionImpl vK sessionRef f =-    do let modFun session =-                        session { sess_data = f (sess_data session) }-       modifySessionBase vK sessionRef modFun--sessionMiddleware :: SessionCfg sess-                  -> V.Key SessionId-                  -> UserSessions conn sess st-                  -> Wai.Middleware-sessionMiddleware cfg vK sessionRef app req respond =-    case getCookieFromReq (sc_cookieName cfg) of-      Just sid ->-          do mSess <- loadSessionImpl sessionRef sid-             case mSess of-               Nothing ->-                   mkNew-               Just sess ->-                   withSess False sess-      Nothing ->-          mkNew-    where-      getCookieFromReq name =-          lookup "cookie" (Wai.requestHeaders req) >>=-                 lookup name . parseCookies . T.decodeUtf8-      renderCookie name value validUntil =-          let formattedTime =-                  TL.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil-          in TL.concat [ TL.fromStrict name-                       , "="-                       , TL.fromStrict value-                       , "; path=/; expires="-                       , formattedTime-                       , ";"-                       ]-      parseCookies :: T.Text -> [(T.Text, T.Text)]-      parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words-      parseCookie = first T.init . T.breakOnEnd "="--      defVal = sc_emptySession cfg-      v = Wai.vault req-      addCookie sess responseHeaders =-          let cookieContent =-                  renderCookie (sc_cookieName cfg) (sess_id sess) (sess_validUntil sess)-              cookieC = ("Set-Cookie", BSL.toStrict $ TL.encodeUtf8 cookieContent)-          in (cookieC : responseHeaders)-      withSess shouldSetCookie sess =-          app (req { Wai.vault = V.insert vK (sess_id sess) v }) $ \unwrappedResp ->-              respond $-              if shouldSetCookie-              then mapReqHeaders (addCookie sess) unwrappedResp-              else unwrappedResp-      mkNew =-          do newSess <- newSessionImpl cfg sessionRef defVal-             withSess True newSess--newSessionImpl :: SessionCfg sess-               -> UserSessions conn sess st-               -> sess-               -> IO (Session conn sess st)-newSessionImpl sessCfg sessionRef content =-    do sess <- createSession sessCfg content-       atomically $ modifyTVar' sessionRef (\hm -> HM.insert (sess_id sess) sess hm)-       return $! sess--loadSessionImpl :: UserSessions conn sess st-                -> SessionId-                -> IO (Maybe (Session conn sess st))-loadSessionImpl sessionRef sid =-    do sessHM <- atomically $ readTVar sessionRef-       now <- getCurrentTime-       case HM.lookup sid sessHM of-         Just sess ->-             do if (sess_validUntil sess) > now-                then return $ Just sess-                else do deleteSessionImpl sessionRef sid-                        return Nothing-         Nothing ->-             return Nothing--deleteSessionImpl :: UserSessions conn sess st-                  -> SessionId-                  -> IO ()-deleteSessionImpl sessionRef sid =-    do atomically $ modifyTVar' sessionRef (\hm -> HM.delete sid hm)-       return ()--clearAllSessionsImpl :: UserSessions conn sess st-                     -> SpockAction conn sess st ()-clearAllSessionsImpl sessionRef =-    liftIO $ atomically $ modifyTVar' sessionRef (const HM.empty)--housekeepSessions :: UserSessions conn sess st -> IO ()-housekeepSessions sessionRef =-    do now <- getCurrentTime-       atomically $ modifyTVar' sessionRef (killOld now)-       threadDelay (1000 * 1000 * 60) -- 60 seconds-    where-      filterOld now (_, sess) =-          (sess_validUntil sess) > now-      killOld now hm =-          HM.fromList $ filter (filterOld now) $ HM.toList hm--createSession :: SessionCfg sess -> sess -> IO (Session conn sess st)-createSession sessCfg content =-    do sid <- randomHash (sc_sessionIdEntropy sessCfg)-       now <- getCurrentTime-       let validUntil = addUTCTime (sc_sessionTTL sessCfg) now-           emptySafeActions =-               SafeActionStore HM.empty HM.empty-       return (Session sid validUntil content emptySafeActions)--randomHash :: Int -> IO T.Text-randomHash len =-    do gen <- g-       return $ T.replace "=" "" $ T.decodeUtf8 $ B64.encode $ BSC.pack $-              take len $ randoms gen-    where-      g = newStdGen :: IO StdGen

@@ -0,0 +1,235 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+module Web.Spock.Simple+    ( -- * Spock's core+      spock, SpockM, SpockAction+    , spockT, SpockT, ActionT+    , spockApp+     -- * Defining routes+    , SpockRoute, (<#>)+     -- * Hooking routes+    , subcomponent+    , get, post, head, put, delete, patch, hookRoute+    , Http.StdMethod (..)+     -- * Handeling requests+    , request, header, cookie, body, jsonBody, jsonBody', files, UploadedFile (..)+    , params, param, param'+     -- * Sending responses+    , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', bytes, lazyBytes+    , text, html, file, json, blaze+     -- * Adding middleware+    , middleware+      -- * Database+    , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)+      -- * Accessing Database and State+    , HasSpock (runQuery, getState), SpockConn, SpockState, SpockSession+      -- * Sessions+    , SessionCfg (..)+    , readSession, writeSession, modifySession, clearAllSessions+      -- * Basic HTTP-Auth+    , requireBasicAuth+      -- * Safe actions+    , SafeAction (..)+    , safeActionPath+      -- * Digestive Functors+    , runForm+      -- * Internals for extending Spock+    , getSpockHeart, runSpockIO, WebStateM, WebState+    )+where+++import Web.Spock.Internal.CoreAction+import Web.Spock.Internal.Digestive+import Web.Spock.Internal.Monad+import Web.Spock.Internal.SessionManager+import Web.Spock.Internal.Types+import Web.Spock.Internal.Wrapper+import qualified Web.Spock.Internal.Wire as W+import qualified Web.Spock.Internal.Core as C++import Control.Applicative+import Control.Monad.Trans+import Data.Monoid+import Data.String+import Network.HTTP.Types.Method+import Prelude hiding (head)+import Web.Routing.TextRouting+import qualified Data.Text as T+import qualified Network.HTTP.Types as Http+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp++type SpockM conn sess st a = SpockT (WebStateM conn sess st) a++newtype SpockT m a+    = SpockT { runSpockT :: C.SpockAllT (TextRouter (ActionT m) ()) m a+             } deriving (Monad, Functor, Applicative, MonadIO)++instance MonadTrans SpockT where+    lift = SpockT . lift++newtype SpockRoute+    = SpockRoute { _unSpockRoute :: T.Text }+    deriving (Eq, Ord, Show, Read, IsString)++-- | Run a spock application using the warp server, a given db storageLayer and an initial state.+-- Spock works with database libraries that already implement connection pooling and+-- with those that don't come with it out of the box. For more see the 'PoolOrConn' type.+spock :: Int -> SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO ()+spock port sessCfg poolOrConn initSt spockAppl =+    spockAll TextRouter port sessCfg poolOrConn initSt (runSpockT spockAppl')+    where+      spockAppl' =+          do hookSafeActions+             spockAppl++-- | Run a raw spock application with custom underlying monad+spockT :: (MonadIO m)+       => Warp.Port+       -> (forall a. m a -> IO a)+       -> SpockT m ()+       -> IO ()+spockT port liftFun (SpockT app) =+    C.spockAllT TextRouter port liftFun app++-- | Convert a Spock-App to a wai-application+spockApp :: (MonadIO m) => (forall a. m a -> IO a) -> SpockT m () -> IO Wai.Application+spockApp liftFun (SpockT app) =+    W.buildApp TextRouter liftFun app++-- | Combine two route components safely+-- "/foo" <#> "/bar" ===> "/foo/bar"+-- "foo" <#> "bar" ===> "/foo/bar"+-- "foo <#> "/bar" ===> "/foo/bar"+(<#>) :: SpockRoute -> SpockRoute -> SpockRoute+(SpockRoute t) <#> (SpockRoute t') = SpockRoute $ combineRoute t t'++-- | Specify an action that will be run when the HTTP verb 'GET' and the given route match+get :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()+get = hookRoute GET++-- | Specify an action that will be run when the HTTP verb 'POST' and the given route match+post :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()+post = hookRoute POST++-- | Specify an action that will be run when the HTTP verb 'HEAD' and the given route match+head :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()+head = hookRoute HEAD++-- | Specify an action that will be run when the HTTP verb 'PUT' and the given route match+put :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()+put = hookRoute PUT++-- | Specify an action that will be run when the HTTP verb 'DELETE' and the given route match+delete :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()+delete = hookRoute DELETE++-- | Specify an action that will be run when the HTTP verb 'PATCH' and the given route match+patch :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m ()+patch = hookRoute PATCH++-- | Specify an action that will be run when a HTTP verb and the given route match+hookRoute :: Monad m => StdMethod -> SpockRoute -> ActionT m () -> SpockT m ()+hookRoute m (SpockRoute path) action = SpockT $ C.hookRoute m (TextRouterPath path) (TAction action)++-- | Define a subcomponent. Usage example:+--+-- > subcomponent "/site" $+-- >   do get "/home" homeHandler+-- >      get "/misc/:param" $ -- ...+-- > subcomponent "/admin" $+-- >   do get "/home" adminHomeHandler+--+-- The request /site/home will be routed to homeHandler and the+-- request /admin/home will be routed to adminHomeHandler+subcomponent :: Monad m => SpockRoute -> SpockT m () -> SpockT m ()+subcomponent (SpockRoute p) (SpockT subapp) = SpockT $ C.subcomponent (TextRouterPath p) subapp++-- | Hook wai middleware into Spock+middleware :: Monad m => Wai.Middleware -> SpockT m ()+middleware = SpockT . C.middleware++-- | Write to the current session. Note that all data is stored on the server.+-- The user only reciedes a sessionId to be identified.+writeSession :: sess -> SpockAction conn sess st ()+writeSession d =+    do mgr <- getSessMgr+       (sm_writeSession mgr) d++-- | Modify the stored session+modifySession :: (sess -> sess) -> SpockAction conn sess st ()+modifySession f =+    do mgr <- getSessMgr+       (sm_modifySession mgr) f++-- | Read the stored session+readSession :: SpockAction conn sess st sess+readSession =+    do mgr <- getSessMgr+       sm_readSession mgr++-- | Globally delete all existing sessions. This is useful for example if you want+-- to require all users to relogin+clearAllSessions :: SpockAction conn sess st ()+clearAllSessions =+    do mgr <- getSessMgr+       sm_clearAllSessions mgr++-- | Wire up a safe action: Safe actions are actions that are protected from+-- csrf attacks. Here's a usage example:+--+-- > newtype DeleteUser = DeleteUser Int deriving (Hashable, Typeable, Eq)+-- >+-- > instance SafeAction Connection () () DeleteUser where+-- >    runSafeAction (DeleteUser i) =+-- >       do runQuery $ deleteUserFromDb i+-- >          redirect "/user-list"+-- >+-- > get "/user-details/:userId" $+-- >   do userId <- param' "userId"+-- >      deleteUrl <- safeActionPath (DeleteUser userId)+-- >      html $ "Click <a href='" <> deleteUrl <> "'>here</a> to delete user!"+--+-- Note that safeActions currently only support GET and POST requests.+--+safeActionPath :: forall conn sess st a.+                  ( SafeAction conn sess st a+                  , HasSpock(SpockAction conn sess st)+                  , SpockConn (SpockAction conn sess st) ~ conn+                  , SpockSession (SpockAction conn sess st) ~ sess+                  , SpockState (SpockAction conn sess st) ~ st)+               => a+               -> SpockAction conn sess st T.Text+safeActionPath safeAction =+    do mgr <- getSessMgr+       hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction)+       return $ "/h/" <> hash++hookSafeActions :: forall conn sess st.+                   ( HasSpock (SpockAction conn sess st)+                   , SpockConn (SpockAction conn sess st) ~ conn+                   , SpockSession (SpockAction conn sess st) ~ sess+                   , SpockState (SpockAction conn sess st) ~ st)+                => SpockM conn sess st ()+hookSafeActions =+    do get "/h/:spock-csurf-protection" run+       post "/h/:spock-csurf-protection" run+    where+      run =+          do Just h <- param "spock-csurf-protection"+             mgr <- getSessMgr+             mAction <- (sm_lookupSafeAction mgr) h+             case mAction of+               Nothing ->+                   do setStatus Http.status404+                      text "File not found"+               Just p@(PackedSafeAction action) ->+                   do runSafeAction action+                      (sm_removeSafeAction mgr) p

@@ -0,0 +1,11 @@+module Web.Spock.Specs.All where++import qualified Web.Spock.Specs.SimpleSpec+import qualified Web.Spock.Specs.SafeSpec++import Test.Hspec++allSpecs :: Spec+allSpecs =+    do Web.Spock.Specs.SimpleSpec.spec+       Web.Spock.Specs.SafeSpec.spec

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.Specs.FrameworkSpecHelper where++import Test.Hspec+import Test.Hspec.Wai++import qualified Network.Wai as Wai++frameworkSpec :: IO Wai.Application -> Spec+frameworkSpec app =+    with app $+    do routingSpec+       actionSpec++routingSpec :: SpecWith Wai.Application+routingSpec =+    describe "Routing Framework" $+      do it "allows root actions" $+            get "/" `shouldRespondWith` "root" { matchStatus = 200 }+         it "routes different HTTP-verbs to different actions" $+            do verbTest get "GET"+               verbTest (\p -> post p "") "POST"+               verbTest (\p -> put p "") "PUT"+               verbTest delete "DELETE"+               verbTest (\p -> patch p "") "PATCH"+         it "can extract params from routes" $+            get "/param-test/42" `shouldRespondWith` "int42" { matchStatus = 200 }+         it "can handle multiple matching routes" $+            get "/param-test/static" `shouldRespondWith` "static" { matchStatus = 200 }+    where+      verbTest verb verbVerbose =+          (verb "/verb-test")+          `shouldRespondWith` (verbVerbose { matchStatus = 200 })++actionSpec :: SpecWith Wai.Application+actionSpec =+    describe "Action Framework" $ return ()

@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Spock.Specs.SafeSpec where++import Web.Spock.Safe+import Web.Spock.Specs.FrameworkSpecHelper++import Data.Monoid+import Test.Hspec+import qualified Data.Text as T++app :: SpockT IO ()+app =+    do get root $ text "root"+       get "verb-test" $ text "GET"+       post "verb-test" $ text "POST"+       put "verb-test" $ text "PUT"+       delete "verb-test" $ text "DELETE"+       patch "verb-test" $ text "PATCH"+       get ("param-test" </> var) $ \(i :: Int) ->+           text $ "int" <> (T.pack $ show i)+       get ("param-test" </> "static") $+           text "static"++spec :: Spec+spec = describe "SafeRouting" $ frameworkSpec (spockApp id app)

@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Spock.Specs.SimpleSpec where++import Web.Spock.Simple+import Web.Spock.Specs.FrameworkSpecHelper++import Data.Monoid+import Test.Hspec+import qualified Data.Text as T++app :: SpockT IO ()+app =+    do get "/" $ text "root"+       get "/verb-test" $ text "GET"+       post "/verb-test" $ text "POST"+       put "/verb-test" $ text "PUT"+       delete "/verb-test" $ text "DELETE"+       patch "/verb-test" $ text "PATCH"+       get "/param-test/:int" $+           do Just (i :: Int) <- param "int"+              text $ "int" <> (T.pack $ show i)+       get "/param-test/static" $+           text "static"+spec :: Spec+spec = describe "SimpleRouting" $ frameworkSpec (spockApp id app)

@@ -1,142 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ExistentialQuantification #-}-module Web.Spock.Types where--import Web.Spock.Core--import Control.Applicative-import Control.Concurrent.STM-import Control.Monad.Base-import Control.Monad.Reader-import Control.Monad.Trans.Control-import Control.Monad.Trans.Resource-import Data.Hashable-import Data.Pool-import Data.Time.Clock ( UTCTime(..), NominalDiffTime )-import Data.Typeable-import Network.Wai-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T---- | Inside the SpockM monad, you may define routes and middleware.-type SpockM conn sess st = SpockT (WebStateM conn sess st)---- | The SpockAction is the monad of all route-actions. You have access--- to the database, session and state of your application.-type SpockAction conn sess st = ActionT (WebStateM conn sess st)---- | If Spock should take care of connection pooling, you need to configure--- it depending on what you need.-data PoolCfg-   = PoolCfg-   { pc_stripes :: Int-   , pc_resPerStripe :: Int-   , pc_keepOpenTime :: NominalDiffTime-   }---- | The ConnBuilder instructs Spock how to create or close a database connection.-data ConnBuilder a-   = ConnBuilder-   { cb_createConn :: IO a-   , cb_destroyConn :: a -> IO ()-   , cb_poolConfiguration :: PoolCfg-   }---- | You can feed Spock with either a connection pool, or instructions on how to build--- a connection pool. See 'ConnBuilder'-data PoolOrConn a-   = PCPool (Pool a)-   | PCConn (ConnBuilder a)---- | Configuration for the session manager-data SessionCfg a-   = SessionCfg-   { sc_cookieName :: T.Text-   , sc_sessionTTL :: NominalDiffTime-   , sc_sessionIdEntropy :: Int-   , sc_emptySession :: a-   }--data WebState conn sess st-   = WebState-   { web_dbConn :: Pool conn-   , web_sessionMgr :: SessionManager conn sess st-   , web_state :: st-   }--class HasSpock m where-    type SpockConn m :: *-    type SpockState m :: *-    type SpockSession m :: *-    -- | Give you access to a database connectin from the connection pool. The connection is-    -- released back to the pool once the function terminates.-    runQuery :: (SpockConn m -> IO a) -> m a-    -- | Read the application's state. If you wish to have mutable state, you could-    -- use a 'TVar' from the STM packge.-    getState :: m (SpockState m)-    -- | Get the session manager-    getSessMgr :: m (SessionManager (SpockConn m) (SpockSession m) (SpockState m))---- | SafeActions are actions that need to be protected from csrf attacks-class (Hashable a, Eq a, Typeable a) => SafeAction conn sess st a where-    -- | The body of the safe action. Either GET or POST-    runSafeAction :: a -> SpockAction conn sess st ()--data PackedSafeAction conn sess st-    = forall a. (SafeAction conn sess st a) => PackedSafeAction { unpackSafeAction :: a }--instance Hashable (PackedSafeAction conn sess st) where-    hashWithSalt i (PackedSafeAction a) = hashWithSalt i a--instance Eq (PackedSafeAction conn sess st) where-   (PackedSafeAction a) == (PackedSafeAction b) =-       cast a == Just b--data SafeActionStore conn sess st-   = SafeActionStore-   { sas_forward :: !(HM.HashMap SafeActionHash (PackedSafeAction conn sess st))-   , sas_reverse :: !(HM.HashMap (PackedSafeAction conn sess st) SafeActionHash)-   }--type SafeActionHash = T.Text--newtype WebStateM conn sess st a = WebStateM { runWebStateM :: ReaderT (WebState conn sess st) (ResourceT IO) a }-    deriving (Monad, Functor, Applicative, MonadIO, MonadReader (WebState conn sess st))--instance MonadBase IO (WebStateM conn sess st) where-    liftBase = WebStateM . liftBase--instance MonadBaseControl IO (WebStateM conn sess st) where-    newtype StM (WebStateM conn sess st) a = WStM { unWStM :: StM (ReaderT (WebState conn sess st) (ResourceT IO)) a }-    liftBaseWith f = WebStateM . liftBaseWith $ \runInBase -> f $ liftM WStM . runInBase . runWebStateM-    restoreM = WebStateM . restoreM . unWStM--type SessionId = T.Text-data Session conn sess st-    = Session-    { sess_id :: !SessionId-    , sess_validUntil :: !UTCTime-    , sess_data :: !sess-    , sess_safeActions :: !(SafeActionStore conn sess st)-    }-instance Show (Session conn sess st) where-    show = show . sess_id--type UserSessions conn sess st =-    TVar (HM.HashMap SessionId (Session conn sess st))--data SessionManager conn sess st-   = SessionManager-   { sm_readSession :: SpockAction conn sess st sess-   , sm_writeSession :: sess -> SpockAction conn sess st ()-   , sm_modifySession :: (sess -> sess) -> SpockAction conn sess st ()-   , sm_clearAllSessions :: SpockAction conn sess st ()-   , sm_middleware :: Middleware-   , sm_addSafeAction :: PackedSafeAction conn sess st -> SpockAction conn sess st SafeActionHash-   , sm_lookupSafeAction :: SafeActionHash -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))-   , sm_removeSafeAction :: PackedSafeAction conn sess st -> SpockAction conn sess st ()-   }

@@ -1,12 +0,0 @@-module Web.Spock.Util where--import Network.HTTP.Types-import Network.Wai.Internal--mapReqHeaders :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response-mapReqHeaders f resp =-    case resp of-      (ResponseFile s h b1 b2) -> ResponseFile s (f h) b1 b2-      (ResponseBuilder s h b) -> ResponseBuilder s (f h) b-      (ResponseStream s h b) -> ResponseStream s (f h) b-      (ResponseRaw x r) -> ResponseRaw x (mapReqHeaders f r)

@@ -1,285 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Web.Spock.Wire where--import Web.Spock.Routing--import Control.Applicative-import Control.Exception-import Control.Monad.RWS.Strict-import Control.Monad.Error-import Control.Monad.Reader.Class ()-import Control.Monad.Trans.Resource-import Data.Hashable-import Data.Maybe-import Network.HTTP.Types.Method-import Network.HTTP.Types.Status-#if MIN_VERSION_base(4,6,0)-import Prelude-#else-import Prelude hiding (catch)-#endif-import System.Directory-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import qualified Data.CaseInsensitive as CI-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Network.Wai as Wai-import qualified Network.Wai.Parse as P--instance Hashable StdMethod where-    hashWithSalt = hashUsing fromEnum--type SpockRoutingTree m = RoutingTree (ActionT m ())-type SpockTreeMap m = HM.HashMap StdMethod (SpockRoutingTree m)--type SpockRouteMap m = HM.HashMap StdMethod (HM.HashMap T.Text (ActionT m ()))--data SpockState m-   = SpockState-   { ss_treeMap :: !(SpockRouteMap m)-   , ss_middleware :: [Wai.Middleware]-   , ss_spockLift :: forall a. m a -> IO a-   }--data UploadedFile-   = UploadedFile-   { uf_name :: T.Text-   , uf_contentType :: T.Text-   , uf_tempLocation :: FilePath-   }--data RequestInfo-   = RequestInfo-   { ri_request :: Wai.Request-   , ri_params :: HM.HashMap CaptureVar T.Text-   , ri_queryParams :: [(T.Text, T.Text)]-   , ri_files :: HM.HashMap T.Text UploadedFile-   }--data ResponseBody-   = ResponseFile FilePath-   | ResponseLBS BSL.ByteString-   | ResponseRedirect T.Text-   deriving (Show, Eq)--data ResponseState-   = ResponseState-   { rs_responseHeaders :: [(T.Text, T.Text)]-   , rs_status :: Status-   , rs_responseBody :: ResponseBody-   } deriving (Show, Eq)--type BaseRoute = T.Text--data ActionInterupt-    = ActionRedirect T.Text-    | ActionTryNext-    | ActionError String-    | ActionDone-    deriving (Show)--instance Error ActionInterupt where-    noMsg = ActionError "Unkown Internal Action Error"-    strMsg = ActionError--newtype ActionT m a-    = ActionT { runActionT :: ErrorT ActionInterupt (RWST RequestInfo () ResponseState m) a }-      deriving (Monad, Functor, Applicative, MonadIO, MonadReader RequestInfo, MonadState ResponseState, MonadError ActionInterupt)--instance MonadTrans ActionT where-    lift = ActionT . lift . lift--newtype SpockT (m :: * -> *) a-    = SpockT { runSpockT :: RWST BaseRoute () (SpockState m) m a }-      deriving (Monad, Functor, Applicative, MonadIO, MonadReader BaseRoute, MonadState (SpockState m))--instance MonadTrans SpockT where-    lift = SpockT . lift--respStateToResponse :: ResponseState -> Wai.Response-respStateToResponse (ResponseState headers status body) =-    case body of-      ResponseFile fp ->-          Wai.responseFile status waiHeaders fp Nothing-      ResponseLBS bsl ->-          Wai.responseLBS status waiHeaders bsl-      ResponseRedirect target ->-          Wai.responseLBS status302 (("Location", T.encodeUtf8 target) : waiHeaders) BSL.empty-    where-      waiHeaders = map (\(k, v) -> (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v)) headers--errorResponse :: Status -> BSL.ByteString -> ResponseState-errorResponse s e =-    ResponseState-    { rs_responseHeaders = [("Content-Type", "text/html")]-    , rs_status = s-    , rs_responseBody =-        ResponseLBS $-        BSL.concat [ "<html><head><title>"-                   , e-                   , "</title></head><body><h1>"-                   , e-                   , "</h1></body></html>"-                   ]-    }--notFound :: Wai.Response-notFound =-    respStateToResponse $ errorResponse status404 "404 - File not found"--invalidReq :: Wai.Response-invalidReq =-    respStateToResponse $ errorResponse status400 "400 - Bad request"--serverError :: ResponseState-serverError =-    errorResponse status500 "500 - Internal Server Error!"--buildApp :: forall m. (MonadIO m)-         => (forall a. m a -> IO a)-         -> SpockT m ()-         -> IO Wai.Application-buildApp spockLift spockActions =-    do let initState =-               SpockState-               { ss_treeMap = HM.empty-               , ss_middleware = []-               , ss_spockLift = spockLift-               }-       (spockState, ()) <- spockLift $ execRWST (runSpockT spockActions) "/" initState-       let spockMiddleware = foldl (.) id (ss_middleware spockState)-           routingTreeMap = buildRoutingTree (ss_treeMap spockState)-           app :: Wai.Application-           app req respond =-            case parseMethod $ Wai.requestMethod req of-              Left _ ->-                  respond invalidReq-              Right stdMethod ->-                  case HM.lookup stdMethod routingTreeMap of-                    Just routeTree ->-                        runResourceT $-                        withInternalState $ \st ->-                            do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req-                               let uploadedFiles =-                                       HM.fromList $-                                         map (\(k, fileInfo) ->-                                                  ( T.decodeUtf8 k-                                                  , UploadedFile (T.decodeUtf8 $ P.fileName fileInfo) (T.decodeUtf8 $ P.fileContentType fileInfo) (P.fileContent fileInfo)-                                                  )-                                             ) bodyFiles-                                   postParams =-                                       map (\(k, v) -> (T.decodeUtf8 k, T.decodeUtf8 v)) bodyParams-                                   getParams =-                                       map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req-                                   queryParams = postParams ++ getParams-                                   resp = errorResponse status200 ""-                                   allActions = matchRoute' (Wai.pathInfo req) routeTree--                                   applyAction :: [(ParamMap, ActionT m ())] -> m ResponseState-                                   applyAction [] =-                                       return $ errorResponse status404 "404 - File not found"-                                   applyAction ((captures, selectedAction) : xs) =-                                       do let env = RequestInfo req captures queryParams uploadedFiles-                                          (r, respState, _) <--                                              runRWST (runErrorT $ runActionT $ selectedAction) env resp-                                          case r of-                                            Left (ActionRedirect loc) ->-                                                return $ ResponseState (rs_responseHeaders respState)-                                                       status302 (ResponseRedirect loc)-                                            Left ActionTryNext ->-                                                applyAction xs-                                            Left (ActionError errorMsg) ->-                                                do liftIO $ putStrLn $ "Spock Error while handeling "-                                                              ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg-                                                   return serverError-                                            Left ActionDone ->-                                                return respState-                                            Right () ->-                                                return respState-                               respState <--                                   liftIO $-                                   (spockLift $ applyAction allActions)-                                     `catch` \(e :: SomeException) ->-                                         do putStrLn $ "Spock Error while handeling " ++ show (Wai.pathInfo req) ++ ": " ++ show e-                                            return serverError-                               forM_ (HM.elems uploadedFiles) $ \uploadedFile ->-                                   do stillThere <- doesFileExist (uf_tempLocation uploadedFile)-                                      when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile)-                               liftIO $ respond $ respStateToResponse respState-                    Nothing ->-                        respond notFound-       return $ spockMiddleware $ app---- | Hook up a 'Wai.Middleware'-middleware :: MonadIO m => Wai.Middleware -> SpockT m ()-middleware mw =-    modify $ \st -> st { ss_middleware = (ss_middleware st ++ [mw]) }---- | Define a route matching a provided 'StdMethod' and route-defRoute :: (MonadIO m) => StdMethod -> T.Text -> ActionT m () -> SpockT m ()-defRoute method route action =-    do baseRoute <- ask-       let fullRoute = baseRoute `combineRoute` route-       modify $ \st -> st { ss_treeMap = HM.insertWith HM.union method (HM.singleton fullRoute action) (ss_treeMap st) }---- | Combine two routes, ensuring that the slashes don't get messed up-combineRoute :: T.Text -> T.Text -> T.Text-combineRoute r1 r2 =-    case T.uncons r1 of-      Nothing -> T.concat ["/", r2']-      Just ('/', _) -> T.concat [r1', r2']-      Just _ -> T.concat ["/", r1', r2']-    where-      r1' =-          if T.last r1 == '/'-          then r1-          else if T.null r2-               then r1-               else T.concat [r1, "/"]-      r2' =-          if T.null r2-          then ""-          else if T.head r2 == '/' then T.drop 1 r2 else r2---- | Define a subcomponent------ > subcomponent "/api" $--- >    do get "/user" $ text "USER"--- >       post "/new-user" $ text "OK!"------ >>> curl http://localhost:8080/api/user--- USER----subcomponent :: (MonadIO m) => T.Text -> SpockT m a -> SpockT m a-subcomponent baseRoute defs =-    do parentState <- get-       parentRoute <- ask-       let initState =-               parentState-               { ss_treeMap = HM.empty-               , ss_middleware = []-               }-       (a, finalState, ()) <--           liftIO $ (ss_spockLift parentState) $-           runRWST (runSpockT defs) (parentRoute `combineRoute` baseRoute) initState-       modify $ \st ->-           st-           { ss_treeMap = HM.unionWith HM.union (ss_treeMap st) (ss_treeMap finalState)-           , ss_middleware = (ss_middleware st) ++ (ss_middleware finalState)-           }-       return a--buildRoutingTree :: SpockRouteMap m -> SpockTreeMap m-buildRoutingTree routeMap =-    HM.map (\v -> foldl treeBuilder emptyRoutingTree $ HM.toList v) routeMap-    where-      treeBuilder tree (route, action) =-          addToRoutingTree route action tree

@@ -1,1 +1,5 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+import Test.Hspec+import Web.Spock.Specs.All++main :: IO ()+main = hspec allSpecs

@@ -1,109 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Web.Spock.RoutingSpec (spec) where--import Test.Hspec--import Web.Spock.Routing-import qualified Data.Vector as V-import qualified Data.HashMap.Strict as HM--spec :: Spec-spec =-    do matchNodeDesc-       matchRouteDesc-       parseRouteNodeDesc-       addToRoutingTreeDesc--matchNodeDesc :: Spec-matchNodeDesc =-    describe "matchNode" $-    do it "shouldn't match to root node" $-          matchNode "foo" RouteNodeRoot `shouldBe` (False, Nothing)-       it "should capture basic variables" $-          matchNode "123" (RouteNodeCapture (CaptureVar "x")) `shouldBe` (True, Just (CaptureVar "x", "123"))-       it "should work with regex" $-          matchNode "123" (RouteNodeRegex (CaptureVar "x") (buildRegex "^[0-9]+$")) `shouldBe` (True, Just (CaptureVar "x", "123"))--matchRouteDesc :: Spec-matchRouteDesc =-    describe "matchRoute" $-    do it "shouldn't match unknown routes" $-          do matchRoute "random" routingTree `shouldBe` noMatches-             matchRoute "/baz" routingTree `shouldBe` noMatches-       it "should match known routes" $-          do matchRoute "/" routingTree `shouldBe` oneMatch emptyParamMap [1]-             matchRoute "/bar" routingTree `shouldBe` oneMatch emptyParamMap [2]-       it "should capture variables in routes" $-          do matchRoute "/bar/5" routingTree `shouldBe` oneMatch (vMap [("baz", "5")]) [3]-             matchRoute "/bar/23/baz" routingTree `shouldBe` oneMatch (vMap [("baz", "23")]) [4]-             matchRoute "/bar/23/baz/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4]-             matchRoute "/ba/23/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4]-             matchRoute "/entry/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [6]-             matchRoute "/entry/bytags/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [7]-             matchRoute "/entry/2/rel/3" routingTree `shouldBe` oneMatch (vMap [("eid", "2"), ("cid", "3")]) [9]-       it "should handle multiple possibile matches correctly" $-          do matchRoute "/bar/bingo" routingTree `shouldBe` multiMatch-             matchRoute "/entry/1/audit" routingTree `shouldBe` multiMatch'-    where-      vMap kv =-          HM.fromList $ map (\(k, v) -> (CaptureVar k, v)) kv-      multiMatch =-          ((oneMatch emptyParamMap [5])-            ++ oneMatch (vMap [("baz", "bingo")]) [3])-      multiMatch' =-          ((oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6])-           ++ (oneMatch (vMap [("eid", "1")]) [8]))-      noMatches = []-      oneMatch pm m = [(pm, m)]-      routingTree =-          foldl (\tree (route, action) -> addToRoutingTree route action tree) emptyRoutingTree routes-      routes =-          [ ("/", [1])-          , ("/bar", [2 :: Int])-          , ("/bar/:baz", [3])-          , ("/bar/bingo", [5])-          , ("/bar/:baz/baz", [4])-          , ("/bar/:baz/baz/:bim", [4])-          , ("/ba/:baz/:bim", [4])-          , ("/entry/:cid/:since", [6])-          , ("/entry/bytags/:cid/:since", [7])-          , ("/entry/:eid/audit", [8])-          , ("/entry/:eid/rel/:cid", [9])-          ]--parseRouteNodeDesc :: Spec-parseRouteNodeDesc =-    describe "parseRouteNode" $-    do it "parses text nodes correctly" $-          parseRouteNode "foo" `shouldBe` RouteNodeText "foo"-       it "parses capture variables" $-          parseRouteNode ":bar" `shouldBe` RouteNodeCapture (CaptureVar "bar")-       it "parses regex capture variables" $-          parseRouteNode "{bar:^[0-9]$}" `shouldBe` RouteNodeRegex (CaptureVar "bar") (buildRegex "^[0-9]$")--addToRoutingTreeDesc :: Spec-addToRoutingTreeDesc =-    describe "addToRoutingTree" $-    do it "adds the root node correctly" $-          addToRoutingTree "/" [True] emptyT `shouldBe` baseRoute-       it "adds a new branch correctly" $-          addToRoutingTree "/foo/:bar" [True] emptyT `shouldBe` fooBar []-       it "add a new subbranch correctly" $-          addToRoutingTree "/foo/:bar/baz" [True] (fooBar []) `shouldBe` fooBar baz-    where-      emptyT = emptyRoutingTree-      baseRoute = RoutingTree { rt_node = RouteData{rd_node = RouteNodeRoot, rd_data = Just [True]}, rt_children = V.empty}-      baz = [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeText "baz", rd_data = Just [True] },rt_children = V.empty }]-      fooBar xs =-          RoutingTree-          { rt_node =-                RouteData {rd_node = RouteNodeRoot, rd_data = Nothing }-          , rt_children =-              V.fromList-                   [ RoutingTree { rt_node = RouteData{rd_node = RouteNodeText "foo", rd_data = Nothing}-                                 , rt_children =-                                     V.fromList-                                          [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeCapture (CaptureVar "bar")-                                                                              , rd_data = Just [True]-                                                                              }-                                                        , rt_children = V.fromList xs}]}]}

@@ -1,16 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Web.Spock.WireSpec (spec) where--import Web.Spock.Wire-import Test.Hspec--spec :: Spec-spec =-    do describe "combineRoute" $-         do it "handles slashes correctly" $-               do ("/" `combineRoute`  "foo") `shouldBe` "/foo"-                  ("" `combineRoute`  "foo") `shouldBe` "/foo"-                  ("/" `combineRoute`  "/foo") `shouldBe` "/foo"-                  ("" `combineRoute`  "/foo") `shouldBe` "/foo"-                  ("/test" `combineRoute`  "foo") `shouldBe` "/test/foo"-                  ("/test" `combineRoute`  "") `shouldBe` "/test"