Merge branch 'master' into 'live'
Interface for decrypting error messages See merge request !88
This commit is contained in:
Gregor Kleen
commit
da5a496e56
@ -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.
|
||||
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
|
||||
1
routes
1
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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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|
|
||||
<p>_{MsgErrorResponseEncrypted}
|
||||
<pre .errMsg>
|
||||
#{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|
|
||||
<p>_{MsgErrorResponseEncrypted}
|
||||
<pre .errMsg>
|
||||
#{formatted}
|
||||
|]
|
||||
| otherwise -> plaintext
|
||||
|
||||
errPage = case err of
|
||||
NotFound -> [whamlet|<p>_{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)
|
||||
|
||||
@ -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
|
||||
<h2>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
|
||||
<pre style="white-space:pre-wrap; font-family:monospace">
|
||||
#{t}
|
||||
|
||||
<form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
|
||||
^{ctView}
|
||||
|]
|
||||
|
||||
@ -284,6 +284,9 @@ reorderField optList = Field{..}
|
||||
---------------------
|
||||
|
||||
formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
|
||||
formResult (FormFailure errs) _ = forM_ errs $ addMessage Error . toHtml
|
||||
formResult FormMissing _ = return ()
|
||||
formResult (FormSuccess res) f = f res
|
||||
formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x
|
||||
|
||||
formResultMaybe :: MonadHandler m => FormResult a -> (a -> m (Maybe b)) -> m (Maybe b)
|
||||
formResultMaybe (FormFailure errs) _ = Nothing <$ forM_ errs (addMessage Error . toHtml)
|
||||
formResultMaybe FormMissing _ = return Nothing
|
||||
formResultMaybe (FormSuccess res) f = f res
|
||||
|
||||
Loading…
Reference in New Issue
Block a user