Spock 0.9.0.1 → 0.10.0.0

raw patch · 12 files changed

+449/−137 lines, 12 filesdep ~timePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: time

API changes (from Hackage documentation)

Files

• README.md +14/−13
• Spock.cabal +5/−1
• src/Web/Spock/Internal/Cookies.hs +126/−0
• src/Web/Spock/Internal/CoreAction.hs +75/−72
• src/Web/Spock/Internal/SessionManager.hs +50/−36
• src/Web/Spock/Internal/Types.hs +2/−1
• src/Web/Spock/Internal/Wire.hs +14/−2
• src/Web/Spock/Shared.hs +17/−5
• test/Web/Spock/FrameworkSpecHelper.hs +15/−1
• test/Web/Spock/Internal/CookiesSpec.hs +92/−0
• test/Web/Spock/SafeSpec.hs +26/−3
• test/Web/Spock/SimpleSpec.hs +13/−3

@@ -50,18 +50,15 @@ * csrf-protection * typesafe contexts -Benchmarks:--* https://github.com/philopon/apiary-benchmark-* https://github.com/agrafix/Spock-scotty-benchmark- ## Important Links  * [Tutorial](https://www.spock.li/tutorial/) * [Type-safe routing in Spock](https://www.spock.li/2015/04/19/type-safe_routing.html) +* [Taking Authentication to the next Level](https://www.spock.li/2015/08/23/taking_authentication_to_the_next_level.html)  ### Talks +* English: [Beginning Web Programming in Haskell (using Spock)](https://www.youtube.com/watch?v=GobPiGL9jJ4) (by Ollie Charles) * German: [Moderne typsichere Web-Entwicklung mit Haskell](https://dl.dropboxusercontent.com/u/15078797/talks/typesafe-webdev-2015.pdf) (by Alexander Thiemann) * German: [reroute-talk](https://github.com/timjb/reroute-talk) (by Tim Baumann) @@ -81,20 +78,19 @@ * Blaze bootstrap helpers [blaze-bootstrap](http://hackage.haskell.org/package/blaze-bootstrap) * digestive-forms bootstrap helpers [digestive-bootstrap](http://hackage.haskell.org/package/digestive-bootstrap) +### Benchmarks++Please note that these benchmarks might not be up to date anymore.++* https://github.com/philopon/apiary-benchmark+* https://github.com/agrafix/Spock-scotty-benchmark+ ## Example Projects  * [funblog](https://github.com/agrafix/funblog) * [makeci](https://github.com/openbrainsrc/makeci) * [curry-recipes](https://github.com/timjb/reroute-talk/tree/06574561918b50c1809f1e24ec7faeff731fddcf/curry-recipes) -## Companies / Projects using Spock--* http://cp-med.com-* http://openbrain.co.uk-* http://findmelike.com-* https://www.tramcloud.net-* http://thitp.de- ## Notes  Since version 0.7.0.0 Spock supports typesafe routing. If you wish to continue using the untyped version of Spock you can Use `Web.Spock.Simple`. The implementation of the routing is implemented in a separate haskell package called `reroute`.@@ -107,6 +103,11 @@  * Tim Baumann [Github](https://github.com/timjb) (lot's of help with typesafe routing) * Tom Nielsen [Github](https://github.com/glutamate)  (much feedback and small improvements)+* ... and all other awesome [contributors](https://github.com/agrafix/Spock/graphs/contributors)!++## Hacking++Pull requests are welcome! Please consider creating an issue beforehand, so we can discuss what you would like to do. Code should be written in a consistent style throughout the project. Avoid whitespace that is sensible to conflicts. (E.g. alignment of `=` signs in functions definitions) Note that by sending a pull request you agree that your contribution can be released under the BSD3 License as part of the `Spock` package or related packages.   ## Misc

