Tweak cookie session

thentos-cookie-session/src/Thentos/CookieSession.hs

@@ -27,7 +27,6 @@ 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(..))
@@ -46,9 +45,11 @@ 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)
+import Thentos.CookieSession.Except (finally)
+import Thentos.CookieSession.Servant (throwError500)
+import Thentos.CookieSession.Types (ThentosSessionToken, getThentosSessionToken)
+
 
 -- * servant integration
 
@@ -104,11 +105,10 @@ noopExtendClearanceOnSessionToken _ = pure ()
 -- | The 'ExtendClearanceOnSessionToken' argument can be used in combination with the lio package to
 -- write the access policy into the server monad state.  If your way of access restriction has no
 -- need for that, simply pass @noopExtendClearanceOnSessionToken@.
-serveFAction :: forall api m s e v.
+serveFAction :: forall api m s 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
+        , MonadRandom m, MonadCsrf s v m, MonadHasSessionCsrfToken s m
         )
      => Proxy api
      -> Proxy s
@@ -130,8 +130,10 @@ serveFAction _ sProxy setCookie extendClearanceOnSessionToken ioNat nat fServer
         nt = enterFAction key smap extendClearanceOnSessionToken ioNat nat
 
 enterFAction
-    :: ( MonadRandom m, MonadError500 e m, MonadHasSessionCsrfToken s m
-       , MonadViewCsrfSecret v m, MonadUseThentosSessionToken s m)
+    :: ( MonadRandom m
+       , MonadCsrf s v m
+       , MonadHasSessionCsrfToken s m
+       )
     => FSessionKey s
     -> FSessionMap s
     -> ExtendClearanceOnSessionToken m

thentos-cookie-session/src/Thentos/CookieSession/CSRF.hs

@@ -17,6 +17,7 @@ module Thentos.CookieSession.CSRF
     , HasSessionCsrfToken(..)
     , MonadHasSessionCsrfToken
     , MonadViewCsrfSecret
+    , MonadCsrf
     , genCsrfSecret
     , validFormatCsrfSecretField
     , validFormatCsrfToken
@@ -28,7 +29,7 @@ module Thentos.CookieSession.CSRF
 import Control.Lens
 import Control.Monad.Reader.Class (MonadReader)
 import Control.Monad.State.Class (MonadState)
-import Control.Monad (when)
+import Control.Monad (unless)
 import Crypto.Hash (SHA256)
 import Crypto.MAC.HMAC (HMAC,hmac)
 import Crypto.Random (MonadRandom(..))
@@ -38,13 +39,15 @@ import Data.String.Conversions (SBS, ST, cs, (<>))
 import Data.String (IsString)
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
+import Servant (ServantErr(..), err412)
 
 import qualified Data.ByteString as SBS
 import qualified Data.Text as ST
 
-import Servant.Missing (MonadError500, throwError500)
+import Thentos.CookieSession.Servant (MonadError500, MonadServantErr, throwError500, throwServantErr)
 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.
@@ -96,7 +99,13 @@ class HasSessionCsrfToken a where
 
 type MonadHasSessionCsrfToken s m = (MonadState s m, HasSessionCsrfToken s)
 
-type MonadViewCsrfSecret e m = (MonadReader e m, GetCsrfSecret e)
+type MonadViewCsrfSecret v m = (MonadReader v m, GetCsrfSecret v)
+
+type MonadCsrf s v m =
+    ( MonadServantErr ServantErr m
+    , MonadViewCsrfSecret v m
+    , MonadUseThentosSessionToken s m
+    )
 
 -- | This ONLY checks the format of a given CSRF secret, not if it has been randomly choosen (duh!).
 validFormatCsrfSecretField :: Maybe ST -> Bool
