From b288b56e1d1031f2f3f56baf1dd0fa14194a53c5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 22 Oct 2018 18:27:08 +0200 Subject: [PATCH] SystemMessage CRUD --- messages/uniworx/de.msg | 39 ++- routes | 1 + src/CryptoID.hs | 1 + src/Foundation.hs | 24 +- src/Handler/SystemMessage.hs | 224 ++++++++++++++++++ src/Handler/Utils/Form.hs | 24 ++ src/Handler/Utils/Table/Pagination.hs | 4 +- src/Import/NoFoundation.hs | 8 +- src/Utils/Form.hs | 33 ++- .../messages/systemMessagesDeleted.hamlet | 6 + .../messages/systemMessagesSetFrom.hamlet | 6 + templates/messages/systemMessagesSetTo.hamlet | 6 + templates/system-message-list.hamlet | 9 + templates/system-message.hamlet | 18 ++ 14 files changed, 395 insertions(+), 8 deletions(-) create mode 100644 templates/messages/systemMessagesDeleted.hamlet create mode 100644 templates/messages/systemMessagesSetFrom.hamlet create mode 100644 templates/messages/systemMessagesSetTo.hamlet create mode 100644 templates/system-message-list.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 3c4ef4358..0d3bea8b7 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -201,6 +201,7 @@ ProfileHeading: Benutzereinstellungen ProfileDataHeading: Gespeicherte Benutzerdaten ImpressumHeading: Impressum SystemMessageHeading: Uni2Work Statusmeldung +SystemMessageListHeading: Uni2Work Statusmeldungen NumCourses n@Int64: #{display n} Kurse CloseAlert: Schliessen @@ -397,4 +398,40 @@ HelpAnonymous: Keine Antwort (Anonym) HelpEMail: E-Mail 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. \ No newline at end of file +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. + +SystemMessageFrom: Sichtbar ab +SystemMessageTo: Sichtbar bis +SystemMessageAuthenticatedOnly: Nur angemeldet +SystemMessageSeverity: Schwere +SystemMessageId: Id +SystemMessageSummaryContent: Zusammenfassung / Inhalt +SystemMessageSummary: Zusammenfassung +SystemMessageContent: Inhalt +SystemMessageLanguage: Sprache + +SystemMessageDelete: Löschen +SystemMessageActivate: Sichtbar schalten +SystemMessageDeactivate: Unsichtbar schalten +SystemMessageTimestamp: Zeitpunkt + +SystemMessagesDeleted: System-Nachrichten gelöscht: +SystemMessagesActivated: Aktivierungszeitpunkt folgender System-Nachrichten gesetzt: +SystemMessagesDeactivated: Deaktivierungszeitpunkt folgender System-Nachrichten gesetzt: +SystemMessageEmptySelection: Keine System-Nachrichten ausgewählt +SystemMessageAdded sysMsgId@CryptoUUIDSystemMessage: System-Nachricht hinzugefügt: #{toPathPiece sysMsgId} +SystemMessageEdit: Statusmeldung anpassen +SystemMessageEditTranslations: Übersetzungen anpassen +SystemMessageAddTranslation: Übersetzung hinzufügen + +SystemMessageEditSuccess: Statusmeldung angepasst. +SystemMessageAddTranslationSuccess: Übersetzung hinzugefügt. +SystemMessageEditTranslationSuccess: Übersetzung angepasst. +SystemMessageDeleteTranslationSuccess: Übersetzung entfernt. + +MessageError: Fehler +MessageWarning: Warnung +MessageInfo: Information +MessageSuccess: Erfolg + +InvalidLangFormat: Ungültiger Sprach-Code (RFC1766) \ No newline at end of file diff --git a/routes b/routes index e2572e8ba..991318c6a 100644 --- a/routes +++ b/routes @@ -91,6 +91,7 @@ /submissions/grade CorrectionsGradeR GET POST !corrector !lecturer +/msgs MessageListR GET POST /msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDisReadANDauthentication diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 9f555ef3e..58f68171e 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -40,6 +40,7 @@ decCryptoIDs [ ''SubmissionId , ''UserId , ''SheetId , ''SystemMessageId + , ''SystemMessageTranslationId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Foundation.hs b/src/Foundation.hs index 95459077c..177222827 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -85,7 +85,7 @@ import Utils.Form import Utils.Lens import Utils.SystemMessage -import Data.Aeson hiding (Error) +import Data.Aeson hiding (Error, Success) import Data.Aeson.TH import qualified Data.Yaml as Yaml @@ -261,6 +261,13 @@ instance RenderMessage UniWorX NotificationTrigger where instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) +instance RenderMessage UniWorX MessageClass where + renderMessage f ls = renderMessage f ls . \case + Error -> MsgMessageError + Warning -> MsgMessageWarning + Info -> MsgMessageInfo + Success -> MsgMessageSuccess + data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink deriving (Enum, Eq, Ord, Bounded, Read, Show) @@ -827,6 +834,12 @@ instance YesodBreadcrumbs UniWorX where -- Others breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) + breadcrumb (MessageR _) = do + mayList <- (== Authorized) <$> evalAccess MessageListR False + return $ if + | mayList -> ("Statusmeldung", Just MessageListR) + | otherwise -> ("Statusmeldung", Just HomeR) + breadcrumb (MessageListR) = return ("Statusmeldungen", Just HomeR) breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId] @@ -942,6 +955,13 @@ pageActions (HomeR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , PageActionPrime $ MenuItem + { menuItemLabel = "System-Nachrichten" + , menuItemIcon = Nothing + , menuItemRoute = MessageListR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (ProfileR) = [ PageActionPrime $ MenuItem @@ -1270,6 +1290,8 @@ pageHeading CorrectionsGradeR = Just $ i18nHeading MsgCorrGrade pageHeading (MessageR _) = Just $ i18nHeading MsgSystemMessageHeading +pageHeading MessageListR + = Just $ i18nHeading MsgSystemMessageListHeading -- TODO: add headings for more single course- and single term-pages pageHeading _ diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 5558d7f32..5158e65f6 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -1,12 +1,39 @@ {-# LANGUAGE NoImplicitPrelude , RecordWildCards , TemplateHaskell + , NamedFieldPuns + , RecordWildCards + , OverloadedStrings + , TypeFamilies + , ViewPatterns + , FlexibleContexts + , LambdaCase + , MultiParamTypeClasses #-} 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 @@ -15,5 +42,202 @@ postMessageR cID = do let (summary, content) = case translation of Nothing -> (systemMessageSummary, systemMessageContent) Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) + + let + mkForm :: Handler (((FormResult SystemMessage, Widget), Enctype), Map Lang ((FormResult (Entity SystemMessageTranslation, [Maybe BtnSubmitDelete]), Widget), Enctype), ((FormResult SystemMessageTranslation, Widget), Enctype)) + mkForm = do + modifyRes'@((modifyRes, _), _) <- 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'@((addTransRes, _), _) <- 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 + + return (modifyRes', modifyTranss', addTransRes') + + 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") diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 46ac21f6b..c7b7aee21 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -108,6 +108,25 @@ instance Button UniWorX AdminHijackUserButton where cssClass BtnHijack = BCDefault +data BtnSubmitDelete = BtnSubmit' | BtnDelete' + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +instance Universe BtnSubmitDelete +instance Finite BtnSubmitDelete + +instance Button UniWorX BtnSubmitDelete where + label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|] + label BtnDelete' = [whamlet|_{MsgBtnDelete}|] + + cssClass BtnSubmit' = BCPrimary + cssClass BtnDelete' = BCDanger + +$(return []) + +instance PathPiece BtnSubmitDelete where + toPathPiece = $(nullaryToPathPiece ''BtnSubmitDelete [ T.intercalate "-" . drop 1 . splitCamel ]) + fromPathPiece = finiteFromPathPiece + -- -- Looks like a button, but is just a link (e.g. for create course, etc.) -- data LinkButton = LinkButton (Route UniWorX) @@ -471,6 +490,11 @@ utcTimeField = Field (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime Nothing -> Left MsgInvalidDateTimeFormat +langField :: Bool -- ^ Only allow values from `appLanguages` + -> Field (HandlerT UniWorX IO) Lang +langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages) +langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages + fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED fsm = bfs -- TODO: get rid of Bootstrap diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index d4fe59a22..ff2e81f64 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -339,8 +339,8 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) - dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . identifyForm dbtIdent - dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> identifyForm dbtIdent form csrf + dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost + dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> form csrf -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype) -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget)) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 55fc73870..45c6c2d6a 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} module Import.NoFoundation ( module Import + , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=)) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import @@ -39,3 +40,8 @@ import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..)) import Control.Monad.Morph as Import (MFunctor(..)) + + +import Control.Monad.Trans.RWS (RWST) + +type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2ec9e3218..12b92f430 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -15,7 +15,7 @@ module Utils.Form where -import ClassyPrelude.Yesod +import ClassyPrelude.Yesod hiding (addMessage) import Settings import qualified Text.Blaze.Internal as Blaze (null) @@ -33,6 +33,10 @@ import Data.List ((!!)) import Web.PathPieces +import Data.UUID + +import Utils.Message + ------------------- -- Form Renderer -- ------------------- @@ -150,8 +154,22 @@ noValidate = addAttr "formnovalidate" "" -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ -data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data FormIdentifier + = FIDcourse + | FIDsheet + | FIDsubmission + | FIDsettings + | FIDcorrectors + | FIDcorrectorTable + | FIDcorrection + | FIDcorrectionsUpload + | FIDcorrectionUpload + | FIDSystemMessageAdd + | FIDSystemMessageTable + | FIDSystemMessageModify + | FIDSystemMessageModifyTranslation UUID + | FIDSystemMessageAddTranslation + deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where fromPathPiece = readFromPathPiece @@ -260,3 +278,12 @@ reorderField optList = Field{..} nums = map (id &&& withNum theId) [1..length olOptions] withNum t n = tshow n <> "." <> t $(widgetFile "widgets/permutation") + +--------------------- +-- Form evaluation -- +--------------------- + +formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m () +formResult (FormFailure errs) _ = forM_ errs $ addMessage Error . toHtml +formResult FormMissing _ = return () +formResult (FormSuccess res) f = f res diff --git a/templates/messages/systemMessagesDeleted.hamlet b/templates/messages/systemMessagesDeleted.hamlet new file mode 100644 index 000000000..0252043a2 --- /dev/null +++ b/templates/messages/systemMessagesDeleted.hamlet @@ -0,0 +1,6 @@ +_{MsgSystemMessagesDeleted} + +