feat(help): attach last error message

config/settings.yml

@@ -67,6 +67,7 @@ ip-retention-time: 1209600
 # Debugging
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"
 allow-deprecated:  "_env:ALLOW_DEPRECATED:false"
+encrypt-errors:    "_env:ENCRYPT_ERRORS:true"
 server-session-acid-fallback: "_env:SERVER_SESSION_ACID_FALLBACK:false"
 
 auth-pw-hash:
@@ -78,7 +79,6 @@ auth-pw-hash:
 # reload-templates: false
 # mutable-static: false
 # skip-combining: false
-# encrypt-errors: true
 
 database:
   user:     "_env:PGUSER:uniworx"

messages/uniworx/de-de-formal.msg

@@ -1075,6 +1075,10 @@ HelpRequest: Supportanfrage / Verbesserungsvorschlag
 HelpProblemPage: Problematische Seite
 HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
 HelpSent: Ihre Supportanfrage wurde weitergeleitet.
+HelpSendLastError: Letzte Fehlermeldung anhängen
+HelpError: Letzte Fehlermeldung
+HelpErrorYamlFilename mailId@MailObjectId: fehlermeldung-#{toPathPiece mailId}.yaml
+HelpErrorOrRequestRequired: Bitte geben Sie entweder eine Supportanfrage bzw. einen Verbesserungsvorschlag an oder hängen Sie die letzte Fehlermeldung an
 
 InfoLecturerTitle: Hinweise für Veranstalter
 

src/Foundation.hs

@@ -1624,43 +1624,70 @@ instance Yesod UniWorX where
     defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
 
     errorHandler err = do
-      mr <- getMessageRender
+      shouldEncrypt <- do
-      let
+        canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
-        encrypted :: ToJSON a => a -> Widget -> Widget
+        shouldEncrypt <- getsYesod $ view _appEncryptErrors
-        encrypted plaintextJson plaintext = do
+        return $ shouldEncrypt && not canDecrypt
-          canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
-          shouldEncrypt <- getsYesod $ view _appEncryptErrors
-          if
-            | shouldEncrypt
-            , not canDecrypt -> do
-                ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
 
-                [whamlet|
+      sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
-                  <p>_{MsgErrorResponseEncrypted}
+      setSessionJson SessionError sessErr
-                  <pre .errMsg>
-                    #{ciphertext}
-                |]
-            | otherwise -> plaintext
 
-        errPage = case err of
+      selectRep $ do
-          NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
+        provideRep $ do
-          InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
+          mr <- getMessageRender
-          InvalidArgs errs -> [whamlet|
+          let
-              <ul>
+            encrypted :: ToJSON a => a -> Widget -> Widget
-                $forall err' <- errs
+            encrypted plaintextJson plaintext = do
-                  <li .errMsg>#{err'}
+              if
-            |]
+                | shouldEncrypt -> do
-          NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
+                    ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
-          PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
+
-          BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
+                    [whamlet|
-      fmap toTypedContent . siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
+                      <p>_{MsgErrorResponseEncrypted}
-        toWidget
+                      <pre .errMsg>
-          [cassius|
+                        #{ciphertext}
-            .errMsg
+                    |]
-              white-space: pre-wrap
+                | otherwise -> plaintext
-              font-family: monospace
+
-          |]
+            errPage = case err of
-        errPage
+              NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
+              InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
+              InvalidArgs errs -> [whamlet|
+                  <ul>
+                    $forall err' <- errs
+                      <li .errMsg>#{err'}
+                 |]
+              NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
+              PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
+              BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
+          siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
+            toWidget
+              [cassius|
+                .errMsg
+                  white-space: pre-wrap
+                  font-family: monospace
+              |]
+            errPage
+        provideRep . fmap PrettyValue $ case err of
+          PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
+          InternalError err'
+            | shouldEncrypt -> do
+                ciphertext <- encodedSecretBox SecretBoxShort err'
+                return $ object [ "message" JSON..= ciphertext
+                                , "encrypted" JSON..= True
+                                ]
+            | otherwise -> return $ object [ "message" JSON..= err' ]
+          InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
+          _other -> return $ object []
+        provideRep $ case err of
+          PermissionDenied err' -> return err'
+          InternalError err'
+            | shouldEncrypt -> do
+                addHeader "Encrypted-Error-Message" "True"
+                encodedSecretBox SecretBoxPretty err'
+            | otherwise -> return err'
+          InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
+          _other -> return Text.empty
 
     defaultLayout = siteLayout' Nothing
 
@@ -1887,7 +1914,7 @@ siteLayout' headingOverride widget = do
   nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren)
 
   mmsgs <- if