@@ -118,7 +127,7 @@ makeCsrfToken :: (MonadError500 err m, MonadViewCsrfSecret e m, MonadUseThentosS
 makeCsrfToken (CsrfNonce rnd) = do
     maySessionToken <- use getThentosSessionToken
     case maySessionToken of
-        Nothing -> throwError500 "No session token"
+        Nothing -> throwError500 "internal error: no session token"
         Just sessionToken -> do
             Just (CsrfSecret key) <- view csrfSecret
             return $ CsrfToken . cs $ rnd <> convertToBase Base16 (hmac key (tok <> rnd) :: HMAC SHA256)
@@ -129,18 +138,21 @@ makeCsrfToken (CsrfNonce rnd) = do
 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
+-- | Verify the authenticity of a given 'CsrfToken'.  This token must 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"
+--
+-- Verifiation works by re-creating the second half of the CSRF token.
+-- If it was made with the same sessionToken and csrfSecret then it will match.
+--
+-- In case of failure, respond with status code 412 (precondition failed).
+checkCsrfToken :: MonadCsrf s v m => CsrfToken -> m ()
+checkCsrfToken csrfToken = do
+    let failUnless cond = unless cond $
+          throwServantErr err412 { errBody = "CSRF token validation failed." }
+
+    failUnless (validFormatCsrfToken csrfToken)
+    csrfToken' <- makeCsrfToken $ csrfNonceFromCsrfToken csrfToken
+    failUnless (csrfToken == csrfToken')
 
 -- | Generates a random 'CsrfSecret'.
 genCsrfSecret :: MonadRandom m => m CsrfSecret
@@ -152,8 +164,7 @@ genCsrfNonce = CsrfNonce . (convertToBase Base16 :: SBS -> SBS) <$> getRandomByt
 
 -- | 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 :: (MonadCsrf s v m, MonadHasSessionCsrfToken s m, MonadRandom m) => m ()
 refreshCsrfToken = do
     csrfToken <- makeCsrfToken =<< genCsrfNonce
     sessionCsrfToken .= Just csrfToken

thentos-cookie-session/src/Control/Monad/Except/Missing.hs → thentos-cookie-session/src/Thentos/CookieSession/Except.hs

@@ -1,4 +1,4 @@
-module Control.Monad.Except.Missing where
+module Thentos.CookieSession.Except where
 
 import Control.Monad.Except (MonadError(catchError, throwError))
 import Data.Functor (($>))

thentos-cookie-session/src/Servant/Missing.hs → thentos-cookie-session/src/Thentos/CookieSession/Servant.hs

@@ -11,7 +11,7 @@
 
 {-# OPTIONS_GHC #-}
 
-module Servant.Missing
+module Thentos.CookieSession.Servant
   ( ThrowServantErr(..)
   , MonadServantErr
   , ThrowError500(..)
@@ -28,7 +28,6 @@ module Servant.Missing
 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)
@@ -44,6 +43,9 @@ import Text.Digestive (Env, Form, FormInput(TextInput, FileInput), View, fromPat
 import qualified Servant
 import qualified Data.Text.Encoding as STE
 
+import Thentos.CookieSession.Except (finally)
+
+
 class ThrowServantErr err where
     _ServantErr :: Prism' err ServantErr
     throwServantErr :: MonadError err m => ServantErr -> m any
@@ -164,5 +166,7 @@ formRedirectH formAction processor1 processor2 =
 
 
 redirect :: (MonadServantErr err m, ConvertibleStrings uri SBS) => uri -> m a
-redirect uri = throwServantErr $
-    Servant.err303 { errHeaders = ("Location", cs uri) : errHeaders Servant.err303 }
+redirect = throwServantErr . err303With
+
+err303With :: ConvertibleStrings uri SBS => uri -> ServantErr
+err303With uri = Servant.err303 { errHeaders = ("Location", cs uri) : errHeaders Servant.err303 }

thentos-cookie-session/thentos-cookie-session.cabal

@@ -1,5 +1,5 @@
 name:                thentos-cookie-session
-version:             0.9.1
+version:             0.10.0
 synopsis:            All-in-one session handling for servant-based frontends
 description:
     Uses cookies to store session keys.
@@ -30,16 +30,16 @@ library
   hs-source-dirs:
       src
   ghc-options:
-      -Wall -j1
+      -Wall -Werror
   if flag(profiling)
       ghc-options:
           -auto-all -caf-all -fforce-recomp
   exposed-modules:
       Thentos.CookieSession
     , Thentos.CookieSession.CSRF
+    , Thentos.CookieSession.Except
+    , Thentos.CookieSession.Servant
     , Thentos.CookieSession.Types
-    , Control.Monad.Except.Missing
-    , Servant.Missing
   build-depends:
       aeson >=0.11 && <0.12
     , base >=4.8 && <4.9