Cleanup & (maybe|require)BearerToken

config/settings.yml

@@ -28,6 +28,7 @@ notification-collate-delay: 300
 notification-expiration: 259201
 session-timeout: 7200
 jwt-expiration: 604800
+jwt-encoding: HS256
 maximum-content-length: 52428800
 
 log-settings:

messages/uniworx/de.msg

@@ -214,6 +214,8 @@ UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
 UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
 UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden.
 UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
+UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert.
+UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
 UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
 UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.

package.yaml

@@ -85,6 +85,7 @@ dependencies:
   - scientific
   - tz
   - system-locale
+  - th-lift
   - th-lift-instances
   - gitrev
   - Glob

src/Data/Aeson/Types/Instances.hs

@@ -6,9 +6,17 @@ module Data.Aeson.Types.Instances
 
 import ClassyPrelude
 
-import Data.Aeson.Types (Parser)
+import Data.Aeson.Types (Parser, Value)
 import Control.Monad.Catch
 
+import Data.Binary (Binary)
+
+import Data.HashMap.Strict.Instances ()
+import Data.Vector.Instances ()
+
 
 instance MonadThrow Parser where
   throwM = fail . show
+
+
+instance Binary Value

src/Data/HashMap/Strict/Instances.hs

@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.HashMap.Strict.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Binary (Binary(..))
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+
+
+instance (Binary k, Binary v, Hashable k, Eq k) => Binary (HashMap k v) where
+  put = put . HashMap.toList
+  get = HashMap.fromList <$> get

src/Data/HashSet/Instances.hs

@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.HashSet.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HashSet
+
+import Data.Binary (Binary(..))
+
+
+instance (Binary a, Hashable a, Eq a) => Binary (HashSet a) where
+  get = HashSet.fromList <$> get
+  put = put . HashSet.toList

src/Data/NonNull/Instances.hs

@@ -8,6 +8,9 @@ import ClassyPrelude
 
 import Data.Aeson
 
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
 
 instance ToJSON a => ToJSON (NonNull a) where
   toJSON = toJSON . toNullable
@@ -18,3 +21,8 @@ instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where
 
 instance Hashable a => Hashable (NonNull a) where
   hashWithSalt s = hashWithSalt s . toNullable
+
+
+instance (Binary a, MonoFoldable a) => Binary (NonNull a) where
+  get = Binary.get >>= maybe (fail "Expected non-empty structure") return . fromNullable
+  put = Binary.put . toNullable

src/Data/Time/Clock/Instances.hs

@@ -0,0 +1,26 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Time.Clock.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Time.Clock
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+deriving instance Generic UTCTime
+
+
+instance Binary Day where
+  get = ModifiedJulianDay <$> Binary.get
+  put = Binary.put . toModifiedJulianDay
+
+instance Binary DiffTime where
+  get = fromRational <$> Binary.get
+  put = Binary.put . toRational
+  
+instance Binary UTCTime

src/Data/Vector/Instances.hs

@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Vector.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+instance Binary a => Binary (Vector a) where
+  get = Vector.fromList <$> Binary.get
+  put = Binary.put . Vector.toList

src/Foundation.hs

@@ -15,7 +15,6 @@ import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
 import Jobs.Types
-import Model.Token
 
 import qualified Network.Wai as W (pathInfo)
 
@@ -57,7 +56,7 @@ import Data.Conduit.List (sourceList)
 
 import qualified Database.Esqueleto as E
 
-import Control.Monad.Except (MonadError(..), runExceptT)
+import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.Reader (runReader, mapReaderT)
 import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
@@ -152,7 +151,7 @@ mkYesodData "UniWorX" $(parseRoutesFile "routes")
 deriving instance Generic (Route UniWorX)
 
 -- | Convenient Type Synonyms:
-type DB a = YesodDB UniWorX a
+type DB = YesodDB UniWorX
 type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
 type MsgRenderer = MsgRendererS UniWorX -- see Utils
 type MailM a = MailT (HandlerT UniWorX IO) a
@@ -403,12 +402,6 @@ newtype InvalidAuthTag = InvalidAuthTag Text
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 instance Exception InvalidAuthTag
 
-data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-instance Universe SessionAuthTags
-instance Finite SessionAuthTags
-nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
-
 
 data AccessPredicate
   = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
@@ -453,6 +446,47 @@ trueAP  = APPure . const . const . const $ trueAR <$> ask
 falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
 
 