-    | isModal -> getMessages
+    | isModal -> return mempty
     | otherwise -> do
         applySystemMessages
         authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags

src/Handler/Help.hs

@@ -7,6 +7,11 @@ import Jobs
 
 import qualified Data.Map as Map
 
+import qualified Data.Yaml as Yaml
+
+import qualified Control.Monad.State.Class as State
+  
+
 data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
   deriving (Eq, Ord, Bounded, Enum, Show, Read)
 
@@ -20,25 +25,56 @@ data HelpForm = HelpForm
   { hfReferer :: Maybe (Route UniWorX)
   , hfUserId  :: Either (Maybe Address) UserId
   , hfSubject :: Maybe Text
-  , hfRequest :: Html
+  , hfRequest :: Maybe Html
+  , hfError   :: Maybe ErrorResponse
   }
 
-helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
+helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> Form HelpForm
-helpForm mr mReferer mUid = HelpForm
+helpForm mReferer mUid = renderWForm FormStandard $ do
-    <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
+  MsgRenderer mr <- getMsgRenderer
-    <*> multiActionA identActions (fslI MsgHelpAnswer) (HIUser <$ mUid)
-    <*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
-    <*> areq htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing
-  where
-    identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
-    identActions = Map.fromList $ case mUid of
-      (Just uid) -> (HIUser, pure $ Right uid):defaultActions
-      Nothing    -> defaultActions
 
-    defaultActions =
+  let defaultActions =
-      [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing))
+        [ ( HIEmail
-      , (HIAnonymous, pure $ Left Nothing)
+          , Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing)
-      ]
+          )
+        , ( HIAnonymous
+          , pure $ Left Nothing
+          )
+        ]
+      identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
+      identActions = Map.fromList $ case mUid of
+        (Just uid) -> (HIUser, pure $ Right uid):defaultActions
+        Nothing    -> defaultActions
+
+  sessErr <- lookupSessionJson SessionError
+
+  hfReferer' <- wopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
+  hfUserId'  <- multiActionW identActions (fslI MsgHelpAnswer) (HIUser <$ mUid)
+  hfSubject' <- wopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
+  hfRequest' <- case sessErr of
+    Nothing -> fmap Just <$> wreq htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing
+    Just _  -> wopt htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing
+  hfError'   <- case sessErr of
+    Nothing -> return $ pure Nothing
+    Just err ->
+      let prettyErr = decodeUtf8 $ Yaml.encode err
+       in optionalActionW 
+            (err <$ aforced textareaField (fslI MsgHelpError) (Textarea prettyErr))
+            (fslI MsgHelpSendLastError)
+            (Just True)
+
+  return $ HelpForm
+    <$> hfReferer'
+    <*> hfUserId'
+    <*> hfSubject'
+    <*> hfRequest'
+    <*> hfError'
+    
+validateHelpForm :: FormValidator HelpForm Handler ()
+validateHelpForm = do
+  HelpForm{..} <- State.get
+
+  guardValidation MsgHelpErrorOrRequestRequired $ is _Just hfRequest || is _Just hfError
 
 getHelpR, postHelpR :: Handler Html
 getHelpR = postHelpR
@@ -46,9 +82,8 @@ postHelpR = do
   mUid <- maybeAuthId
   mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
   isModal <- hasCustomHeader HeaderIsModal
-  MsgRenderer mr <- getMsgRenderer
 
