packages feed

thentos-cookie-session (empty) → 0.8.4

raw patch · 10 files changed

+725/−0 lines, 10 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, cookie, cryptonite, digestive-functors, hspec, hspec-wai, http-types, lens, memory, mtl, resourcet, sandi, servant, servant-server, string-conversions, text, thentos-cookie-session, transformers, vault, wai, wai-extra, wai-session

Files

+ LICENSE view
@@ -0,0 +1,15 @@+Thentos: A tool for privacy-preserving identity management+Copyright (C) 2015-2019 liquid democracy e.V.++This program is free software: you can redistribute it and/or modify+it under the terms of the GNU Affero General Public License as+published by the Free Software Foundation, either version 3 of the+License, or (at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+GNU Affero General Public License for more details.++You should have received a copy of the GNU Affero General Public License+along with this program.  If not, see <http://www.gnu.org/licenses/>.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Control/Monad/Except/Missing.hs view
@@ -0,0 +1,9 @@+module Control.Monad.Except.Missing where++import Control.Monad.Except (MonadError(catchError, throwError))+import Data.Functor (($>))++finally :: MonadError e m => m a -> m b -> m a+finally action finalizer = do+    a <- action `catchError` \e -> finalizer >> throwError e+    finalizer $> a
+ src/Servant/Missing.hs view
@@ -0,0 +1,169 @@+-- FIXME: create a package servant-digestive-functors and+--        choose a different module name.+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.Missing+  (ThrowServantErr(..)+  ,MonadServantErr+  ,ThrowError500(..)+  ,MonadError500+  ,FormH+  ,FormReqBody+  ,FormData, getFormDataEnv, releaseFormTempFiles+  ,formH+  ,formRedirectH+  ,fromEnvIdentity+  ,redirect) where++import Control.Lens (prism, Prism', (#))+import Control.Monad ((>=>))+import Control.Monad.Except (MonadError, throwError)+import Control.Monad.Except.Missing (finally)+import Control.Monad.Identity (Identity, runIdentity)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState)+import Data.Proxy (Proxy(Proxy))+import Data.String.Conversions (ST, SBS, ConvertibleStrings, cs)+import Network.Wai.Parse (fileContent, parseRequestBody, tempFileBackEnd)+import Servant ((:<|>)((:<|>)), (:>), ServerT, (:~>)(Nat), unNat)+import Servant.Server (ServantErr(..), err500)+import Servant.Server.Internal (HasServer, route, addBodyCheck)+import Servant.Server.Internal.RoutingApplication (withRequest)+import Text.Digestive (Env, Form, FormInput(TextInput, FileInput), View, fromPath, getForm, postForm)++import qualified Servant+import qualified Data.Text.Encoding as STE++class ThrowServantErr err where+    _ServantErr :: Prism' err ServantErr+    throwServantErr :: MonadError err m => ServantErr -> m any+    throwServantErr err = throwError $ _ServantErr # err++type MonadServantErr err m = (MonadError err m, ThrowServantErr err)++instance ThrowServantErr ServantErr where+    _ServantErr = id++class ThrowError500 err where+    error500 :: Prism' err String++    throwError500 :: MonadError err m => String -> m b+    throwError500 err = throwError $ error500 # err++type MonadError500 err m = (MonadError err m, ThrowError500 err)++-- FIXME: ORPHAN move+instance ThrowError500 ServantErr where+    error500 = prism (\msg -> err500 { errBody = cs msg })+                     (\err -> if errHTTPCode err == 500 then Right (cs (errBody err)) else Left err)+++type FormH (htm :: [*]) html payload =+         Servant.Get htm html+    :<|> FormReqBody :> Servant.Post htm html++data FormReqBody++fromEnvIdentity :: Applicative m => Env Identity -> Env m+fromEnvIdentity env = pure . runIdentity . env++data FormData = FormData+  { _formEnv :: Env Identity+  , _formTmpFilesState :: InternalState+  }++getFormDataEnv :: FormData -> Env Identity+getFormDataEnv (FormData env _) = env++releaseFormTempFiles :: FormData -> IO ()+releaseFormTempFiles (FormData _ tmpFilesState) = closeInternalState tmpFilesState++instance HasServer sublayout context => HasServer (FormReqBody :> sublayout) context where+  type ServerT (FormReqBody :> sublayout) m = FormData -> ServerT sublayout m++  route Proxy context subserver =+      route (Proxy :: Proxy sublayout) context (addBodyCheck subserver bodyCheck)+    where+      -- FIXME: honor accept header++      -- FIXME: file upload:+      --   - file deletion is the responsibility of the handler.+      --   - content type and file name are lost in digestive-functors.+      --   - remember to set upload size limit!++      bodyCheck = withRequest $ \req -> do+          tempFileState <- liftIO createInternalState+          (params, files) <- liftIO $ parseRequestBody (tempFileBackEnd tempFileState) req++          let env :: Env Identity+              env query = pure $ f (TextInput . STE.decodeUtf8) params+                              ++ f (FileInput . fileContent) files+                where+                  f :: (a -> b) -> [(SBS, a)] -> [b]+                  f g = map (g . snd)+                      . filter ((== fromPath query) . STE.decodeUtf8 . fst)++          return $ FormData env tempFileState+++-- | Handle a route of type @'FormH' htm html payload@.  'formAction' is used by digestive-functors+-- as submit path for the HTML @FORM@ element.  'processor1' constructs the form, either as empty in+-- response to a @GET@, or displaying validation errors in response to a @POST@.  'processor2'+-- responds to a @POST@, handles the validated input values, and returns a new page displaying the+-- result.  Note that the renderer is monadic so that it can have effects (such as e.g. flushing a+-- message queue in the session state).+formH :: forall payload m err htm html uri.+     (Monad m, MonadError err m, ConvertibleStrings uri ST)+  => IO :~> m                     -- ^ liftIO+  -> uri                          -- ^ formAction+  -> Form html m payload          -- ^ processor1+  -> (payload -> m html)          -- ^ processor2+  -> (View html -> uri -> m html) -- ^ renderer+  -> ServerT (FormH htm html payload) m+formH liftIO' formAction processor1 processor2 renderer = getH :<|> postH+  where+    getH :: m html+    getH = do+        v <- getForm (cs formAction) processor1+        renderer v formAction++    postH :: FormData -> m html+    postH (FormData env tmpFilesState) = do+        (v, mpayload) <- postForm (cs formAction) processor1 (\_ -> pure $ fromEnvIdentity env)+        (case mpayload of+            Just payload -> processor2 payload+            Nothing      -> renderer v formAction)+            `finally` unNat liftIO' (closeInternalState tmpFilesState)++-- | Handle a route of type @'FormH' htm html payload@ and redirect afterwards.+-- 'formAction' is used by digestive-functors as submit path for the HTML @FORM@ element.+-- 'processor1' constructs the form, either as empty in response to a @GET@, or displaying validation+-- errors in response to a @POST@.+-- 'processor2' responds to a @POST@, handles the validated input values, calculates the redirection address.+-- Note that the renderer is monadic so that it can have effects (such as e.g. flushing a+-- message queue in the session state).+formRedirectH :: forall payload m htm html uri.+     (MonadIO m, MonadError ServantErr m,+      ConvertibleStrings uri ST, ConvertibleStrings uri SBS)+  => uri                             -- ^ formAction+  -> Form html m payload             -- ^ processor1+  -> (payload -> m uri)              -- ^ processor2+  -> (View html -> uri -> m html)    -- ^ renderer+  -> ServerT (FormH htm html payload) m+formRedirectH formAction processor1 processor2 =+    formH (Nat liftIO) formAction processor1 (processor2 >=> redirect)+++redirect :: (MonadServantErr err m, ConvertibleStrings uri SBS) => uri -> m a+redirect uri = throwServantErr $+    Servant.err303 { errHeaders = ("Location", cs uri) : errHeaders Servant.err303 }
+ src/Thentos/Frontend/Session.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+module Thentos.Frontend.Session+    ( serveFAction+    , enterFAction++    -- * types+    , SSession+    , FSession+    , FSessionMap+    , FSessionStore+    , FServantSession+    , FSessionKey+    )+where++import Control.Lens (use)+import Control.Monad (when)+import Control.Monad.Except.Missing (finally)+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans.Except (ExceptT)+import Crypto.Random (MonadRandom(..))+import Data.Char (ord)+import Data.Maybe (isJust)+import Data.Proxy (Proxy(Proxy))+import Data.String.Conversions+import Network.Wai (Middleware, Application, vault)+import Network.Wai.Session (SessionStore, Session, withSession)+import Servant (ServantErr, (:>), serve, HasServer, ServerT, Server, (:~>)(Nat), unNat)+import Servant.Server.Internal (route, passToServer)+import Servant.Utils.Enter (Enter, enter)+import Web.Cookie (SetCookie, setCookieName)++import qualified Data.ByteString as SBS+import qualified Data.Vault.Lazy as Vault+import qualified Network.Wai.Session.Map as SessionMap++import Servant.Missing (MonadError500, throwError500)+import Thentos.Frontend.Session.CSRF+import Thentos.Frontend.Session.Types (ThentosSessionToken, MonadUseThentosSessionToken, getThentosSessionToken)++-- * servant integration++-- | @SSession m k v@ represents a session storage with keys of type @k@,+-- values of type @v@, and operating under the monad @m@.+-- The underlying implementation uses the 'wai-session' package, and any+-- backend compatible with that package should work here too.+data SSession (m :: * -> *) (k :: *) (v :: *)++-- | 'HasServer' instance for 'SSession'.+instance (HasServer sublayout context) => HasServer (SSession n k v :> sublayout) context where+  type ServerT (SSession n k v :> sublayout) m+    = (Vault.Key (Session n k v) -> Maybe (Session n k v)) -> ServerT sublayout m+  route Proxy context subserver =+    route (Proxy :: Proxy sublayout) context (passToServer subserver go)+    where+      go request key = Vault.lookup key $ vault request+++-- * middleware++type FSession        fsd = Session IO () fsd+type FSessionMap     fsd = Vault.Key (FSession fsd) -> Maybe (FSession fsd)+type FSessionStore   fsd = SessionStore IO () fsd+type FServantSession fsd = SSession IO () fsd+type FSessionKey     fsd = Vault.Key (FSession fsd)++cookieName :: SetCookie -> SBS+cookieName setCookie =+    if cookieNameValid n+        then n+        else error $ "Thentos.Frontend.State: bad cookie name: " ++ show n+  where+    n = setCookieName setCookie++cookieNameValid :: SBS -> Bool+cookieNameValid = SBS.all (`elem` (fromIntegral . ord <$> '_':['a'..'z']))++sessionMiddleware :: Proxy fsd -> SetCookie -> IO (Middleware, FSessionKey fsd)+sessionMiddleware Proxy setCookie = do+    smap :: FSessionStore fsd <- SessionMap.mapStore_+    key  :: Vault.Key (FSession fsd) <- Vault.newKey+    return (withSession smap (cookieName setCookie) setCookie key, key)+++-- * frontend action monad++type ExtendClearanceOnSessionToken m = ThentosSessionToken -> m ()++serveFAction :: forall api m s e v.+        ( HasServer api '[]+        , Enter (ServerT api m) (m :~> ExceptT ServantErr IO) (Server api)+        , MonadRandom m, MonadError500 e m, MonadHasSessionCsrfToken s m+        , MonadViewCsrfSecret v m, MonadUseThentosSessionToken s m+        )+     => Proxy api+     -> Proxy s+     -> SetCookie+     -> ExtendClearanceOnSessionToken m+     -> IO :~> m+     -> m :~> ExceptT ServantErr IO+     -> ServerT api m -> IO Application+serveFAction _ sProxy setCookie extendClearanceOnSessionToken ioNat nat fServer =+    app <$> sessionMiddleware sProxy setCookie+  where+    app :: (Middleware, FSessionKey s) -> Application+    app (mw, key) = mw $ serve (Proxy :: Proxy (FServantSession s :> api)) (server' key)++    server' :: FSessionKey s -> FSessionMap s -> Server api+    server' key smap = enter nt fServer+      where+        nt :: m :~> ExceptT ServantErr IO+        nt = enterFAction key smap extendClearanceOnSessionToken ioNat nat++enterFAction+    :: ( MonadRandom m, MonadError500 e m, MonadHasSessionCsrfToken s m+       , MonadViewCsrfSecret v m, MonadUseThentosSessionToken s m)+    => FSessionKey s+    -> FSessionMap s+    -> ExtendClearanceOnSessionToken m+    -> IO :~> m+    -> m :~> ExceptT ServantErr IO+    -> m :~> ExceptT ServantErr IO+enterFAction key smap extendClearanceOnSessionToken ioNat nat = Nat $ \fServer -> unNat nat $ do+    case smap key of+        Nothing ->+            -- FIXME: this case should not be code 500, as it can (probably) be provoked by+            -- the client.+            throwError500 "Could not read cookie."+        Just (lkup, ins) -> do+            cookieToFSession ioNat (lkup ())+            maybeSessionToken <- use getThentosSessionToken+            -- Update privileges and refresh the CSRF token if there is a session token+            mapM_ extendClearanceOnSessionToken maybeSessionToken+            when (isJust maybeSessionToken) refreshCsrfToken+            fServer `finally` (do+                clearCsrfToken -- could be replaced by 'refreshCsrfToken'+                cookieFromFSession ioNat (ins ()))++-- | Write 'FrontendSessionData' from the 'SSession' state to 'MonadFAction' state.  If there+-- is no state, do nothing.+cookieToFSession :: MonadState s m => IO :~> m -> IO (Maybe s) -> m ()+cookieToFSession ioNat r = unNat ioNat r >>= mapM_ put++-- | Read 'FrontendSessionData' from 'MonadFAction' and write back into 'SSession' state.+cookieFromFSession :: MonadState s m => IO :~> m -> (s -> IO ()) -> m ()+cookieFromFSession ioNat w = get >>= unNat ioNat . w
+ src/Thentos/Frontend/Session/CSRF.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}++module Thentos.Frontend.Session.CSRF+    ( CsrfSecret(..)+    , CsrfToken(..)+    , CsrfNonce(..)+    , GetCsrfSecret(..)+    , HasSessionCsrfToken(..)+    , MonadHasSessionCsrfToken+    , MonadViewCsrfSecret+    , genCsrfSecret+    , validFormatCsrfSecretField+    , validFormatCsrfToken+    , checkCsrfToken+    , refreshCsrfToken+    , clearCsrfToken+    ) where++import Control.Lens+import Control.Monad.Reader.Class (MonadReader)+import Control.Monad.State.Class (MonadState)+import Control.Monad (when)+import Crypto.Hash (SHA256)+import Crypto.MAC.HMAC (HMAC,hmac)+import Crypto.Random (MonadRandom(..))+import Data.Aeson (FromJSON, ToJSON)+import Data.ByteArray.Encoding (convertToBase, convertFromBase, Base(Base16))+import Data.String.Conversions (SBS, ST, cs, (<>))+import Data.String (IsString)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++import qualified Data.ByteString as SBS+import qualified Data.Text as ST++import Servant.Missing (MonadError500, throwError500)+import Thentos.Frontend.Session.Types (ThentosSessionToken(fromThentosSessionToken), MonadUseThentosSessionToken, getThentosSessionToken)++-- | This token is used to prevent CSRF (Cross Site Request Forgery).+-- This token is part of 'FrontendSessionData' since it is required by the views which+-- generate the forms with a special hidden field containing the value of this token.+-- However, this token is cleared before being serialized as a cookie.+-- Indeed we have no need yet to have it on the client side nor to make it persistent.+-- When processing requests, this token is freshly generated from the 'CsrfSecret' and the+-- 'ThentosSessionToken'. This token is only used by requests that yield an HTML form.+-- Upon POST requests on such forms, the handlers will check the validity of the CSRF token.+-- Verification of this token can be done solely from the 'CsrfSecret' and+-- the 'ThentosSessionToken'.+--+-- This all means that if the attacker could get access to one of these tokens it would be enough to+-- validate any form.  Changing the token on every request even inside the session helps to counter+-- an attack based on entropy leakage through TLS plaintext compression.  TLS compression should be+-- disabled for the exact reason that it is vulnerable to this attack, but this code does not rely+-- on it.+--+-- *The idea of the attack:* When combining encryption (which hides the contents but not the length)+-- and compression (which makes the length depend on the content).  If you compress after encryption+-- its safe but useless; if you compress then encrypt (which is often done), then some data leaks+-- through the length of the ciphertext.  The BEAST attack exploited this by guessing the CSRF token+-- by sending request to the server pretending to be the client injecting in the request the guess+-- of the token in a parameter which is echoed back by the server to the real client encrypted for+-- the client.  Assuming the CSRF token is given as an attribute such as csrf:SOMESECRET to keep it+-- simple, then the guess is going to be csrf:XYZ with all combination of XYZ then you look at which+-- answer was the shortest it is highly likely that XYZ=SOM will compress better than the rest+-- because of the repetition with the real secret also part of the response. You then proceed with+-- your guess being csrf:SOMXYZ. On a test setup, it was possible to recover the full token in 30+-- secs.+newtype CsrfToken = CsrfToken { fromCsrfToken :: ST }+    deriving (Eq, Ord, Show, Read, FromJSON, ToJSON, Typeable, Generic, IsString)++newtype CsrfSecret = CsrfSecret SBS+    deriving (Show, Eq)++newtype CsrfNonce  = CsrfNonce  SBS+    deriving (Show, Eq)++class GetCsrfSecret a where+    csrfSecret :: Getter a (Maybe CsrfSecret)++instance GetCsrfSecret ST.Text where+    csrfSecret = to $ \secret -> do+        let Right sbs = convertFromBase Base16 (cs secret :: SBS)+        return $ CsrfSecret sbs++class HasSessionCsrfToken a where+    sessionCsrfToken :: Lens' a (Maybe CsrfToken)++type MonadHasSessionCsrfToken s m = (MonadState s m, HasSessionCsrfToken s)++type MonadViewCsrfSecret e m = (MonadReader e m, GetCsrfSecret e)++-- | This ONLY checks the format of a given CSRF secret, not if it has been randomly choosen (duh!).+validFormatCsrfSecretField :: Maybe ST -> Bool+validFormatCsrfSecretField ms+    | Just t <- ms+    , Right s' <- convertFromBase Base16 (cs t :: SBS)+    = SBS.length s' == 32+    | otherwise = False++-- | This ONLY checks the format of a given CSRF token, not if it has been tampered with.+validFormatCsrfToken :: CsrfToken -> Bool+validFormatCsrfToken (CsrfToken st)+    | Right s' <- convertFromBase Base16 (cs st :: SBS) = SBS.length s' == 64+    | otherwise                                         = False++-- | Computes a valid CSRF token given a nonce.+makeCsrfToken :: (MonadError500 err m, MonadViewCsrfSecret e m, MonadUseThentosSessionToken s m) =>+                 CsrfNonce -> m CsrfToken+makeCsrfToken (CsrfNonce rnd) = do+    maySessionToken <- use getThentosSessionToken+    case maySessionToken of+        Nothing -> throwError500 "No session token"+        Just sessionToken -> do+            Just (CsrfSecret key) <- view csrfSecret+            return $ CsrfToken . cs $ rnd <> convertToBase Base16 (hmac key (tok <> rnd) :: HMAC SHA256)+          where+            tok = cs $ fromThentosSessionToken sessionToken++-- | Extracts the nonce part from the CSRF token.+csrfNonceFromCsrfToken :: CsrfToken -> CsrfNonce+csrfNonceFromCsrfToken = CsrfNonce . SBS.take 64 . cs . fromCsrfToken++-- | Verify the authenticity of a given 'CsrfToken'.  This token should come from the form data of+-- the POST request, NOT from 'FrontendSessionData'.+checkCsrfToken :: (MonadError500 err m, MonadViewCsrfSecret e m, MonadUseThentosSessionToken s m) => CsrfToken -> m ()+checkCsrfToken csrfToken+    | not (validFormatCsrfToken csrfToken) =+        throwError500 $ "Ill-formatted CSRF Token " <> show csrfToken+    | otherwise = do+        -- Here we essentially re-create the second half of the CSRF token.+        -- If it was made with the same sessionToken and csrfSecret then it will match.+        csrfToken' <- makeCsrfToken (csrfNonceFromCsrfToken csrfToken)+        when (csrfToken /= csrfToken') $+            throwError500 "Invalid CSRF token"++-- | Generates a random 'CsrfSecret'.+genCsrfSecret :: MonadRandom m => m CsrfSecret+genCsrfSecret = CsrfSecret . (convertToBase Base16 :: SBS -> SBS) <$> getRandomBytes 32++-- | Generates a random 'CsrfNonce'.+genCsrfNonce :: MonadRandom m => m CsrfNonce+genCsrfNonce = CsrfNonce . (convertToBase Base16 :: SBS -> SBS) <$> getRandomBytes 32++-- | See 'CsrfToken'.+-- This function assigns a newly generated 'CsrfToken' to the 'FrontendSessionData'.+refreshCsrfToken :: (MonadError500 err m, MonadHasSessionCsrfToken s m,+                     MonadRandom m, MonadViewCsrfSecret e m, MonadUseThentosSessionToken s m) => m ()+refreshCsrfToken = do+    csrfToken <- makeCsrfToken =<< genCsrfNonce+    sessionCsrfToken .= Just csrfToken++-- | See 'CsrfToken'+-- As long as we do not need to generate any forms on the client side it's better to+-- clear the value of the 'CsrfToken', preventing it to be stored in the cookie.+-- Still if we ever need to persist a 'CsrfToken' it might be safer to refresh it+-- with 'refreshCsrfToken' first.+clearCsrfToken :: MonadHasSessionCsrfToken s m => m ()+clearCsrfToken = sessionCsrfToken .= Nothing
+ src/Thentos/Frontend/Session/Types.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PackageImports             #-}+module Thentos.Frontend.Session.Types where++import Control.Lens (Getter)+import Control.Monad.State.Class (MonadState)+import "cryptonite" Crypto.Random (MonadRandom, getRandomBytes)+import Data.Aeson (FromJSON, ToJSON)+import Data.String.Conversions+import Data.String (IsString)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Servant.API (FromHttpApiData)+import qualified Codec.Binary.Base64 as Base64+import qualified Data.Text as ST++newtype ThentosSessionToken = ThentosSessionToken { fromThentosSessionToken :: ST }+    deriving ( Eq, Ord, Show, Read, Typeable, Generic, IsString+             , FromHttpApiData, FromJSON, ToJSON+             )++class GetThentosSessionToken a where+    getThentosSessionToken :: Getter a (Maybe ThentosSessionToken)++type MonadUseThentosSessionToken s m = (MonadState s m, GetThentosSessionToken s)++-- | Return a base64 encoded random string of length 24 (18 bytes of entropy).+-- We use @_@ instead of @/@ as last letter of the base64 alphabet since it allows using names+-- within URLs without percent-encoding. Our Base64 alphabet thus consists of ASCII letters ++-- digits as well as @+@ and @_@. All of these are reliably recognized in URLs, even if they occur+-- at the end.+--+-- RFC 4648 also has a "URL Safe Alphabet" which additionally replaces @+@ by @-@. But that's+-- problematic, since @-@ at the end of URLs is not recognized as part of the URL by some programs+-- such as Thunderbird.+freshRandomName :: MonadRandom m => m ST+freshRandomName = ST.replace "/" "_" . cs . Base64.encode <$> getRandomBytes 18++freshSessionToken :: MonadRandom m => m ThentosSessionToken+freshSessionToken = ThentosSessionToken <$> freshRandomName
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Thentos/Frontend/SessionSpec.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}++{-# OPTIONS -fno-warn-incomplete-patterns #-}++module Thentos.Frontend.SessionSpec (spec) where++import           Control.Monad              (replicateM_)+import           Control.Monad.Trans.Except (ExceptT)+import qualified Data.Vault.Lazy            as Vault+import           Network.HTTP.Types         (methodGet)+import           Network.Wai                (Middleware, Application)+import           Network.Wai.Session        (SessionStore, Session, withSession)+import           Network.Wai.Session.Map    (mapStore)+import           Network.Wai.Test           (simpleBody, simpleHeaders)+import           Servant                    (Proxy(Proxy), ServantErr, Get, JSON, (:>), serve)+import           Test.Hspec                 (Spec, context, describe, it, shouldBe, shouldSatisfy)+import           Test.Hspec.Wai             (with, request, liftIO)+import           Web.Cookie                 (SetCookie, def, parseSetCookie,+                                             setCookieName, setCookieValue, setCookieMaxAge)++import           Thentos.Frontend.Session+++spec :: Spec+spec = describe "Thentos.Frontend.Session" . with server $ do++  context "the cookie is set" $ do++    it "has read and write access to the cookie" $ do+        replicateM_ 5 $ request methodGet "" [("Cookie", "test=const")] ""+        x <- request methodGet "" [("Cookie", "test=const")] ""+        liftIO $ simpleBody x `shouldSatisfy` (== "\"4\"")+++  context "no cookie is set" $ do++    it "one will be in the Set-Cookie header of the response" $ do+        resp <- request methodGet "" [] ""+        let Just c = parseSetCookie <$> lookup "Set-Cookie" (simpleHeaders resp)+        liftIO $ setCookieName c `shouldBe` setCookieName setCookieOpts+        liftIO $ setCookieValue c `shouldBe` "const"++    it "adds SetCookie params" $ do+        resp <- request methodGet "" [] ""+        let Just c = parseSetCookie <$> lookup "Set-Cookie" (simpleHeaders resp)+        liftIO $ setCookieMaxAge c `shouldBe` setCookieMaxAge setCookieOpts+++type API = SSession IO Int Int :> Get '[JSON] String++setCookieOpts :: SetCookie+setCookieOpts = def { setCookieName = "test", setCookieMaxAge = Just 300 }++sessionMiddleware :: SessionStore IO Int a -> Vault.Key (Session IO Int a) -> Middleware+sessionMiddleware s = withSession s "test" setCookieOpts++server :: IO Application+server = do+    ref <- mapStore (return "const")+    key <- Vault.newKey+    return $ sessionMiddleware ref key+           $ serve (Proxy :: Proxy API) (handler key)++handler :: Vault.Key (Session IO Int Int)+        -> (Vault.Key (Session IO Int Int) -> Maybe (Session IO Int Int))+        -> ExceptT ServantErr IO String+handler key smap = do+    x <- liftIO $ lkup 1+    case x of+        Nothing -> liftIO (ins 1 0) >> return "Nothing"+        Just y -> liftIO (ins 1 $ succ y) >> return (show y)+  where+    Just (lkup, ins) = smap key
@@ -0,0 +1,86 @@+name:                thentos-cookie-session+version:             0.8.4+synopsis:            All-in-one session handling for servant-based frontends+description:+    Uses cookies to store session keys.+    .+    Offers CSRF protection.+    .+    Designed with HTML frontends in mind, but Suitable for any HTTP service.+license:             AGPL+license-file:        LICENSE+homepage:            https://github.com/liqd/thentos+author:              Matthias Fischmann, Florian Hartwig, Christian Siefkes, Nicolas Pouillard+maintainer:          mf@zerobuzz.net, np@nicolaspouillard.fr+copyright:           liquid democracy e.V. (https://liqd.net/)+category:            Web, Authentication+build-type:          Simple+cabal-version:       >= 1.18++Source-Repository head+  type: git+  location: https://github.com/liqd/thentos++flag profiling+  default: False++library+  default-language:+      Haskell2010+  hs-source-dirs:+      src+  ghc-options:+      -Wall -j1+  if flag(profiling)+      ghc-options:+          -auto-all -caf-all -fforce-recomp+  exposed-modules:+      Thentos.Frontend.Session+    , Thentos.Frontend.Session.CSRF+    , Thentos.Frontend.Session.Types+    , Control.Monad.Except.Missing+    , Servant.Missing+  build-depends:+      aeson >=0.11 && <0.12+    , base >=4.8 && <4.9+    , bytestring >=0.10 && <0.11+    , cookie >=0.4 && <0.5+    , cryptonite >=0.15 && <0.16+    , digestive-functors >=0.8 && <0.9+    , lens >=4.13 && <4.14+    , memory >=0.13 && <0.14+    , mtl >=2.2 && <2.3+    , resourcet >=1.1 && <1.2+    , sandi >=0.3.5 && <0.4+    , servant >=0.7 && <0.8+    , servant-server >=0.7 && <0.8+    , string-conversions >=0.4 && <0.5+    , text >=1.2 && <1.3+    , transformers >=0.4 && <0.5+    , vault >=0.3 && <0.4+    , wai >=3.2 && <3.3+    , wai-extra >=3.0 && <3.1+    , wai-session >=0.3 && <0.4++test-suite spec+  type: exitcode-stdio-1.0+  ghc-options:+    -Wall -fno-warn-name-shadowing+  default-language: Haskell2010+  hs-source-dirs: test+  main-is: Spec.hs+  other-modules:+      Thentos.Frontend.SessionSpec+  build-depends:+      base == 4.*+    , cookie+    , hspec == 2.*+    , hspec-wai+    , http-types+    , servant-server+    , thentos-cookie-session+    , wai+    , wai-extra+    , wai-session+    , transformers+    , vault