@@ -1,5 +1,5 @@ name:                Spock-version:             0.9.0.1+version:             0.10.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:                      .@@ -37,6 +37,7 @@   hs-source-dirs:      src   exposed-modules:                        Web.Spock,+                       Web.Spock.Internal.Cookies,                        Web.Spock.Internal.Util,                        Web.Spock.Internal.SessionVault,                        Web.Spock.Safe,@@ -90,6 +91,7 @@   main-is:             Spec.hs   other-modules:                        Web.Spock.FrameworkSpecHelper,+                       Web.Spock.Internal.CookiesSpec,                        Web.Spock.Internal.UtilSpec,                        Web.Spock.Internal.SessionVaultSpec,                        Web.Spock.SafeSpec,@@ -97,6 +99,7 @@   build-depends:                        base,                        bytestring,+                       base64-bytestring >=1.0,                        hspec >= 2.0,                        hspec-wai >= 0.6,                        http-types,@@ -104,6 +107,7 @@                        stm,                        reroute,                        text,+                       time,                        unordered-containers,                        wai,                        wai-extra

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

@@ -2,21 +2,25 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RecordWildCards #-} module Web.Spock.Internal.CoreAction     ( ActionT     , UploadedFile (..)     , request, header, rawHeader, cookie, body, jsonBody, jsonBody'     , reqMethod     , files, params, param, param', setStatus, setHeader, redirect+    , setRawMultiHeader+    , CookieSettings(..), CookieEOL(..), defaultCookieSettings+    , setCookie, deleteCookie     , jumpNext, middlewarePass, modifyVault, queryVault-    , setCookie, setCookie', deleteCookie     , bytes, lazyBytes, text, html, file, json, stream, response-    , requireBasicAuth+    , requireBasicAuth, withBasicAuthData     , getContext, runInContext     , preferredFormat, ClientPreferredFormat(..)     ) where +import Web.Spock.Internal.Cookies import Web.Spock.Internal.Util import Web.Spock.Internal.Wire @@ -31,16 +35,13 @@ import Control.Monad.RWS.Strict (runRWST) import Control.Monad.State hiding (get, put) import qualified Control.Monad.State as ST+import Data.Maybe import Data.Monoid import Data.Time import Network.HTTP.Types.Header (HeaderName, ResponseHeaders) import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Prelude hiding (head)-#if MIN_VERSION_time(1,5,0)-#else-import System.Locale (defaultTimeLocale)-#endif import Web.PathPieces import Web.Routing.AbstractRouter import qualified Data.Aeson as A@@ -71,15 +72,11 @@     liftM (lookup t . Wai.requestHeaders) request {-# INLINE rawHeader #-} --- | Read a cookie+-- | Read a cookie. The cookie value will already be urldecoded. cookie :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text) cookie name =     do req <- request-       return $ lookup "cookie" (Wai.requestHeaders req) >>= lookup name . parseCookies . 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 "="+       return $ lookup "cookie" (Wai.requestHeaders req) >>= lookup name . parseCookies {-# INLINE cookie #-}  -- | Tries to dected the preferred format of the response using the Accept header@@ -117,13 +114,13 @@        return $ A.decodeStrict b {-# INLINE jsonBody #-} --- | Parse the request body as json and fails with 500 status code on error+-- | Parse the request body as json and fails with 400 status code on error jsonBody' :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m a jsonBody' =     do b <- body        case A.eitherDecodeStrict' b of          Left err ->-             do setStatus status500+             do setStatus status400                 text (T.pack $ "Failed to parse json: " ++ err)          Right val ->              return val@@ -183,36 +180,44 @@ -- be appended. Otherwise the previous value is overwritten. -- See 'setMultiHeader'. setHeader :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()-setHeader k v =-    do let ciVal = CI.mk $ T.encodeUtf8 k-       case HM.lookup ciVal multiHeaderMap of+setHeader k v = setRawHeader (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v)+{-# INLINE setHeader #-}++setRawHeader :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()+setRawHeader k v =+    do case HM.lookup k multiHeaderMap of          Just mhk ->-             setMultiHeader mhk v+             setRawMultiHeader mhk v          Nothing ->-             setHeaderUnsafe k v-{-# INLINE setHeader #-}+             setRawHeaderUnsafe k v  -- | INTERNAL: Set a response header that can occur multiple times. (eg: Cache-Control) setMultiHeader :: MonadIO m => MultiHeader -> T.Text -> ActionCtxT ctx m ()-setMultiHeader k v =+setMultiHeader k v = setRawMultiHeader k (T.encodeUtf8 v)+{-# INLINE setMultiHeader #-}++setRawMultiHeader :: MonadIO m => MultiHeader -> BS.ByteString -> ActionCtxT ctx m ()+setRawMultiHeader k v =     modify $ \rs ->         rs         { rs_multiResponseHeaders =-              HM.insertWith (++) k [T.encodeUtf8 v] (rs_multiResponseHeaders rs)+              HM.insertWith (++) k [v] (rs_multiResponseHeaders rs)         }-{-# INLINE setMultiHeader #-}  -- | INTERNAL: Unsafely set a header (no checking if the header can occur multiple times) setHeaderUnsafe :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()-setHeaderUnsafe k v =+setHeaderUnsafe k v = setRawHeaderUnsafe (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v)+{-# INLINE setHeaderUnsafe #-}++-- | INTERNAL: Unsafely set a header (no checking if the header can occur multiple times)+setRawHeaderUnsafe :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()+setRawHeaderUnsafe k v =     modify $ \rs ->         rs         { rs_responseHeaders =-              HM.insert (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v) (rs_responseHeaders rs)+              HM.insert k v (rs_responseHeaders rs)         }-{-# INLINE setHeaderUnsafe #-} - -- | Abort the current action and jump the next one matching the route jumpNext :: MonadIO m => ActionCtxT ctx m a jumpNext = throwError ActionTryNext@@ -245,36 +250,6 @@        liftIO $ vi_lookupKey vaultIf k {-# INLINE queryVault #-} --- | Set a cookie living for a given number of seconds-setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionCtxT ctx m ()-setCookie name value validSeconds =-    do now <- liftIO getCurrentTime-       setCookie' name value (validSeconds `addUTCTime` now)-{-# INLINE setCookie #-}--deleteCookie :: MonadIO m => T.Text -> ActionCtxT ctx m ()-deleteCookie name = setCookie' name T.empty epoch-  where-    epoch = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0)-{-# INLINE deleteCookie #-}---- | Set a cookie living until a specific 'UTCTime'-setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionCtxT ctx m ()-setCookie' name value validUntil =-    setMultiHeader MultiHeaderSetCookie rendered-    where-      rendered =-          let formattedTime =-                  T.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil-          in T.concat [ name-                      , "="-                      , value-                      , "; path=/; expires="-                      , formattedTime-                      , ";"-                      ]-{-# INLINE setCookie' #-}- -- | Use a custom 'Wai.Response' generator as response body. response :: MonadIO m => (Status -> ResponseHeaders -> Wai.Response) -> ActionCtxT ctx m a response val =@@ -328,35 +303,47 @@     response $ \status headers -> Wai.responseStream status headers val {-# INLINE stream #-} --- | Basic authentification+-- | Convenience 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 ;-)"+-- > get ("auth" <//> var <//> var) $ \user pass ->+-- >       let checker user' pass' =+-- >               unless (user == user' && pass == pass') $+-- >               do setStatus status401+-- >                  text "err"+-- >       in requireBasicAuth "Foo" checker $ \() -> text "ok" ---requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> m Bool) -> ActionCtxT ctx m a -> ActionCtxT ctx m a+requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> ActionCtxT ctx m b) -> (b -> ActionCtxT ctx m a) -> ActionCtxT ctx m a requireBasicAuth realmTitle authFun cont =+    withBasicAuthData $ \mAuthHeader ->+    case mAuthHeader of+      Nothing ->+          authFailed Nothing+      Just (user, pass) ->+          authFun user pass >>= cont+    where+      authFailed mMore =+          do setStatus status401+             setMultiHeader MultiHeaderWWWAuth ("Basic realm=\"" <> realmTitle <> "\"")+             text $ "Authentication required. " <> fromMaybe "" mMore++-- | "Lower level" basic authentification handeling. Does not set any headers that will promt+-- browser users, only looks for an "Authorization" header in the request and breaks it into+-- username and passwort component if present+withBasicAuthData :: MonadIO m => (Maybe (T.Text, T.Text) -> ActionCtxT ctx m a) -> ActionCtxT ctx m a+withBasicAuthData handler =     do mAuthHeader <- header "Authorization"        case mAuthHeader of          Nothing ->-             authFailed+             handler Nothing          Just authHeader ->              let (_, rawValue) =                      T.breakOn " " authHeader                  (user, rawPass) =                      (T.breakOn ":" . T.decodeUtf8 . B64.decodeLenient . T.encodeUtf8 . T.strip) rawValue                  pass = T.drop 1 rawPass-             in do isOk <- lift $ authFun user pass-                   if isOk-                   then cont-                   else authFailed-    where-      authFailed =-          do setStatus status401-             setMultiHeader MultiHeaderWWWAuth ("Basic realm=\"" <> realmTitle <> "\"")-             html "<h1>Authentication required.</h1>"+             in handler (Just (user, pass))  -- | Get the context of the current request getContext :: MonadIO m => ActionCtxT ctx m ctx@@ -381,3 +368,19 @@              throwError interupt          Right d -> return d {-# INLINE runInContext #-}++-- | Set a cookie. The cookie value will be urlencoded.+setCookie :: MonadIO m => T.Text -> T.Text -> CookieSettings -> ActionCtxT ctx m ()+setCookie name value cs =+    do now <- liftIO getCurrentTime+       let cookieHeaderString = generateCookieHeaderString name value cs now+       setRawMultiHeader MultiHeaderSetCookie cookieHeaderString+{-# INLINE setCookie #-}++-- | Delete a cookie+deleteCookie :: MonadIO m => T.Text -> ActionCtxT ctx m ()+deleteCookie name = setCookie name T.empty cs+  where+    cs = defaultCookieSettings { cs_EOL = CookieValidUntil epoch }+    epoch = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0)+{-# INLINE deleteCookie #-}

