diff --git a/config/settings.yml b/config/settings.yml index 0d6855fa5..96e378b69 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 741370d07..0d3bea8b7 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -201,6 +201,7 @@ ProfileHeading: Benutzereinstellungen ProfileDataHeading: Gespeicherte Benutzerdaten ImpressumHeading: Impressum SystemMessageHeading: Uni2Work Statusmeldung +SystemMessageListHeading: Uni2Work Statusmeldungen NumCourses n@Int64: #{display n} Kurse CloseAlert: Schliessen @@ -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) \ No newline at end of file diff --git a/package.yaml b/package.yaml index 656ac5902..4a48ee43d 100644 --- a/package.yaml +++ b/package.yaml @@ -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. diff --git a/routes b/routes index dbe76f4d9..991318c6a 100644 --- a/routes +++ b/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 diff --git a/src/Application.hs b/src/Application.hs index c0a92d695..9ffcf2106 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 () diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 9f555ef3e..58f68171e 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -40,6 +40,7 @@ decCryptoIDs [ ''SubmissionId , ''UserId , ''SheetId , ''SystemMessageId + , ''SystemMessageTranslationId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Foundation.hs b/src/Foundation.hs index 29869d78a..b625042b6 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -85,7 +85,7 @@ import Utils.Form import Utils.Lens import Utils.SystemMessage -import Data.Aeson hiding (Error) +import Data.Aeson hiding (Error, Success) import Data.Aeson.TH import qualified Data.Yaml as Yaml @@ -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 _ diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 1db0c9b95..78ad460c8 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 2b3fce6d3..3ba5bab0a 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -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 diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 5558d7f32..5158e65f6 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -1,12 +1,39 @@ {-# LANGUAGE NoImplicitPrelude , RecordWildCards , TemplateHaskell + , NamedFieldPuns + , RecordWildCards + , OverloadedStrings + , TypeFamilies + , ViewPatterns + , FlexibleContexts + , LambdaCase + , MultiParamTypeClasses #-} module Handler.SystemMessage where import Import +import qualified Data.Map.Lazy as Map +import qualified Data.Text as Text + +import qualified Data.Set as Set + +import qualified Data.List.NonEmpty as NonEmpty + +import Handler.Utils + +import Utils.Lens + + +htmlField' :: Field (HandlerT UniWorX IO) Html +htmlField' = htmlField + { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis + } + + + getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html getMessageR = postMessageR postMessageR cID = do @@ -15,5 +42,202 @@ postMessageR cID = do let (summary, content) = case translation of Nothing -> (systemMessageSummary, systemMessageContent) Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) + + let + mkForm :: Handler (((FormResult SystemMessage, Widget), Enctype), Map Lang ((FormResult (Entity SystemMessageTranslation, [Maybe BtnSubmitDelete]), Widget), Enctype), ((FormResult SystemMessageTranslation, Widget), Enctype)) + mkForm = do + modifyRes'@((modifyRes, _), _) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard + $ SystemMessage + <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom) + <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo) + <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly) + <*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity) + <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageDefaultLanguage) + <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageContent) + <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageSummary) + <* submitButton + + ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage] + let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts + + modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do + cID' <- encrypt tId + runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard + $ (,) + <$> ( fmap (Entity tId) $ SystemMessageTranslation + <$> pure systemMessageTranslationMessage + <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage) + <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent) + <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary) + ) + <*> combinedButtonField (universeF :: [BtnSubmitDelete]) + + let modifyTranss = Map.map (view $ _1._1) modifyTranss' + + addTransRes'@((addTransRes, _), _) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard + $ SystemMessageTranslation + <$> pure smId + <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing + <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing + <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing + <* submitButton + + formResult modifyRes $ \SystemMessage{..} -> do + runDB $ update smId + [ SystemMessageFrom =. systemMessageFrom + , SystemMessageTo =. systemMessageTo + , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly + , SystemMessageSeverity =. systemMessageSeverity + , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage + , SystemMessageContent =. systemMessageContent + , SystemMessageSummary =. systemMessageSummary + ] + addMessageI Success MsgSystemMessageEditSuccess + redirect $ MessageR cID + + formResult addTransRes $ \smt -> do + runDB . void . insert $ smt + addMessageI Success MsgSystemMessageAddTranslationSuccess + redirect $ MessageR cID + + forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, (catMaybes -> acts)) -> case acts of + [BtnDelete'] -> do + runDB $ delete tId + addMessageI Success MsgSystemMessageDeleteTranslationSuccess + redirect $ MessageR cID + _other -> do + runDB $ update tId + [ SystemMessageTranslationLanguage =. systemMessageTranslationLanguage + , SystemMessageTranslationContent =. systemMessageTranslationContent + , SystemMessageTranslationSummary =. systemMessageTranslationSummary + ] + addMessageI Success MsgSystemMessageEditTranslationSuccess + redirect $ MessageR cID + + return (modifyRes', modifyTranss', addTransRes') + + maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True + forms <- traverse (const mkForm) $ () <$ guard maySubmit + defaultLayout $ do $(widgetFile "system-message") + + +type MessageListData = DBRow (Entity SystemMessage, Maybe SystemMessageTranslation) + +data ActionSystemMessage = SMDelete | SMActivate | SMDeactivate + deriving (Eq, Ord, Enum, Bounded, Show, Read) +instance Universe ActionSystemMessage +instance Finite ActionSystemMessage +$(return []) +instance PathPiece ActionSystemMessage where + toPathPiece = $(nullaryToPathPiece ''ActionSystemMessage [ Text.intercalate "-" . drop 1 . splitCamel ]) + fromPathPiece = finiteFromPathPiece + +instance RenderMessage UniWorX ActionSystemMessage where + renderMessage m ls = renderMessage m ls . \case + SMDelete -> MsgSystemMessageDelete + SMActivate -> MsgSystemMessageActivate + SMDeactivate -> MsgSystemMessageDeactivate + +data ActionSystemMessageData = SMDDelete + | SMDActivate (Maybe UTCTime) + | SMDDeactivate (Maybe UTCTime) + deriving (Eq, Show, Read) + +getMessageListR, postMessageListR :: Handler Html +getMessageListR = postMessageListR +postMessageListR = do + let + dbtSQLQuery = return + dbtColonnade = mconcat + [ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId + , dbRow + , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) (\cID -> MessageR cID) (toWidget . tshow . ciphertext) + , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom + , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo + , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly + , sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity + , sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let + (summary, content) = case smT of + Nothing -> (systemMessageSummary, systemMessageContent) + Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) + in cell . toWidget $ fromMaybe content summary + ] + dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do + Just (_, smT) <- lift $ getSystemMessage appLanguages smId + return $ DBRow + { dbrOutput = (smE, smT) + , .. + } + psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool)) + tableForm <- dbTable psValidator $ DBTable + { dbtSQLQuery + , dbtColonnade + , dbtProj + , dbtSorting = Map.fromList + [ -- TODO: from, to, authenticated, severity + ] + , dbtFilter = Map.fromList + [ + ] + , dbtStyle = def + , dbtIdent = "messages" :: Text + } + ((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do + ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf + now <- liftIO $ getCurrentTime + let actions = Map.fromList + [ (SMDelete, pure SMDDelete) + , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now)) + , (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing)) + ] + (actionRes, action) <- multiAction actions (Just SMActivate) + $logDebugS "SystemMessage" $ tshow (actionRes, selectionRes) + return ((,) <$> actionRes <*> selectionRes, table <> action) + + case tableRes of + FormMissing -> return () + FormFailure errs -> forM_ errs $ addMessage Error . toHtml + FormSuccess (SMDDelete, selection) + | not $ null selection -> do + selection' <- traverse decrypt $ Set.toList selection + runDB $ deleteCascadeWhere [ SystemMessageId <-. selection' ] + $(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet") + redirect MessageListR + FormSuccess (SMDActivate ts, selection) + | not $ null selection -> do + selection' <- traverse decrypt $ Set.toList selection + runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageFrom =. ts ] + $(addMessageFile Success "templates/messages/systemMessagesSetFrom.hamlet") + redirect MessageListR + FormSuccess (SMDDeactivate ts, selection) + | not $ null selection -> do + selection' <- traverse decrypt $ Set.toList selection + runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ] + $(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet") + redirect MessageListR + FormSuccess (_, selection) + | null selection -> addMessageI Error MsgSystemMessageEmptySelection + + ((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage + <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing + <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing + <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing + <*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (fslI MsgSystemMessageSeverity) Nothing + <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just $ NonEmpty.head appLanguages) + <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing + <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing + <* submitButton + + case addRes of + FormMissing -> return () + FormFailure errs -> forM_ errs $ addMessage Error . toHtml + FormSuccess sysMsg -> do + sId <- runDB $ insert sysMsg + cID <- encrypt sId :: Handler CryptoUUIDSystemMessage + addMessageI Success $ MsgSystemMessageAdded cID + redirect $ MessageR cID + + defaultLayout $ do + $(widgetFile "system-message-list") diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 46ac21f6b..c7b7aee21 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -108,6 +108,25 @@ instance Button UniWorX AdminHijackUserButton where cssClass BtnHijack = BCDefault +data BtnSubmitDelete = BtnSubmit' | BtnDelete' + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +instance Universe BtnSubmitDelete +instance Finite BtnSubmitDelete + +instance Button UniWorX BtnSubmitDelete where + label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|] + label BtnDelete' = [whamlet|_{MsgBtnDelete}|] + + cssClass BtnSubmit' = BCPrimary + cssClass BtnDelete' = BCDanger + +$(return []) + +instance PathPiece BtnSubmitDelete where + toPathPiece = $(nullaryToPathPiece ''BtnSubmitDelete [ T.intercalate "-" . drop 1 . splitCamel ]) + fromPathPiece = finiteFromPathPiece + -- -- Looks like a button, but is just a link (e.g. for create course, etc.) -- data LinkButton = LinkButton (Route UniWorX) @@ -471,6 +490,11 @@ utcTimeField = Field (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime Nothing -> Left MsgInvalidDateTimeFormat +langField :: Bool -- ^ Only allow values from `appLanguages` + -> Field (HandlerT UniWorX IO) Lang +langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages) +langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages + fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED fsm = bfs -- TODO: get rid of Bootstrap diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 3e017472c..ff2e81f64 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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| +
+
+
_{msg} + |] + anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a anchorCell = anchorCellM . return diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9268563f8..45c6c2d6a 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} module Import.NoFoundation ( module Import + , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import @@ -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 diff --git a/src/Jobs.hs b/src/Jobs.hs index 9f2d8bd23..f89265009 100644 --- a/src/Jobs.hs +++ b/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) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs new file mode 100644 index 000000000..955c09ee4 --- /dev/null +++ b/src/Jobs/Crontab.hs @@ -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 diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs new file mode 100644 index 000000000..ba466d700 --- /dev/null +++ b/src/Jobs/Handler/HelpRequest.hs @@ -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)) diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs new file mode 100644 index 000000000..1767f7133 --- /dev/null +++ b/src/Jobs/Handler/QueueNotification.hs @@ -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 + + diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs new file mode 100644 index 000000000..39598368b --- /dev/null +++ b/src/Jobs/Handler/SendNotification.hs @@ -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 diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs new file mode 100644 index 000000000..c25962a7e --- /dev/null +++ b/src/Jobs/Handler/SendNotification/SheetActive.hs @@ -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)) diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs new file mode 100644 index 000000000..5caf09e0a --- /dev/null +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -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)) diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs new file mode 100644 index 000000000..91d983265 --- /dev/null +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -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)) diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs new file mode 100644 index 000000000..4b2865fdd --- /dev/null +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -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)) diff --git a/src/Jobs/Handler/SetLogSettings.hs b/src/Jobs/Handler/SetLogSettings.hs new file mode 100644 index 000000000..01c8d618f --- /dev/null +++ b/src/Jobs/Handler/SetLogSettings.hs @@ -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 diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs new file mode 100644 index 000000000..d72734aeb --- /dev/null +++ b/src/Jobs/Queue.hs @@ -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 + + + diff --git a/src/Jobs/TH.hs b/src/Jobs/TH.hs new file mode 100644 index 000000000..47e69f62d --- /dev/null +++ b/src/Jobs/TH.hs @@ -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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 9cb800c4d..4d3bbb85f 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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 } diff --git a/src/Settings.hs b/src/Settings.hs index 455839b13..9ba5e40ca 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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" diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2ec9e3218..12b92f430 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -15,7 +15,7 @@ module Utils.Form where -import ClassyPrelude.Yesod +import ClassyPrelude.Yesod hiding (addMessage) import Settings import qualified Text.Blaze.Internal as Blaze (null) @@ -33,6 +33,10 @@ import Data.List ((!!)) import Web.PathPieces +import Data.UUID + +import Utils.Message + ------------------- -- Form Renderer -- ------------------- @@ -150,8 +154,22 @@ noValidate = addAttr "formnovalidate" "" -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ -data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data FormIdentifier + = FIDcourse + | FIDsheet + | FIDsubmission + | FIDsettings + | FIDcorrectors + | FIDcorrectorTable + | FIDcorrection + | FIDcorrectionsUpload + | FIDcorrectionUpload + | FIDSystemMessageAdd + | FIDSystemMessageTable + | FIDSystemMessageModify + | FIDSystemMessageModifyTranslation UUID + | FIDSystemMessageAddTranslation + deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where fromPathPiece = readFromPathPiece @@ -260,3 +278,12 @@ reorderField optList = Field{..} nums = map (id &&& withNum theId) [1..length olOptions] withNum t n = tshow n <> "." <> t $(widgetFile "widgets/permutation") + +--------------------- +-- Form evaluation -- +--------------------- + +formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m () +formResult (FormFailure errs) _ = forM_ errs $ addMessage Error . toHtml +formResult FormMissing _ = return () +formResult (FormSuccess res) f = f res diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index 6cdb0a144..ef2d2c6ea 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -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) ) diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs index 163722a66..80a7b7e00 100644 --- a/src/Utils/SystemMessage.hs +++ b/src/Utils/SystemMessage.hs @@ -5,7 +5,6 @@ module Utils.SystemMessage where import Import.NoFoundation -import Utils import qualified Data.List.NonEmpty as NonEmpty import Data.List (findIndex) diff --git a/src/index.md b/src/index.md index 1a81b627c..2fcfbeaa6 100644 --- a/src/index.md +++ b/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 diff --git a/start.sh b/start.sh index da7e422d4..7f0a48c4e 100755 --- a/start.sh +++ b/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 diff --git a/templates/corrections-grade.hamlet b/templates/corrections-grade.hamlet new file mode 100644 index 000000000..f68d51e69 --- /dev/null +++ b/templates/corrections-grade.hamlet @@ -0,0 +1,5 @@ +
+
+ ^{table} +