feat(errors): redirect errors back to ApprootDefault

config/settings.yml

@@ -250,4 +250,4 @@ token-buckets:
 
 fallback-personalised-sheet-files-keys-expire: 2419200
 
-download-token-expire: 14400
+download-token-expire: 604801

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}

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}

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

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"

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

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

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

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

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)

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.

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

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

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)
 

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