diff --git a/config/settings.yml b/config/settings.yml index 9479d002a..287baf0b3 100644 --- a/config/settings.yml +++ b/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: diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index fb521065d..c42f8cb0c 100644 --- a/messages/uniworx/de.msg +++ b/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. diff --git a/package.yaml b/package.yaml index f6d487376..47917503c 100644 --- a/package.yaml +++ b/package.yaml @@ -85,6 +85,7 @@ dependencies: - scientific - tz - system-locale + - th-lift - th-lift-instances - gitrev - Glob diff --git a/src/Data/Aeson/Types/Instances.hs b/src/Data/Aeson/Types/Instances.hs index f785576f2..66ff1df61 100644 --- a/src/Data/Aeson/Types/Instances.hs +++ b/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 diff --git a/src/Data/HashMap/Strict/Instances.hs b/src/Data/HashMap/Strict/Instances.hs new file mode 100644 index 000000000..7d56f03a8 --- /dev/null +++ b/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 diff --git a/src/Data/HashSet/Instances.hs b/src/Data/HashSet/Instances.hs new file mode 100644 index 000000000..3fc16cd43 --- /dev/null +++ b/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 diff --git a/src/Data/NonNull/Instances.hs b/src/Data/NonNull/Instances.hs index 1a11a66d9..55981d6ff 100644 --- a/src/Data/NonNull/Instances.hs +++ b/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 diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs new file mode 100644 index 000000000..1783ac465 --- /dev/null +++ b/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 diff --git a/src/Data/Vector/Instances.hs b/src/Data/Vector/Instances.hs new file mode 100644 index 000000000..953130328 --- /dev/null +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 40dc1246c..cc919e8b4 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 4e4b07eee..32f8db822 100644 --- a/src/Handler/Admin.hs +++ b/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 $ (,,) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 848faf0e7..c084c139f 100644 --- a/src/Handler/Course.hs +++ b/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 - - ^{btnInnerWidget} - |] formResult btnResult $ \case (lType, BtnLecInvAccept) -> do diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 71e718da9..aa1593ea2 100644 --- a/src/Handler/Profile.hs +++ b/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 - - ^{nsInnerWdgt} - |] formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do lift . runDB $ update uid [ UserNotificationSettings =. ns ] diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs new file mode 100644 index 000000000..00a0cdbe7 --- /dev/null +++ b/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 diff --git a/src/Import.hs b/src/Import.hs index 9743e86ac..27dc6e5df 100644 --- a/src/Import.hs +++ b/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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 2c89df2a1..9b7114837 100644 --- a/src/Import/NoFoundation.hs +++ b/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) diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs new file mode 100644 index 000000000..48c419705 --- /dev/null +++ b/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 diff --git a/src/Mail.hs b/src/Mail.hs index 008af9987..283de2deb 100644 --- a/src/Mail.hs +++ b/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 diff --git a/src/Model/Token.hs b/src/Model/Tokens.hs similarity index 51% rename from src/Model/Token.hs rename to src/Model/Tokens.hs index e3b3148cf..2b445eb99 100644 --- a/src/Model/Token.hs +++ b/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 - ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 00bda42a1..3978399b4 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Settings.hs b/src/Settings.hs index ae2ce4b30..47e0b25e8 100644 --- a/src/Settings.hs +++ b/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" diff --git a/src/Utils.hs b/src/Utils.hs index a95cb7bfc..68906d803 100644 --- a/src/Utils.hs +++ b/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) |] diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 4493dc612..05261e95b 100644 --- a/src/Utils/Lens.hs +++ b/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 diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs new file mode 100644 index 000000000..f6533120d --- /dev/null +++ b/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 + + #{fragment} + |] +formEmbedJwtGet f fragment = do + mJwt <- askJwt + f [shamlet| + $newline never + $maybe jwt <- mJwt + + #{fragment} + |]