+askTokenUnsafe :: forall m.
+                  ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  , MonadLogger m
+                  , MonadCatch m
+                  )
+               => ExceptT AuthResult m (BearerToken (UniWorX))
+-- | This performs /no/ meaningful validation of the `BearerToken`
+--
+-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead
+askTokenUnsafe = $cachedHere $ do
+  jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
+  catch (decodeToken jwt) $ \case
+    BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
+    BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
+    other -> do
+      $logWarnS "AuthToken" $ tshow other
+      throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
+
+validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
+validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token'
+  where
+    validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
+    validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
+      guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
+
+      User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
+      guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
+
+      authorityVal <- do
+        dnf <- either throwM return $ routeAuthTags route
+        fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
+      guardExceptT (is _Authorized authorityVal) authorityVal
+
+      whenIsJust tokenAddAuth $ \addDNF -> do
+        additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
+        guardExceptT (is _Authorized additionalVal) additionalVal
+
+      return Authorized
+
+
 tagAccessPredicate :: AuthTag -> AccessPredicate
 tagAccessPredicate AuthFree = trueAP
 tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
@@ -474,30 +508,8 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
     adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
-tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ do
-  jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
-  BearerToken{..} <- catch (decodeToken jwt) $ \case
-    BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
-    BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
-    other -> do
-      $logWarnS "AuthToken" $ tshow other
-      throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
-
-  guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
-
-  User{userTokensIssuedAfter} <- lift $ get404 tokenAuthority
-  guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
-
-  authorityVal <- do
-    dnf <- either throwM return $ routeAuthTags route
-    fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
-  guardExceptT (is _Authorized authorityVal) authorityVal
-
-  whenIsJust tokenAddAuth $ \addDNF -> do
-    additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
-    guardExceptT (is _Authorized additionalVal) additionalVal
-
-  return Authorized
+tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
+  lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
 tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
   AdminHijackUserR cID -> exceptT return return $ do
     myUid <- maybeExceptT AuthenticationRequired $ return mAuthId

src/Handler/Admin.hs

@@ -286,9 +286,6 @@ instance Button UniWorX ButtonAdminStudyTerms where
   btnClasses BtnCandidatesDeleteAll       = [BCIsButton, BCDanger]
 -- END Button needed only here
 
-sessionKeyNewStudyTerms :: Text
-sessionKeyNewStudyTerms = "key-new-study-terms"
-
 getAdminFeaturesR, postAdminFeaturesR :: Handler Html
 getAdminFeaturesR = postAdminFeaturesR
 postAdminFeaturesR = do