-  ((res,formWidget'),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid
+  ((res,formWidget'),formEnctype) <- runFormPost . validateForm validateHelpForm $ helpForm mReferer mUid
 
   formResultModal res HelpR $ \HelpForm{..} -> do
     now <- liftIO getCurrentTime
@@ -59,7 +94,12 @@ postHelpR = do
       , jHelpRequest = hfRequest
       , jRequestTime = now
       , jReferer     = hfReferer'
+      , jError       = hfError
       }
+
+    whenIsJust hfError $ \error' ->
+      modifySessionJson SessionError $ assertM (/= error')
+    
     tell . pure =<< messageI Success MsgHelpSent
 
   defaultLayout $ do

src/Jobs/Handler/HelpRequest.hs

@@ -15,10 +15,11 @@ import Data.Bitraversable
 dispatchJobHelpRequest :: Either (Maybe Address) UserId
                        -> UTCTime
                        -> Maybe Text -- ^ Help Subject
-                       -> Html -- ^ Help Request
+                       -> Maybe Html -- ^ Help Request
                        -> Maybe Text -- ^ Referer
+                       -> Maybe ErrorResponse
                        -> Handler ()
-dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
+dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer jError = do
   supportAddress <- getsYesod $ view _appMailSupport
   userInfo <- bitraverse return (runDB . getEntity) jSender
   let senderAddress = either
@@ -32,4 +33,15 @@ dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer =
     setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject
     setDate jRequestTime
     rtime <- formatTimeMail SelFormatDateTime jRequestTime
+
+    errPartName <- for jError $ \_ -> do
+      objId <- setMailObjectIdRandom
+      mr <- getMailMessageRender
+      return . mr $ MsgHelpErrorYamlFilename objId
+    
     addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+
+    whenIsJust ((,) <$> jError <*> errPartName) $ \(err, partName) -> addPart' $ do
+        toMailPart $ toYAML err
+        _partDisposition .= InlineDisposition partName
+    

src/Jobs/Types.hs

@@ -42,8 +42,9 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
          | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
                           , jRequestTime :: UTCTime
                           , jSubject :: Maybe Text
-                          , jHelpRequest :: Html
+                          , jHelpRequest :: Maybe Html
                           , jReferer :: Maybe Text
+                          , jError :: Maybe ErrorResponse
                           }
          | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
          | JobDistributeCorrections { jSheet :: SheetId }

src/Mail.hs

@@ -67,8 +67,9 @@ import qualified Data.Foldable as Foldable
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Builder as LTB
 import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString as BS
 
-import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT)
+import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT, YamlValue)
 import Utils.Lens.TH
 
 import Control.Lens hiding (from)
@@ -97,6 +98,7 @@ import qualified Text.Shakespeare as Shakespeare (RenderUrl)
 
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Encode.Pretty as Aeson
+import qualified Data.Yaml as Yaml
 import Data.Aeson.TH
 import Utils.PathPiece (splitCamel)
 import Utils.DateTime
@@ -110,12 +112,15 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
   
-import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen)
+import Control.Monad.Random (MonadRandom(..))
 import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..))
 import qualified Data.ByteArray as ByteArray (convert)
-import Crypto.MAC.HMAC (hmac, HMAC)
+import Crypto.MAC.KMAC (KMAC)
+import qualified Crypto.MAC.KMAC as KMAC
 import Crypto.Hash.Algorithms (SHAKE128)
 
+import Language.Haskell.TH (nameBase)
+
 
 makeLenses_ ''Address
 makeLenses_ ''Mail
@@ -370,6 +375,12 @@ instance YesodMail site => ToMailPart site Aeson.Value where
     _partEncoding .= QuotedPrintableText
     _partContent .= PartContent (Aeson.encodePretty val)
 
+instance YesodMail site => ToMailPart site YamlValue where
+  toMailPart val = do
+    _partType .= "text/vnd.yaml"
+    _partEncoding .= QuotedPrintableText
+    _partContent .= PartContent (fromStrict $ Yaml.encode val)
+
 
 addAlternatives :: (MonadMail m)
                 => Writer (PrioritisedAlternatives m) ()
