Merge branch 'master' into 'live'

Interface for decrypting error messages

See merge request !88

messages/uniworx/de.msg

@@ -455,3 +455,10 @@ ErrorResponseNotAuthenticated: Um Zugriff auf einige Teile des Systems zu erhalt
 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.
+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

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
 

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
+      appErrorMsgKey <- clusterSetting (Proxy :: Proxy 'ClusterErrorMessageKey) `runSqlPool` sqlPool
-        | appEncryptErrors -> Just <$> clusterSetting (Proxy :: Proxy 'ClusterErrorMessageKey) `runSqlPool` sqlPool
-        | otherwise -> return Nothing
 
       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

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
+          if
-            Nothing -> plaintext
+            | shouldEncrypt
-            Just key -> do
+            , not canDecrypt -> do
-              nonce <- liftIO SecretBox.newNonce
+                nonce <- liftIO SecretBox.newNonce
-              let ciphertext = SecretBox.secretbox key nonce . Lazy.ByteString.toStrict $ encode plaintextJson
+                let ciphertext = SecretBox.secretbox errKey nonce . Lazy.ByteString.toStrict $ encode plaintextJson
-                  encoded = decodeUtf8 . Base64.encode . Lazy.ByteString.toStrict $ Binary.encode (Saltine.encode nonce, ciphertext)
+                    encoded = decodeUtf8 . Base64.encode $ Saltine.encode nonce <> ciphertext
-                  formatted = Text.intercalate "\n" . map (Text.intercalate " " . Text.chunksOf 4) $ Text.chunksOf 72 encoded
+                    formatted = Text.intercalate "\n" $ Text.chunksOf 76 encoded
-              [whamlet|
+                [whamlet|
-                <p>_{MsgErrorResponseEncrypted}
+                  <p>_{MsgErrorResponseEncrypted}
-                <pre .errMsg>
+                  <pre .errMsg>
-                  #{formatted}
+                    #{formatted}
-              |]
+                |]
+            | otherwise -> plaintext
         
         errPage = case err of
           NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
@@ -971,8 +973,8 @@ pageActions (HomeR) =
 --       , menuItemAccessCallback' = return True
 --       }
 --   ,
-    NavbarAside $ MenuItem
+    PageActionPrime $ MenuItem
-      { menuItemLabel = "AdminDemo"
+      { 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)

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
       <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}
+    |]

src/Utils/Form.hs

@@ -284,6 +284,9 @@ reorderField optList = Field{..}
 ---------------------
 
 formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
-formResult (FormFailure errs) _ = forM_ errs $ addMessage Error . toHtml
+formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x
-formResult  FormMissing       _ = return ()
+
-formResult (FormSuccess res)  f = f res
+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