@@ -8,10 +8,11 @@  import Web.Spock.Internal.Types import Web.Spock.Internal.CoreAction+import Web.Spock.Internal.Wire import Web.Spock.Internal.Util+import Web.Spock.Internal.Cookies import qualified Web.Spock.Internal.SessionVault as SV -import Control.Arrow (first) #if MIN_VERSION_base(4,8,0) #else import Control.Applicative@@ -27,13 +28,11 @@ import System.Locale (defaultTimeLocale) #endif import qualified Crypto.Random as CR+import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64-import qualified Data.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 @@ -55,6 +54,7 @@        return           SessionManager           { sm_getSessionId = getSessionIdImpl vaultKey cacheHM+          , sm_regenerateSessionId = regenerateSessionIdImpl vaultKey cacheHM pool cfg           , sm_readSession = readSessionImpl vaultKey cacheHM           , sm_writeSession = writeSessionImpl vaultKey cacheHM           , sm_modifySession = modifySessionImpl vaultKey cacheHM@@ -88,6 +88,20 @@           , sess_safeActions = SafeActionStore HM.empty HM.empty           } +regenerateSessionIdImpl ::+    V.Key SessionId+    -> SV.SessionVault (Session conn sess st)+    -> CR.EntropyPool+    -> SessionCfg sess+    -> SpockActionCtx ctx conn sess st ()+regenerateSessionIdImpl vK sessionRef entropyPool cfg =+    do sess <- readSessionBase vK sessionRef+       liftIO $ deleteSessionImpl sessionRef (sess_id sess)+       newSession <- liftIO $ newSessionImpl entropyPool cfg sessionRef (sess_data sess)+       now <- liftIO getCurrentTime+       setRawMultiHeader MultiHeaderSetCookie $ makeSessionIdCookie cfg newSession now+       modifyVault $ V.insert vK (sess_id newSession)+ getSessionIdImpl :: V.Key SessionId                  -> SV.SessionVault (Session conn sess st)                  -> SpockActionCtx ctx conn sess st SessionId@@ -100,8 +114,8 @@                   -> (Session conn sess st -> (Session conn sess st, a))                   -> SpockActionCtx ctx conn sess st a modifySessionBase vK sessionRef modFun =-    do req <- request-       case V.lookup vK (Wai.vault req) of+    do mValue <- queryVault vK+       case mValue of          Nothing ->              error "(3) Internal Spock Session Error. Please report this bug!"          Just sid ->@@ -119,8 +133,8 @@                 -> SV.SessionVault (Session conn sess st)                 -> SpockActionCtx ctx conn sess st (Session conn sess st) readSessionBase vK sessionRef =-    do req <- request-       case V.lookup vK (Wai.vault req) of+    do mValue <- queryVault vK+       case mValue of          Nothing ->              error "(1) Internal Spock Session Error. Please report this bug!"          Just sid ->@@ -160,10 +174,11 @@     do base <- readSessionBase vaultKey sessionMapVar        return $ HM.lookup hash (sas_forward (sess_safeActions base)) -removeSafeActionImpl :: V.Key SessionId-                     -> SV.SessionVault (Session conn sess st)-                     -> PackedSafeAction conn sess st-                     -> SpockActionCtx ctx conn sess st ()+removeSafeActionImpl ::+    V.Key SessionId+    -> SV.SessionVault (Session conn sess st)+    -> PackedSafeAction conn sess st+    -> SpockActionCtx ctx conn sess st () removeSafeActionImpl vaultKey sessionMapVar action =     modifySessionBase vaultKey sessionMapVar (\s -> (s { sess_safeActions = f (sess_safeActions s ) }, ()))     where@@ -200,6 +215,18 @@                in (session { sess_data = sessData' }, out)        modifySessionBase vK sessionRef modFun +makeSessionIdCookie :: SessionCfg sess -> Session conn sess st -> UTCTime -> BS.ByteString+makeSessionIdCookie cfg sess now =+    generateCookieHeaderString name value settings now+    where+      name = sc_cookieName cfg+      value = sess_id sess+      settings =+          defaultCookieSettings+          { cs_EOL = CookieValidUntil (sess_validUntil sess)+          , cs_HTTPOnly = True+          }+ sessionMiddleware ::     CR.EntropyPool     -> SessionCfg sess@@ -220,34 +247,20 @@     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 "="-+                 lookup name . parseCookies       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)+      addCookie sess now responseHeaders =+          let cookieContent = makeSessionIdCookie cfg sess now+              cookieC = ("Set-Cookie", cookieContent)           in (cookieC : responseHeaders)       withSess shouldSetCookie sess =           app (req { Wai.vault = V.insert vK (sess_id sess) v }) $ \unwrappedResp ->-              respond $-              if shouldSetCookie-              then mapReqHeaders (addCookie sess) unwrappedResp-              else unwrappedResp+              do now <- getCurrentTime+                 respond $+                   if shouldSetCookie+                   then mapReqHeaders (addCookie sess now) unwrappedResp+                   else unwrappedResp       mkNew =           do newSess <- newSessionImpl pool cfg sessionRef defVal              withSess True newSess@@ -340,4 +353,5 @@ randomHash pool len =     do let sys :: CR.SystemRNG            sys = CR.cprgCreate pool-       return $ T.replace "=" "" $ T.decodeUtf8 $ B64.encode $ fst $ CR.cprgGenerateWithEntropy len sys+       return $ T.replace "=" "" $ T.replace "/" "_" $ T.replace "+" "-" $+              T.decodeUtf8 $ B64.encode $ fst $ CR.cprgGenerateWithEntropy len sys