@@ -304,7 +301,7 @@ postAdminFeaturesR = do
         unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
         unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
         let newKeys = map (StudyTermsKey' . fst) infAccepted
-        setSessionJson sessionKeyNewStudyTerms newKeys
+        setSessionJson SessionNewStudyTerms newKeys
         if  | null infAccepted
               -> addMessageI Info      MsgNoCandidatesInferred
             | otherwise
@@ -322,7 +319,7 @@ postAdminFeaturesR = do
         Candidates.conflicts
       _other -> runDB Candidates.conflicts
 
-    newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms
+    newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
     (   (degreeResult,degreeTable)
       , (studyTermsResult,studytermsTable)
       , ((), candidateTable)) <- runDB $ (,,)

src/Handler/Course.hs

@@ -1104,26 +1104,18 @@ postCLecInviteR tid ssh csh email = do
     iRes <- getBy404 $ UniqueLecturerInvitation email cid
     return (cRes, iRes)
 
-  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ \csrf -> do
+  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost . formEmbedJwtPost $ \csrf -> do
     (ltRes, ltView) <- case lecturerInvitationType of
       Nothing -> mreq (selectField optionsFinite) "" Nothing
       Just lType -> mforced (selectField optionsFinite) "" lType
     (btnRes, btnWdgt) <- buttonForm mempty
     return ((,) <$> ltRes <*> btnRes, toWidget csrf <> fvInput ltView <> btnWdgt)
-  mJwt <- askJwt
 
-  let btnWidget = wrapForm btnInnerWidget' def
+  let btnWidget = wrapForm btnInnerWidget def
         { formEncoding = btnEncoding
         , formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email
         , formSubmit = FormNoSubmit
         }
-      btnInnerWidget'
-        = [whamlet|
-            $newline never
-            $maybe jwt <- mJwt
-              <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
-            ^{btnInnerWidget}
-          |]
 
   formResult btnResult $ \case
     (lType, BtnLecInvAccept) -> do

src/Handler/Profile.hs

@@ -587,21 +587,14 @@ postUserNotificationR cID = do
   uid <- decrypt cID
   User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
 
-  ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
+  ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
   mJwt <- askJwt
   isModal <- hasCustomHeader HeaderIsModal
-  let formWidget = wrapForm nsInnerWdgt' def
+  let formWidget = wrapForm nsInnerWdgt def
         { formAction = Just . SomeRoute $ UserNotificationR cID
         , formEncoding = nsEnc
         , formAttrs = [ ("data-ajax-submit", "") | isModal ]
         }
-      nsInnerWdgt'
-        = [whamlet|
-            $newline never
-            $maybe jwt <- mJwt
-              <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
-            ^{nsInnerWdgt}
-          |]
 
   formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
     lift . runDB $ update uid [ UserNotificationSettings =. ns ]

src/Handler/Utils/Tokens.hs

@@ -0,0 +1,27 @@
+module Handler.Utils.Tokens
+  ( maybeBearerToken, requireBearerToken
+  ) where
+
+import Import
+
+import Utils.Lens
+
+import Control.Monad.Trans.Maybe (runMaybeT)
+
+
+maybeBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => m (Maybe (BearerToken UniWorX))
+maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
+  where
+    cPred err = any ($ err)
+      [ is $ _HCError . _PermissionDenied
+      , is $ _HCError . _NotAuthenticated
+      ]
+
+requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
+requireBearerToken = liftHandlerT $ do
+  token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return $ askTokenUnsafe
+  mAuthId <- maybeAuthId
+  currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
+  isWrite <- isWriteRequest currentRoute
+  guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
+  return token

src/Import.hs

@@ -6,4 +6,3 @@ import Foundation            as Import
 import Import.NoFoundation   as Import
 
 import Utils.SystemMessage   as Import
-import Model.Token           as Import

src/Import/NoFoundation.hs

@@ -9,6 +9,7 @@ import Model.Types.JSON       as Import
 import Model.Migration        as Import
 import Model.Rating           as Import
 import Model.Submission       as Import
+import Model.Tokens           as Import
 import Settings               as Import
 import Settings.StaticFiles   as Import
 import Yesod.Auth             as Import
@@ -20,6 +21,10 @@ import Utils.Frontend.I18n    as Import
 import Yesod.Core.Json        as Import (provideJson)
 import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
 
+import Language.Haskell.TH.Instances as Import ()
+
+import Utils.Tokens           as Import
+
 
 import Data.Fixed             as Import
 
@@ -49,6 +54,10 @@ import Data.Text.Encoding.Error as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Semigroup)
 import Data.Monoid            as Import (Last(..), First(..))
 import Data.Monoid.Instances  as Import ()
+import Data.HashMap.Strict.Instances as Import ()
+import Data.HashSet.Instances as Import ()
+import Data.Vector.Instances  as Import ()
+import Data.Time.Clock.Instances as Import ()
 
 import Data.Binary            as Import (Binary)
 

src/Language/Haskell/TH/Instances.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Language.Haskell.TH.Instances
+  (
+  ) where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Lift (deriveLift)
+import Data.Binary (Binary)
+
+
+instance Binary Loc
+
+deriveLift ''Loc

src/Mail.hs

@@ -27,6 +27,7 @@ module Mail
   , setSubjectI, setMailObjectId, setMailObjectId'
   , setDate, setDateCurrent
   , setMailSmtpData
+  , _addressName, _addressEmail
   , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
   , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
   ) where
@@ -105,6 +106,7 @@ import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
   
 
+makeLenses_ ''Address
 makeLenses_ ''Mail
 makeLenses_ ''Part
 

src/Model/Tokens.hs

