diff --git a/config/settings.yml b/config/settings.yml index 4cf98ef99..b1fb3cc7a 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -250,4 +250,4 @@ token-buckets: fallback-personalised-sheet-files-keys-expire: 2419200 -download-token-expire: 14400 +download-token-expire: 604801 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 50a124c2d..7ff6e44cd 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1538,6 +1538,7 @@ BreadcrumbWorkflowWorkflowDelete: Löschen BreadcrumbGlobalWorkflowInstanceList: Systemweite Workflows BreadcrumbTopWorkflowInstanceList: Workflows BreadcrumbTopWorkflowWorkflowList: Laufende Workflows +BreadcrumbError: Fehler ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index f7a9ef2c5..0704d6c81 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1538,6 +1538,7 @@ BreadcrumbWorkflowWorkflowDelete: Delete BreadcrumbGlobalWorkflowInstanceList: System-wide workflows BreadcrumbTopWorkflowInstanceList: Workflows BreadcrumbTopWorkflowWorkflowList: Running workflows +BreadcrumbError: Error ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn} ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn} diff --git a/routes b/routes index c522e4129..b40036b29 100644 --- a/routes +++ b/routes @@ -41,6 +41,8 @@ /metrics MetricsR GET +/err ErrorR GET !free + / NewsR GET !free /users UsersR GET POST -- no tags, i.e. admins only /users/#CryptoUUIDUser AdminUserR GET POST diff --git a/src/Application.hs b/src/Application.hs index 252eb7aba..9e559e6a0 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -129,6 +129,7 @@ import Handler.ExternalExam import Handler.Participants import Handler.StorageKey import Handler.Workflow +import Handler.Error -- This line actually creates our YesodDispatch instance. It is the second half @@ -183,7 +184,7 @@ makeFoundation appSettings'@AppSettings{..} = do -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret = UniWorX {..} + let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html @@ -200,6 +201,7 @@ makeFoundation appSettings'@AppSettings{..} = do (error "memcached forced in tempFoundation") (error "MinioConn forced in tempFoundation") (error "VerpSecret forced in tempFoundation") + (error "AuthKey forced in tempFoundation") runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID @@ -244,6 +246,7 @@ makeFoundation appSettings'@AppSettings{..} = do appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `runSqlPool` sqlPool + appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `runSqlPool` sqlPool appMemcached <- for appMemcachedConf $ \memcachedConf -> do $logDebugS "setup" "Memcached" @@ -261,7 +264,7 @@ makeFoundation appSettings'@AppSettings{..} = do handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadCacheBucket Nothing return conn - let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret + let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey -- Return the foundation $logDebugS "setup" "Done" diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 8159bcb00..a3677a07c 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -304,3 +304,6 @@ instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where secretBoxKey = getsYesod appSecretBoxKey + +instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadAuth m where + authKey = getsYesod appAuthKey diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 42e7d3e56..feb11b3df 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -65,6 +65,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing + breadcrumb ErrorR = i18nCrumb MsgBreadcrumbError Nothing breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 9ca763f3f..e58ee1f96 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -6,7 +6,7 @@ module Foundation.Type , SomeSessionStorage(..) , _SessionStorageMemcachedSql, _SessionStorageAcid , SMTPPool - , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport + , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey , DB, Form, MsgRenderer, MailM, DBFile ) where @@ -19,6 +19,7 @@ import Yesod.Core.Types (Logger) import qualified Crypto.Saltine.Core.SecretBox as SecretBox import qualified Crypto.Saltine.Core.AEAD as AEAD +import qualified Crypto.Saltine.Core.Auth as Auth import qualified Jose.Jwk as Jose import qualified Database.Memcached.Binary.IO as Memcached @@ -58,6 +59,7 @@ data UniWorX = UniWorX , appMemcached :: Maybe (AEAD.Key, Memcached.Connection) , appUploadCache :: Maybe MinioConn , appVerpSecret :: VerpSecret + , appAuthKey :: Auth.Key } makeLenses_ ''UniWorX diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index a8ee44100..2720300dc 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -14,10 +14,13 @@ import Foundation.Routes import qualified Data.Aeson as JSON import qualified Data.Text as Text + +import qualified Network.Wai as W errorHandler :: ( MonadSecretBox (HandlerFor UniWorX) , MonadSecretBox (WidgetFor UniWorX) + , MonadAuth (HandlerFor UniWorX) , BearerAuthSite UniWorX , Button UniWorX ButtonSubmit , BackendCompatible SqlBackend (YesodPersistBackend UniWorX) @@ -25,12 +28,35 @@ errorHandler :: ( MonadSecretBox (HandlerFor UniWorX) ) => ErrorResponse -> HandlerFor UniWorX TypedContent errorHandler err = do + -- when (is _NotAuthenticated err) $ do + -- authed <- is _Just <$> maybeAuthId + -- unless authed $ do + -- mCurrent <- getCurrentRoute + -- gets' <- reqGetParams <$> getRequest + -- wai <- waiRequest + -- maybe clearUltDest setUltDest $ do + -- current <- mCurrent + -- case current of + -- _ | W.requestMethod wai `notElem` ["GET"] -> Nothing + -- ErrorR -> Nothing + -- current' -> Just (current', gets') + -- $logInfoS "errorHandler" "Redirect to LoginR" + -- redirect $ AuthR LoginR + shouldEncrypt <- do canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True shouldEncrypt <- getsYesod $ view _appEncryptErrors return $ shouldEncrypt && not canDecrypt sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err + + void . runMaybeT $ do + reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest + approotHost <- MaybeT . getsYesod $ approotScopeHost ApprootDefault + when (approotHost /= reqHost) $ do + authErr <- lift $ encodedAuth sessErr + redirect (ErrorR, [(toPathPiece GetError, authErr)]) + setSessionJson SessionError sessErr selectRep $ do diff --git a/src/Handler/Error.hs b/src/Handler/Error.hs new file mode 100644 index 000000000..7ed412849 --- /dev/null +++ b/src/Handler/Error.hs @@ -0,0 +1,12 @@ +module Handler.Error + ( getErrorR + ) where + +import Import +import Yesod.Core.Types (HandlerContents(HCError)) + + +getErrorR :: Handler Void +getErrorR = do + encodedErrResponse <- maybe (redirect NewsR) return =<< lookupGlobalGetParam GetError + throwM . HCError =<< throwExceptT (encodedAuthVerify encodedErrResponse) diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index 3e3bd5678..a3bfb46b4 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -67,6 +67,10 @@ dispatchHealthCheckMatchingClusterConfig ourSetting <- getsYesod appVerpSecret dbSetting <- clusterSetting @'ClusterVerpSecret return $ Just ourSetting == dbSetting + clusterSettingMatches ClusterAuthKey = do + ourSetting <- getsYesod appAuthKey + dbSetting <- clusterSetting @'ClusterAuthKey + return $ Just ourSetting == dbSetting clusterSetting :: forall key. diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index dd565b7c6..5bc298e83 100644 --- a/src/Settings/Cluster.hs +++ b/src/Settings/Cluster.hs @@ -18,6 +18,7 @@ import qualified Data.Aeson as Aeson import qualified Crypto.Saltine.Core.SecretBox as SecretBox import qualified Crypto.Saltine.Core.AEAD as AEAD +import qualified Crypto.Saltine.Core.Auth as Auth import qualified Crypto.Saltine.Class as Saltine import Data.CryptoID.ByteString (CryptoIDKey) @@ -49,6 +50,7 @@ data ClusterSettingsKey | ClusterId | ClusterMemcachedKey | ClusterVerpSecret + | ClusterAuthKey deriving (Eq, Ord, Enum, Bounded, Show, Read) instance Universe ClusterSettingsKey @@ -98,9 +100,9 @@ instance ToJSON AEAD.Key where toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode instance FromJSON AEAD.Key where - parseJSON = Aeson.withText "Key" $ \t -> do + parseJSON = Aeson.withText "AEAD.Key" $ \t -> do bytes <- either fail return . Base64.decode $ encodeUtf8 t - maybe (fail "Could not parse key") return $ Saltine.decode bytes + maybe (fail "Could not parse AEAD.Key") return $ Saltine.decode bytes instance ClusterSetting 'ClusterSecretBoxKey where @@ -112,9 +114,9 @@ instance ToJSON SecretBox.Key where toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode instance FromJSON SecretBox.Key where - parseJSON = Aeson.withText "Key" $ \t -> do + parseJSON = Aeson.withText "SecretBox.Key" $ \t -> do bytes <- either fail return . Base64.decode $ encodeUtf8 t - maybe (fail "Could not parse key") return $ Saltine.decode bytes + maybe (fail "Could not parse SecretBox.Key") return $ Saltine.decode bytes instance ClusterSetting 'ClusterJSONWebKeySet where @@ -152,3 +154,16 @@ instance ClusterSetting 'ClusterVerpSecret where type ClusterSettingValue 'ClusterVerpSecret = VerpSecret initClusterSetting _ = liftIO $ Crypto.getRandomBytes 16 knownClusterSetting _ = ClusterVerpSecret + +instance ToJSON Auth.Key where + toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode + +instance FromJSON Auth.Key where + parseJSON = Aeson.withText "Auth.Key" $ \t -> do + bytes <- either fail return . Base64.decode $ encodeUtf8 t + maybe (fail "Could not parse Auth.Key") return $ Saltine.decode bytes + +instance ClusterSetting 'ClusterAuthKey where + type ClusterSettingValue 'ClusterAuthKey = Auth.Key + initClusterSetting _ = liftIO $ Auth.newKey + knownClusterSetting _ = ClusterAuthKey diff --git a/src/Utils.hs b/src/Utils.hs index 646e7afb5..f16625b16 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -83,6 +83,7 @@ import Data.Universe import qualified Crypto.Saltine.Internal.ByteSizes as Saltine import qualified Data.ByteString.Base64.URL as Base64 import qualified Crypto.Saltine.Core.SecretBox as SecretBox +import qualified Crypto.Saltine.Core.Auth as Auth import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Data.PKCS7 as PKCS7 import Crypto.MAC.KMAC (KMAC, HashSHAKE) @@ -1141,6 +1142,62 @@ encodedSecretBoxOpen ciphertext = do sKey <- secretBoxKey encodedSecretBoxOpen' sKey ciphertext +encodedAuthSep :: Text +encodedAuthSep = "." + +encodedAuth' :: ToJSON a + => Auth.Key + -> a -> Text +encodedAuth' aKey val = base64 msg <> encodedAuthSep <> base64 (Saltine.encode auth) + where msg = toStrict $ Aeson.encode val + auth = Auth.auth aKey msg + base64 = decodeUtf8 . Base64.encodeUnpadded + +data EncodedAuthException + = EncodedAuthInvalidSeparation + | EncodedAuthInvalidBase64 !String + | EncodedAuthCouldNotDecodeAuthenticator + | EncodedAuthInvalidAuthenticator + | EncodedAuthCouldNotDecodePlaintext !String + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Exception) + +encodedAuthVerify' :: (FromJSON a, MonadError EncodedAuthException m) + => Auth.Key + -> Text -> m a +encodedAuthVerify' aKey bothEncoded = do + (msgEncoded, authEncoded) <- case Text.splitOn encodedAuthSep bothEncoded of + [msgEncoded, authEncoded] -> return (msgEncoded, authEncoded) + _other -> throwError EncodedAuthInvalidSeparation + authBS <- either (throwError . EncodedAuthInvalidBase64) return . Base64.decode $ encodeUtf8 authEncoded + auth <- maybe (throwError EncodedAuthCouldNotDecodeAuthenticator) return $ Saltine.decode authBS + msgDecoded <- either (throwError . EncodedAuthInvalidBase64) return . Base64.decode $ encodeUtf8 msgEncoded + unless (Auth.verify aKey auth msgDecoded) $ + throwError EncodedAuthInvalidAuthenticator + either (throwError . EncodedAuthCouldNotDecodePlaintext) return $ Aeson.eitherDecodeStrict' msgDecoded + +class Monad m => MonadAuth m where + authKey :: m Auth.Key + +instance MonadAuth ((->) Auth.Key) where + authKey = id + +instance Monad m => MonadAuth (ReaderT Auth.Key m) where + authKey = ask + +encodedAuth :: ( ToJSON a, MonadAuth m ) + => a -> m Text +encodedAuth val = do + aKey <- authKey + return $ encodedAuth' aKey val + +encodedAuthVerify :: ( FromJSON a, MonadError EncodedAuthException m, MonadAuth m ) + => Text -> m a +encodedAuthVerify bothEncoded = do + aKey <- authKey + encodedAuthVerify' aKey bothEncoded + + kmaclazy :: forall a string key ba chunk. ( HashSHAKE a diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index bdf07749b..dcc6d8c95 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -21,7 +21,14 @@ import Data.Universe import Control.Monad.Trans.Maybe (MaybeT(..)) -data GlobalGetParam = GetLang | GetReferer | GetBearer | GetRecipient | GetCsvExampleData | GetDryRun | GetDownload +data GlobalGetParam = GetLang + | GetReferer + | GetBearer + | GetRecipient + | GetCsvExampleData + | GetDryRun + | GetDownload + | GetError deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) diff --git a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs index 27aa2bc13..ab5342ff3 100644 --- a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs +++ b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs @@ -12,7 +12,7 @@ module Web.ServerSession.Frontend.Yesod.Jwt -- serversession-frontend-yesod-1.0@sha256:8ddb112a1ef6ee863f5ea13978dd08e1c39444c1a252f775a780013430bcc884,1230 -import Import.NoModel hiding (State, state, Header, deleteCookie) +import Import.NoModel hiding (State, state, Header, deleteCookie, authKey) import Yesod.Core.Types import Model.Types.Common