@@ -41,7 +41,7 @@ -- | The 'SpockAction' is a specialisation of 'SpockActionCtx' with a '()' context. type SpockAction conn sess st = SpockActionCtx () conn sess st --- | Spock configuration+-- | Spock configuration, use 'defaultSpockCfg' and change single values if needed data SpockCfg conn sess st    = SpockCfg    { spc_initialState :: st@@ -218,6 +218,7 @@ data SessionManager conn sess st    = SessionManager    { sm_getSessionId :: forall ctx. SpockActionCtx ctx conn sess st SessionId+   , sm_regenerateSessionId :: forall ctx. SpockActionCtx ctx conn sess st ()    , sm_readSession :: forall ctx. SpockActionCtx ctx conn sess st sess    , sm_writeSession :: forall ctx. sess -> SpockActionCtx ctx conn sess st ()    , sm_modifySession :: forall a ctx. (sess -> (sess, a)) -> SpockActionCtx ctx conn sess st a

@@ -206,6 +206,19 @@                    ]     } +defResponse :: ResponseState+defResponse =+    ResponseState+    { rs_responseHeaders =+          HM.empty+    , rs_multiResponseHeaders =+          HM.empty+    , rs_status = status200+    , rs_responseBody = ResponseBody $ \status headers ->+        Wai.responseLBS status headers $+        BSL.empty+    }+ notFound :: Wai.Response notFound =     respStateToResponse $ errorResponse status404 "404 - File not found"@@ -283,9 +296,8 @@     return $ Just $ errorResponse status404 "404 - File not found" applyAction req mkEnv ((captures, selectedAction) : xs) =     do let env = mkEnv captures-           defResp = errorResponse status200 ""        (r, respState, _) <--           runRWST (runErrorT $ runActionCtxT selectedAction) env defResp+           runRWST (runErrorT $ runActionCtxT selectedAction) env defResponse        case r of          Left (ActionRedirect loc) ->              return $ Just $