@@ -495,9 +506,9 @@ setMailObjectIdPseudorandom :: ( MonadHeader m
 setMailObjectIdPseudorandom obj = do
   sbKey <- secretBoxKey
   let
-    seed :: HMAC (SHAKE128 64)
+    seed :: KMAC (SHAKE128 128)
-    seed = hmac (Saltine.encode sbKey) . toStrict $ Binary.encode obj
+    seed = KMAC.finalize . KMAC.updates (KMAC.initialize (BS.pack . encodeUtf8 $ nameBase 'setMailObjectIdPseudorandom) $ Saltine.encode sbKey) . LBS.toChunks $ Binary.encode obj
-  setMailObjectUUID . evalRand getRandom . mkStdGen $ hash (ByteArray.convert seed :: ByteString)
+  setMailObjectUUID . fromMaybe (error "Could not convert hash to UUID") . UUID.fromByteString $ fromStrict (ByteArray.convert seed :: ByteString)
 
 
 setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()

src/Network/HTTP/Types/Method/Instances.hs

@@ -9,6 +9,17 @@ import Data.Binary (Binary)
 
 import Network.HTTP.Types.Method
 
+import Utils.PathPiece (pathPieceJSON, pathPieceJSONKey)
+
+import Web.PathPieces
+
 
 deriving instance Generic StdMethod
 instance Binary StdMethod
+
+instance PathPiece Method where
+  toPathPiece = decodeUtf8
+  fromPathPiece = Just . encodeUtf8
+
+pathPieceJSON ''Method
+pathPieceJSONKey ''Method

src/Utils.hs

@@ -68,6 +68,8 @@ import Text.Shakespeare.Text (st)
 import Data.Aeson (FromJSONKey)
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
+import qualified Data.Yaml as Yaml
 
 import Data.Universe
 
@@ -97,6 +99,7 @@ import Control.Monad.Random.Class (MonadRandom)
 import qualified System.Random.Shuffle as Rand (shuffleM)
 
 import Data.Data (Data)
+import qualified Data.Text.Lazy.Builder as Builder
 
 import Unsafe.Coerce
 
@@ -140,6 +143,36 @@ maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)]
 maybeAttribute _ _ Nothing  = []
 maybeAttribute a c (Just v) = [(a,c v)]
 
+  
+newtype PrettyValue = PrettyValue { unPrettyValue :: Value }
+  deriving (Eq, Read, Show, Generic, Typeable, Data)
+  deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
+
+instance ToContent PrettyValue where
+  toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
+instance ToTypedContent PrettyValue where
+  toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
+instance HasContentType PrettyValue where
+  getContentType _ = typeJson
+
+toPrettyJSON :: ToJSON a => a -> PrettyValue
+toPrettyJSON = PrettyValue . toJSON
+
+
+newtype YamlValue = YamlValue { unYamlValue :: Value }
+  deriving (Eq, Read, Show, Generic, Typeable, Data)
+  deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
+
+instance ToContent YamlValue where
+  toContent = toContent . Yaml.encode
+instance ToTypedContent YamlValue where
+  toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
+instance HasContentType YamlValue where
+  getContentType _ = "text/vnd.yaml"
+
+toYAML :: ToJSON a => a -> YamlValue
+toYAML = YamlValue . toJSON
+
 
 ---------------------
 -- Text and String --

src/Utils/Session.hs

@@ -15,6 +15,7 @@ data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
                 | SessionBearer
                 | SessionAllocationResults
                 | SessionLang
+                | SessionError
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 

src/Yesod/Core/Instances.hs

@@ -13,6 +13,7 @@ import Control.Lens
 import Data.ByteString.Builder (toLazyByteString)
 
 import Data.Aeson
+import Data.Aeson.TH
 import Data.Aeson.Types
 
 import Control.Monad.Fix
@@ -24,6 +25,10 @@ import qualified Data.Binary as Binary
 
 import Control.Monad.Fail
 
+import Utils.PathPiece (camelToPathPiece)
+
+import Network.HTTP.Types.Method.Instances ()
+
 
 routeFromPathPiece :: ParseRoute site => Text -> Maybe (Route site)
 routeFromPathPiece
@@ -97,3 +102,13 @@ instance Extend FormResult where
   duplicated (FormSuccess x)    = FormSuccess $ FormSuccess x
   duplicated  FormMissing       = FormMissing
   duplicated (FormFailure errs) = FormFailure errs
+
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  , sumEncoding = ObjectWithSingleField
+  } ''ErrorResponse
+
+deriving instance Ord ErrorResponse
+deriving instance Read ErrorResponse
+instance Hashable ErrorResponse

start.sh

@@ -14,6 +14,7 @@ export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true}
 export SERVER_SESSION_COOKIES_SECURE=${SERVER_SESSION_COOKIES_SECURE:-false}
 export COOKIES_SECURE=${COOKIES_SECURE:-false}
 export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
+export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false}
 export RIBBON=${RIBBON:-${__HOST:-localhost}}
 unset HOST
 

templates/mail/support.hamlet

@@ -38,5 +38,11 @@ $newline never
           <dd>
             <a href=#{referer} style="font-family: monospace">
               #{referer}
-    <section>
+        $maybe errName <- errPartName
-      #{jHelpRequest}
+          <dt>Fehlermeldung
+          <dd>
+            <a href="cid:#{errName}">
+              #{errName}
+    $maybe request <- jHelpRequest
+      <section>
+        #{request}