diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index da3c0a31e..f27bdb02b 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -454,4 +454,11 @@ ErrorResponseNotFound: Unter der von Ihrem Browser angefragten URL wurde keine S
ErrorResponseNotAuthenticated: Um Zugriff auf einige Teile des Systems zu erhalten müssen Sie sich zunächst anmelden.
ErrorResponseBadMethod requestMethodText@Text: Ihr Browser kann auf mehrere verschiedene Arten versuchen mit den vom System angebotenen Ressourcen zu interagieren. Die aktuell versuchte Methode (#{requestMethodText}) wird nicht unterstützt.
-ErrorResponseEncrypted: Um keine sensiblen Daten preiszugeben wurden nähere Details verschlüsselt. Wenn Sie eine Anfrage an den Support schicken fügen Sie bitte die unten aufgeführten verschlüsselten Daten mit an.
\ No newline at end of file
+ErrorResponseEncrypted: Um keine sensiblen Daten preiszugeben wurden nähere Details verschlüsselt. Wenn Sie eine Anfrage an den Support schicken fügen Sie bitte die unten aufgeführten verschlüsselten Daten mit an.
+ErrMsgCiphertext: Verschlüsselte Fehlermeldung
+ErrMsgCiphertextTooShort: Verschlüsselte Daten zu kurz um valide zu sein
+ErrMsgInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64url-kodiert: #{base64Err}
+ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
+ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
+ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
+ErrMsgHeading: Fehlermeldung entschlüsseln
\ No newline at end of file
diff --git a/routes b/routes
index 991318c6a..17a653125 100644
--- a/routes
+++ b/routes
@@ -36,6 +36,7 @@
/admin/test AdminTestR GET POST
/admin/user/#CryptoUUIDUser AdminUserR GET
/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
+/admin/errMsg AdminErrMsgR GET POST
/info VersionR GET !free
/help HelpR GET POST !free
diff --git a/src/Application.hs b/src/Application.hs
index f52c180e9..0e7c7e211 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -155,9 +155,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
migrateAll `runSqlPool` sqlPool
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
- appErrorMsgKey <- if
- | appEncryptErrors -> Just <$> clusterSetting (Proxy :: Proxy 'ClusterErrorMessageKey) `runSqlPool` sqlPool
- | otherwise -> return Nothing
+ appErrorMsgKey <- clusterSetting (Proxy :: Proxy 'ClusterErrorMessageKey) `runSqlPool` sqlPool
let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appErrorMsgKey
@@ -178,7 +176,7 @@ clusterSetting proxy@(knownClusterSetting -> key) = do
case Aeson.fromJSON . clusterConfigValue <$> current' of
Just (Aeson.Success c) -> return c
Just (Aeson.Error str) -> do
- $logErrorS "clusterSetting" $ "Could not parse JSON-Value for " <> toPathPiece key
+ $logErrorS "clusterSetting" $ "Could not parse JSON-Value for " <> toPathPiece key <> ": " <> pack str
liftIO exitFailure
Nothing -> do
new <- initClusterSetting proxy
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 2634974fb..78ff9dc21 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -100,7 +100,6 @@ import qualified Data.Conduit.List as C
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Crypto.Saltine.Class as Saltine
-import qualified Data.Binary as Binary
instance DisplayAble b => DisplayAble (E.CryptoID a b) where
@@ -133,7 +132,7 @@ data UniWorX = UniWorX
, appCryptoIDKey :: CryptoIDKey
, appInstanceID :: InstanceId
, appJobCtl :: [TMChan JobCtl]
- , appErrorMsgKey :: Maybe SecretBox.Key
+ , appErrorMsgKey :: SecretBox.Key
, appSessionKey :: ClientSession.Key
}
@@ -610,19 +609,22 @@ instance Yesod UniWorX where
let
encrypted :: ToJSON a => a -> Widget -> Widget
encrypted plaintextJson plaintext = do
+ canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
+ shouldEncrypt <- getsYesod $ appEncryptErrors . appSettings
errKey <- getsYesod appErrorMsgKey
- case errKey of
- Nothing -> plaintext
- Just key -> do
- nonce <- liftIO SecretBox.newNonce
- let ciphertext = SecretBox.secretbox key nonce . Lazy.ByteString.toStrict $ encode plaintextJson
- encoded = decodeUtf8 . Base64.encode . Lazy.ByteString.toStrict $ Binary.encode (Saltine.encode nonce, ciphertext)
- formatted = Text.intercalate "\n" . map (Text.intercalate " " . Text.chunksOf 4) $ Text.chunksOf 72 encoded
- [whamlet|
- _{MsgErrorResponseEncrypted}
-
- #{formatted}
- |]
+ if
+ | shouldEncrypt
+ , not canDecrypt -> do
+ nonce <- liftIO SecretBox.newNonce
+ let ciphertext = SecretBox.secretbox errKey nonce . Lazy.ByteString.toStrict $ encode plaintextJson
+ encoded = decodeUtf8 . Base64.encode $ Saltine.encode nonce <> ciphertext
+ formatted = Text.intercalate "\n" $ Text.chunksOf 76 encoded
+ [whamlet|
+ _{MsgErrorResponseEncrypted}
+
+ #{formatted}
+ |]
+ | otherwise -> plaintext
errPage = case err of
NotFound -> [whamlet|_{MsgErrorResponseNotFound}|]
@@ -971,8 +973,8 @@ pageActions (HomeR) =
-- , menuItemAccessCallback' = return True
-- }
-- ,
- NavbarAside $ MenuItem
- { menuItemLabel = "AdminDemo"
+ PageActionPrime $ MenuItem
+ { menuItemLabel = "Admin-Demo"
, menuItemIcon = Just "screwdriver"
, menuItemRoute = AdminTestR
, menuItemModal = False
@@ -985,6 +987,13 @@ pageActions (HomeR) =
, menuItemModal = False
, menuItemAccessCallback' = return True
}
+ , PageActionPrime $ MenuItem
+ { menuItemLabel = "Fehlermeldung entschlüsseln"
+ , menuItemIcon = Nothing
+ , menuItemRoute = AdminErrMsgR
+ , menuItemModal = False
+ , menuItemAccessCallback' = return True
+ }
]
pageActions (ProfileR) =
[ PageActionPrime $ MenuItem
@@ -1232,6 +1241,8 @@ pageHeading (AdminTestR)
= Just $ [whamlet|Internal Code Demonstration Page|]
pageHeading (AdminUserR _)
= Just $ [whamlet|User Display for Admin|]
+pageHeading (AdminErrMsgR)
+ = Just $ i18nHeading MsgErrMsgHeading
pageHeading (VersionR)
= Just $ i18nHeading MsgImpressumHeading
pageHeading (HelpR)
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index 1b5c3ae9d..46d65d29f 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -15,6 +15,19 @@ import Import
import Handler.Utils
import Jobs
+import qualified Data.ByteString as BS
+
+import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
+import qualified Data.ByteString.Base64.URL as Base64
+import Crypto.Saltine.Core.SecretBox (secretboxOpen)
+import qualified Crypto.Saltine.Class as Saltine
+
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.Char (isSpace)
+
+import Control.Monad.Trans.Except
+
-- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
@@ -105,3 +118,35 @@ getAdminUserR uuid = do
Admin Page for User ^{nameWidget userDisplayName userSurname}
|]
+getAdminErrMsgR, postAdminErrMsgR :: Handler Html
+getAdminErrMsgR = postAdminErrMsgR
+postAdminErrMsgR = do
+ errKey <- getsYesod appErrorMsgKey
+
+ ((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
+ (unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing)
+ <* submitButton
+
+ plaintext <- formResultMaybe ctResult $ \(encodeUtf8 . Text.filter (not . isSpace) -> inputBS) ->
+ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) $ do
+ ciphertext <- either (throwE . MsgErrMsgInvalidBase64) return $ Base64.decode inputBS
+
+ unless (BS.length ciphertext >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
+ throwE MsgErrMsgCiphertextTooShort
+ let (nonceBS, secretbox) = BS.splitAt Saltine.secretBoxNonce ciphertext
+
+ nonce <- maybe (throwE MsgErrMsgCouldNotDecodeNonce) return $ Saltine.decode nonceBS
+
+ plainBS <- maybe (throwE MsgErrMsgCouldNotOpenSecretbox) return $ secretboxOpen errKey nonce secretbox
+
+ either (throwE . MsgErrMsgCouldNotDecodePlaintext . tshow) return $ Text.decodeUtf8' plainBS
+
+ defaultLayout $
+ [whamlet|
+ $maybe t <- plaintext
+
+ #{t}
+
+