281 lines
13 KiB
Haskell
281 lines
13 KiB
Haskell
module Handler.SystemMessage where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Map.Lazy as Map
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Table.Cells
|
|
|
|
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)
|
|
|
|
let
|
|
mkForm = do
|
|
((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
|
|
$ SystemMessage
|
|
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
|
|
<*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
|
|
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
|
|
<*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
|
|
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageDefaultLanguage)
|
|
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageContent)
|
|
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (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 "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
|
|
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
|
|
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
|
|
)
|
|
<*> combinedButtonFieldF ""
|
|
|
|
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
|
|
|
|
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
|
|
$ SystemMessageTranslation
|
|
<$> pure smId
|
|
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing
|
|
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
|
|
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") 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 SystemMessage{..} = do
|
|
runDB $ update smId
|
|
[ SystemMessageFrom =. systemMessageFrom
|
|
, SystemMessageTo =. systemMessageTo
|
|
, SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly
|
|
, SystemMessageSeverity =. systemMessageSeverity
|
|
, SystemMessageDefaultLanguage =. systemMessageDefaultLanguage
|
|
, SystemMessageContent =. systemMessageContent
|
|
, SystemMessageSummary =. systemMessageSummary
|
|
]
|
|
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
|
|
, dbRow
|
|
, 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 "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
|
|
, sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity
|
|
, 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
|
|
Just (_, smT) <- lift $ getSystemMessage appLanguages smId
|
|
return DBRow
|
|
{ dbrOutput = (smE, smT)
|
|
, ..
|
|
}
|
|
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (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
|
|
)
|
|
, ( "authenticated"
|
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly
|
|
)
|
|
, ( "severity"
|
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity
|
|
)
|
|
]
|
|
, 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 = liftHandlerT . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
, dbtIdent = "messages" :: Text
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
}
|
|
|
|
let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
|
& mapped._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
|
|
|
|
((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
|
|
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
|
|
<*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
|
|
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
|
|
<*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) Nothing
|
|
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just $ NonEmpty.head appLanguages)
|
|
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
|
|
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") 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")
|