Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
SJost
commit
af5f4f190d
@ -25,9 +25,12 @@ job-cron-interval: "_env:CRON_INTERVAL:60"
|
||||
job-stale-threshold: 300
|
||||
notification-rate-limit: 3600
|
||||
|
||||
detailed-logging: "_env:DETAILED_LOGGING:false"
|
||||
should-log-all: "_env:LOG_ALL:false"
|
||||
minimum-log-level: "_env:LOGLEVEL:warn"
|
||||
log-settings:
|
||||
log-detailed: "_env:DETAILED_LOGGING:false"
|
||||
log-all: "_env:LOG_ALL:false"
|
||||
log-minimum-level: "_env:LOGLEVEL:warn"
|
||||
|
||||
# Debugging
|
||||
auth-dummy-login: "_env:DUMMY_LOGIN:false"
|
||||
allow-deprecated: "_env:ALLOW_DEPRECATED:false"
|
||||
|
||||
|
||||
@ -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
|
||||
@ -258,6 +259,8 @@ RatingPercent: Erreicht
|
||||
RatingFiles: Korrigierte Dateien
|
||||
PointsNotPositive: Punktzahl darf nicht negativ sein
|
||||
RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
|
||||
ColumnRatingPointsDone: Punktzahl/Abgeschlossen
|
||||
Pseudonyms: Pseudonyme
|
||||
|
||||
FileTitle: Dateiname
|
||||
FileModified: Letzte Änderung
|
||||
@ -385,15 +388,50 @@ SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt
|
||||
SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert:
|
||||
SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben:
|
||||
|
||||
CorrGrade: Korrekturen eintragen
|
||||
|
||||
UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht!
|
||||
|
||||
HelpAnswer: Anfrage von
|
||||
HelpUser: Benutzeraccount Uni2Work
|
||||
HelpAnonymous: Anonym (Keine Antwort möglich)
|
||||
HelpEMail: E-Mail (ohne Login)
|
||||
HelpAnswer: Antworten an
|
||||
HelpUser: Meinen Benutzeraccount
|
||||
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.
|
||||
|
||||
SystemMessageFrom: Sichtbar ab
|
||||
SystemMessageTo: Sichtbar bis
|
||||
SystemMessageAuthenticatedOnly: Nur angemeldet
|
||||
SystemMessageSeverity: Schwere
|
||||
SystemMessageId: Id
|
||||
SystemMessageSummaryContent: Zusammenfassung / Inhalt
|
||||
SystemMessageSummary: Zusammenfassung
|
||||
SystemMessageContent: Inhalt
|
||||
SystemMessageLanguage: Sprache
|
||||
|
||||
Dummy: TODO Message not defined!
|
||||
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)
|
||||
@ -106,6 +106,7 @@ dependencies:
|
||||
- resourcet
|
||||
- postgresql-simple
|
||||
- word24
|
||||
- mmorph
|
||||
|
||||
# The library contains all of our application code. The executable
|
||||
# defined below is just a thin wrapper.
|
||||
|
||||
8
routes
8
routes
@ -85,11 +85,13 @@
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
|
||||
|
||||
/corrections CorrectionsR GET POST !corrector !lecturer
|
||||
/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||
/corrections/create CorrectionsCreateR GET POST !corrector !lecturer
|
||||
/submissions CorrectionsR GET POST !corrector !lecturer
|
||||
/submissions/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||
/submissions/create CorrectionsCreateR GET POST !corrector !lecturer
|
||||
/submissions/grade CorrectionsGradeR GET POST !corrector !lecturer
|
||||
|
||||
|
||||
/msgs MessageListR GET POST
|
||||
/msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDisReadANDauthentication
|
||||
|
||||
|
||||
|
||||
@ -63,6 +63,10 @@ import Control.Monad.Trans.Resource
|
||||
|
||||
import System.Log.FastLogger.Date
|
||||
import qualified Yesod.Core.Types as Yesod (Logger(..))
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Control.Lens ((&))
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
||||
@ -109,6 +113,8 @@ makeFoundation appSettings@(AppSettings{..}) = do
|
||||
recvChan <- dupTMChan chan
|
||||
return (chan, recvChan)
|
||||
|
||||
appLogSettings <- liftIO $ newTVarIO appInitialLogSettings
|
||||
|
||||
-- We need a log function to create a connection pool. We need a connection
|
||||
-- pool to create our foundation. And we need our foundation to get a
|
||||
-- logging function. To get out of this loop, we initially create a
|
||||
@ -190,25 +196,38 @@ makeApplication foundation = liftIO $ do
|
||||
return $ logWare $ defaultMiddlewaresNoLogging appPlain
|
||||
|
||||
makeLogWare :: MonadIO m => UniWorX -> m Middleware
|
||||
makeLogWare foundation = liftIO $
|
||||
mkRequestLogger def
|
||||
{ outputFormat =
|
||||
if appDetailedRequestLogging $ appSettings foundation
|
||||
then Detailed True
|
||||
else Apache
|
||||
(if appIpFromHeader $ appSettings foundation
|
||||
then FromFallback
|
||||
else FromSocket)
|
||||
, destination = Logger $ loggerSet $ appLogger foundation
|
||||
}
|
||||
makeLogWare app = do
|
||||
logWareMap <- liftIO $ newTVarIO HashMap.empty
|
||||
|
||||
let
|
||||
mkLogWare ls@LogSettings{..} = do
|
||||
logWare <- mkRequestLogger def
|
||||
{ outputFormat = bool
|
||||
(Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
|
||||
(Detailed True)
|
||||
logDetailed
|
||||
, destination = Logger . loggerSet $ appLogger app
|
||||
}
|
||||
atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare
|
||||
return logWare
|
||||
|
||||
void. liftIO $
|
||||
mkLogWare =<< readTVarIO (appLogSettings app)
|
||||
|
||||
return $ \wai req fin -> do
|
||||
lookupRes <- atomically $ do
|
||||
ls <- readTVar $ appLogSettings app
|
||||
existing <- HashMap.lookup ls <$> readTVar logWareMap
|
||||
return $ maybe (Left ls) Right existing
|
||||
logWare <- either mkLogWare return lookupRes
|
||||
logWare wai req fin
|
||||
|
||||
-- | Warp settings for the given foundation value.
|
||||
warpSettings :: UniWorX -> Settings
|
||||
warpSettings foundation =
|
||||
setPort (appPort $ appSettings foundation)
|
||||
$ setHost (appHost $ appSettings foundation)
|
||||
$ setOnException (\_req e ->
|
||||
warpSettings foundation = defaultSettings
|
||||
& setPort (appPort $ appSettings foundation)
|
||||
& setHost (appHost $ appSettings foundation)
|
||||
& setOnException (\_req e ->
|
||||
when (defaultShouldDisplayException e) $ messageLoggerSource
|
||||
foundation
|
||||
(appLogger foundation)
|
||||
@ -216,7 +235,6 @@ warpSettings foundation =
|
||||
"yesod"
|
||||
LevelError
|
||||
(toLogStr $ "Exception from Warp: " ++ show e))
|
||||
defaultSettings
|
||||
|
||||
-- | For yesod devel, return the Warp settings and WAI Application.
|
||||
getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application)
|
||||
@ -232,9 +250,8 @@ getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSetting
|
||||
|
||||
-- | main function for use by yesod devel
|
||||
develMain :: IO ()
|
||||
develMain = runResourceT $ do
|
||||
app <- getApplicationDev
|
||||
liftIO . develMainHelper $ return app
|
||||
develMain = runResourceT $
|
||||
liftIO . develMainHelper . return =<< getApplicationDev
|
||||
|
||||
-- | The @main@ function for an executable running this site.
|
||||
appMain :: MonadResourceBase m => m ()
|
||||
|
||||
@ -40,6 +40,7 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''UserId
|
||||
, ''SheetId
|
||||
, ''SystemMessageId
|
||||
, ''SystemMessageTranslationId
|
||||
]
|
||||
|
||||
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
|
||||
|
||||
@ -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
|
||||
|
||||
@ -123,6 +123,7 @@ data UniWorX = UniWorX
|
||||
, appSmtpPool :: Maybe SMTPPool
|
||||
, appHttpManager :: Manager
|
||||
, appLogger :: Logger
|
||||
, appLogSettings :: TVar LogSettings
|
||||
, appCryptoIDKey :: CryptoIDKey
|
||||
, appInstanceID :: InstanceId
|
||||
, appJobCtl :: [TMChan JobCtl]
|
||||
@ -260,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)
|
||||
@ -751,7 +759,10 @@ instance Yesod UniWorX where
|
||||
|
||||
-- What messages should be logged. The following includes all messages when
|
||||
-- in development, and warnings and errors in production.
|
||||
shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app)
|
||||
shouldLog _ _ _ = error "Must use shouldLogIO"
|
||||
shouldLogIO app _source level = do
|
||||
LogSettings{..} <- readTVarIO $ appLogSettings app
|
||||
return $ logAll || level >= logMinimumLevel
|
||||
|
||||
makeLogger = return . appLogger
|
||||
|
||||
@ -823,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]
|
||||
@ -938,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
|
||||
@ -1118,6 +1142,35 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
|
||||
}
|
||||
]
|
||||
pageActions (CorrectionsR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrekturen hochladen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CorrectionsUploadR
|
||||
, menuItemModal = True
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgaben erstellen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CorrectionsCreateR
|
||||
, menuItemModal = True
|
||||
, menuItemAccessCallback' = runDB $ do
|
||||
uid <- liftHandlerT requireAuthId
|
||||
[E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
|
||||
return E.countRows
|
||||
return $ (count :: Int) /= 0
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrekturen eintragen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CorrectionsGradeR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CorrectionsGradeR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrekturen hochladen"
|
||||
, menuItemIcon = Nothing
|
||||
@ -1233,8 +1286,12 @@ pageHeading CorrectionsUploadR
|
||||
= Just $ i18nHeading MsgCorrUpload
|
||||
pageHeading CorrectionsCreateR
|
||||
= Just $ i18nHeading MsgCorrCreate
|
||||
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 _
|
||||
|
||||
@ -69,6 +69,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter)
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
import Control.Monad.Trans.State (State, StateT(..), runState)
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
@ -90,8 +92,11 @@ courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
|
||||
sheetIs :: Key Sheet -> CorrectionsWhere
|
||||
sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
|
||||
|
||||
submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere
|
||||
submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
|
||||
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId User)
|
||||
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
|
||||
|
||||
colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
@ -143,13 +148,15 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
link cid = CourseR tid ssh csh $ CUserR cid
|
||||
cell = listCell (Map.toList users) $ \(userId, User{..}) -> do
|
||||
anchorCellM (link <$> encrypt userId) (nameWidget userDisplayName userSurname)
|
||||
cell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
|
||||
anchorCellM (link <$> encrypt userId) $ case mPseudo of
|
||||
Nothing -> nameWidget userDisplayName userSurname
|
||||
Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review pseudonymText p})|]
|
||||
in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
|
||||
cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
|
||||
cell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
|
||||
in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
@ -171,13 +178,31 @@ colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
|
||||
maybe mempty timeCell submissionRatingTime
|
||||
|
||||
colPseudonyms :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
|
||||
lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo ->
|
||||
cell [whamlet|#{review pseudonymText pseudo}|]
|
||||
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), a))))
|
||||
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone & cellTooltip MsgRatingPointsDone) $ formCell
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
|
||||
NotGraded -> over (_1.mapped) ((_1 .~) . fmap Left) . over _2 fvInput <$> mopt checkBoxField "" (Just . Just $ isJust submissionRatingPoints)
|
||||
_other -> over (_1.mapped) ((_1 .~) . fmap Right) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints)
|
||||
)
|
||||
|
||||
colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Text))))
|
||||
colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_2 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
|
||||
|
||||
|
||||
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
|
||||
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
||||
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
|
||||
makeCorrectionsTable whereClause colChoices psValidator = do
|
||||
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
|
||||
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
||||
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
|
||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||
@ -191,18 +216,20 @@ makeCorrectionsTable whereClause colChoices psValidator = do
|
||||
)
|
||||
return (submission, sheet, crse, corrector)
|
||||
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
|
||||
dbtProj = traverse $ \(submission@(Entity sId _), sheet, (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
|
||||
submittors <- lift . E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
|
||||
submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
|
||||
E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
|
||||
E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
|
||||
E.orderBy [E.asc $ user E.^. UserId]
|
||||
return user
|
||||
return (user, pseudonym E.?. SheetPseudonymPseudonym)
|
||||
let
|
||||
submittorMap = foldr (\(Entity userId user) -> Map.insert userId user) Map.empty submittors
|
||||
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
|
||||
submittorMap = foldr (\((Entity userId user, E.Value pseudo)) -> Map.insert userId (user, pseudo)) Map.empty submittors
|
||||
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
|
||||
dbTable psValidator $ DBTable
|
||||
{ dbtSQLQuery
|
||||
, dbtColonnade = colChoices
|
||||
, dbtColonnade
|
||||
, dbtProj
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "term"
|
||||
@ -220,6 +247,9 @@ makeCorrectionsTable whereClause colChoices psValidator = do
|
||||
, ( "rating"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
|
||||
)
|
||||
, ( "ratingtime"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime
|
||||
)
|
||||
]
|
||||
, dbtFilter = Map.fromList
|
||||
[ ( "term"
|
||||
@ -267,7 +297,7 @@ data ActionCorrectionsData = CorrDownloadData
|
||||
|
||||
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
|
||||
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
|
||||
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
|
||||
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return
|
||||
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
|
||||
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
|
||||
(actionRes, action) <- multiAction actions Nothing
|
||||
@ -383,6 +413,7 @@ postCorrectionsR = do
|
||||
, colTerm
|
||||
, colCourse
|
||||
, colSheet
|
||||
, colPseudonyms
|
||||
, colSubmissionLink
|
||||
, colAssigned
|
||||
, colRating
|
||||
@ -591,6 +622,7 @@ postCorrectionsCreateR = do
|
||||
FormMissing -> return ()
|
||||
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
||||
FormSuccess (sid, pss) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ do
|
||||
Sheet{..} <- get404 sid
|
||||
(sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
|
||||
@ -632,6 +664,7 @@ postCorrectionsCreateR = do
|
||||
| otherwise
|
||||
-> do
|
||||
subId <- insert submission
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
@ -644,12 +677,14 @@ postCorrectionsCreateR = do
|
||||
case (groups :: [E.Value SubmissionGroupId]) of
|
||||
[x] -> do
|
||||
subId <- insert submission
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
[] -> do
|
||||
subId <- insert submission
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
@ -660,17 +695,20 @@ postCorrectionsCreateR = do
|
||||
| [SheetPseudonym{sheetPseudonymUser}] <- spGroup
|
||||
-> do
|
||||
subId <- insert submission
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insert_ SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
| otherwise -> do
|
||||
subId <- insert submission
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
|
||||
redirect CorrectionsGradeR
|
||||
|
||||
|
||||
defaultLayout $ do
|
||||
@ -690,3 +728,51 @@ postCorrectionsCreateR = do
|
||||
[] -> return $ Right valid
|
||||
textFromList :: [[Pseudonym]] -> Textarea
|
||||
textFromList = Textarea . Text.unlines . map (Text.intercalate ", " . map (review pseudonymText))
|
||||
|
||||
getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
|
||||
getCorrectionsGradeR = postCorrectionsGradeR
|
||||
postCorrectionsGradeR = do
|
||||
uid <- requireAuthId
|
||||
let whereClause = ratedBy uid
|
||||
displayColumns = mconcat -- should match getSSubsR for consistent UX
|
||||
[ dbRow
|
||||
, colTerm
|
||||
, colCourse
|
||||
, colSheet
|
||||
, colPseudonyms
|
||||
, colSubmissionLink
|
||||
, colRated
|
||||
, colPointsField
|
||||
, colCommentField
|
||||
] -- Continue here
|
||||
psValidator = def
|
||||
& defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), Maybe Text)))
|
||||
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } -> (bool (Right <$> submissionRatingPoints) (Just . Left $ isJust submissionRatingPoints) $ sheetType == NotGraded, submissionRatingComment)
|
||||
|
||||
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
|
||||
cID <- encrypt subId
|
||||
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
|
||||
return i
|
||||
(((fmap unFormResult -> tableRes), table), tableEncoding) <- runFormPost tableForm
|
||||
|
||||
case tableRes of
|
||||
FormMissing -> return ()
|
||||
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
||||
FormSuccess resMap -> do
|
||||
now <- liftIO getCurrentTime
|
||||
subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (mPoints, mComment)) -> do
|
||||
let mPoints' = either (bool Nothing $ return 0) return =<< mPoints
|
||||
Submission{..} <- get404 subId
|
||||
if
|
||||
| submissionRatingPoints /= mPoints' || submissionRatingComment /= mComment
|
||||
-> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints'
|
||||
, SubmissionRatingComment =. mComment
|
||||
, SubmissionRatingBy =. Just uid
|
||||
, SubmissionRatingTime =. now <$ (void mPoints' <|> void mComment)
|
||||
]
|
||||
| otherwise -> return $ Nothing
|
||||
subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission]
|
||||
unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet")
|
||||
|
||||
defaultLayout $ do
|
||||
$(widgetFile "corrections-grade")
|
||||
|
||||
@ -117,10 +117,10 @@ homeAnonymous = do
|
||||
, dbtStyle = def
|
||||
, dbtIdent = "upcomingdeadlines" :: Text
|
||||
}
|
||||
let features = $(widgetFile "featureList")
|
||||
addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
|
||||
-- let features = $(widgetFile "featureList")
|
||||
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
|
||||
defaultLayout $ do
|
||||
$(widgetFile "dsgvDisclaimer")
|
||||
-- $(widgetFile "dsgvDisclaimer")
|
||||
$(widgetFile "home")
|
||||
|
||||
homeUser :: Key User -> Handler Html
|
||||
@ -218,11 +218,11 @@ homeUser uid = do
|
||||
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
|
||||
, dbtIdent = "upcomingdeadlines" :: Text
|
||||
}
|
||||
addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
|
||||
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
|
||||
defaultLayout $ do
|
||||
-- setTitle "Willkommen zum Uni2work Test!"
|
||||
$(widgetFile "homeUser")
|
||||
$(widgetFile "dsgvDisclaimer")
|
||||
-- $(widgetFile "dsgvDisclaimer")
|
||||
|
||||
|
||||
getVersionR :: Handler TypedContent
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -35,7 +35,7 @@ module Handler.Utils.Table.Pagination
|
||||
, widgetColonnade, formColonnade, dbColonnade
|
||||
, cell, textCell, stringCell, i18nCell
|
||||
, anchorCell, anchorCell', anchorCellM, anchorCellM'
|
||||
, tickmarkCell
|
||||
, tickmarkCell, cellTooltip
|
||||
, listCell
|
||||
, formCell, DBFormResult, getDBFormResult
|
||||
, dbRow, dbSelect
|
||||
@ -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))
|
||||
@ -499,6 +499,15 @@ tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
|
||||
tickmarkCell True = textCell (tickmark :: Text)
|
||||
tickmarkCell False = mempty
|
||||
|
||||
cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
|
||||
cellTooltip msg cell = cell & cellContents.mapped %~ (<> tipWdgt)
|
||||
where
|
||||
tipWdgt = [whamlet|
|
||||
<div .js-tooltip>
|
||||
<div .tooltip__handle>
|
||||
<div .tooltip__content>_{msg}
|
||||
|]
|
||||
|
||||
|
||||
anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
|
||||
anchorCell = anchorCellM . return
|
||||
|
||||
@ -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
|
||||
@ -37,3 +38,10 @@ import GHC.Generics as Import (Generic)
|
||||
|
||||
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
|
||||
|
||||
282
src/Jobs.hs
282
src/Jobs.hs
@ -14,19 +14,17 @@
|
||||
|
||||
module Jobs
|
||||
( module Types
|
||||
, writeJobCtl
|
||||
, queueJob, queueJob'
|
||||
, YesodJobDB
|
||||
, runDBJobs, queueDBJob
|
||||
, module Jobs.Queue
|
||||
, handleJobs
|
||||
) where
|
||||
|
||||
import Import hiding ((.=), Proxy)
|
||||
import Handler.Utils.Mail
|
||||
import Handler.Utils.DateTime
|
||||
import Import hiding (Proxy)
|
||||
|
||||
import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
|
||||
import Jobs.Types (JobCtl(JobCtlQueue))
|
||||
import Jobs.Queue
|
||||
import Jobs.TH
|
||||
import Jobs.Crontab
|
||||
|
||||
import Data.Conduit.TMChan
|
||||
import qualified Data.Conduit.List as C
|
||||
@ -36,40 +34,25 @@ import qualified Data.Text.Lazy as LT
|
||||
import Data.Aeson (fromJSON, toJSON)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Database.Persist.Sql (executeQQ, fromSqlKey, transactionSave)
|
||||
import Database.Persist.Sql (fromSqlKey)
|
||||
|
||||
import Data.Monoid (Last(..))
|
||||
import Data.Semigroup (Max(..))
|
||||
import Data.Bitraversable
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Sql
|
||||
|
||||
import Control.Monad.Random (evalRand, uniform, mkStdGen)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Text.Shakespeare.Text
|
||||
import Text.Hamlet
|
||||
import Control.Monad.Random (evalRand, mkStdGen)
|
||||
|
||||
import Cron
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
import Data.Foldable (foldrM)
|
||||
|
||||
import Control.Monad.Trans.Reader (mapReaderT)
|
||||
import Control.Monad.Trans.Writer (WriterT(..), execWriterT)
|
||||
import Control.Monad.Trans.State (StateT, evalStateT, mapStateT)
|
||||
import qualified Control.Monad.State.Class as State
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import Control.Monad.Reader.Class (MonadReader(..))
|
||||
import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
@ -82,6 +65,13 @@ import Data.Time.Zones
|
||||
|
||||
import Control.Concurrent.STM (retry)
|
||||
|
||||
|
||||
import Jobs.Handler.SendNotification
|
||||
import Jobs.Handler.SendTestEmail
|
||||
import Jobs.Handler.QueueNotification
|
||||
import Jobs.Handler.HelpRequest
|
||||
import Jobs.Handler.SetLogSettings
|
||||
|
||||
|
||||
data JobQueueException = JInvalid QueuedJobId QueuedJob
|
||||
| JLocked QueuedJobId InstanceId UTCTime
|
||||
@ -105,7 +95,7 @@ handleJobs recvChans foundation@UniWorX{..} = do
|
||||
logStart = $logDebugS ("Jobs #" <> tshow n) "Starting"
|
||||
logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping"
|
||||
doFork = fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n
|
||||
in void $ allocate (liftIO doFork) (liftIO . killThread)
|
||||
in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
|
||||
|
||||
-- Start cron operation
|
||||
void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread)
|
||||
@ -135,9 +125,8 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
|
||||
Just (_, MatchNone) -> liftBase retry
|
||||
Just x -> return (crontab, x)
|
||||
|
||||
let doJob = do
|
||||
mJid <- mapStateT (mapReaderT $ liftHandlerT . runDB . setSerializable) $ do
|
||||
newCrontab <- lift . lift $ determineCrontab
|
||||
let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
|
||||
newCrontab <- lift . lift . hoist lift $ determineCrontab'
|
||||
if
|
||||
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
|
||||
-> do
|
||||
@ -154,12 +143,11 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
|
||||
, cronLastExecInstance = instanceID
|
||||
}
|
||||
[ CronLastExecTime =. now ]
|
||||
Just <$> lift (lift $ queueJobUnsafe job)
|
||||
other -> Nothing <$ writeJobCtl other
|
||||
lift . lift $ queueDBJob job
|
||||
other -> writeJobCtl other
|
||||
| otherwise
|
||||
-> lift . fmap (const Nothing) . mapReaderT (liftIO . atomically) $
|
||||
-> lift . mapReaderT (liftIO . atomically) $
|
||||
lift . flip writeTVar newCrontab =<< asks jobCrontab
|
||||
maybe (return ()) (writeJobCtl . JobCtlPerform) mJid
|
||||
|
||||
case nextMatch of
|
||||
MatchAsap -> doJob
|
||||
@ -252,7 +240,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
|
||||
-- `performJob` is expected to throw an exception if it detects that the job was not done
|
||||
runDB $ delete jId
|
||||
handleCmd JobCtlDetermineCrontab = do
|
||||
newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab
|
||||
newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
|
||||
-- $logDebugS logIdent $ tshow newCTab
|
||||
mapReaderT (liftIO . atomically) $
|
||||
lift . flip writeTVar newCTab =<< asks jobCrontab
|
||||
@ -292,57 +280,6 @@ jLocked jId act = do
|
||||
|
||||
bracket lock (const unlock) act
|
||||
|
||||
writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
|
||||
writeJobCtl cmd = do
|
||||
tid <- liftIO myThreadId
|
||||
chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl
|
||||
liftIO . atomically $ writeTMChan chan cmd
|
||||
|
||||
writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
|
||||
writeJobCtlBlock cmd = do
|
||||
getResVar <- asks jobConfirm
|
||||
resVar <- liftIO . atomically $ do
|
||||
var <- newEmptyTMVar
|
||||
modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var)
|
||||
return var
|
||||
lift $ writeJobCtl cmd
|
||||
let
|
||||
removeResVar = HashMap.update (nonEmpty . NonEmpty.filter (/= resVar)) cmd
|
||||
mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar
|
||||
maybe (return ()) throwM mExc
|
||||
|
||||
queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId
|
||||
queueJobUnsafe job = do
|
||||
now <- liftIO getCurrentTime
|
||||
self <- getsYesod appInstanceID
|
||||
insert QueuedJob
|
||||
{ queuedJobContent = toJSON job
|
||||
, queuedJobCreationInstance = self
|
||||
, queuedJobCreationTime = now
|
||||
, queuedJobLockInstance = Nothing
|
||||
, queuedJobLockTime = Nothing
|
||||
}
|
||||
-- We should not immediately notify a worker; instead wait for the transaction to finish first
|
||||
-- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
|
||||
-- return jId
|
||||
|
||||
queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
|
||||
queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
|
||||
|
||||
queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
|
||||
-- ^ `queueJob` followed by `JobCtlPerform`
|
||||
queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
|
||||
|
||||
type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
|
||||
|
||||
queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
|
||||
queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
|
||||
|
||||
runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
|
||||
runDBJobs act = do
|
||||
(ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
|
||||
forM_ jIds $ writeJobCtl . JobCtlPerform
|
||||
return ret
|
||||
|
||||
pruneLastExecs :: Crontab JobCtl -> DB ()
|
||||
pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab
|
||||
@ -352,181 +289,10 @@ pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCronta
|
||||
, HashMap.member (JobCtlQueue job) crontab
|
||||
= return ()
|
||||
| otherwise = delete leId
|
||||
|
||||
|
||||
determineCrontab :: DB (Crontab JobCtl)
|
||||
-- ^ Extract all future jobs from the database (sheet deadlines, ...)
|
||||
determineCrontab = (\ct -> ct <$ pruneLastExecs ct) <=< execWriterT $ do
|
||||
AppSettings{..} <- getsYesod appSettings
|
||||
|
||||
case appJobFlushInterval of
|
||||
Just interval -> tell $ HashMap.singleton
|
||||
JobCtlFlush
|
||||
Cron
|
||||
{ cronInitial = CronAsap
|
||||
, cronRepeat = CronRepeatScheduled CronAsap
|
||||
, cronRateLimit = interval
|
||||
}
|
||||
Nothing -> return ()
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
tell $ HashMap.singleton
|
||||
JobCtlDetermineCrontab
|
||||
Cron
|
||||
{ cronInitial = CronAsap
|
||||
, cronRepeat = CronRepeatScheduled CronAsap
|
||||
, cronRateLimit = appJobCronInterval
|
||||
}
|
||||
|
||||
let
|
||||
sheetJobs (Entity nSheet Sheet{..}) = do
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom
|
||||
, cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
}
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
|
||||
, cronRepeat = CronRepeatOnChange
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
}
|
||||
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
|
||||
|
||||
|
||||
determineNotificationCandidates :: Notification -> DB [Entity User]
|
||||
determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
|
||||
return user
|
||||
determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
|
||||
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
||||
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
||||
return user
|
||||
determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
|
||||
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
||||
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
||||
return user
|
||||
|
||||
classifyNotification :: Notification -> DB NotificationTrigger
|
||||
classifyNotification NotificationSubmissionRated{..} = do
|
||||
Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission
|
||||
return $ case sheetType of
|
||||
NotGraded -> NTSubmissionRated
|
||||
_other -> NTSubmissionRatedGraded
|
||||
classifyNotification NotificationSheetActive{} = return NTSheetActive
|
||||
classifyNotification NotificationSheetInactive{} = return NTSheetInactive
|
||||
determineCrontab' :: DB (Crontab JobCtl)
|
||||
determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab
|
||||
|
||||
|
||||
performJob :: Job -> HandlerT UniWorX IO ()
|
||||
performJob JobQueueNotification{jNotification} = do
|
||||
jIds <- runDB. setSerializable $ do
|
||||
candidates <- determineNotificationCandidates jNotification
|
||||
nClass <- classifyNotification jNotification
|
||||
mapM (queueJobUnsafe . flip JobSendNotification jNotification) $ do
|
||||
Entity uid User{userNotificationSettings} <- candidates
|
||||
guard $ notificationAllowed userNotificationSettings nClass
|
||||
return uid
|
||||
forM_ jIds $ writeJobCtl . JobCtlPerform
|
||||
performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, jRecipient } = userMailT jRecipient $ do
|
||||
(Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do
|
||||
submission@Submission{submissionRatingBy} <- getJust nSubmission
|
||||
sheet <- belongsToJust submissionSheet submission
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
corrector <- traverse getJust submissionRatingBy
|
||||
return (course, sheet, submission, corrector)
|
||||
setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
|
||||
|
||||
csid <- encrypt nSubmission
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||
submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime
|
||||
let tid = courseTerm
|
||||
ssh = courseSchool
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
-- TODO: provide convienience template-haskell for `addAlternatives`
|
||||
addAlternatives $ do
|
||||
provideAlternative $ Aeson.object
|
||||
[ "submission" Aeson..= ciphertext csid
|
||||
, "submission-rating-points" Aeson..= (guard (sheetType /= NotGraded) *> submissionRatingPoints)
|
||||
, "submission-rating-comment" Aeson..= submissionRatingComment
|
||||
, "submission-rating-time" Aeson..= submissionRatingTime
|
||||
, "submission-rating-by" Aeson..= (userDisplayName <$> corrector)
|
||||
, "submission-rating-passed" Aeson..= ((>=) <$> submissionRatingPoints <*> preview _passingPoints sheetType)
|
||||
, "sheet-name" Aeson..= sheetName
|
||||
, "sheet-type" Aeson..= sheetType
|
||||
, "course-name" Aeson..= courseName
|
||||
, "course-shorthand" Aeson..= courseShorthand
|
||||
, "course-term" Aeson..= courseTerm
|
||||
, "course-school" Aeson..= courseSchool
|
||||
]
|
||||
-- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
performJob JobSendNotification{ jNotification = NotificationSheetActive{..}, jRecipient } = userMailT jRecipient $ do
|
||||
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
|
||||
sheet <- getJust nSheet
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
return (course, sheet)
|
||||
setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
|
||||
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||
tid = courseTerm
|
||||
ssh = courseSchool
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
addAlternatives $ do
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
performJob JobSendNotification{ jNotification = NotificationSheetInactive{..}, jRecipient } = userMailT jRecipient $ do
|
||||
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
|
||||
sheet <- getJust nSheet
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
return (course, sheet)
|
||||
setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName
|
||||
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||
tid = courseTerm
|
||||
ssh = courseSchool
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
addAlternatives $ do
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
performJob JobSendTestEmail{..} = mailT jMailContext $ do
|
||||
_mailTo .= [Address Nothing jEmail]
|
||||
setSubjectI MsgMailTestSubject
|
||||
now <- liftIO getCurrentTime
|
||||
nDT <- formatTimeMail SelFormatDateTime now
|
||||
nD <- formatTimeMail SelFormatDate now
|
||||
nT <- formatTimeMail SelFormatTime now
|
||||
addPart $ \(MsgRenderer mr) -> ([text|
|
||||
#{mr MsgMailTestContent}
|
||||
|
||||
#{mr MsgMailTestDateTime}
|
||||
* #{nDT}
|
||||
* #{nD}
|
||||
* #{nT}
|
||||
|] :: TextUrl (Route UniWorX))
|
||||
performJob JobHelpRequest{..} = do
|
||||
supportAddress <- getsYesod $ appMailSupport . appSettings
|
||||
userInfo <- bitraverse return (runDB . getEntity) jSender
|
||||
let userAddress = either (fmap $ Address Nothing)
|
||||
(fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
|
||||
userInfo
|
||||
mailT def $ do
|
||||
_mailTo .= [supportAddress]
|
||||
whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress
|
||||
setSubjectI MsgMailSubjectSupport
|
||||
setDate jRequestTime
|
||||
rtime <- formatTimeMail SelFormatDateTime jRequestTime
|
||||
addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
|
||||
performJob = $(dispatchTH ''Job)
|
||||
|
||||
63
src/Jobs/Crontab.hs
Normal file
63
src/Jobs/Crontab.hs
Normal file
@ -0,0 +1,63 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, RecordWildCards
|
||||
, FlexibleContexts
|
||||
#-}
|
||||
|
||||
module Jobs.Crontab
|
||||
( determineCrontab
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Jobs.Types
|
||||
|
||||
import Data.Time
|
||||
import Data.Time.Zones
|
||||
|
||||
import Control.Monad.Trans.Writer (execWriterT)
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
|
||||
determineCrontab :: DB (Crontab JobCtl)
|
||||
-- ^ Extract all future jobs from the database (sheet deadlines, ...)
|
||||
determineCrontab = execWriterT $ do
|
||||
AppSettings{..} <- getsYesod appSettings
|
||||
|
||||
case appJobFlushInterval of
|
||||
Just interval -> tell $ HashMap.singleton
|
||||
JobCtlFlush
|
||||
Cron
|
||||
{ cronInitial = CronAsap
|
||||
, cronRepeat = CronRepeatScheduled CronAsap
|
||||
, cronRateLimit = interval
|
||||
}
|
||||
Nothing -> return ()
|
||||
|
||||
tell $ HashMap.singleton
|
||||
JobCtlDetermineCrontab
|
||||
Cron
|
||||
{ cronInitial = CronAsap
|
||||
, cronRepeat = CronRepeatScheduled CronAsap
|
||||
, cronRateLimit = appJobCronInterval
|
||||
}
|
||||
|
||||
let
|
||||
sheetJobs (Entity nSheet Sheet{..}) = do
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom
|
||||
, cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
}
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
|
||||
, cronRepeat = CronRepeatOnChange
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
}
|
||||
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
|
||||
40
src/Jobs/Handler/HelpRequest.hs
Normal file
40
src/Jobs/Handler/HelpRequest.hs
Normal file
@ -0,0 +1,40 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, TemplateHaskell
|
||||
, RecordWildCards
|
||||
, OverloadedStrings
|
||||
#-}
|
||||
|
||||
module Jobs.Handler.HelpRequest
|
||||
( dispatchJobHelpRequest
|
||||
) where
|
||||
|
||||
import Import hiding ((.=))
|
||||
|
||||
import Text.Hamlet
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Bitraversable
|
||||
|
||||
|
||||
dispatchJobHelpRequest :: Either (Maybe Email) UserId
|
||||
-> UTCTime
|
||||
-> Text -- ^ Help Request
|
||||
-> Maybe Text -- ^ Referer
|
||||
-> Handler ()
|
||||
dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
|
||||
supportAddress <- getsYesod $ appMailSupport . appSettings
|
||||
userInfo <- bitraverse return (runDB . getEntity) jSender
|
||||
let userAddress = either (fmap $ Address Nothing)
|
||||
(fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
|
||||
userInfo
|
||||
mailT def $ do
|
||||
_mailTo .= [supportAddress]
|
||||
whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress
|
||||
setSubjectI MsgMailSubjectSupport
|
||||
setDate jRequestTime
|
||||
rtime <- formatTimeMail SelFormatDateTime jRequestTime
|
||||
addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
54
src/Jobs/Handler/QueueNotification.hs
Normal file
54
src/Jobs/Handler/QueueNotification.hs
Normal file
@ -0,0 +1,54 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, RecordWildCards
|
||||
, NamedFieldPuns
|
||||
#-}
|
||||
|
||||
module Jobs.Handler.QueueNotification
|
||||
( dispatchJobQueueNotification
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Jobs.Types
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Utils.Sql
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
dispatchJobQueueNotification :: Notification -> Handler ()
|
||||
dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
|
||||
candidates <- hoist lift $ determineNotificationCandidates jNotification
|
||||
nClass <- hoist lift $ classifyNotification jNotification
|
||||
mapM_ (queueDBJob . flip JobSendNotification jNotification) $ do
|
||||
Entity uid User{userNotificationSettings} <- candidates
|
||||
guard $ notificationAllowed userNotificationSettings nClass
|
||||
return uid
|
||||
|
||||
|
||||
determineNotificationCandidates :: Notification -> DB [Entity User]
|
||||
determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
|
||||
return user
|
||||
determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
|
||||
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
||||
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
||||
return user
|
||||
determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
|
||||
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
||||
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
||||
return user
|
||||
|
||||
classifyNotification :: Notification -> DB NotificationTrigger
|
||||
classifyNotification NotificationSubmissionRated{..} = do
|
||||
Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission
|
||||
return $ case sheetType of
|
||||
NotGraded -> NTSubmissionRated
|
||||
_other -> NTSubmissionRatedGraded
|
||||
classifyNotification NotificationSheetActive{} = return NTSheetActive
|
||||
classifyNotification NotificationSheetInactive{} = return NTSheetInactive
|
||||
|
||||
|
||||
21
src/Jobs/Handler/SendNotification.hs
Normal file
21
src/Jobs/Handler/SendNotification.hs
Normal file
@ -0,0 +1,21 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, TemplateHaskell
|
||||
#-}
|
||||
|
||||
module Jobs.Handler.SendNotification
|
||||
( dispatchJobSendNotification
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Jobs.TH
|
||||
import Jobs.Types
|
||||
|
||||
|
||||
import Jobs.Handler.SendNotification.SubmissionRated
|
||||
import Jobs.Handler.SendNotification.SheetActive
|
||||
import Jobs.Handler.SendNotification.SheetInactive
|
||||
|
||||
|
||||
dispatchJobSendNotification :: UserId -> Notification -> Handler ()
|
||||
dispatchJobSendNotification jRecipient jNotification = $(dispatchTH ''Notification) jNotification jRecipient
|
||||
36
src/Jobs/Handler/SendNotification/SheetActive.hs
Normal file
36
src/Jobs/Handler/SendNotification/SheetActive.hs
Normal file
@ -0,0 +1,36 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, RecordWildCards
|
||||
, NamedFieldPuns
|
||||
, TemplateHaskell
|
||||
, OverloadedStrings
|
||||
#-}
|
||||
|
||||
module Jobs.Handler.SendNotification.SheetActive
|
||||
( dispatchNotificationSheetActive
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils.Mail
|
||||
|
||||
import Text.Hamlet
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
dispatchNotificationSheetActive :: SheetId -> UserId -> Handler ()
|
||||
dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
|
||||
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
|
||||
sheet <- getJust nSheet
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
return (course, sheet)
|
||||
setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
|
||||
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||
tid = courseTerm
|
||||
ssh = courseSchool
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
addAlternatives $ do
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
36
src/Jobs/Handler/SendNotification/SheetInactive.hs
Normal file
36
src/Jobs/Handler/SendNotification/SheetInactive.hs
Normal file
@ -0,0 +1,36 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, RecordWildCards
|
||||
, NamedFieldPuns
|
||||
, TemplateHaskell
|
||||
, OverloadedStrings
|
||||
#-}
|
||||
|
||||
module Jobs.Handler.SendNotification.SheetInactive
|
||||
( dispatchNotificationSheetInactive
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils.Mail
|
||||
|
||||
import Text.Hamlet
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
|
||||
dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
|
||||
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
|
||||
sheet <- getJust nSheet
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
return (course, sheet)
|
||||
setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName
|
||||
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||
tid = courseTerm
|
||||
ssh = courseSchool
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
addAlternatives $ do
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
58
src/Jobs/Handler/SendNotification/SubmissionRated.hs
Normal file
58
src/Jobs/Handler/SendNotification/SubmissionRated.hs
Normal file
@ -0,0 +1,58 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, RecordWildCards
|
||||
, NamedFieldPuns
|
||||
, TemplateHaskell
|
||||
, OverloadedStrings
|
||||
#-}
|
||||
|
||||
module Jobs.Handler.SendNotification.SubmissionRated
|
||||
( dispatchNotificationSubmissionRated
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.Mail
|
||||
|
||||
import Text.Hamlet
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler ()
|
||||
dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipient $ do
|
||||
(Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do
|
||||
submission@Submission{submissionRatingBy} <- getJust nSubmission
|
||||
sheet <- belongsToJust submissionSheet submission
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
corrector <- traverse getJust submissionRatingBy
|
||||
return (course, sheet, submission, corrector)
|
||||
setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
|
||||
|
||||
csid <- encrypt nSubmission
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||
submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime
|
||||
let tid = courseTerm
|
||||
ssh = courseSchool
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
-- TODO: provide convienience template-haskell for `addAlternatives`
|
||||
addAlternatives $ do
|
||||
provideAlternative $ Aeson.object
|
||||
[ "submission" Aeson..= ciphertext csid
|
||||
, "submission-rating-points" Aeson..= (guard (sheetType /= NotGraded) *> submissionRatingPoints)
|
||||
, "submission-rating-comment" Aeson..= submissionRatingComment
|
||||
, "submission-rating-time" Aeson..= submissionRatingTime
|
||||
, "submission-rating-by" Aeson..= (userDisplayName <$> corrector)
|
||||
, "submission-rating-passed" Aeson..= ((>=) <$> submissionRatingPoints <*> preview _passingPoints sheetType)
|
||||
, "sheet-name" Aeson..= sheetName
|
||||
, "sheet-type" Aeson..= sheetType
|
||||
, "course-name" Aeson..= courseName
|
||||
, "course-shorthand" Aeson..= courseShorthand
|
||||
, "course-term" Aeson..= courseTerm
|
||||
, "course-school" Aeson..= courseSchool
|
||||
]
|
||||
-- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
34
src/Jobs/Handler/SendTestEmail.hs
Normal file
34
src/Jobs/Handler/SendTestEmail.hs
Normal file
@ -0,0 +1,34 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, RecordWildCards
|
||||
, NamedFieldPuns
|
||||
, QuasiQuotes
|
||||
#-}
|
||||
|
||||
module Jobs.Handler.SendTestEmail
|
||||
( dispatchJobSendTestEmail
|
||||
) where
|
||||
|
||||
import Import hiding ((.=))
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
import Text.Shakespeare.Text
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
|
||||
dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
|
||||
_mailTo .= [Address Nothing jEmail]
|
||||
setSubjectI MsgMailTestSubject
|
||||
now <- liftIO getCurrentTime
|
||||
nDT <- formatTimeMail SelFormatDateTime now
|
||||
nD <- formatTimeMail SelFormatDate now
|
||||
nT <- formatTimeMail SelFormatTime now
|
||||
addPart $ \(MsgRenderer mr) -> ([text|
|
||||
#{mr MsgMailTestContent}
|
||||
|
||||
#{mr MsgMailTestDateTime}
|
||||
* #{nDT}
|
||||
* #{nD}
|
||||
* #{nT}
|
||||
|] :: TextUrl (Route UniWorX))
|
||||
15
src/Jobs/Handler/SetLogSettings.hs
Normal file
15
src/Jobs/Handler/SetLogSettings.hs
Normal file
@ -0,0 +1,15 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
#-}
|
||||
|
||||
module Jobs.Handler.SetLogSettings
|
||||
( dispatchJobSetLogSettings
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
dispatchJobSetLogSettings :: InstanceId -> LogSettings -> Handler ()
|
||||
dispatchJobSetLogSettings jInstance jLogSettings = do
|
||||
instanceId <- getsYesod appInstanceID
|
||||
unless (instanceId == jInstance) $ fail "Incorrect instance"
|
||||
lSettings <- getsYesod appLogSettings
|
||||
atomically $ writeTVar lSettings jLogSettings
|
||||
81
src/Jobs/Queue.hs
Normal file
81
src/Jobs/Queue.hs
Normal file
@ -0,0 +1,81 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, TypeFamilies
|
||||
#-}
|
||||
|
||||
module Jobs.Queue
|
||||
( writeJobCtl, writeJobCtlBlock
|
||||
, queueJob, queueJob'
|
||||
, YesodJobDB
|
||||
, runDBJobs, queueDBJob
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Sql
|
||||
import Jobs.Types
|
||||
|
||||
import Control.Monad.Trans.Writer (WriterT, runWriterT)
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import Control.Monad.Trans.Reader (ReaderT, mapReaderT)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen, uniform)
|
||||
|
||||
|
||||
writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
|
||||
writeJobCtl cmd = do
|
||||
tid <- liftIO myThreadId
|
||||
chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl
|
||||
liftIO . atomically $ writeTMChan chan cmd
|
||||
|
||||
writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
|
||||
writeJobCtlBlock cmd = do
|
||||
getResVar <- asks jobConfirm
|
||||
resVar <- liftIO . atomically $ do
|
||||
var <- newEmptyTMVar
|
||||
modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var)
|
||||
return var
|
||||
lift $ writeJobCtl cmd
|
||||
let
|
||||
removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd
|
||||
mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar
|
||||
maybe (return ()) throwM mExc
|
||||
|
||||
queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId
|
||||
queueJobUnsafe job = do
|
||||
now <- liftIO getCurrentTime
|
||||
self <- getsYesod appInstanceID
|
||||
insert QueuedJob
|
||||
{ queuedJobContent = toJSON job
|
||||
, queuedJobCreationInstance = self
|
||||
, queuedJobCreationTime = now
|
||||
, queuedJobLockInstance = Nothing
|
||||
, queuedJobLockTime = Nothing
|
||||
}
|
||||
-- We should not immediately notify a worker; instead wait for the transaction to finish first
|
||||
-- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
|
||||
-- return jId
|
||||
|
||||
queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
|
||||
queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
|
||||
|
||||
queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
|
||||
-- ^ `queueJob` followed by `JobCtlPerform`
|
||||
queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
|
||||
|
||||
type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
|
||||
|
||||
queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
|
||||
queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
|
||||
|
||||
runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
|
||||
runDBJobs act = do
|
||||
(ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
|
||||
forM_ jIds $ writeJobCtl . JobCtlPerform
|
||||
return ret
|
||||
|
||||
|
||||
|
||||
29
src/Jobs/TH.hs
Normal file
29
src/Jobs/TH.hs
Normal file
@ -0,0 +1,29 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, TemplateHaskell
|
||||
, QuasiQuotes
|
||||
, RecordWildCards
|
||||
#-}
|
||||
|
||||
module Jobs.TH
|
||||
( dispatchTH
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Datatype
|
||||
|
||||
import Data.List (foldl)
|
||||
|
||||
|
||||
dispatchTH :: Name -- ^ Datatype to pattern match
|
||||
-> ExpQ
|
||||
dispatchTH dType = do
|
||||
DatatypeInfo{..} <- reifyDatatype dType
|
||||
let
|
||||
matches = map mkMatch datatypeCons
|
||||
mkMatch ConstructorInfo{..} = do
|
||||
pats <- forM constructorFields $ \_ -> newName "x"
|
||||
let fName = mkName $ "dispatch" <> nameBase constructorName
|
||||
match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
|
||||
lamCaseE matches
|
||||
@ -24,6 +24,7 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
|
||||
| JobHelpRequest { jSender :: Either (Maybe Email) UserId
|
||||
, jRequestTime :: UTCTime
|
||||
, jHelpRequest :: Text, jReferer :: Maybe Text }
|
||||
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
| NotificationSheetActive { nSheet :: SheetId }
|
||||
|
||||
@ -6,6 +6,7 @@
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
-- | Settings are centralized, as much as possible, into this file. This
|
||||
@ -89,10 +90,8 @@ data AppSettings = AppSettings
|
||||
, appJobStaleThreshold :: NominalDiffTime
|
||||
, appNotificationRateLimit :: NominalDiffTime
|
||||
|
||||
, appDetailedRequestLogging :: Bool
|
||||
-- ^ Use detailed request logging system
|
||||
, appShouldLogAll :: Bool
|
||||
-- ^ Should all log messages be displayed?
|
||||
, appInitialLogSettings :: LogSettings
|
||||
|
||||
, appReloadTemplates :: Bool
|
||||
-- ^ Use the reload version of templates
|
||||
, appMutableStatic :: Bool
|
||||
@ -103,7 +102,6 @@ data AppSettings = AppSettings
|
||||
-- ^ Indicate if auth dummy login should be enabled.
|
||||
, appAllowDeprecated :: Bool
|
||||
-- ^ Indicate if deprecated routes are accessible for everyone
|
||||
, appMinimumLogLevel :: LogLevel
|
||||
|
||||
, appUserDefaults :: UserDefaultConf
|
||||
, appAuthPWHash :: PWHashConf
|
||||
@ -111,7 +109,16 @@ data AppSettings = AppSettings
|
||||
, appCryptoIDKeyFile :: FilePath
|
||||
, appInstanceIDFile :: Maybe FilePath
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
data LogSettings = LogSettings
|
||||
{ logAll, logDetailed :: Bool
|
||||
, logMinimumLevel :: LogLevel
|
||||
} deriving (Show, Read, Generic, Eq, Ord)
|
||||
|
||||
deriving instance Generic LogLevel
|
||||
instance Hashable LogLevel
|
||||
instance Hashable LogSettings
|
||||
|
||||
data UserDefaultConf = UserDefaultConf
|
||||
{ userDefaultTheme :: Theme
|
||||
, userDefaultMaxFavourites :: Int
|
||||
@ -169,6 +176,10 @@ data SmtpAuthConf = SmtpAuthConf
|
||||
, smtpAuthPassword :: HaskellNet.Password
|
||||
} deriving (Show)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = intercalate "-" . map toLower . splitCamel
|
||||
} ''LogSettings
|
||||
|
||||
deriveFromJSON defaultOptions ''Ldap.Scope
|
||||
deriveFromJSON defaultOptions
|
||||
{ fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
|
||||
@ -199,7 +210,7 @@ deriveFromJSON
|
||||
}
|
||||
''ResourcePoolConf
|
||||
|
||||
deriveFromJSON
|
||||
deriveJSON
|
||||
defaultOptions
|
||||
{ constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
|
||||
, sumEncoding = UntaggedValue
|
||||
@ -283,15 +294,14 @@ instance FromJSON AppSettings where
|
||||
appJobStaleThreshold <- o .: "job-stale-threshold"
|
||||
appNotificationRateLimit <- o .: "notification-rate-limit"
|
||||
|
||||
appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
|
||||
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
|
||||
appMinimumLogLevel <- o .: "minimum-log-level"
|
||||
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
|
||||
appMutableStatic <- o .:? "mutable-static" .!= defaultDev
|
||||
appSkipCombining <- o .:? "skip-combining" .!= defaultDev
|
||||
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
|
||||
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
|
||||
|
||||
appInitialLogSettings <- o .: "log-settings"
|
||||
|
||||
appUserDefaults <- o .: "user-defaults"
|
||||
appAuthPWHash <- o .: "auth-pw-hash"
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -32,6 +32,7 @@ setSerializable act = setSerializable' (0 :: Integer)
|
||||
delay :: NominalDiffTime
|
||||
delay = 1e-3 * 2 ^ logBackoff
|
||||
$logWarnS "Sql" $ tshow (delay, e)
|
||||
transactionUndo
|
||||
threadDelay . round $ delay * 1e6
|
||||
setSerializable' (succ logBackoff)
|
||||
)
|
||||
|
||||
@ -5,7 +5,6 @@
|
||||
module Utils.SystemMessage where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Utils
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.List (findIndex)
|
||||
|
||||
37
src/index.md
37
src/index.md
@ -103,6 +103,43 @@ Jobs
|
||||
|
||||
Jobs.Types
|
||||
: `Job`, `Notification`, `JobCtl` Types of Jobs
|
||||
|
||||
Cron.Types
|
||||
: Datentypen zur Spezifikation von Intervallen zu denen Jobs ausgeführt werden
|
||||
können:
|
||||
|
||||
`Cron`, `CronMatch`, `CronAbsolute`, `CronRepeat`, `Crontab`
|
||||
|
||||
Cron
|
||||
: Seiteneffektfreie Berechnungen auf Typen aus `Cron.Types`: `nextCronMatch`
|
||||
|
||||
Jobs.Queue
|
||||
: Funktionen zum _anstoßen_ von Jobs und zur Kommunikation mit den
|
||||
Worker-Threads
|
||||
|
||||
`writeJobCtl` schickt Nachricht an einen pseudo-Zufälligen worker-thread der
|
||||
lokalen Instanz
|
||||
|
||||
`queueJob` und `queueJob'` schreiben neue Jobs in die Instanz-übergreifende
|
||||
Job-Queue, `queueJob'` stößt außerdem einen lokalen worker-thread an sich
|
||||
des Jobs anzunehmen
|
||||
|
||||
`runDBJobs` ersetzt `runDB` und erlaubt `queueDBJob` zu
|
||||
benutzen. `queueDBJob` schreibt einen Job in die Queue; am Ende stößt
|
||||
`runDBJobs` lokale worker-threads für alle mit `queueDBJobs` eingetragenen
|
||||
Jobs an.
|
||||
|
||||
Jobs.TH
|
||||
: Templatehaskell für den dispatch mechanismus für `Jobs`
|
||||
|
||||
Jobs.Crontab
|
||||
: Generiert `Crontab JobCtl` aus der Datenbank (sammelt alle in den Daten aus
|
||||
der Datenbank impliziten Jobs (notifications zu bestimmten zeiten,
|
||||
aufräumaktionen, ...) ein)
|
||||
|
||||
Jobs.Handler.**
|
||||
: Via `Jobs.TH` delegiert `Jobs` das Interpretieren und Ausführen eines Werts
|
||||
aus `Jobs.Types` an einen dieser Handler
|
||||
|
||||
Mail
|
||||
: Monadically constructing MIME emails
|
||||
|
||||
1
start.sh
1
start.sh
@ -3,6 +3,7 @@
|
||||
unset HOST
|
||||
export DETAILED_LOGGING=true
|
||||
export LOG_ALL=true
|
||||
export LOGLEVEL=info
|
||||
export DUMMY_LOGIN=true
|
||||
export ALLOW_DEPRECATED=true
|
||||
export PWFILE=users.yml
|
||||
|
||||
5
templates/corrections-grade.hamlet
Normal file
5
templates/corrections-grade.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
<div .container>
|
||||
<form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}>
|
||||
^{table}
|
||||
<button type=submit>
|
||||
_{MsgBtnSubmit}
|
||||
@ -1,5 +1,4 @@
|
||||
|
||||
Bitte beschreiben Sie Ihr Problem:
|
||||
_{MsgHelpIntroduction}
|
||||
|
||||
<form method=post action=@{HelpR} enctype=#{formEnctype}>
|
||||
^{formWidget}
|
||||
|
||||
@ -1,11 +1,5 @@
|
||||
<div .container>
|
||||
|
||||
<h1>
|
||||
<h2>
|
||||
Kurse mit offener Registrierung
|
||||
<div .container>
|
||||
^{courseTable}
|
||||
|
||||
<h3>
|
||||
Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
|
||||
|
||||
^{features}
|
||||
|
||||
@ -1,13 +1,10 @@
|
||||
<div .container>
|
||||
<h3>
|
||||
Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
|
||||
|
||||
<div .container>
|
||||
<h1>
|
||||
<h2>
|
||||
Anstehende Übungsblätter
|
||||
<div .container>
|
||||
^{sheetTable}
|
||||
|
||||
<!--
|
||||
<div .container>
|
||||
<h1>
|
||||
Anstehende Klausuren
|
||||
@ -17,3 +14,4 @@
|
||||
<h1>
|
||||
Anstehende Kursanmeldungen
|
||||
TODO
|
||||
-->
|
||||
|
||||
@ -25,5 +25,5 @@ $newline never
|
||||
<dd> #{lang}
|
||||
<dt> Zeit
|
||||
<dd> #{rtime}
|
||||
<p>
|
||||
<p style="white-space: pre">
|
||||
#{jHelpRequest}
|
||||
|
||||
6
templates/messages/systemMessagesDeleted.hamlet
Normal file
6
templates/messages/systemMessagesDeleted.hamlet
Normal file
@ -0,0 +1,6 @@
|
||||
_{MsgSystemMessagesDeleted}
|
||||
|
||||
<ul>
|
||||
$forall sel <- selection
|
||||
<li style="white-space: nowrap">
|
||||
#{toPathPiece sel}
|
||||
6
templates/messages/systemMessagesSetFrom.hamlet
Normal file
6
templates/messages/systemMessagesSetFrom.hamlet
Normal file
@ -0,0 +1,6 @@
|
||||
_{MsgSystemMessagesActivated}
|
||||
|
||||
<ul>
|
||||
$forall sel <- selection
|
||||
<li style="white-space: nowrap">
|
||||
#{toPathPiece sel}
|
||||
6
templates/messages/systemMessagesSetTo.hamlet
Normal file
6
templates/messages/systemMessagesSetTo.hamlet
Normal file
@ -0,0 +1,6 @@
|
||||
_{MsgSystemMessagesDeactivated}
|
||||
|
||||
<ul>
|
||||
$forall sel <- selection
|
||||
<li style="white-space: nowrap">
|
||||
#{toPathPiece sel}
|
||||
@ -16,11 +16,13 @@
|
||||
overflow: auto;
|
||||
opacity: 0;
|
||||
transition: all .15s ease;
|
||||
pointer-events: none;
|
||||
|
||||
&.modal--open {
|
||||
opacity: 1;
|
||||
z-index: 200;
|
||||
transform: translate(-50%, -50%) scale(1, 1);
|
||||
pointer-events: all;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -13,7 +13,7 @@ $maybe cID <- mcid
|
||||
<p>
|
||||
_{MsgSubmissionNoUploadExpected}
|
||||
|
||||
$if not (null lastEdits)
|
||||
$if maySubmit && not (null lastEdits)
|
||||
<h3>_{MsgLastEdits}
|
||||
<ul>
|
||||
$forall (mbName,time) <- lastEdits
|
||||
|
||||
9
templates/system-message-list.hamlet
Normal file
9
templates/system-message-list.hamlet
Normal 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}
|
||||
@ -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}
|
||||
|
||||
@ -10,11 +10,11 @@
|
||||
Bekannte Bugs
|
||||
<ul>
|
||||
<li>
|
||||
Umlaute in Benutzernamen werden durch externes LDAP-Plugin entfernt
|
||||
Login ist u.U. anders als im alten System, z.B. <span style="font-family:monospace">@campus.lmu.de</span> statt <span style="font-family:monospace">@lmu.de</span>
|
||||
<li>
|
||||
Auswahlbox "alle markieren" fehlt noch
|
||||
Favicon ist default des Frameworks
|
||||
<li>
|
||||
Tabellen über mehrere Seiten müssen vor Seitenwechsel manuell sortiert werden
|
||||
Format von Bewertungsdateien ist provisorisch
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
@ -26,7 +26,7 @@
|
||||
<h2>
|
||||
Impressum
|
||||
|
||||
<ul>
|
||||
<ul style="list-style-type: none">
|
||||
<li>
|
||||
Dr Steffen Jost
|
||||
<li>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user