packages feed

thentos-cookie-session 0.8.4 → 0.9.0

raw patch · 10 files changed

+469/−468 lines, 10 files

Files

src/Servant/Missing.hs view
@@ -1,5 +1,3 @@--- FIXME: create a package servant-digestive-functors and---        choose a different module name. {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-}@@ -11,19 +9,21 @@ {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-} -{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC #-}+ module Servant.Missing-  (ThrowServantErr(..)-  ,MonadServantErr-  ,ThrowError500(..)-  ,MonadError500-  ,FormH-  ,FormReqBody-  ,FormData, getFormDataEnv, releaseFormTempFiles-  ,formH-  ,formRedirectH-  ,fromEnvIdentity-  ,redirect) where+  ( ThrowServantErr(..)+  , MonadServantErr+  , ThrowError500(..)+  , MonadError500+  , FormH+  , FormReqBody+  , FormData, getFormDataEnv, releaseFormTempFiles+  , formH+  , formRedirectH+  , fromEnvIdentity+  , redirect+  ) where  import Control.Lens (prism, Prism', (#)) import Control.Monad ((>=>))@@ -62,7 +62,6 @@  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)@@ -124,11 +123,11 @@ -- 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+  => 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
+ src/Thentos/CookieSession.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++module Thentos.CookieSession+    ( 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.CookieSession.CSRF+import Thentos.CookieSession.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.CookieSession: 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/CookieSession/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.CookieSession.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.CookieSession.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/CookieSession/Types.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PackageImports             #-}++module Thentos.CookieSession.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
− src/Thentos/Frontend/Session.hs 
@@ -1,155 +0,0 @@-{-# 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 
@@ -1,167 +0,0 @@-{-# 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 
@@ -1,43 +0,0 @@-{-# 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/Thentos/CookieSessionSpec.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.CookieSessionSpec (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.CookieSession+++spec :: Spec+spec = describe "Thentos.CookieSession" . 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
− test/Thentos/Frontend/SessionSpec.hs 
@@ -1,78 +0,0 @@-{-# 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
@@ -1,5 +1,5 @@ name:                thentos-cookie-session-version:             0.8.4+version:             0.9.0 synopsis:            All-in-one session handling for servant-based frontends description:     Uses cookies to store session keys.@@ -35,9 +35,9 @@       ghc-options:           -auto-all -caf-all -fforce-recomp   exposed-modules:-      Thentos.Frontend.Session-    , Thentos.Frontend.Session.CSRF-    , Thentos.Frontend.Session.Types+      Thentos.CookieSession+    , Thentos.CookieSession.CSRF+    , Thentos.CookieSession.Types     , Control.Monad.Except.Missing     , Servant.Missing   build-depends:@@ -70,7 +70,7 @@   hs-source-dirs: test   main-is: Spec.hs   other-modules:-      Thentos.Frontend.SessionSpec+      Thentos.CookieSessionSpec   build-depends:       base == 4.*     , cookie