264 lines
12 KiB
Haskell
264 lines
12 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, RecordWildCards
|
|
, TemplateHaskell
|
|
, NamedFieldPuns
|
|
, RecordWildCards
|
|
, OverloadedStrings
|
|
, TypeFamilies
|
|
, ViewPatterns
|
|
, FlexibleContexts
|
|
, LambdaCase
|
|
, MultiParamTypeClasses
|
|
, QuasiQuotes
|
|
#-}
|
|
|
|
module Handler.SystemMessage where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Map.Lazy as Map
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
|
|
import Handler.Utils
|
|
|
|
import Utils.Lens
|
|
|
|
|
|
htmlField' :: Field (HandlerT UniWorX IO) Html
|
|
htmlField' = htmlField
|
|
{ fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
|
|
}
|
|
|
|
|
|
|
|
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 . identForm 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 (id :: MessageClass -> MessageClass)) (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)
|
|
<* submitButton
|
|
|
|
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 . identForm (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)
|
|
)
|
|
<*> combinedButtonField (universeF :: [BtnSubmitDelete])
|
|
|
|
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
|
|
|
|
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identForm 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
|
|
<* submitButton
|
|
|
|
formResult modifyRes $ \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
|
|
|
|
formResult addTransRes $ \smt -> do
|
|
runDB . void . insert $ smt
|
|
addMessageI Success MsgSystemMessageAddTranslationSuccess
|
|
redirect $ MessageR cID
|
|
|
|
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
|
|
[whamlet|
|
|
<form method=post action=@{MessageR cID} enctype=#{modifyEnctype}>
|
|
^{modifyView}
|
|
|]
|
|
translationAddModal = modal [whamlet|_{MsgSystemMessageAddTranslation}|] $ Right
|
|
[whamlet|
|
|
<form method=post action=@{MessageR cID} enctype=#{addTransEnctype}>
|
|
^{addTransView}
|
|
|]
|
|
translationsEditModal
|
|
| not $ null modifyTranss' = modal [whamlet|_{MsgSystemMessageEditTranslations}|] $ Right
|
|
[whamlet|
|
|
$forall ((_, transView), transEnctype) <- modifyTranss'
|
|
<section>
|
|
<form method=post action=@{MessageR cID} enctype=#{transEnctype}>
|
|
^{transView}
|
|
|]
|
|
| otherwise = mempty
|
|
return (messageEditModal, translationAddModal, translationsEditModal)
|
|
|
|
maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
|
|
forms <- traverse (const mkForm) $ () <$ guard maySubmit
|
|
|
|
defaultLayout $ do
|
|
$(widgetFile "system-message")
|
|
|
|
|
|
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
|
|
$(return [])
|
|
instance PathPiece ActionSystemMessage where
|
|
toPathPiece = $(nullaryToPathPiece ''ActionSystemMessage [ Text.intercalate "-" . drop 1 . splitCamel ])
|
|
fromPathPiece = finiteFromPathPiece
|
|
|
|
instance RenderMessage UniWorX ActionSystemMessage where
|
|
renderMessage m ls = renderMessage m ls . \case
|
|
SMDelete -> MsgSystemMessageDelete
|
|
SMActivate -> MsgSystemMessageActivate
|
|
SMDeactivate -> MsgSystemMessageDeactivate
|
|
|
|
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 id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
|
|
, dbRow
|
|
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) (\cID -> MessageR cID) (toWidget . tshow . 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 (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
|
|
tableForm <- dbTable psValidator $ DBTable
|
|
{ dbtSQLQuery
|
|
, dbtColonnade
|
|
, dbtProj
|
|
, dbtSorting = Map.fromList
|
|
[ -- TODO: from, to, authenticated, severity
|
|
]
|
|
, dbtFilter = Map.fromList
|
|
[
|
|
]
|
|
, dbtStyle = def
|
|
, dbtIdent = "messages" :: Text
|
|
}
|
|
((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
|
|
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
|
|
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) <- multiAction actions (Just SMActivate)
|
|
$logDebugS "SystemMessage" $ tshow (actionRes, selectionRes)
|
|
return ((,) <$> actionRes <*> selectionRes, table <> action)
|
|
|
|
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)
|
|
| null selection -> addMessageI Error MsgSystemMessageEmptySelection
|
|
|
|
((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
|
|
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
|
|
<*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
|
|
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
|
|
<*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (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
|
|
<* submitButton
|
|
|
|
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
|
|
|
|
defaultLayout $ do
|
|
$(widgetFile "system-message-list")
|