@@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Web.Spock.Shared     (-- * Helpers for running Spock-      runSpock, spockAsApp+      runSpock, runSpockNoBanner, spockAsApp      -- * Action types     , SpockAction, SpockActionCtx, ActionT, W.ActionCtxT      -- * Handling requests@@ -19,7 +19,7 @@      -- * Working with context     , getContext, runInContext      -- * Sending responses-    , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', deleteCookie, bytes, lazyBytes+    , setStatus, setHeader, redirect, jumpNext, CookieSettings(..), defaultCookieSettings, CookieEOL(..), setCookie, deleteCookie, bytes, lazyBytes     , text, html, file, json, stream, response       -- * Middleware helpers     , middlewarePass, modifyVault, queryVault@@ -30,13 +30,13 @@       -- * Accessing Database and State     , HasSpock (runQuery, getState), SpockConn, SpockState, SpockSession       -- * Basic HTTP-Auth-    , requireBasicAuth+    , requireBasicAuth, withBasicAuthData      -- * Sessions     , defaultSessionCfg, SessionCfg (..)     , defaultSessionHooks, SessionHooks (..)     , SessionPersistCfg(..), readShowSessionPersist     , SessionId-    , getSessionId, readSession, writeSession+    , sessionRegenerateId, getSessionId, readSession, writeSession     , modifySession, modifySession', modifyReadSession, mapAllSessions, clearAllSessions      -- * Internals for extending Spock     , getSpockHeart, runSpockIO, WebStateM, WebState@@ -54,17 +54,29 @@ import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp --- | Run a Spock application. Basically just a wrapper aroung @Warp.run@.+-- | Run a Spock application. Basically just a wrapper aroung 'Warp.run'. runSpock :: Warp.Port -> IO Wai.Middleware -> IO () runSpock port mw =     do putStrLn ("Spock is running on port " ++ show port)        app <- spockAsApp mw        Warp.run port app +-- | Like 'runSpock', but does not display the banner "Spock is running on port XXX" on stdout.+runSpockNoBanner :: Warp.Port -> IO Wai.Middleware -> IO ()+runSpockNoBanner port mw =+    do app <- spockAsApp mw+       Warp.run port app+ -- | Convert a middleware to an application. All failing requests will -- result in a 404 page spockAsApp :: IO Wai.Middleware -> IO Wai.Application spockAsApp = liftM W.middlewareToApp++-- | Regenerate the users sessionId. This preserves all stored data. Call this prior+-- to logging in a user to prevent session fixation attacks.+sessionRegenerateId :: SpockActionCtx ctx conn sess st ()+sessionRegenerateId =+    getSessMgr >>= sm_regenerateSessionId  -- | Get the current users sessionId. Note that this ID should only be -- shown to it's owner as otherwise sessions can be hijacked.

@@ -6,6 +6,10 @@  import Data.Monoid import Data.Word+import Network.HTTP.Types.Header+import Network.HTTP.Types.Method+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy.Char8 as BSLC import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -80,7 +84,17 @@  actionSpec :: SpecWith Wai.Application actionSpec =-    describe "Action Framework" $ return ()+    describe "Action Framework" $+      do it "handles auth correctly" $+            do request methodGet "/auth/user/pass" [mkAuthHeader "user" "pass"] "" `shouldRespondWith` "ok" { matchStatus = 200 }+               request methodGet "/auth/user/pass" [mkAuthHeader "user" ""] "" `shouldRespondWith` "err" { matchStatus = 401 }+               request methodGet "/auth/user/pass" [mkAuthHeader "" ""] "" `shouldRespondWith` "err" { matchStatus = 401 }+               request methodGet "/auth/user/pass" [mkAuthHeader "asd" "asd"] "" `shouldRespondWith` "err" { matchStatus = 401 }+               request methodGet "/auth/user/pass" [] "" `shouldRespondWith` "Authentication required. " { matchStatus = 401 }+    where+      mkAuthHeader :: BS.ByteString -> BS.ByteString -> Header+      mkAuthHeader user pass =+          ("Authorization", "Basic " <> (B64.encode $ user <> ":" <> pass))  cookieTest :: SpecWith Wai.Application cookieTest =

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

@@ -11,6 +11,7 @@ import Data.IORef import Data.List (find) import Data.Monoid+import Network.HTTP.Types.Status import Test.Hspec import qualified Data.HashSet as HS import qualified Data.Text as T@@ -34,11 +35,11 @@        get ("param-test" <//> "static") $            text "static"        get ("cookie" <//> "single") $-           do setCookie "single" "test" 3600+           do setCookie "single" "test" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }               text "set"        get ("cookie" <//> "multiple") $-           do setCookie "multiple1" "test1" 3600-              setCookie "multiple2" "test2" 3600+           do setCookie "multiple1" "test1" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }+              setCookie "multiple2" "test2" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }               text "set"        get "set-header" $            do setHeader "X-FooBar" "Baz"@@ -56,6 +57,12 @@             case fmt of               PrefHTML -> text "html"               x -> text (T.pack (show x))+       get ("auth" <//> var <//> var) $ \user pass ->+           let checker user' pass' =+                   unless (user == user' && pass == pass') $+                   do setStatus status401+                      text "err"+           in requireBasicAuth "Foo" checker $ \() -> text "ok"        hookAny GET $ text . T.intercalate "/"  routeRenderingSpec :: Spec@@ -114,12 +121,28 @@                Just sessCookie ->                    Test.request "GET" "/check" [("Cookie", T.encodeUtf8 sessCookie)] ""                            `Test.shouldRespondWith` "5"+       it "should regenerate and preserve all content" $+          do res <- Test.get "/set/5"+             case getSessCookie res of+               Nothing ->+                   Test.liftIO $ expectationFailure "Missing spockcookie"+               Just sessCookie ->+                   do res2 <- Test.request "GET" "/regenerate" [("Cookie", T.encodeUtf8 sessCookie)] ""+                      case getSessCookie res2 of+                        Nothing ->+                            Test.liftIO $ expectationFailure "Missing new spockcookie"+                        Just sessCookie2 ->+                            do Test.request "GET" "/check" [("Cookie", T.encodeUtf8 sessCookie2)] ""+                                       `Test.shouldRespondWith` "5"+                               Test.request "GET" "/check" [("Cookie", T.encodeUtf8 sessCookie)] ""+                                       `Test.shouldRespondWith` "0"     where       sessionApp =           spockAsApp $           spock spockCfg $           do get "test" $ text "text"              get ("set" <//> var) $ \number -> writeSession number >> text "done"+             get "regenerate" $ sessionRegenerateId >> text "done"              get "check" $                  do val <- readSession                     text (T.pack $ show val)

@@ -5,7 +5,9 @@ import Web.Spock.Simple import Web.Spock.FrameworkSpecHelper +import Control.Monad import Data.Monoid+import Network.HTTP.Types.Status import Test.Hspec import qualified Data.Text as T @@ -35,11 +37,11 @@               PrefHTML -> text "html"               x -> text (T.pack (show x))        get "/cookie/single" $-           do setCookie "single" "test" 3600+           do setCookie "single" "test" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }               text "set"        get "/cookie/multiple" $-           do setCookie "multiple1" "test1" 3600-              setCookie "multiple2" "test2" 3600+           do setCookie "multiple1" "test1" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }+              setCookie "multiple2" "test2" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }               text "set"        get "set-header" $            do setHeader "X-FooBar" "Baz"@@ -48,6 +50,14 @@            do setHeader "Content-Language" "de"               setHeader "Content-Language" "en"               text "ok"+       get ("/auth/:user/:pass") $+           do user <- param' "user"+              pass <- param' "pass"+              let checker user' pass' =+                   unless (user == user' && pass == pass') $+                   do setStatus status401+                      text "err"+              requireBasicAuth "Foo" checker $ \() -> text "ok"        hookAny GET $ text . T.intercalate "/"  spec :: Spec