feat(help): attach last error message
This commit is contained in:
Gregor Kleen
parent
a1a0fa3a44
commit
fdd6b1a194
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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|
|
||||
<p>_{MsgErrorResponseEncrypted}
|
||||
<pre .errMsg>
|
||||
#{ciphertext}
|
||||
|]
|
||||
| otherwise -> plaintext
|
||||
sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
|
||||
setSessionJson SessionError sessErr
|
||||
|
||||
errPage = case err of
|
||||
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)}|]
|
||||
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|
|
||||
<p>_{MsgErrorResponseEncrypted}
|
||||
<pre .errMsg>
|
||||
#{ciphertext}
|
||||
|]
|
||||
| otherwise -> plaintext
|
||||
|
||||
errPage = case err of
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 }
|
||||
|
||||
23
src/Mail.hs
23
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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
33
src/Utils.hs
33
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 --
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
1
start.sh
1
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
|
||||
|
||||
|
||||
@ -38,5 +38,11 @@ $newline never
|
||||
<dd>
|
||||
<a href=#{referer} style="font-family: monospace">
|
||||
#{referer}
|
||||
<section>
|
||||
#{jHelpRequest}
|
||||
$maybe errName <- errPartName
|
||||
<dt>Fehlermeldung
|
||||
<dd>
|
||||
<a href="cid:#{errName}">
|
||||
#{errName}
|
||||
$maybe request <- jHelpRequest
|
||||
<section>
|
||||
#{request}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user