116 lines
3.7 KiB
Haskell
116 lines
3.7 KiB
Haskell
module Handler.Help where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Info (faqsWidget)
|
|
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)
|
|
|
|
instance Universe HelpIdentOptions
|
|
instance Finite HelpIdentOptions
|
|
|
|
nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
|
|
embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")
|
|
|
|
data HelpForm = HelpForm
|
|
{ hfReferer :: Maybe (Route UniWorX)
|
|
, hfUserId :: Either (Maybe Address) UserId
|
|
, hfSubject :: Maybe Text
|
|
, hfRequest :: Maybe Html
|
|
, hfError :: Maybe ErrorResponse
|
|
}
|
|
|
|
helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> Form HelpForm
|
|
helpForm mReferer mUid = renderWForm FormStandard $ do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
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
|
|
postHelpR = do
|
|
mUid <- maybeAuthId
|
|
mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
|
|
((res,formWidget'),formEnctype) <- runFormPost . validateForm validateHelpForm $ helpForm mReferer mUid
|
|
|
|
formResultModal res HelpR $ \HelpForm{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
hfReferer' <- traverse toTextUrl hfReferer
|
|
queueJob' JobHelpRequest
|
|
{ jHelpSender = hfUserId
|
|
, jSubject = hfSubject
|
|
, jHelpRequest = hfRequest
|
|
, jRequestTime = now
|
|
, jReferer = hfReferer'
|
|
, jError = hfError
|
|
}
|
|
|
|
whenIsJust hfError $ \error' ->
|
|
modifySessionJson SessionError $ assertM (/= error')
|
|
|
|
tell . pure =<< messageI Success MsgHelpSent
|
|
|
|
defaultLayout $ do
|
|
setTitleI MsgHelpTitle
|
|
let formWidget = wrapForm formWidget' def
|
|
{ formAction = Just $ SomeRoute HelpR
|
|
, formEncoding = formEnctype
|
|
, formAttrs = [ asyncSubmitAttr | isModal ]
|
|
}
|
|
|
|
mFaqs <- (>>= \(mWgt, truncated) -> (, truncated) <$> mWgt) <$> traverse (faqsWidget $ Just 5) (Just <$> mReferer)
|
|
|
|
$(widgetFile "help")
|