@@ -1,28 +1,23 @@
 {-# LANGUAGE UndecidableInstances #-}
 
-module Model.Token
+module Model.Tokens
   ( BearerToken(..)
   , _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
   , tokenRestrict
-  , bearerToken
-  , encodeToken, BearerTokenException(..), decodeToken, jwtEncoding
-  , tokenToJSON, tokenParseJSON, tokenParseJSON'
-  , askJwt
+  , tokenToJSON, tokenParseJSON
   ) where
 
 import ClassyPrelude.Yesod
+import Yesod.Core.Instances ()
+  
 import Model
-import Settings
-import Utils (NTop(..), hoistMaybe, assertM')
+import Utils (assertM')
 import Utils.Lens hiding ((.=))
 import Data.Aeson.Lens (AsJSON(..))
-import Utils.Parameters
 
 import Yesod.Auth (AuthId)
 
-import qualified Jose.Jwa as Jose
-import Jose.Jwk (JwkSet(..))
-import Jose.Jwt (Jwt(..), IntDate(..))
+import Jose.Jwt (IntDate(..))
 import qualified Jose.Jwt as Jose
 
 import Jose.Jwt.Instances ()
@@ -31,21 +26,20 @@ import Data.Aeson.Types.Instances ()
 import Data.HashSet (HashSet)
 
 import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict.Instances ()
+import Data.HashSet.Instances ()
+import Data.Time.Clock.Instances ()
 
-import Data.Aeson.Types (Parser, (.:?), (.:), (.!=))
+import Data.Aeson.Types (Parser, (.:?), (.:), (.!=), (.=))
 import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Types as JSON
-import qualified Data.Aeson.Parser as JSON
-import qualified Data.Aeson.Parser.Internal as JSON (jsonEOF')
-import qualified Data.Aeson.Internal as JSON (iparse, formatError)
 
 import CryptoID
 
-import Data.Time.Clock
 import Data.Time.Clock.POSIX
 
-import Control.Monad.Random (MonadRandom(..))
-import Control.Monad.Trans.Maybe (MaybeT(..))
+import Data.Binary (Binary)
+
 
 
 -- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
@@ -72,6 +66,8 @@ deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
 deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
 deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
 
+instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
+
 makeLenses_ ''BearerToken
 
 _tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
@@ -130,7 +126,7 @@ tokenParseJSON :: forall site.
 --
 -- Monadic context is needed because `AuthId`s are encrypted during encoding
 --
--- It's usually easier to use `tokenParseJSON'`
+-- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
 tokenParseJSON v@(Object o) = do
   tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
   tokenAuthority <- decrypt tokenAuthority'
@@ -151,116 +147,3 @@ tokenParseJSON v@(Object o) = do
   return BearerToken{..}
 tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
 
-tokenParseJSON' :: forall m.
-                  ( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
-                  , ParseRoute (HandlerSite m)
-                  , Hashable (Route (HandlerSite m))
-                  , MonadHandler m
-                  , MonadCrypto m
-                  , MonadCryptoKey m ~ CryptoIDKey
-                  )
-               => m (Value -> Parser (BearerToken (HandlerSite m)))
--- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
-tokenParseJSON' = do
-  cidKey <- cryptoIDKey return
-  return $ flip runReaderT cidKey . tokenParseJSON
-
-
-bearerToken :: forall m.
-               ( MonadHandler m
-               , HasInstanceID (HandlerSite m) InstanceId
-               , HasCryptoUUID (AuthId (HandlerSite m)) m
-               , HasAppSettings (HandlerSite m)
-               )
-            => AuthId (HandlerSite m)
-            -> Maybe (HashSet (Route (HandlerSite m)))
-            -> Maybe AuthDNF
-            -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
-            -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
-            -> m (BearerToken (HandlerSite m))
--- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
-bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
-  tokenIdentifier <- liftIO getRandom
-  tokenIssuedAt <- liftIO getCurrentTime
-  tokenIssuedBy <- getsYesod $ view instanceID
-
-  defaultExpiration <- getsYesod $ view _appJWTExpiration
-  
-  let tokenExpiresAt
-        | Just t <- mTokenExpiresAt
-        = t
-        | Just tDiff <- defaultExpiration
-        = Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
-        | otherwise
-        = Nothing
-      tokenRestrictions = HashMap.empty
-
-  return BearerToken{..}
-
-
-jwtEncoding :: Jose.JwtEncoding
--- ^ How should `Jwt`s be signed and/or encrypted?
-jwtEncoding = Jose.JwsEncoding Jose.HS256
-
-
-encodeToken :: forall m.
-               ( MonadHandler m
-               , HasJSONWebKeySet (HandlerSite m) JwkSet
-               , HasInstanceID (HandlerSite m) InstanceId
-               , HasCryptoUUID (AuthId (HandlerSite m)) m
-               , RenderRoute (HandlerSite m)
-               )
-            => BearerToken (HandlerSite m) -> m Jwt
--- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `jwtEncoding`
-encodeToken token = do
-  payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
-  JwkSet jwks <- getsYesod $ view jsonWebKeySet
-  either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
-
-
-data BearerTokenException
-  = BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation
-  | BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted)
-  | BearerTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `BearerToken`
-  | BearerTokenExpired | BearerTokenNotStarted
-  deriving (Eq, Show, Generic, Typeable)
-
-instance Exception BearerTokenException
-
-decodeToken :: forall m.
-               ( MonadHandler m
-               , HasJSONWebKeySet (HandlerSite m) JwkSet
-               , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
-               , MonadCryptoKey m ~ CryptoIDKey
-               , MonadCrypto m
-               , MonadThrow m
-               , ParseRoute (HandlerSite m)
-               , Hashable (Route (HandlerSite m))
-               )
-            => Jwt -> m (BearerToken (HandlerSite m))
--- ^ Decode a `Jwt` according to `jwtEncoding` and call `tokenParseJSON`
-decodeToken (Jwt bs) = do
-  JwkSet jwks <- getsYesod $ view jsonWebKeySet
-  content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
-  content' <- case content of
-    Jose.Unsecured _ -> throwM BearerTokenUnsecured
-    Jose.Jws (_header, payload) -> return payload
-    Jose.Jwe (_header, payload) -> return payload
-  parser <- tokenParseJSON'
-  token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
-  now <- liftIO getCurrentTime
-  unless (NTop tokenExpiresAt > NTop (Just now)) $
-    throwM BearerTokenExpired
-  unless (tokenStartsAt <= Just now) $
-    throwM BearerTokenNotStarted
-  return token
-
-
-askJwt :: forall m. ( MonadHandler m )
-       => m (Maybe Jwt)
--- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
-askJwt = runMaybeT $ asum
-  [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
-  , MaybeT $ lookupGlobalPostParam PostBearer
-  , MaybeT $ lookupGlobalGetParam GetBearer
-  ]

src/Model/Types.hs

@@ -81,6 +81,7 @@ import Model.Types.Wordlist
 import Data.Text.Metrics (damerauLevenshtein)
 
 import Data.Binary (Binary)
+import qualified Data.Binary as Binary
   
 
 instance PathPiece UUID where
@@ -795,6 +796,8 @@ instance PathPiece a => PathPiece (PredLiteral a) where
   fromPathPiece t = PLVariable <$> fromPathPiece t
                 <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
 
+instance Binary a => Binary (PredLiteral a)
+
 
 newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -802,11 +805,15 @@ newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
 
 $(return [])
 
-instance (Ord a, ToJSON a) => ToJSON (PredDNF a) where
+instance ToJSON a => ToJSON (PredDNF a) where
   toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
 instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
   parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
 
+instance (Ord a, Binary a) => Binary (PredDNF a) where
+  get = PredDNF <$> Binary.get
+  put = Binary.put . dnfTerms
+
 type AuthLiteral = PredLiteral AuthTag
 
 type AuthDNF = PredDNF AuthTag

src/Settings.hs

@@ -63,6 +63,9 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 
 import qualified System.FilePath as FilePath
 
+import Jose.Jwt (JwtEncoding(..))
+
+
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
 -- theoretically even a database.
@@ -100,7 +103,8 @@ data AppSettings = AppSettings
     , appNotificationExpiration :: NominalDiffTime
     , appSessionTimeout         :: NominalDiffTime
     , appMaximumContentLength   :: Maybe Word64
-    , appJWTExpiration          :: Maybe NominalDiffTime
+    , appJwtExpiration          :: Maybe NominalDiffTime
+    , appJwtEncoding            :: JwtEncoding
 
     , appInitialLogSettings     :: LogSettings
 
@@ -311,6 +315,18 @@ deriveFromJSON
     }
   ''SmtpAuthConf
 
+instance FromJSON JwtEncoding where
+  parseJSON v@(String _) = JwsEncoding <$> parseJSON v
+  parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum
+    [ do
+        alg <- obj .: "alg"
+        return $ JwsEncoding alg
+    , do
+        alg <- obj .: "alg"
+        enc <- obj .: "enc"
+        return $ JweEncoding alg enc
+    ]
+
 
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
@@ -353,7 +369,8 @@ instance FromJSON AppSettings where
         appNotificationRateLimit  <- o .:  "notification-rate-limit"
         appNotificationCollateDelay <- o .: "notification-collate-delay"
         appNotificationExpiration <- o .: "notification-expiration"
-        appJWTExpiration          <- o .:? "jwt-expiration"
+        appJwtExpiration          <- o .:? "jwt-expiration"
+        appJwtEncoding            <- o .: "jwt-encoding"
 
         appSessionTimeout         <- o .: "session-timeout"
 

src/Utils.hs

@@ -52,6 +52,7 @@ import Control.Monad.Catch hiding (throwM)
 import qualified Database.Esqueleto as E (Value, unValue)
 
 import Language.Haskell.TH
+import Language.Haskell.TH.Instances ()
 import Instances.TH.Lift ()
 
 import Text.Shakespeare.Text (st)
@@ -69,6 +70,8 @@ import qualified Crypto.Data.PKCS7 as PKCS7
 import Data.Fixed (Centi)
 import Data.Ratio ((%))
 
+import qualified Data.Binary as Binary
+
 {-# ANN choice ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -607,6 +610,15 @@ choice = foldr (<|>) empty
 -- Sessions --
 --------------
 
+data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
+                | SessionNewStudyTerms
+                | SessionBearer
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+instance Universe SessionKey
+instance Finite SessionKey
+
+nullaryPathPiece ''SessionKey $ camelToPathPiece' 1
+
 setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
 setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
 
@@ -731,3 +743,12 @@ encodedSecretBoxOpen :: ( FromJSON a, MonadError EncodedSecretBoxException m, Mo
 encodedSecretBoxOpen ciphertext = do
   sKey <- secretBoxKey
   encodedSecretBoxOpen' sKey ciphertext
+
+-------------
+-- Caching --
+-------------
+
+cachedHere :: Q Exp
+cachedHere = do
+  loc <- location
+  [e| cachedBy (toStrict $ Binary.encode loc) |]

src/Utils/Lens.hs

@@ -1,12 +1,16 @@
 module Utils.Lens ( module Utils.Lens ) where
 
-import Import.NoFoundation
+import ClassyPrelude.Yesod hiding ((.=))
+import Model
 import Control.Lens as Utils.Lens hiding ((<.>))
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
 
+import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
+
 import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
 
+
 _unValue :: Lens' (E.Value a) a
 _unValue f (E.Value a) = E.Value <$> f a
 
@@ -70,8 +74,6 @@ hasEntityUser = hasEntity
 --   hasUser = _entityVal . hasUser
 
 
-makeLenses_ ''Address
-
 makeLenses_ ''SheetCorrector
 
 makeLenses_ ''SubmissionGroup
@@ -92,6 +94,10 @@ makeLenses_ ''StudyTerms
 
 makeLenses_ ''StudyTermCandidate
 
+makePrisms ''HandlerContents
+
+makePrisms ''ErrorResponse
+
 
 -- makeClassy_ ''Load
 

src/Utils/Tokens.hs

@@ -0,0 +1,174 @@
+module Utils.Tokens
+  ( bearerToken
+  , encodeToken, BearerTokenException(..), decodeToken
+  , tokenParseJSON'
+  , askJwt
+  , formEmbedJwtPost, formEmbedJwtGet
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Yesod.Auth (AuthId)
+
+import Utils (NTop(..), hoistMaybe, SessionKey(..))
+import Utils.Parameters
+import Utils.Lens hiding ((.=))
+
+import Model
+import Model.Tokens
+
+import Jose.Jwk (JwkSet(..))
+import Jose.Jwt (Jwt(..))
+import qualified Jose.Jwt as Jose
+
+import Data.Aeson.Types (Parser)
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Parser as JSON
+import qualified Data.Aeson.Parser.Internal as JSON (jsonEOF')
+import qualified Data.Aeson.Internal as JSON (iparse, formatError)
+
+import qualified Data.HashMap.Strict as HashMap
+
+import Data.Time.Clock
+
+import Control.Monad.Random (MonadRandom(..))
+import Control.Monad.Trans.Maybe (MaybeT(..))
+
+import Settings
+
+import CryptoID
+
+import Text.Blaze (Markup)
+
+
+tokenParseJSON' :: forall m.
+                  ( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+                  , ParseRoute (HandlerSite m)
+                  , Hashable (Route (HandlerSite m))
+                  , MonadHandler m
+                  , MonadCrypto m
+                  , MonadCryptoKey m ~ CryptoIDKey
+                  )
+               => m (Value -> Parser (BearerToken (HandlerSite m)))
+-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
+tokenParseJSON' = do
+  cidKey <- cryptoIDKey return
+  return $ flip runReaderT cidKey . tokenParseJSON
+
+
+bearerToken :: forall m.
+               ( MonadHandler m
+               , HasInstanceID (HandlerSite m) InstanceId
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , HasAppSettings (HandlerSite m)
+               )
+            => AuthId (HandlerSite m)
+            -> Maybe (HashSet (Route (HandlerSite m)))
+            -> Maybe AuthDNF
+            -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
+            -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
+            -> m (BearerToken (HandlerSite m))
+-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
+bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
+  tokenIdentifier <- liftIO getRandom
+  tokenIssuedAt <- liftIO getCurrentTime
+  tokenIssuedBy <- getsYesod $ view instanceID
+
+  defaultExpiration <- getsYesod $ view _appJwtExpiration
+  
+  let tokenExpiresAt
+        | Just t <- mTokenExpiresAt
+        = t
+        | Just tDiff <- defaultExpiration
+        = Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
+        | otherwise
+        = Nothing
+      tokenRestrictions = HashMap.empty
+
+  return BearerToken{..}
+
+
+encodeToken :: forall m.
+               ( MonadHandler m
+               , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , HasInstanceID (HandlerSite m) InstanceId
+               , HasAppSettings (HandlerSite m)
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , RenderRoute (HandlerSite m)
+               )
+            => BearerToken (HandlerSite m) -> m Jwt
+-- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
+encodeToken token = do
+  payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
+  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  jwtEncoding <- getsYesod $ view _appJwtEncoding
+  either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
+
+
+data BearerTokenException
+  = BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation
+  | BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted)
+  | BearerTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `BearerToken`
+  | BearerTokenExpired | BearerTokenNotStarted
+  deriving (Eq, Show, Generic, Typeable)
+
+instance Exception BearerTokenException
+
+decodeToken :: forall m.
+               ( MonadHandler m
+               , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+               , MonadCryptoKey m ~ CryptoIDKey
+               , MonadCrypto m
+               , MonadThrow m
+               , ParseRoute (HandlerSite m)
+               , Hashable (Route (HandlerSite m))
+               )
+            => Jwt -> m (BearerToken (HandlerSite m))
+-- ^ Decode a `Jwt` and call `tokenParseJSON`
+--
+-- Throws `bearerTokenException`s
+decodeToken (Jwt bs) = do
+  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
+  content' <- case content of
+    Jose.Unsecured _ -> throwM BearerTokenUnsecured
+    Jose.Jws (_header, payload) -> return payload
+    Jose.Jwe (_header, payload) -> return payload
+  parser <- tokenParseJSON'
+  token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
+  now <- liftIO getCurrentTime
+  unless (NTop tokenExpiresAt > NTop (Just now)) $
+    throwM BearerTokenExpired
+  unless (tokenStartsAt <= Just now) $
+    throwM BearerTokenNotStarted
+  return token
+
+
+askJwt :: forall m. ( MonadHandler m )
+       => m (Maybe Jwt)
+-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
+askJwt = runMaybeT $ asum
+  [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
+  , MaybeT $ lookupGlobalPostParam PostBearer
+  , MaybeT $ lookupGlobalGetParam GetBearer
+  , fmap Jwt . MaybeT $ lookupSessionBS (toPathPiece SessionBearer)
+  ]
+
+formEmbedJwtPost, formEmbedJwtGet :: MonadHandler m => (Markup -> m a) -> (Markup -> m a)
+formEmbedJwtPost f fragment = do
+  mJwt <- askJwt
+  f [shamlet|
+       $newline never
+       $maybe jwt <- mJwt
+         <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
+       #{fragment}
+    |]
+formEmbedJwtGet f fragment = do
+  mJwt <- askJwt
+  f [shamlet|
+       $newline never
+       $maybe jwt <- mJwt
+         <input type=hidden name=#{toPathPiece GetBearer} value=#{toPathPiece jwt}>
+       #{fragment}
+    |]