diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 9f3625c7e..8b60430d0 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -1,4 +1,4 @@ -{ +{ "version": "2.0.0", "tasks": [ { @@ -11,7 +11,7 @@ }, "presentation": { "echo": true, - "reveal": "silent", + "reveal": "always", "focus": false, "panel": "dedicated", "showReuseMessage": false diff --git a/config/keter_testworx.yml b/config/keter_testworx.yml index b67de9dc6..be7037613 100644 --- a/config/keter_testworx.yml +++ b/config/keter_testworx.yml @@ -47,6 +47,12 @@ stanzas: - SMTPTIMEOUT - SMTPLIMIT - INSTANCE_ID + - MEMCACHEDHOST + - MEMCACHEDPORT + - MEMCACHEDLIMIT + - MEMCACHEDTIMEOUT + - MEMCACHEDROOT + - MEMCACHEDEXPIRATION # Use the following to automatically copy your bundle upon creation via `yesod # keter`. Uses `scp` internally, so you can set it to a remote destination diff --git a/config/keter_uni2work.yml b/config/keter_uni2work.yml index 04c0a506b..873124070 100644 --- a/config/keter_uni2work.yml +++ b/config/keter_uni2work.yml @@ -46,6 +46,12 @@ stanzas: - SMTPTIMEOUT - SMTPLIMIT - INSTANCE_ID + - MEMCACHEDHOST + - MEMCACHEDPORT + - MEMCACHEDLIMIT + - MEMCACHEDTIMEOUT + - MEMCACHEDROOT + - MEMCACHEDEXPIRATION # Use the following to automatically copy your bundle upon creation via `yesod diff --git a/config/settings.yml b/config/settings.yml index f3243a773..2ff396932 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -34,7 +34,6 @@ log-settings: minimum-level: "_env:LOGLEVEL:warn" destination: "_env:LOGDEST:stderr" - # Debugging auth-dummy-login: "_env:DUMMY_LOGIN:false" allow-deprecated: "_env:ALLOW_DEPRECATED:false" @@ -80,7 +79,16 @@ smtp: pool: stripes: "_env:SMTPSTRIPES:1" timeout: "_env:SMTPTIMEOUT:20" - limit: "_env:SMTPLIMIT:10" + limit: "_env:SMTPLIMIT:10" + +widget-memcached: + host: "_env:MEMCACHEDHOST:" + port: "_env:MEMCACHEDPORT:11211" + auth: [] + limit: "_env:MEMCACHEDLIMIT:10" + timeout: "_env:MEMCACHEDTIMEOUT:20" + base-url: "_env:MEMCACHEDROOT:" + expiration: "_env:MEMCACHEDEXPIRATION:3600" user-defaults: max-favourites: 12 diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index f2e5c81b6..1595dc8d9 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -171,7 +171,7 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar. -UnsupportedAuthPredicate tag@String shownRoute@String: "#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} +UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt @@ -380,7 +380,9 @@ SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tsh SheetGradingPassBinary: Bestanden/Nicht Bestanden SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. +SheetGradingCount': Anzahl SheetGradingPoints': Punkte +SheetGradingPassing': Bestehen SheetGradingPassPoints': Bestehen nach Punkten SheetGradingPassBinary': Bestanden/Nicht bestanden @@ -388,7 +390,11 @@ SheetTypeBonus grading@SheetGrading: Bonus SheetTypeNormal grading@SheetGrading: Normal SheetTypeInformational grading@SheetGrading: Keine Wertung SheetTypeNotGraded: Unbewertet -SheetTypeInfo: Bonus Blätter zählen, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter. Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer. +SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter. +SheetTypeInfoNotGraded: Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer. +SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt. +SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Blätter +SubmissionGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben SheetTypeBonus': Bonus SheetTypeNormal': Normal diff --git a/package.yaml b/package.yaml index 0aa2b1269..4bc841965 100644 --- a/package.yaml +++ b/package.yaml @@ -111,6 +111,7 @@ dependencies: - xss-sanitize - text-metrics - pkcs7 + - memcached-binary other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index a84d2842e..4508cb781 100644 --- a/routes +++ b/routes @@ -26,7 +26,7 @@ -- !deprecated -- like free, but logs and gives a warning; entirely disabled in production -- !development -- like free, but only for development builds -/static StaticR Static appStatic !free +/static StaticR EmbeddedStatic appStatic !free /auth AuthR Auth getAuth !free /favicon.ico FaviconR GET !free diff --git a/src/Application.hs b/src/Application.hs index 90792b4f5..cdf4d9ecc 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -69,6 +69,8 @@ import Data.Proxy import qualified Data.Aeson as Aeson import System.Exit (exitFailure) + +import qualified Database.Memcached.Binary.IO as Memcached -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) @@ -125,7 +127,7 @@ makeFoundation appSettings@AppSettings{..} = do (tVar, ) <$> fork (updateLogger initialSettings) appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet)) - appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir + let appStatic = embeddedStatic appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID @@ -137,7 +139,7 @@ makeFoundation appSettings@AppSettings{..} = do -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey = UniWorX {..} + let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html @@ -147,6 +149,7 @@ makeFoundation appSettings@AppSettings{..} = do (error "cryptoIDKey forced in tempFoundation") (error "sessionKey forced in tempFoundation") (error "secretBoxKey forced in tempFoundation") + (error "widgetMemcached forced in tempFoundation") logFunc loc src lvl str = do f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger) f loc src lvl str @@ -157,6 +160,8 @@ makeFoundation appSettings@AppSettings{..} = do smtpPool <- traverse createSmtpPool appSmtpConf + appWidgetMemcached <- traverse createWidgetMemcached appWidgetMemcachedConf + -- Create the database connection pool sqlPool <- createPostgresqlPool (pgConnStr appDatabaseConf) @@ -168,7 +173,7 @@ makeFoundation appSettings@AppSettings{..} = do appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool - let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey + let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached handleJobs foundation @@ -234,6 +239,9 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do return conn liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit +createWidgetMemcached :: (MonadLogger m, MonadResource m) => WidgetMemcachedConf -> m Memcached.Connection +createWidgetMemcached WidgetMemcachedConf{widgetMemcachedConnectInfo} = snd <$> allocate (Memcached.connect widgetMemcachedConnectInfo) Memcached.close + -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. makeApplication :: MonadIO m => UniWorX -> m Application @@ -348,6 +356,10 @@ getApplicationRepl = do shutdownApp :: MonadIO m => UniWorX -> m () shutdownApp app = do stopJobCtl app + liftIO $ do + for_ (appWidgetMemcached app) Memcached.close + for_ (appSmtpPool app) destroyAllResources + destroyAllResources $ appConnPool app release . fst $ appLogger app diff --git a/src/Foundation.hs b/src/Foundation.hs index 8577ae9fd..601db3527 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto module Foundation where @@ -6,7 +7,6 @@ module Foundation where import Import.NoFoundation import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) -import Text.Jasmine (minifym) import qualified Web.ClientSession as ClientSession @@ -18,7 +18,6 @@ import Jobs.Types import qualified Network.Wai as W (pathInfo) -import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe import Data.CaseInsensitive (CI) @@ -75,6 +74,9 @@ import qualified Data.Conduit.List as C import qualified Crypto.Saltine.Core.SecretBox as SecretBox +import qualified Database.Memcached.Binary.IO as Memcached +import Data.Bits (Bits(zeroBits)) + instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext @@ -96,19 +98,20 @@ instance DisplayAble SchoolId where -- starts running, such as database connections. Every handler will have -- access to the data present here. data UniWorX = UniWorX - { appSettings :: AppSettings - , appStatic :: Static -- ^ Settings for static file serving. - , appConnPool :: ConnectionPool -- ^ Database connection pool. - , appSmtpPool :: Maybe SMTPPool - , appHttpManager :: Manager - , appLogger :: (ReleaseKey, TVar Logger) - , appLogSettings :: TVar LogSettings - , appCryptoIDKey :: CryptoIDKey - , appInstanceID :: InstanceId - , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) - , appCronThread :: TMVar (ReleaseKey, ThreadId) - , appSessionKey :: ClientSession.Key - , appSecretBoxKey :: SecretBox.Key + { appSettings :: AppSettings + , appStatic :: EmbeddedStatic -- ^ Settings for static file serving. + , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appSmtpPool :: Maybe SMTPPool + , appWidgetMemcached :: Maybe Memcached.Connection + , appHttpManager :: Manager + , appLogger :: (ReleaseKey, TVar Logger) + , appLogSettings :: TVar LogSettings + , appCryptoIDKey :: CryptoIDKey + , appInstanceID :: InstanceId + , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) + , appCronThread :: TMVar (ReleaseKey, ThreadId) + , appSessionKey :: ClientSession.Key + , appSecretBoxKey :: SecretBox.Key } type SMTPPool = Pool SMTPConnection @@ -142,7 +145,7 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) --- Messages +-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de" @@ -222,6 +225,16 @@ instance RenderMessage UniWorX SheetType where newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>) +newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX] + deriving (Generic, Typeable) + deriving newtype (Semigroup, Monoid, IsList) + +instance RenderMessage UniWorX UniWorXMessages where + renderMessage foundation ls (UniWorXMessages msgs) = + intercalate " " $ map (renderMessage foundation ls) msgs + +uniworxMessages :: [UniWorXMessage] -> UniWorXMessages +uniworxMessages = UniWorXMessages . map SomeMessage -- Menus and Favourites data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary @@ -441,7 +454,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of && NTop systemMessageTo >= cTime return Authorized - r -> $unsupportedAuthPredicate "time" r + r -> $unsupportedAuthPredicate AuthTime r tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId @@ -454,14 +467,14 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) return Authorized - r -> $unsupportedAuthPredicate "registered" r + r -> $unsupportedAuthPredicate AuthRegistered r tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized - r -> $unsupportedAuthPredicate "capacity" r + r -> $unsupportedAuthPredicate AuthCapacity r tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh @@ -469,41 +482,41 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ registered <= 0 return Authorized - r -> $unsupportedAuthPredicate "empty" r + r -> $unsupportedAuthPredicate AuthEmpty r tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized - r -> $unsupportedAuthPredicate "materials" r + r -> $unsupportedAuthPredicate AuthMaterials r tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized - r -> $unsupportedAuthPredicate "owner" r + r -> $unsupportedAuthPredicate AuthOwner r tagAccessPredicate AuthRated = APDB $ \route _ -> case route of CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sub <- MaybeT $ get sid guard $ submissionRatingDone sub return Authorized - r -> $unsupportedAuthPredicate "rated" r + r -> $unsupportedAuthPredicate AuthRated r tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn guard $ sheetSubmissionMode == UserSubmissions return Authorized - r -> $unsupportedAuthPredicate "user-submissions" r + r -> $unsupportedAuthPredicate AuthUserSubmissions r tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn guard $ sheetSubmissionMode == CorrectorSubmissions return Authorized - r -> $unsupportedAuthPredicate "corrector-submissions" r + r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- decrypt cID @@ -511,7 +524,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of isAuthenticated <- isJust <$> liftHandlerT maybeAuthId guard $ not systemMessageAuthenticatedOnly || isAuthenticated return Authorized - r -> $unsupportedAuthPredicate "authentication" r + r -> $unsupportedAuthPredicate AuthAuthentication r tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite) tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized) @@ -704,21 +717,16 @@ instance Yesod UniWorX where isAuthorized = evalAccess - -- This function creates static content files in the static folder - -- and names them based on a hash of their content. This allows - -- expiration dates to be set far in the future without worry of - -- users receiving stale content. - addStaticContent ext mime content = do - master <- getYesod - let staticDir = appStaticDir $ appSettings master - addStaticContentExternal - minifym - genFileName - staticDir - (StaticR . flip StaticRoute []) - ext - mime - content + addStaticContent ext _mime content = do + UniWorX{appWidgetMemcached, appSettings} <- getYesod + for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do + let expiry = (maybe 0 ceiling widgetMemcachedExpiry) + touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn + add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn + absoluteLink = unpack widgetMemcachedBaseUrl fileName + C.catchIf Memcached.isKeyNotFound touch $ \_ -> + C.handleIf Memcached.isKeyExists (\_ -> return ()) add + return . Left $ pack absoluteLink where -- Generate a unique filename based on the content itself, this is used -- for deduplication so a collision resistant hash function is required @@ -727,12 +735,13 @@ instance Yesod UniWorX where -- -- Length of hash is 144 bits instead of MD5's 128, so as to avoid -- padding after base64-conversion - genFileName lbs = Text.unpack - . Text.decodeUtf8 - . Base64.encode - . (convert :: Digest (SHAKE256 144) -> ByteString) - . runIdentity - $ sourceList (Lazy.ByteString.toChunks lbs) $$ sinkHash + fileName = (<.> unpack ext) + . unpack + . decodeUtf8 + . Base64.encode + . (convert :: Digest (SHAKE256 144) -> ByteString) + . runIdentity + $ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 390b041e1..54eddd1c3 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -2,7 +2,7 @@ module Handler.Common where import Data.FileEmbed (embedFile) -import Import +import Import hiding (embedFile) -- These handlers embed files in the executable at compile time to avoid a -- runtime dependency, and for efficiency. @@ -10,8 +10,8 @@ import Import getFaviconR :: Handler TypedContent getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month return $ TypedContent "image/x-icon" - $ toContent $(embedFile "embedded/favicon.ico") + $ toContent $(embedFile "static/favicon.ico") getRobotsR :: Handler TypedContent getRobotsR = return $ TypedContent typePlain - $ toContent $(embedFile "embedded/robots.txt") + $ toContent $(embedFile "static/robots.txt") diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 63867d4d4..803ef4bae 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -7,18 +7,20 @@ import Jobs import Handler.Utils import Handler.Utils.Submission import Handler.Utils.Table.Cells +import Handler.Utils.SheetType -- import Handler.Utils.Zip import Utils.Lens import Data.Set (Set) import qualified Data.Set as Set -import Data.Map (Map) +import Data.Map (Map, (!)) import qualified Data.Map as Map import qualified Data.Text as Text import Data.Semigroup (Sum(..)) +import Data.Monoid (All(..)) -- import Data.Time -- import qualified Data.Text as T @@ -45,7 +47,8 @@ import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) -import Control.Monad.Trans.Writer (WriterT(..), runWriter) +import Control.Monad.Trans.Writer (WriterT(..), runWriter, execWriterT) +import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Trans.RWS (RWST) @@ -56,25 +59,33 @@ import Data.Foldable (foldrM) -type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) => - (expr (Entity Course), expr (Entity Sheet), expr (Entity Submission)) - -> expr (E.Value Bool) - -ratedBy :: Key User -> CorrectionsWhere -ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) - -courseIs :: Key Course -> CorrectionsWhere -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 CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) +type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool) type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym)) +correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v +correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do + E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ whereClause t + return $ returnStatement t + +-- Where Clauses +ratedBy :: UserId -> CorrectionTableWhere +ratedBy uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) + +courseIs :: CourseId -> CorrectionTableWhere +courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid + +sheetIs :: Key Sheet -> CorrectionTableWhere +sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid + +submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere +submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode + + +-- Columns colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> @@ -94,6 +105,10 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet) shn = sheetName $ entityVal sheet in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] +colSheetType :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) + $ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet + colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty @@ -116,7 +131,7 @@ colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) -colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let +colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let csh = course ^. _2 tid = course ^. _3 ssh = course ^. _4 @@ -138,6 +153,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=( tid = course ^. _3 ssh = course ^. _4 -- shn = sheetName + mkRoute = do cid <- encrypt subId return $ CSubmissionR tid ssh csh sheetName cid CorrectionR @@ -176,23 +192,19 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . 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 -> _ -> DB (DBResult m x) + => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (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 - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ whereClause (course,sheet,submission) - let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName) - , course E.^. CourseShorthand - , course E.^. CourseTerm - , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) - ) - return (submission, sheet, crse, corrector) + dbtSQLQuery = correctionsTableQuery whereClause + (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> + let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName) + , course E.^. CourseShorthand + , course E.^. CourseTerm + , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) + ) + in (submission, sheet, crse, corrector) + ) dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData 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 @@ -200,7 +212,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do 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] + E.orderBy [E.asc $ user E.^. UserDisplayName] return (user, pseudonym E.?. SheetPseudonymPseudonym) let submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors @@ -231,6 +243,16 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do , ( "assignedtime" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned ) + , ( "submittors" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> + E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.orderBy [E.asc $ user E.^. UserDisplayName] + E.limit 1 + return (user E.^. UserDisplayName) + + ) ] , dbtFilter = Map.fromList [ ( "term" @@ -356,9 +378,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) redirect currentRoute + gradingSummary <- runDB $ do + let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime) + points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints + -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn [] + return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points + let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary fmap toTypedContent . defaultLayout $ do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") + where authorizedToAssign :: SubmissionId -> DB Bool authorizedToAssign sId = do @@ -641,81 +670,96 @@ postCorrectionsCreateR = do FormMissing -> return () FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess (sid, (pss, invalids)) -> do - forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet") - - runDB $ do - Sheet{..} <- get404 sid - (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) - forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText - now <- liftIO getCurrentTime - let - sps' :: [[SheetPseudonym]] - duplicate :: Set Pseudonym - ( sps' - , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate - ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do - known <- State.gets $ Map.member sheetPseudonymPseudonym - State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) - return $ bool (p :) id known ps - submissionPrototype = Submission - { submissionSheet = sid - , submissionRatingPoints = Nothing - , submissionRatingComment = Nothing - , submissionRatingBy = Just uid - , submissionRatingAssigned = Just now - , submissionRatingTime = Nothing - } - unless (null duplicate) - $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet") - existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do - E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') - E.&&. submission E.^. SubmissionSheet E.==. E.val sid - return submissionUser - unless (null existingSubUsers) $ do - (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers - $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet") - let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' - forM_ sps'' $ \spGroup - -> let - sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup - in case sheetGrouping of - Arbitrary maxSize -> do - subId <- insert submissionPrototype - void . insert $ SubmissionEdit uid now subId - insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser - { submissionUserUser = sheetPseudonymUser - , submissionUserSubmission = subId + allDone <- fmap getAll . execWriterT $ do + forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet") + tell . All $ null invalids + + WriterT . runDB . mapReaderT runWriterT $ do + Sheet{..} <- get404 sid + (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) + forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText + tell . All $ null unknown + now <- liftIO getCurrentTime + let + sps' :: [[SheetPseudonym]] + duplicate :: Set Pseudonym + ( sps' + , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate + ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do + known <- State.gets $ Map.member sheetPseudonymPseudonym + State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) + return $ bool (p :) id known ps + submissionPrototype = Submission + { submissionSheet = sid + , submissionRatingPoints = Nothing + , submissionRatingComment = Nothing + , submissionRatingBy = Just uid + , submissionRatingAssigned = Just now + , submissionRatingTime = Nothing } - when (genericLength spGroup > maxSize) $ - addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc - RegisteredGroups -> do - groups <- E.select . E.from $ \submissionGroup -> do - E.where_ . E.exists . E.from $ \submissionGroupUser -> - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) - return $ submissionGroup E.^. SubmissionGroupId - if - | length (groups :: [E.Value SubmissionGroupId]) < 2 - -> do - subId <- insert submissionPrototype - void . insert $ SubmissionEdit uid now subId - insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser - { submissionUserUser = sheetPseudonymUser - , submissionUserSubmission = subId - } - when (null groups) $ - addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc - | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc - NoGroups -> do - subId <- insert submissionPrototype - void . insert $ SubmissionEdit uid now subId - insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser - { submissionUserUser = sheetPseudonymUser - , submissionUserSubmission = subId - } - when (length spGroup > 1) $ - addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc - redirect CorrectionsGradeR + unless (null duplicate) + $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet") + existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') + E.&&. submission E.^. SubmissionSheet E.==. E.val sid + return submissionUser + unless (null existingSubUsers) . mapReaderT lift $ do + (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers + $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet") + let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' + forM_ sps'' $ \spGroup + -> let + sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup + in case sheetGrouping of + Arbitrary maxSize -> do + subId <- insert submissionPrototype + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + when (genericLength spGroup > maxSize) $ + addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc + RegisteredGroups -> do + let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup + groups <- E.select . E.from $ \submissionGroup -> do + E.where_ . E.exists . E.from $ \submissionGroupUser -> + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) + return $ submissionGroup E.^. SubmissionGroupId + groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups) + return $ submissionGroupUser E.^. SubmissionGroupUserUser + if + | [_] <- groups + , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers + -> do + subId <- insert submissionPrototype + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser + { submissionUserUser = sheetUser + , submissionUserSubmission = subId + } + when (null groups) $ + addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc + | length groups < 2 + -> do + forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do + addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym) + tell $ All False + | otherwise -> + addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc + NoGroups -> do + subId <- insert submissionPrototype + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + when (length spGroup > 1) $ + addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc + when allDone $ + redirect CorrectionsGradeR defaultLayout $ diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 18a4c473a..6728e11a2 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -6,6 +6,7 @@ import System.FilePath (takeFileName) import Handler.Utils -- import Handler.Utils.Zip import Handler.Utils.Table.Cells +import Handler.Utils.SheetType -- import Data.Time -- import qualified Data.Text as T @@ -41,7 +42,7 @@ import qualified Data.Map as Map import Data.Map (Map, (!?)) -import Data.Monoid (Sum(..), Any(..)) +import Data.Monoid (Any(..)) -- import Control.Lens import Utils.Lens @@ -62,7 +63,7 @@ data SheetForm = SheetForm { sfName :: SheetName , sfDescription :: Maybe Html , sfType :: SheetType - , sfGrouping :: SheetGroup + , sfGrouping :: SheetGroup , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: UTCTime , sfActiveTo :: UTCTime @@ -97,8 +98,9 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do <$> areq ciField (fslI MsgSheetName) (sfName <$> template) <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) <*> sheetTypeAFormReq (fslI MsgSheetType - & setTooltip MsgSheetTypeInfo) (sfType <$> template) - <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) + & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded])) + (sfType <$> template) + <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) ((sfVisibleFrom <$> template) <|> pure (Just ctime)) @@ -118,7 +120,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) - <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) + <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) <* submitButton return $ case result of FormSuccess sheetResult @@ -137,7 +139,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do ] ] getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getSheetListR tid ssh csh = do +getSheetListR tid ssh csh = do muid <- maybeAuthId Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh let @@ -152,18 +154,19 @@ getSheetListR tid ssh csh = do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return (sheet, lastSheetEdit sheet, submission) sheetCol = widgetColonnade . mconcat $ - [ sortable (Just "name") (i18nCell MsgSheet) - $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) + [ dbRow + , sortable (Just "name") (i18nCell MsgSheet) + $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) , sortable (Just "last-edit") (i18nCell MsgLastEdit) - $ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime + $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty timeCell mEditTime , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) - $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom + $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveFrom , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) - $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo + $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveTo , sortable Nothing (i18nCell MsgSheetType) - $ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType + $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> i18nCell sheetType , sortable Nothing (i18nCell MsgSubmission) - $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of + $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of Nothing -> mempty (Just (Entity sid Submission{..})) -> let mkCid = encrypt sid -- TODO: executed twice @@ -172,7 +175,7 @@ getSheetListR tid ssh csh = do return $ CSubmissionR tid ssh csh sheetName cid' SubShowR in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|]) , sortable (Just "rating") (i18nCell MsgRating) - $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of + $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of Nothing -> mempty (Just (Entity sid Submission{..})) -> let mkCid = encrypt sid @@ -180,15 +183,15 @@ getSheetListR tid ssh csh = do cid' <- mkCid return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR in anchorCellM mkRoute $(widgetFile "widgets/rating") - , sortable Nothing -- (Just "percent") + , sortable Nothing -- (Just "percent") (i18nCell MsgRatingPercent) - $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of + $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub)} -> case mbSub of (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) -> case preview (_grading . _maxPoints) sType of Just maxPoints | maxPoints /= 0 -> let percent = sPoints / maxPoints - in textCell $ textPercent $ realToFrac percent + in textCell $ textPercent $ realToFrac percent _other -> mempty _other -> mempty ] @@ -197,8 +200,8 @@ getSheetListR tid ssh csh = do table <- runDB $ dbTableWidget' psValidator DBTable { dbtSQLQuery = sheetData , dbtColonnade = sheetCol - , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } - -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False) + , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) } + -> dbr <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False) , dbtSorting = Map.fromList [ ( "name" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName @@ -228,7 +231,7 @@ getSheetListR tid ssh csh = do , dbtIdent = "sheets" :: Text } -- Collect summary over all Sheets, not just the ones shown due to pagination: - SheetTypeSummary{..} <- do + statistics <- gradeSummaryWidget MsgSheetGradingSummaryTitle <$> do rows <- runDB $ E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet @@ -238,7 +241,6 @@ getSheetListR tid ssh csh = do return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows defaultLayout $ do $(widgetFile "sheetList") - $(widgetFile "widgets/sheetTypeSummary") data ButtonGeneratePseudonym = BtnGenerate deriving (Enum, Eq, Ord, Bounded, Read, Show) @@ -398,7 +400,7 @@ getSheetNewR tid ssh csh = do { sfName = stepTextCounterCI sheetName , sfDescription = sheetDescription , sfType = sheetType - , sfGrouping = sheetGrouping + , sfGrouping = sheetGrouping , sfVisibleFrom = addOneWeek <$> sheetVisibleFrom , sfActiveFrom = addOneWeek sheetActiveFrom , sfActiveTo = addOneWeek sheetActiveTo @@ -431,7 +433,7 @@ getSEditR tid ssh csh shn = do { sfName = sheetName , sfDescription = sheetDescription , sfType = sheetType - , sfGrouping = sheetGrouping + , sfGrouping = sheetGrouping , sfVisibleFrom = sheetVisibleFrom , sfActiveFrom = sheetActiveFrom , sfActiveTo = sheetActiveTo diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index d1c9d3e4b..cc16635d7 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -263,7 +263,7 @@ multiFileField permittedFiles' = Field{..} pVals <- lift permittedFiles' let decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId) - decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt + decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt yieldMany vals .| C.filter (/= unpackZips) .| C.map fromPathPiece .| C.catMaybes @@ -288,7 +288,7 @@ multiFileField permittedFiles' = Field{..} let fuiChecked | Right sentVals' <- sentVals = fuiId' `elem` sentVals' | otherwise = True - return FileUploadInfo{..} + return FileUploadInfo{..} fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals) E.orderBy [E.asc $ file E.^. FileTitle] @@ -303,13 +303,13 @@ multiFileField permittedFiles' = Field{..} data SheetGrading' = Points' | PassPoints' | PassBinary' - deriving (Eq, Ord, Read, Show, Enum, Bounded) + deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe SheetGrading' instance Finite SheetGrading' nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'") -embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>) +embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>) data SheetType' = Bonus' | Normal' | Informational' | NotGraded' @@ -319,7 +319,7 @@ instance Universe SheetType' instance Finite SheetType' nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'") -embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>) +embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>) data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups' @@ -333,31 +333,31 @@ embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'") sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template) - where - selOptions = Map.fromList - [ ( Points', Points <$> maxPointsReq ) + where + selOptions = Map.fromList + [ ( Points', Points <$> maxPointsReq ) , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq ) , ( PassBinary', pure PassBinary) ] - classify' :: SheetGrading -> SheetGrading' - classify' = \case - Points {} -> Points' + classify' :: SheetGrading -> SheetGrading' + classify' = \case + Points {} -> Points' PassPoints {} -> PassPoints' PassBinary {} -> PassBinary' - - maxPointsReq = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints) + + maxPointsReq = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints) passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints) sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template) - where + where selOptions = Map.fromList [ ( Bonus' , Bonus <$> gradingReq ) , ( Normal', Normal <$> gradingReq ) , ( Informational', Informational <$> gradingReq ) , ( NotGraded', pure NotGraded ) - ] + ] gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading & setTooltip MsgSheetGradingInfo) (template >>= preview _grading) @@ -440,8 +440,8 @@ utcTimeField = Field fieldTimeFormat :: String --fieldTimeFormat = "%e.%m.%y %k:%M" fieldTimeFormat = "%Y-%m-%dT%H:%M" - - -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any + + -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any readTime :: Text -> Either UniWorXMessage UTCTime readTime t = case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of @@ -595,7 +595,7 @@ formResultModal res finalDest handler = maybeT_ $ do FormMissing -> mzero FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero FormSuccess val -> lift . execWriterT $ handler val - + isModal <- hasCustomHeader HeaderIsModal if | isModal -> sendResponse $ toJSON messages diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index be259344f..fc4e88574 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -41,7 +41,7 @@ import qualified Database.Esqueleto as E import qualified Data.Conduit.List as Conduit -import Utils.Lens hiding ((<.>)) +import Utils.Lens instance HasResolution prec => Pretty (Fixed prec) where @@ -51,7 +51,7 @@ instance Pretty x => Pretty (CI x) where pretty = pretty . CI.original -instance Pretty SheetGrading where +instance Pretty SheetGrading where pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String) pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String ) pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String ) @@ -59,12 +59,12 @@ instance Pretty SheetGrading where validateRating :: SheetType -> Rating' -> [RatingException] validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..} - | rp < 0 - = [RatingNegative] - | NotGraded <- ratingSheetType + | rp < 0 + = [RatingNegative] + | NotGraded <- ratingSheetType = [RatingNotExpected] | (Just maxPoints ) <- ratingSheetType ^? _grading . _maxPoints - , rp > maxPoints + , rp > maxPoints = [RatingExceedsMax] | (Just PassBinary) <- ratingSheetType ^? _grading , not (rp == 0 || rp == 1) @@ -98,7 +98,7 @@ getRating submissionId = runMaybeT $ do , E.unValue -> ratingComment , E.unValue -> ratingTime ) ] <- lift query - + return Rating{ ratingValues = Rating'{..}, .. } formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString diff --git a/src/Handler/Utils/SheetType.hs b/src/Handler/Utils/SheetType.hs new file mode 100644 index 000000000..150b7cd63 --- /dev/null +++ b/src/Handler/Utils/SheetType.hs @@ -0,0 +1,39 @@ +module Handler.Utils.SheetType + ( + gradeSummaryWidget + ) where + +import Import +import Data.Monoid (Sum(..)) +import Utils.Lens + +addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary +addBonusToPoints sts = + sts & _normalSummary . _achievedPoints %~ maxBonusPts . addBonusPts + & _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass + where + bonusPoints = sts ^. _bonusSummary . _achievedPoints + maxPoints = sts ^. _normalSummary . _sumGradePoints + maxBonusPts = fmap $ min maxPoints + addBonusPts = maybeAdd bonusPoints + + bonusPasses = sts ^. _bonusSummary . _achievedPasses + maxPasses = sts ^. _normalSummary . _numGradePasses + maxBonusPass = fmap $ min maxPasses + addBonusPass = maybeAdd bonusPasses + +gradeSummaryWidget :: RenderMessage UniWorX msg => (Int -> msg) -> SheetTypeSummary -> Widget +gradeSummaryWidget title sts = + let SheetTypeSummary{..} = addBonusToPoints sts + sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded) + hasPassings = positiveSum $ numGradePasses sumSummaries + hasPoints = positiveSum $ sumGradePoints sumSummaries + rowWdgts = [ $(widgetFile "widgets/gradingSummaryRow") + | (sumHeader,summary) <- + [ (MsgSheetTypeNormal' ,normalSummary) + , (MsgSheetTypeBonus' ,bonusSummary) + , (MsgSheetTypeInformational' ,informationalSummary) + ] ] + in if 0 == numSheets sumSummaries + then mempty + else $(widgetFile "widgets/gradingSummary") diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 3c5155842..808ad04af 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -183,7 +183,7 @@ instance Default (PSValidator m x) where Just pi -> swap . (\act -> execRWS act pi def) $ do asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s }) asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f }) - + l <- asks piLimit case l of Just l' @@ -258,7 +258,7 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) data DBCell m x :: * dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget) - + -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x) -- | Format @DBTable@ when sort-circuiting dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget @@ -284,7 +284,7 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where dbCell = iso (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents)) (uncurry WidgetCell) - + -- dbWidget Proxy Proxy = iso (, ()) $ view _1 dbWidget _ _ = return . snd dbHandler _ _ f = return . over _2 f @@ -331,7 +331,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc dbCell = iso (\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents)) (\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget) - + -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi @@ -353,10 +353,10 @@ addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragmen instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where mempty = FormCell mempty (return mempty) (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c') - + instance IsDBTable m a => IsString (DBCell m a) where fromString = cell . fromString - + dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x) dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do @@ -378,7 +378,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , fieldView = error "multiTextField: should not be rendered" , fieldEnctype = UrlEncoded } - + piResult <- lift . runInputGetResult $ PaginationInput <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) @@ -571,6 +571,7 @@ formCell genIndex genForm input = FormCell -- Predefined colonnades +--Number column? dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 94c8ffbd2..3bd7ebc45 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -3,7 +3,7 @@ module Import.NoFoundation , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import @@ -35,10 +35,12 @@ import Mail as Import import Data.Data as Import (Data) import Data.Typeable as Import (Typeable) import GHC.Generics as Import (Generic) +import GHC.Exts as Import (IsList) import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..)) import Data.Text.Encoding.Error as Import(UnicodeException(..)) +import Data.Semigroup as Import (Semigroup) import Control.Monad.Morph as Import (MFunctor(..)) diff --git a/src/Jobs.hs b/src/Jobs.hs index 45a5f74f6..9385eeff4 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -134,6 +134,7 @@ execCrontab = evalStateT go HashMap.empty runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge refT <- liftIO getCurrentTime + settings <- getsYesod appSettings currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab case crontab' of @@ -141,7 +142,7 @@ execCrontab = evalStateT go HashMap.empty Just crontab -> Just <$> do State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab prevExec <- State.get - case earliestJob prevExec crontab refT of + case earliestJob settings prevExec crontab refT of Nothing -> liftBase retry Just (_, MatchNone) -> liftBase retry Just x -> return (crontab, x) @@ -189,6 +190,11 @@ execCrontab = evalStateT go HashMap.empty acc :: NominalDiffTime acc = 1e-3 + debouncingAcc :: AppSettings -> JobCtl -> NominalDiffTime + debouncingAcc AppSettings{appNotificationRateLimit} = \case + JobCtlQueue (JobQueueNotification _) -> appNotificationRateLimit + _ -> acc + applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime applyJitter seed t = do appInstance <- getsYesod appInstanceID @@ -197,8 +203,8 @@ execCrontab = evalStateT go HashMap.empty diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed) return $ addUTCTime diff t - earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime) - earliestJob lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab + earliestJob :: AppSettings -> HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime) + earliestJob settings lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab where go' (jobCtl, cron) mbPrev | Just (_, t') <- mbPrev @@ -207,7 +213,7 @@ execCrontab = evalStateT go HashMap.empty | otherwise = Just (jobCtl, t) where - t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) acc now cron + t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool waitUntil crontabTV crontab nextTime = runResourceT $ do diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index 6ce7760f5..c7b4e910f 100644 --- a/src/Model/Rating.hs +++ b/src/Model/Rating.hs @@ -2,7 +2,6 @@ module Model.Rating where import ClassyPrelude.Yesod import Model - -- import Data.Text (Text) import Data.Text.Encoding.Error (UnicodeException(..)) import GHC.Generics (Generic) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 27025eed3..222b84a22 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -135,10 +135,11 @@ gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints gradingPassed (PassBinary {}) pts = Just $ pts /= 0 data SheetGradeSummary = SheetGradeSummary - { sumGradePoints :: Sum Points + { numSheets :: Sum Int , numGradePasses :: Sum Int - , achievedPoints :: Maybe (Sum Points) + , sumGradePoints :: Sum Points , achievedPasses :: Maybe (Sum Int) + , achievedPoints :: Maybe (Sum Points) } deriving (Generic, Read, Show, Eq) instance Monoid SheetGradeSummary where @@ -146,18 +147,25 @@ instance Monoid SheetGradeSummary where mappend = mappenddefault instance Semigroup SheetGradeSummary where - (<>) = mappend -- remove for GHC > 8.4.x + (<>) = mappend -- TODO: remove for GHC > 8.4.x + +makeLenses_ ''SheetGradeSummary sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary sheetGradeSum gr (Just p) = let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p } in case gr of PassBinary -> baseSum _other -> baseSum { achievedPoints = Just $ Sum $ p } -sheetGradeSum (Points {..}) Nothing = mempty { sumGradePoints = Sum maxPoints } -sheetGradeSum (PassPoints{..}) Nothing = mempty { sumGradePoints = Sum maxPoints - , numGradePasses = Sum 1 } -sheetGradeSum (PassBinary) Nothing = mempty { numGradePasses = Sum 1 } - +sheetGradeSum (Points {..}) Nothing = mempty { numSheets = Sum 1 + , sumGradePoints = Sum maxPoints + } +sheetGradeSum (PassPoints{..}) Nothing = mempty { numSheets = Sum 1 + , numGradePasses = Sum 1 + , sumGradePoints = Sum maxPoints + } +sheetGradeSum (PassBinary) Nothing = mempty { numSheets = Sum 1 + , numGradePasses = Sum 1 + } data SheetType = Normal { grading :: SheetGrading } @@ -174,19 +182,26 @@ deriveJSON defaultOptions derivePersistFieldJSON ''SheetType data SheetTypeSummary = SheetTypeSummary - { normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary - , numNotGraded :: Sum Int + { normalSummary + , bonusSummary + , informationalSummary :: SheetGradeSummary + , numNotGraded :: Sum Int } deriving (Generic, Read, Show, Eq) instance Monoid SheetTypeSummary where mempty = memptydefault mappend = mappenddefault +instance Semigroup SheetTypeSummary where + (<>) = mappend -- TODO: remove for GHC > 8.4.x + +makeLenses_ ''SheetTypeSummary + sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary sheetTypeSum Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps } sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps } sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } -sheetTypeSum NotGraded _ = mempty { numNotGraded = Sum 1 } +sheetTypeSum NotGraded _ = mempty { numNotGraded = Sum 1 } data SheetGroup = Arbitrary { maxParticipants :: Natural } diff --git a/src/Settings.hs b/src/Settings.hs index 9b4e48541..8abbc1fe1 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -29,7 +29,7 @@ import Yesod.Default.Util (WidgetFileSettings, widgetFileReload) import qualified Yesod.Auth.Util.PasswordStore as PWStore -import Data.Time (NominalDiffTime) +import Data.Time (NominalDiffTime, nominalDay) import Data.Scientific (toBoundedInteger) import Data.Word (Word16) @@ -47,12 +47,15 @@ import qualified Data.Char as Char import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..)) import qualified Network.Socket as HaskellNet (PortNumber(..), HostName) +import qualified Network import Network.Mail.Mime (Address) import Network.Mail.Mime.Instances () import Mail (VerpMode) +import qualified Database.Memcached.Binary.Types as Memcached + import Model import Settings.Cluster @@ -68,6 +71,8 @@ data AppSettings = AppSettings -- ^ Configuration settings for accessing the LDAP-directory , appSmtpConf :: Maybe SmtpConf -- ^ Configuration settings for accessing a SMTP Mailserver + , appWidgetMemcachedConf :: Maybe WidgetMemcachedConf + -- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent` , appRoot :: Maybe Text -- ^ Base for all generated URLs. If @Nothing@, determined -- from the request headers. @@ -167,6 +172,34 @@ data SmtpConf = SmtpConf , smtpPool :: ResourcePoolConf } deriving (Show) +data WidgetMemcachedConf = WidgetMemcachedConf + { widgetMemcachedConnectInfo :: Memcached.ConnectInfo + , widgetMemcachedBaseUrl :: Text + , widgetMemcachedExpiry :: Maybe NominalDiffTime + } deriving (Show) + +instance FromJSON Memcached.Auth where + parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw + +instance FromJSON Network.PortID where + parseJSON v = Network.UnixSocket <$> pSocket v <|> Network.PortNumber <$> pNumber v <|> Network.Service <$> pService v + where + pSocket = Aeson.withText "UnixSocket" $ fmap unpack . assertM' ("/" `Text.isPrefixOf`) + pNumber = Aeson.withScientific "PortNumber" $ maybe (fail "PortNumber ") (return . (fromIntegral :: Word16 -> Network.PortNumber)) . toBoundedInteger + pService = Aeson.withText "Service" $ return . unpack + +instance FromJSON WidgetMemcachedConf where + parseJSON = withObject "WidgetMemcachedConf" $ \o -> do + connectHost <- o .: "host" + connectPort <- o .: "port" + connectAuth <- o .: "auth" + numConnection <- o .: "limit" + connectionIdleTime <- o .: "timeout" + widgetMemcachedBaseUrl <- o .: "base-url" + widgetMemcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration" + + return WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, .. } + data ResourcePoolConf = ResourcePoolConf { poolStripes :: Int , poolTimeout :: NominalDiffTime @@ -284,6 +317,15 @@ instance FromJSON AppSettings where Ldap.Plain host -> not $ null host appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap" appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" + let validWidgetMemcachedConf WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and + [ not (null connectHost) || isUnixSocket connectPort + , not $ null widgetMemcachedBaseUrl + , numConnection > 0 + , connectionIdleTime >= 0 + ] + isUnixSocket (Network.UnixSocket _) = True + isUnixSocket _ = False + appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached" appRoot <- o .:? "approot" appHost <- fromString <$> o .: "host" appPort <- o .: "port" diff --git a/src/Settings/StaticFiles.hs b/src/Settings/StaticFiles.hs index c8021d3a5..c7bd88255 100644 --- a/src/Settings/StaticFiles.hs +++ b/src/Settings/StaticFiles.hs @@ -1,18 +1,26 @@ -module Settings.StaticFiles where +module Settings.StaticFiles + ( module Settings.StaticFiles + , module Yesod.EmbeddedStatic + ) where + +import ClassyPrelude import Settings (appStaticDir, compileTimeAppSettings) -import Yesod.Static (staticFiles) +import Yesod.EmbeddedStatic -- This generates easy references to files in the static directory at compile time, -- giving you compile-time verification that referenced files exist. -- Warning: any files added to your static directory during run-time can't be --- accessed this way. You'll have to use their FilePath or URL to access them. +-- accessed this way. -- -- For example, to refer to @static/js/script.js@ via an identifier, you'd use: -- -- js_script_js --- --- If the identifier is not available, you may use: --- --- StaticFile ["js", "script.js"] [] -staticFiles (appStaticDir compileTimeAppSettings) + +#ifdef DEVELOPMENT +#define DEV_BOOL True +#else +#define DEV_BOOL False +#endif + +mkEmbeddedStatic DEV_BOOL "embeddedStatic" [embedDir $ appStaticDir compileTimeAppSettings] diff --git a/src/Utils.hs b/src/Utils.hs index 8965c0009..fed726e6f 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -63,6 +63,9 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Data.PKCS7 as PKCS7 +import Data.Fixed (Centi) +import Data.Ratio ((%)) + ----------- @@ -87,7 +90,7 @@ guardAuthResult AuthenticationRequired = notAuthenticated guardAuthResult (Unauthorized t) = permissionDenied t guardAuthResult Authorized = return () -data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route +data UnsupportedAuthPredicate route = UnsupportedAuthPredicate Text route deriving (Eq, Ord, Typeable, Show) instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route) @@ -95,8 +98,8 @@ unsupportedAuthPredicate :: ExpQ unsupportedAuthPredicate = do logFunc <- logErrorS [e| \tag route -> do - $(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|] - unauthorizedI (UnsupportedAuthPredicate tag route) + $(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|] + unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route) |] @@ -204,15 +207,16 @@ instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out display = pack . show -} -textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? +textPercent :: Real a => a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? textPercent x = lz <> pack (show rx) <> "%" where - round' :: Double -> Int -- avoids annoying warning - round' = round - rx :: Double - rx = fromIntegral (round' $ 1000.0*x) / 10.0 + rx :: Centi + rx = realToFrac (x * 100) lz = if rx < 10.0 then "0" else "" +textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? +textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole + stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes stepTextCounterCI = CI.map stepTextCounter @@ -317,14 +321,13 @@ toNothing = const Nothing toNothingS :: String -> Maybe b toNothingS = const Nothing -maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap +maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap maybeAdd (Just x) (Just y) = Just (x + y) maybeAdd Nothing y = y maybeAdd x Nothing = x maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m -maybeEmpty (Just x) f = f x -maybeEmpty Nothing _ = mempty +maybeEmpty = flip foldMap whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x @@ -339,7 +342,7 @@ maybePositive a | a > 0 = Just a | otherwise = Nothing positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive -positiveSum (Sum x) = maybePositive x +positiveSum = maybePositive . getSum maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM dft act mb = mb >>= maybe dft act @@ -369,7 +372,6 @@ instance Ord a => Ord (NTop (Maybe a)) where compare (NTop (Just x)) (NTop (Just y)) = compare x y - ------------ -- Either -- ------------ diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 7d7df4350..7d71d63ef 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -1,7 +1,7 @@ module Utils.Lens ( module Utils.Lens ) where import Import.NoFoundation -import Control.Lens as Utils.Lens +import Control.Lens as Utils.Lens hiding ((<.>)) import Control.Lens.Extras as Utils.Lens (is) import Utils.Lens.TH as Utils.Lens (makeLenses_) diff --git a/stack.yaml b/stack.yaml index bd108cdef..6ae2e45d6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -45,4 +45,8 @@ extra-deps: - quickcheck-classes-0.4.14 - semirings-0.2.1.1 + - memcached-binary-0.2.0 + +allow-newer: true + resolver: lts-10.5 diff --git a/embedded/favicon.ico b/static/favicon.ico similarity index 100% rename from embedded/favicon.ico rename to static/favicon.ico diff --git a/embedded/robots.txt b/static/robots.txt similarity index 100% rename from embedded/robots.txt rename to static/robots.txt diff --git a/templates/corrections.hamlet b/templates/corrections.hamlet index ae932745a..8dcaa38fb 100644 --- a/templates/corrections.hamlet +++ b/templates/corrections.hamlet @@ -1,5 +1,7 @@ -
+
^{table}