357 lines
17 KiB
Haskell
357 lines
17 KiB
Haskell
module Handler.SystemMessage
|
|
( getMessageR, postMessageR
|
|
, getMessageListR, postMessageListR
|
|
, ButtonSystemMessageHide(..)
|
|
, postMessageHideR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Map.Lazy as Map
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.News
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
-- htmlField' moved to Handler.Utils.Form/Fields
|
|
|
|
getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
|
|
getMessageR = postMessageR
|
|
postMessageR cID = do
|
|
smId <- decrypt cID
|
|
(SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage appLanguages smId
|
|
let (summary, content) = case translation of
|
|
Nothing -> (systemMessageSummary, systemMessageContent)
|
|
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
now <- liftIO getCurrentTime
|
|
let
|
|
mkForm = do
|
|
((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
|
|
$ SystemMessage
|
|
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
|
|
<*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
|
|
<*> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just systemMessageNewsOnly)
|
|
<*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
|
|
<*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
|
|
<*> pure systemMessageCreated
|
|
<*> (bool now systemMessageLastChanged <$> apopt checkBoxField (fslI MsgSystemMessageRecordChanged & setTooltip MsgSystemMessageRecordChangedTip) (Just True))
|
|
<*> (bool now systemMessageLastUnhide <$> apopt checkBoxField (fslI MsgSystemMessageUnhide & setTooltip MsgSystemMessageUnhideTip) (Just False))
|
|
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageDefaultLanguage)
|
|
<*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent)
|
|
<*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary)
|
|
|
|
ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage]
|
|
let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts
|
|
|
|
modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do
|
|
cID' <- encrypt tId
|
|
runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
|
|
$ (,)
|
|
<$> fmap (Entity tId)
|
|
( SystemMessageTranslation
|
|
<$> pure systemMessageTranslationMessage
|
|
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
|
|
<*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent)
|
|
<*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary)
|
|
)
|
|
<*> combinedButtonFieldF ""
|
|
|
|
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
|
|
nextLang = toList appLanguages
|
|
& filter (not . langMatches systemMessageDefaultLanguage)
|
|
& filter (\l -> none (`langMatches` l) $ Map.keys ts')
|
|
|
|
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
|
|
$ SystemMessageTranslation
|
|
<$> pure smId
|
|
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
|
|
<*> areq htmlField (fslI MsgSystemMessageContent) Nothing
|
|
<*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
|
|
|
|
formResult modifyRes $ modifySystemMessage smId
|
|
|
|
formResult addTransRes addTranslation
|
|
|
|
forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, catMaybes -> acts) -> case acts of
|
|
[BtnDelete'] -> do
|
|
runDB $ delete tId
|
|
addMessageI Success MsgSystemMessageDeleteTranslationSuccess
|
|
redirect $ MessageR cID
|
|
_other -> do
|
|
runDB $ update tId
|
|
[ SystemMessageTranslationLanguage =. systemMessageTranslationLanguage
|
|
, SystemMessageTranslationContent =. systemMessageTranslationContent
|
|
, SystemMessageTranslationSummary =. systemMessageTranslationSummary
|
|
]
|
|
addMessageI Success MsgSystemMessageEditTranslationSuccess
|
|
redirect $ MessageR cID
|
|
|
|
let
|
|
messageEditModal = modal [whamlet|_{MsgSystemMessageEdit}|] . Right $
|
|
wrapForm modifyView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ MessageR cID
|
|
, formEncoding = modifyEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
translationAddModal = modal [whamlet|_{MsgSystemMessageAddTranslation}|] . Right $
|
|
wrapForm addTransView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ MessageR cID
|
|
, formEncoding = addTransEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
translationsEditModal
|
|
| not $ null modifyTranss' = modal [whamlet|_{MsgSystemMessageEditTranslations}|] . Right $ do
|
|
let modifyTranss'' = flip map modifyTranss' $ \((_, transView), transEnctype) -> wrapForm transView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ MessageR cID
|
|
, formEncoding = transEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormNoSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
[whamlet|
|
|
$forall transView <- modifyTranss''
|
|
<section>
|
|
^{transView}
|
|
|]
|
|
| otherwise = mempty
|
|
return (messageEditModal, translationAddModal, translationsEditModal)
|
|
|
|
maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
|
|
forms <- traverse (const mkForm) $ () <$ guard maySubmit
|
|
|
|
siteLayout' (toWidget <$> summary)
|
|
$(widgetFile "system-message")
|
|
where
|
|
modifySystemMessage smId sm = do
|
|
runDB $ replace smId sm
|
|
addMessageI Success MsgSystemMessageEditSuccess
|
|
redirect $ MessageR cID
|
|
|
|
addTranslation translation = do
|
|
runDB . void $ insert translation
|
|
addMessageI Success MsgSystemMessageAddTranslationSuccess
|
|
redirect $ MessageR cID
|
|
|
|
type MessageListData = DBRow (Entity SystemMessage, Maybe SystemMessageTranslation)
|
|
|
|
data ActionSystemMessage = SMDelete | SMActivate | SMDeactivate
|
|
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
|
instance Universe ActionSystemMessage
|
|
instance Finite ActionSystemMessage
|
|
|
|
nullaryPathPiece ''ActionSystemMessage (camelToPathPiece' 1)
|
|
embedRenderMessage ''UniWorX ''ActionSystemMessage (("SystemMessage" <>) . dropPrefix "SM")
|
|
|
|
data ActionSystemMessageData = SMDDelete
|
|
| SMDActivate (Maybe UTCTime)
|
|
| SMDDeactivate (Maybe UTCTime)
|
|
deriving (Eq, Show, Read)
|
|
|
|
getMessageListR, postMessageListR :: Handler Html
|
|
getMessageListR = postMessageListR
|
|
postMessageListR = do
|
|
let
|
|
dbtSQLQuery = return
|
|
dbtColonnade = mconcat
|
|
[ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
|
|
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR ciphertext
|
|
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
|
|
, sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
|
|
, sortable (Just "news-only") (i18nCell MsgSystemMessageNewsOnly) $ \DBRow { dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageNewsOnly
|
|
, sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
|
|
, sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity
|
|
, sortable (Just "created") (i18nCell MsgSystemMessageCreated) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageCreated
|
|
, sortable (Just "last-changed") (i18nCell MsgSystemMessageLastChanged) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageLastChanged
|
|
, sortable (Just "last-unhide") (i18nCell MsgSystemMessageLastUnhide) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageLastUnhide
|
|
, sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let
|
|
(summary, content) = case smT of
|
|
Nothing -> (systemMessageSummary, systemMessageContent)
|
|
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
|
|
in cell . toWidget $ fromMaybe content summary
|
|
]
|
|
dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
|
|
smT <- (>>= view _2) <$> getSystemMessage appLanguages smId
|
|
return DBRow
|
|
{ dbrOutput = (smE, smT)
|
|
, ..
|
|
}
|
|
psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
|
|
(tableRes', tableView) <- runDB $ dbTable psValidator DBTable
|
|
{ dbtSQLQuery
|
|
, dbtRowKey = (E.^. SystemMessageId)
|
|
, dbtColonnade
|
|
, dbtProj
|
|
, dbtSorting = Map.fromList
|
|
[ ( "from"
|
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageFrom
|
|
)
|
|
, ( "to"
|
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageTo
|
|
)
|
|
, ( "news-only"
|
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageNewsOnly
|
|
)
|
|
, ( "authenticated"
|
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly
|
|
)
|
|
, ( "severity"
|
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity
|
|
)
|
|
, ( "created"
|
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageCreated
|
|
)
|
|
, ( "last-changed"
|
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageLastChanged
|
|
)
|
|
, ( "last-unhide"
|
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageLastUnhide
|
|
)
|
|
]
|
|
, dbtFilter = mempty
|
|
, dbtFilterUI = mempty
|
|
, dbtStyle = def
|
|
, dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just $ SomeRoute MessageListR
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional = \frag -> do
|
|
now <- liftIO getCurrentTime
|
|
let actions = Map.fromList
|
|
[ (SMDelete, pure SMDDelete)
|
|
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
|
|
, (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
|
|
]
|
|
(actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty
|
|
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
, dbtIdent = "messages" :: Text
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
}
|
|
|
|
let tableRes = tableRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
|
<&> _1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
|
|
|
|
case tableRes of
|
|
FormMissing -> return ()
|
|
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
|
FormSuccess (SMDDelete, selection)
|
|
| not $ null selection -> do
|
|
selection' <- traverse decrypt $ Set.toList selection
|
|
runDB $ deleteCascadeWhere [ SystemMessageId <-. selection' ]
|
|
$(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet")
|
|
redirect MessageListR
|
|
FormSuccess (SMDActivate ts, selection)
|
|
| not $ null selection -> do
|
|
selection' <- traverse decrypt $ Set.toList selection
|
|
runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageFrom =. ts ]
|
|
$(addMessageFile Success "templates/messages/systemMessagesSetFrom.hamlet")
|
|
redirect MessageListR
|
|
FormSuccess (SMDDeactivate ts, selection)
|
|
| not $ null selection -> do
|
|
selection' <- traverse decrypt $ Set.toList selection
|
|
runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ]
|
|
$(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet")
|
|
redirect MessageListR
|
|
FormSuccess (_, _selection) -- prop> null _selection
|
|
-> addMessageI Error MsgSystemMessageEmptySelection
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
now <- liftIO getCurrentTime
|
|
((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
|
|
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just Nothing)
|
|
<*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just Nothing)
|
|
<*> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just False)
|
|
<*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just False)
|
|
<*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just Info)
|
|
<*> pure now <*> pure now <*> pure now
|
|
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just $ NonEmpty.head appLanguages)
|
|
<*> areq htmlField (fslI MsgSystemMessageContent) Nothing
|
|
<*> aopt htmlField (fslI MsgSystemMessageSummary) (Just Nothing)
|
|
|
|
case addRes of
|
|
FormMissing -> return ()
|
|
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
|
FormSuccess sysMsg -> do
|
|
sId <- runDB $ insert sysMsg
|
|
cID <- encrypt sId :: Handler CryptoUUIDSystemMessage
|
|
addMessageI Success $ MsgSystemMessageAdded cID
|
|
redirect $ MessageR cID
|
|
|
|
let addForm = wrapForm addView def
|
|
{ formAction = Just $ SomeRoute MessageListR
|
|
, formEncoding = addEncoding
|
|
}
|
|
|
|
defaultLayout
|
|
$(widgetFile "system-message-list")
|
|
|
|
|
|
data ButtonSystemMessageHide
|
|
= BtnSystemMessageHide
|
|
| BtnSystemMessageUnhide
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
deriving anyclass (Universe, Finite)
|
|
nullaryPathPiece ''ButtonSystemMessageHide $ camelToPathPiece' 3
|
|
embedRenderMessage ''UniWorX ''ButtonSystemMessageHide id
|
|
|
|
instance Button UniWorX ButtonSystemMessageHide where
|
|
btnClasses BtnSystemMessageHide = [BCLink]
|
|
btnClasses BtnSystemMessageUnhide = [BCLink]
|
|
|
|
|
|
postMessageHideR :: CryptoUUIDSystemMessage -> Handler Void
|
|
postMessageHideR cID = do
|
|
now <- liftIO getCurrentTime
|
|
muid <- maybeAuthId
|
|
smId <- decrypt cID
|
|
|
|
((btnRes, _), _) <- runFormPost buttonForm
|
|
|
|
formResult btnRes $ \case
|
|
BtnSystemMessageHide -> runDB $ do
|
|
existsKey404 smId
|
|
|
|
whenIsJust muid $ \uid -> void $
|
|
upsert SystemMessageHidden
|
|
{ systemMessageHiddenMessage = smId
|
|
, systemMessageHiddenUser = uid
|
|
, systemMessageHiddenTime = now
|
|
}
|
|
[ SystemMessageHiddenTime =. now ]
|
|
|
|
modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
|
|
-> fmap MergeHashMap . assertM' (/= mempty) $
|
|
HashMap.update (\smSt -> assertM' (/= mempty) $ smSt { userSystemMessageUnhidden = Nothing, userSystemMessageHidden = guardOn (is _Nothing muid) now }) cID hm
|
|
|
|
BtnSystemMessageUnhide -> runDB $ do
|
|
existsKey404 smId
|
|
|
|
whenIsJust muid $ \uid ->
|
|
deleteBy $ UniqueSystemMessageHidden uid smId
|
|
|
|
modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
|
|
-> fmap MergeHashMap . assertM' (/= mempty) $
|
|
HashMap.update (\smSt -> assertM' (/= mempty) $ smSt { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = guardOn (is _Nothing muid) now }) cID hm
|
|
|
|
redirect . (NewsR, ) . bool [] [(toPathPiece GetHidden, "")] $ btnRes == FormSuccess BtnSystemMessageUnhide
|