diff --git a/config/settings.yml b/config/settings.yml index a810f4c83..85cd909e6 100644 --- a/config/settings.yml +++ b/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" diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index f7548e2af..11772317c 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 12d149392..77f0828d8 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1624,43 +1624,70 @@ instance Yesod UniWorX where defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" errorHandler err = do - mr <- getMessageRender - let - encrypted :: ToJSON a => a -> Widget -> Widget - encrypted plaintextJson plaintext = do - canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True - shouldEncrypt <- getsYesod $ view _appEncryptErrors - if - | shouldEncrypt - , not canDecrypt -> do - ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson + shouldEncrypt <- do + canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True + shouldEncrypt <- getsYesod $ view _appEncryptErrors + return $ shouldEncrypt && not canDecrypt - [whamlet| -
_{MsgErrorResponseEncrypted} -
- #{ciphertext}
- |]
- | otherwise -> plaintext
+ sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
+ setSessionJson SessionError sessErr
- errPage = case err of
- NotFound -> [whamlet|_{MsgErrorResponseNotFound}|]
- InternalError err' -> encrypted err' [whamlet|
#{err'}|]
- InvalidArgs errs -> [whamlet|
-
_{MsgErrorResponseNotAuthenticated}|] - PermissionDenied err' -> [whamlet|
#{err'}|] - BadMethod method -> [whamlet|
_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] - fmap toTypedContent . siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do - toWidget - [cassius| - .errMsg - white-space: pre-wrap - font-family: monospace - |] - errPage + selectRep $ do + provideRep $ do + mr <- getMessageRender + let + encrypted :: ToJSON a => a -> Widget -> Widget + encrypted plaintextJson plaintext = do + if + | shouldEncrypt -> do + ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson + + [whamlet| +
_{MsgErrorResponseEncrypted} +
+ #{ciphertext}
+ |]
+ | otherwise -> plaintext
+
+ errPage = case err of
+ NotFound -> [whamlet|_{MsgErrorResponseNotFound}|]
+ InternalError err' -> encrypted err' [whamlet|
#{err'}|]
+ InvalidArgs errs -> [whamlet|
+
_{MsgErrorResponseNotAuthenticated}|] + PermissionDenied err' -> [whamlet|
#{err'}|] + BadMethod method -> [whamlet|
_{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 diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index 098695563..28bf3e804 100644 --- a/src/Handler/Help.hs +++ b/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 mr mReferer mUid = HelpForm - <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) - <*> 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 +helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> Form HelpForm +helpForm mReferer mUid = renderWForm FormStandard $ do + MsgRenderer mr <- getMsgRenderer - defaultActions = - [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing)) - , (HIAnonymous, pure $ Left Nothing) - ] + let defaultActions = + [ ( HIEmail + , 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 diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index b4e9c5b69..10b4e310e 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/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 + diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 5d1eb8be5..79acc5c7c 100644 --- a/src/Jobs/Types.hs +++ b/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 } diff --git a/src/Mail.hs b/src/Mail.hs index c472a75f2..36ae4146d 100644 --- a/src/Mail.hs +++ b/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 = hmac (Saltine.encode sbKey) . toStrict $ Binary.encode obj - setMailObjectUUID . evalRand getRandom . mkStdGen $ hash (ByteArray.convert seed :: ByteString) + seed :: KMAC (SHAKE128 128) + seed = KMAC.finalize . KMAC.updates (KMAC.initialize (BS.pack . encodeUtf8 $ nameBase 'setMailObjectIdPseudorandom) $ Saltine.encode sbKey) . LBS.toChunks $ Binary.encode obj + setMailObjectUUID . fromMaybe (error "Could not convert hash to UUID") . UUID.fromByteString $ fromStrict (ByteArray.convert seed :: ByteString) setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m () diff --git a/src/Network/HTTP/Types/Method/Instances.hs b/src/Network/HTTP/Types/Method/Instances.hs index 144f901a3..b71b009ea 100644 --- a/src/Network/HTTP/Types/Method/Instances.hs +++ b/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 diff --git a/src/Utils.hs b/src/Utils.hs index 3addd9116..ffc77197e 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/src/Utils/Session.hs b/src/Utils/Session.hs index c4418d0ae..51f66105c 100644 --- a/src/Utils/Session.hs +++ b/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) diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs index e145d6575..17838c4b8 100644 --- a/src/Yesod/Core/Instances.hs +++ b/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 diff --git a/start.sh b/start.sh index 51ffc6340..329fdad02 100755 --- a/start.sh +++ b/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 diff --git a/templates/mail/support.hamlet b/templates/mail/support.hamlet index de412b7d3..623ba907f 100644 --- a/templates/mail/support.hamlet +++ b/templates/mail/support.hamlet @@ -38,5 +38,11 @@ $newline never