fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

SystemMessage CRUD

Browse Source
This commit is contained in:
Gregor Kleen 2018-10-22 18:27:08 +02:00
parent d663586516
commit b288b56e1d
14 changed files with 395 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
messages/uniworx/de.msg
View File

@ -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.
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)

1
routes
View File

@ -91,6 +91,7 @@
/submissions/grade CorrectionsGradeR GET POST !corrector !lecturer
/msgs MessageListR GET POST
/msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDisReadANDauthentication

1
src/CryptoID.hs
View File

@ -40,6 +40,7 @@ decCryptoIDs [ ''SubmissionId
, ''UserId
, ''SheetId
, ''SystemMessageId
, ''SystemMessageTranslationId
]
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

24
src/Foundation.hs
View File

@ -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 _

224
src/Handler/SystemMessage.hs
View File

@ -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")

24
src/Handler/Utils/Form.hs
View File

@ -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

4
src/Handler/Utils/Table/Pagination.hs
View File

@ -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))

8
src/Import/NoFoundation.hs
View File

@ -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

33
src/Utils/Form.hs
View File

@ -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

6
templates/messages/systemMessagesDeleted.hamlet Normal file
View File

@ -0,0 +1,6 @@
_{MsgSystemMessagesDeleted}
<ul>
$forall sel <- selection
<li style="white-space: nowrap">
#{toPathPiece sel}

6
templates/messages/systemMessagesSetFrom.hamlet Normal file
View File

@ -0,0 +1,6 @@
_{MsgSystemMessagesActivated}
<ul>
$forall sel <- selection
<li style="white-space: nowrap">
#{toPathPiece sel}

6
templates/messages/systemMessagesSetTo.hamlet Normal file
View File

@ -0,0 +1,6 @@
_{MsgSystemMessagesDeactivated}
<ul>
$forall sel <- selection
<li style="white-space: nowrap">
#{toPathPiece sel}

9
templates/system-message-list.hamlet Normal file
View File

@ -0,0 +1,9 @@
<section>
<form method=post action=@{MessageListR} encytpe=#{tableEncoding}>
^{tableView}
<button type=submit>
_{MsgBtnSubmit}
<section>
<form method=post action=@{MessageListR} enctype=#{addEncoding}>
^{addView}

18
templates/system-message.hamlet
View File

@ -4,3 +4,21 @@
#{summary'}
<p>
#{content}
$maybe (((_, modifyView), modifyEnctype), modifyTranss, ((_, addTransView), addTransEnctype)) <- forms
<section>
<h2>_{MsgSystemMessageEdit}
<form method=post action=@{MessageR cID} enctype=#{modifyEnctype}>
^{modifyView}
<section>
<h2>_{MsgSystemMessageAddTranslation}
<form method=post action=@{MessageR cID} enctype=#{addTransEnctype}>
^{addTransView}
$if not (null modifyTranss)
<section>
<h2>_{MsgSystemMessageEditTranslations}
$forall ((_, transView), transEnctype) <- modifyTranss
<form method=post action=@{MessageR cID} enctype=#{transEnctype}>
^{transView}