fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

Merge branch 'master' into 'live'

Browse Source 
Master

Closes #251 and #247

See merge request !120
This commit is contained in:
Gregor Kleen 2018-12-05 22:10:17 +01:00
commit eb4ff3ada6
36 changed files with 577 additions and 288 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.vscode/tasks.json vendored
View File

@ -1,4 +1,4 @@
{ {
"version": "2.0.0", "version": "2.0.0",
"tasks": [ "tasks": [
{ {
@ -11,7 +11,7 @@
}, },
"presentation": { "presentation": {
"echo": true, "echo": true,
"reveal": "silent", "reveal": "always",
"focus": false, "focus": false,
"panel": "dedicated", "panel": "dedicated",
"showReuseMessage": false "showReuseMessage": false

6
config/keter_testworx.yml
View File

@ -47,6 +47,12 @@ stanzas:
- SMTPTIMEOUT - SMTPTIMEOUT
- SMTPLIMIT - SMTPLIMIT
- INSTANCE_ID - INSTANCE_ID
- MEMCACHEDHOST
- MEMCACHEDPORT
- MEMCACHEDLIMIT
- MEMCACHEDTIMEOUT
- MEMCACHEDROOT
- MEMCACHEDEXPIRATION
# Use the following to automatically copy your bundle upon creation via `yesod # 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 # keter`. Uses `scp` internally, so you can set it to a remote destination

6
config/keter_uni2work.yml
View File

@ -46,6 +46,12 @@ stanzas:
- SMTPTIMEOUT - SMTPTIMEOUT
- SMTPLIMIT - SMTPLIMIT
- INSTANCE_ID - INSTANCE_ID
- MEMCACHEDHOST
- MEMCACHEDPORT
- MEMCACHEDLIMIT
- MEMCACHEDTIMEOUT
- MEMCACHEDROOT
- MEMCACHEDEXPIRATION
# Use the following to automatically copy your bundle upon creation via `yesod # Use the following to automatically copy your bundle upon creation via `yesod

12
config/settings.yml
View File

@ -34,7 +34,6 @@ log-settings:
minimum-level: "_env:LOGLEVEL:warn" minimum-level: "_env:LOGLEVEL:warn"
destination: "_env:LOGDEST:stderr" destination: "_env:LOGDEST:stderr"
# Debugging # Debugging
auth-dummy-login: "_env:DUMMY_LOGIN:false" auth-dummy-login: "_env:DUMMY_LOGIN:false"
allow-deprecated: "_env:ALLOW_DEPRECATED:false" allow-deprecated: "_env:ALLOW_DEPRECATED:false"
@ -80,7 +79,16 @@ smtp:
pool: pool:
stripes: "_env:SMTPSTRIPES:1" stripes: "_env:SMTPSTRIPES:1"
timeout: "_env:SMTPTIMEOUT:20" 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: user-defaults:
max-favourites: 12 max-favourites: 12

10
messages/uniworx/de.msg
View File

@ -171,7 +171,7 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer 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 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 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 SheetGradingPassBinary: Bestanden/Nicht Bestanden
SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
SheetGradingCount': Anzahl
SheetGradingPoints': Punkte SheetGradingPoints': Punkte
SheetGradingPassing': Bestehen
SheetGradingPassPoints': Bestehen nach Punkten SheetGradingPassPoints': Bestehen nach Punkten
SheetGradingPassBinary': Bestanden/Nicht bestanden SheetGradingPassBinary': Bestanden/Nicht bestanden
@ -388,7 +390,11 @@ SheetTypeBonus grading@SheetGrading: Bonus
SheetTypeNormal grading@SheetGrading: Normal SheetTypeNormal grading@SheetGrading: Normal
SheetTypeInformational grading@SheetGrading: Keine Wertung SheetTypeInformational grading@SheetGrading: Keine Wertung
SheetTypeNotGraded: Unbewertet 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 SheetTypeBonus': Bonus
SheetTypeNormal': Normal SheetTypeNormal': Normal

1
package.yaml
View File

@ -111,6 +111,7 @@ dependencies:
- xss-sanitize - xss-sanitize
- text-metrics - text-metrics
- pkcs7 - pkcs7
- memcached-binary
other-extensions: other-extensions:
- GeneralizedNewtypeDeriving - GeneralizedNewtypeDeriving

2
routes
View File

@ -26,7 +26,7 @@
-- !deprecated -- like free, but logs and gives a warning; entirely disabled in production -- !deprecated -- like free, but logs and gives a warning; entirely disabled in production
-- !development -- like free, but only for development builds -- !development -- like free, but only for development builds
/static StaticR Static appStatic !free /static StaticR EmbeddedStatic appStatic !free
/auth AuthR Auth getAuth !free /auth AuthR Auth getAuth !free
/favicon.ico FaviconR GET !free /favicon.ico FaviconR GET !free

18
src/Application.hs
View File

@ -69,6 +69,8 @@ import Data.Proxy
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import System.Exit (exitFailure) import System.Exit (exitFailure)
import qualified Database.Memcached.Binary.IO as Memcached
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.) -- (HPack takes care to add new modules to our cabal file nowadays.)
@ -125,7 +127,7 @@ makeFoundation appSettings@AppSettings{..} = do
(tVar, ) <$> fork (updateLogger initialSettings) (tVar, ) <$> fork (updateLogger initialSettings)
appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet)) 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 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 -- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function -- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation. -- 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 -- The UniWorX {..} syntax is an example of record wild cards. For more
-- information, see: -- information, see:
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html -- 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 "cryptoIDKey forced in tempFoundation")
(error "sessionKey forced in tempFoundation") (error "sessionKey forced in tempFoundation")
(error "secretBoxKey forced in tempFoundation") (error "secretBoxKey forced in tempFoundation")
(error "widgetMemcached forced in tempFoundation")
logFunc loc src lvl str = do logFunc loc src lvl str = do
f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger) f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger)
f loc src lvl str f loc src lvl str
@ -157,6 +160,8 @@ makeFoundation appSettings@AppSettings{..} = do
smtpPool <- traverse createSmtpPool appSmtpConf smtpPool <- traverse createSmtpPool appSmtpConf
appWidgetMemcached <- traverse createWidgetMemcached appWidgetMemcachedConf
-- Create the database connection pool -- Create the database connection pool
sqlPool <- createPostgresqlPool sqlPool <- createPostgresqlPool
(pgConnStr appDatabaseConf) (pgConnStr appDatabaseConf)
@ -168,7 +173,7 @@ makeFoundation appSettings@AppSettings{..} = do
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `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 handleJobs foundation
@ -234,6 +239,9 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
return conn return conn
liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit 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 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares. -- applying some additional middlewares.
makeApplication :: MonadIO m => UniWorX -> m Application makeApplication :: MonadIO m => UniWorX -> m Application
@ -348,6 +356,10 @@ getApplicationRepl = do
shutdownApp :: MonadIO m => UniWorX -> m () shutdownApp :: MonadIO m => UniWorX -> m ()
shutdownApp app = do shutdownApp app = do
stopJobCtl app stopJobCtl app
liftIO $ do
for_ (appWidgetMemcached app) Memcached.close
for_ (appSmtpPool app) destroyAllResources
destroyAllResources $ appConnPool app
release . fst $ appLogger app release . fst $ appLogger app

103
src/Foundation.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto {-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto
module Foundation where module Foundation where
@ -6,7 +7,6 @@ module Foundation where
import Import.NoFoundation import Import.NoFoundation
import Database.Persist.Sql (ConnectionPool, runSqlPool) import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet (hamletFile) import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
import qualified Web.ClientSession as ClientSession import qualified Web.ClientSession as ClientSession
@ -18,7 +18,6 @@ import Jobs.Types
import qualified Network.Wai as W (pathInfo) import qualified Network.Wai as W (pathInfo)
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger) import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Core.Unsafe as Unsafe
import Data.CaseInsensitive (CI) 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 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 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
display = display . ciphertext display = display . ciphertext
@ -96,19 +98,20 @@ instance DisplayAble SchoolId where
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
-- access to the data present here. -- access to the data present here.
data UniWorX = UniWorX data UniWorX = UniWorX
{ appSettings :: AppSettings { appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving. , appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool. , appConnPool :: ConnectionPool -- ^ Database connection pool.
, appSmtpPool :: Maybe SMTPPool , appSmtpPool :: Maybe SMTPPool
, appHttpManager :: Manager , appWidgetMemcached :: Maybe Memcached.Connection
, appLogger :: (ReleaseKey, TVar Logger) , appHttpManager :: Manager
, appLogSettings :: TVar LogSettings , appLogger :: (ReleaseKey, TVar Logger)
, appCryptoIDKey :: CryptoIDKey , appLogSettings :: TVar LogSettings
, appInstanceID :: InstanceId , appCryptoIDKey :: CryptoIDKey
, appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) , appInstanceID :: InstanceId
, appCronThread :: TMVar (ReleaseKey, ThreadId) , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl))
, appSessionKey :: ClientSession.Key , appCronThread :: TMVar (ReleaseKey, ThreadId)
, appSecretBoxKey :: SecretBox.Key , appSessionKey :: ClientSession.Key
, appSecretBoxKey :: SecretBox.Key
} }
type SMTPPool = Pool SMTPConnection type SMTPPool = Pool SMTPConnection
@ -142,7 +145,7 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr
pattern CSubmissionR tid ssh csh shn cid ptn pattern CSubmissionR tid ssh csh shn cid ptn
= CSheetR tid ssh csh shn (SubmissionR cid ptn) = CSheetR tid ssh csh shn (SubmissionR cid ptn)
-- Messages -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
mkMessage "UniWorX" "messages/uniworx" "de" mkMessage "UniWorX" "messages/uniworx" "de"
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de" mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
@ -222,6 +225,16 @@ instance RenderMessage UniWorX SheetType where
newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>) 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 -- Menus and Favourites
data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary
@ -441,7 +454,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
&& NTop systemMessageTo >= cTime && NTop systemMessageTo >= cTime
return Authorized return Authorized
r -> $unsupportedAuthPredicate "time" r r -> $unsupportedAuthPredicate AuthTime r
tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
@ -454,14 +467,14 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
return Authorized return Authorized
r -> $unsupportedAuthPredicate "registered" r r -> $unsupportedAuthPredicate AuthRegistered r
tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ NTop courseCapacity > NTop (Just registered) guard $ NTop courseCapacity > NTop (Just registered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate "capacity" r r -> $unsupportedAuthPredicate AuthCapacity r
tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh -- 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 ] registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ registered <= 0 guard $ registered <= 0
return Authorized return Authorized
r -> $unsupportedAuthPredicate "empty" r r -> $unsupportedAuthPredicate AuthEmpty r
tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
guard courseMaterialFree guard courseMaterialFree
return Authorized return Authorized
r -> $unsupportedAuthPredicate "materials" r r -> $unsupportedAuthPredicate AuthMaterials r
tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
return Authorized return Authorized
r -> $unsupportedAuthPredicate "owner" r r -> $unsupportedAuthPredicate AuthOwner r
tagAccessPredicate AuthRated = APDB $ \route _ -> case route of tagAccessPredicate AuthRated = APDB $ \route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
sub <- MaybeT $ get sid sub <- MaybeT $ get sid
guard $ submissionRatingDone sub guard $ submissionRatingDone sub
return Authorized return Authorized
r -> $unsupportedAuthPredicate "rated" r r -> $unsupportedAuthPredicate AuthRated r
tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == UserSubmissions guard $ sheetSubmissionMode == UserSubmissions
return Authorized return Authorized
r -> $unsupportedAuthPredicate "user-submissions" r r -> $unsupportedAuthPredicate AuthUserSubmissions r
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == CorrectorSubmissions guard $ sheetSubmissionMode == CorrectorSubmissions
return Authorized return Authorized
r -> $unsupportedAuthPredicate "corrector-submissions" r r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- decrypt cID smId <- decrypt cID
@ -511,7 +524,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
isAuthenticated <- isJust <$> liftHandlerT maybeAuthId isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized return Authorized
r -> $unsupportedAuthPredicate "authentication" r r -> $unsupportedAuthPredicate AuthAuthentication r
tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite) tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized) tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
@ -704,21 +717,16 @@ instance Yesod UniWorX where
isAuthorized = evalAccess isAuthorized = evalAccess
-- This function creates static content files in the static folder addStaticContent ext _mime content = do
-- and names them based on a hash of their content. This allows UniWorX{appWidgetMemcached, appSettings} <- getYesod
-- expiration dates to be set far in the future without worry of for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
-- users receiving stale content. let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
addStaticContent ext mime content = do touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
master <- getYesod add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
let staticDir = appStaticDir $ appSettings master absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
addStaticContentExternal C.catchIf Memcached.isKeyNotFound touch $ \_ ->
minifym C.handleIf Memcached.isKeyExists (\_ -> return ()) add
genFileName return . Left $ pack absoluteLink
staticDir
(StaticR . flip StaticRoute [])
ext
mime
content
where where
-- Generate a unique filename based on the content itself, this is used -- Generate a unique filename based on the content itself, this is used
-- for deduplication so a collision resistant hash function is required -- 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 -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
-- padding after base64-conversion -- padding after base64-conversion
genFileName lbs = Text.unpack fileName = (<.> unpack ext)
. Text.decodeUtf8 . unpack
. Base64.encode . decodeUtf8
. (convert :: Digest (SHAKE256 144) -> ByteString) . Base64.encode
. runIdentity . (convert :: Digest (SHAKE256 144) -> ByteString)
$ sourceList (Lazy.ByteString.toChunks lbs) $$ sinkHash . runIdentity
$ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash
-- What messages should be logged. The following includes all messages when -- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production. -- in development, and warnings and errors in production.

6
src/Handler/Common.hs
View File

@ -2,7 +2,7 @@
module Handler.Common where module Handler.Common where
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
import Import import Import hiding (embedFile)
-- These handlers embed files in the executable at compile time to avoid a -- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency. -- runtime dependency, and for efficiency.
@ -10,8 +10,8 @@ import Import
getFaviconR :: Handler TypedContent getFaviconR :: Handler TypedContent
getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
return $ TypedContent "image/x-icon" return $ TypedContent "image/x-icon"
$ toContent $(embedFile "embedded/favicon.ico") $ toContent $(embedFile "static/favicon.ico")
getRobotsR :: Handler TypedContent getRobotsR :: Handler TypedContent
getRobotsR = return $ TypedContent typePlain getRobotsR = return $ TypedContent typePlain
$ toContent $(embedFile "embedded/robots.txt") $ toContent $(embedFile "static/robots.txt")

262
src/Handler/Corrections.hs
View File

@ -7,18 +7,20 @@ import Jobs
import Handler.Utils import Handler.Utils
import Handler.Utils.Submission import Handler.Utils.Submission
import Handler.Utils.Table.Cells import Handler.Utils.Table.Cells
import Handler.Utils.SheetType
-- import Handler.Utils.Zip -- import Handler.Utils.Zip
import Utils.Lens import Utils.Lens
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Map (Map) import Data.Map (Map, (!))
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Semigroup (Sum(..)) import Data.Semigroup (Sum(..))
import Data.Monoid (All(..))
-- import Data.Time -- import Data.Time
-- import qualified Data.Text as T -- import qualified Data.Text as T
@ -45,7 +47,8 @@ import Database.Persist.Sql (updateWhereCount)
import Data.List (genericLength) 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) 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) => 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))
(expr (Entity Course), expr (Entity Sheet), expr (Entity Submission)) type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
-> 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 CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym)) 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 :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm) colTerm = sortable (Just "term") (i18nCell MsgTerm)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } -> $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
@ -94,6 +105,10 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
shn = sheetName $ entityVal sheet shn = sheetName $ entityVal sheet
in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] 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 :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty
@ -116,7 +131,7 @@ colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) 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 csh = course ^. _2
tid = course ^. _3 tid = course ^. _3
ssh = course ^. _4 ssh = course ^. _4
@ -138,6 +153,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(
tid = course ^. _3 tid = course ^. _3
ssh = course ^. _4 ssh = course ^. _4
-- shn = sheetName -- shn = sheetName
mkRoute = do mkRoute = do
cid <- encrypt subId cid <- encrypt subId
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR 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)) (\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 ) 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 makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do dbtSQLQuery = correctionsTableQuery whereClause
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName)
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse , course E.^. CourseShorthand
E.where_ $ whereClause (course,sheet,submission) , course E.^. CourseTerm
let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName) , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
, course E.^. CourseShorthand )
, course E.^. CourseTerm in (submission, sheet, crse, corrector)
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) )
)
return (submission, sheet, crse, corrector)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData 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 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 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.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId 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) return (user, pseudonym E.?. SheetPseudonymPseudonym)
let let
submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors 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" , ( "assignedtime"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned , 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 , dbtFilter = Map.fromList
[ ( "term" [ ( "term"
@ -356,9 +378,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
redirect currentRoute 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 fmap toTypedContent . defaultLayout $ do
setTitleI MsgCourseCorrectionsTitle setTitleI MsgCourseCorrectionsTitle
$(widgetFile "corrections") $(widgetFile "corrections")
where where
authorizedToAssign :: SubmissionId -> DB Bool authorizedToAssign :: SubmissionId -> DB Bool
authorizedToAssign sId = do authorizedToAssign sId = do
@ -641,81 +670,96 @@ postCorrectionsCreateR = do
FormMissing -> return () FormMissing -> return ()
FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess (sid, (pss, invalids)) -> do FormSuccess (sid, (pss, invalids)) -> do
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet") allDone <- fmap getAll . execWriterT $ do
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
runDB $ do tell . All $ null invalids
Sheet{..} <- get404 sid
(sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) WriterT . runDB . mapReaderT runWriterT $ do
forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText Sheet{..} <- get404 sid
now <- liftIO getCurrentTime (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
let forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
sps' :: [[SheetPseudonym]] tell . All $ null unknown
duplicate :: Set Pseudonym now <- liftIO getCurrentTime
( sps' let
, Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate sps' :: [[SheetPseudonym]]
) = 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 duplicate :: Set Pseudonym
known <- State.gets $ Map.member sheetPseudonymPseudonym ( sps'
State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
return $ bool (p :) id known ps ) = 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
submissionPrototype = Submission known <- State.gets $ Map.member sheetPseudonymPseudonym
{ submissionSheet = sid State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
, submissionRatingPoints = Nothing return $ bool (p :) id known ps
, submissionRatingComment = Nothing submissionPrototype = Submission
, submissionRatingBy = Just uid { submissionSheet = sid
, submissionRatingAssigned = Just now , submissionRatingPoints = Nothing
, submissionRatingTime = Nothing , submissionRatingComment = Nothing
} , submissionRatingBy = Just uid
unless (null duplicate) , submissionRatingAssigned = Just now
$(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet") , submissionRatingTime = Nothing
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
} }
when (genericLength spGroup > maxSize) $ unless (null duplicate)
addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
RegisteredGroups -> do existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
groups <- E.select . E.from $ \submissionGroup -> do E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.where_ . E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) E.&&. submission E.^. SubmissionSheet E.==. E.val sid
return $ submissionGroup E.^. SubmissionGroupId return submissionUser
if unless (null existingSubUsers) . mapReaderT lift $ do
| length (groups :: [E.Value SubmissionGroupId]) < 2 (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
-> do $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
subId <- insert submissionPrototype let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
void . insert $ SubmissionEdit uid now subId forM_ sps'' $ \spGroup
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser -> let
{ submissionUserUser = sheetPseudonymUser sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
, submissionUserSubmission = subId in case sheetGrouping of
} Arbitrary maxSize -> do
when (null groups) $ subId <- insert submissionPrototype
addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc void . insert $ SubmissionEdit uid now subId
| otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
NoGroups -> do { submissionUserUser = sheetPseudonymUser
subId <- insert submissionPrototype , submissionUserSubmission = subId
void . insert $ SubmissionEdit uid now subId }
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser when (genericLength spGroup > maxSize) $
{ submissionUserUser = sheetPseudonymUser addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
, submissionUserSubmission = subId RegisteredGroups -> do
} let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup
when (length spGroup > 1) $ groups <- E.select . E.from $ \submissionGroup -> do
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc E.where_ . E.exists . E.from $ \submissionGroupUser ->
redirect CorrectionsGradeR 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 $ defaultLayout $

48
src/Handler/Sheet.hs
View File

@ -6,6 +6,7 @@ import System.FilePath (takeFileName)
import Handler.Utils import Handler.Utils
-- import Handler.Utils.Zip -- import Handler.Utils.Zip
import Handler.Utils.Table.Cells import Handler.Utils.Table.Cells
import Handler.Utils.SheetType
-- import Data.Time -- import Data.Time
-- import qualified Data.Text as T -- import qualified Data.Text as T
@ -41,7 +42,7 @@ import qualified Data.Map as Map
import Data.Map (Map, (!?)) import Data.Map (Map, (!?))
import Data.Monoid (Sum(..), Any(..)) import Data.Monoid (Any(..))
-- import Control.Lens -- import Control.Lens
import Utils.Lens import Utils.Lens
@ -62,7 +63,7 @@ data SheetForm = SheetForm
{ sfName :: SheetName { sfName :: SheetName
, sfDescription :: Maybe Html , sfDescription :: Maybe Html
, sfType :: SheetType , sfType :: SheetType
, sfGrouping :: SheetGroup , sfGrouping :: SheetGroup
, sfVisibleFrom :: Maybe UTCTime , sfVisibleFrom :: Maybe UTCTime
, sfActiveFrom :: UTCTime , sfActiveFrom :: UTCTime
, sfActiveTo :: UTCTime , sfActiveTo :: UTCTime
@ -97,8 +98,9 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
<$> areq ciField (fslI MsgSheetName) (sfName <$> template) <$> areq ciField (fslI MsgSheetName) (sfName <$> template)
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
<*> sheetTypeAFormReq (fslI MsgSheetType <*> sheetTypeAFormReq (fslI MsgSheetType
& setTooltip MsgSheetTypeInfo) (sfType <$> template) & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) (sfType <$> template)
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom <*> aopt utcTimeField (fslI MsgSheetVisibleFrom
& setTooltip MsgSheetVisibleFromTip) & setTooltip MsgSheetVisibleFromTip)
((sfVisibleFrom <$> template) <|> pure (Just ctime)) ((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 SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
<* submitButton <* submitButton
return $ case result of return $ case result of
FormSuccess sheetResult FormSuccess sheetResult
@ -137,7 +139,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
] ] ] ]
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid ssh csh = do getSheetListR tid ssh csh = do
muid <- maybeAuthId muid <- maybeAuthId
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
let let
@ -152,18 +154,19 @@ getSheetListR tid ssh csh = do
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet, lastSheetEdit sheet, submission) return (sheet, lastSheetEdit sheet, submission)
sheetCol = widgetColonnade . mconcat $ sheetCol = widgetColonnade . mconcat $
[ sortable (Just "name") (i18nCell MsgSheet) [ dbRow
$ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) , sortable (Just "name") (i18nCell MsgSheet)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
, sortable (Just "last-edit") (i18nCell MsgLastEdit) , 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) , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
$ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveFrom
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
$ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveTo
, sortable Nothing (i18nCell MsgSheetType) , sortable Nothing (i18nCell MsgSheetType)
$ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> i18nCell sheetType
, sortable Nothing (i18nCell MsgSubmission) , sortable Nothing (i18nCell MsgSubmission)
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
Nothing -> mempty Nothing -> mempty
(Just (Entity sid Submission{..})) -> (Just (Entity sid Submission{..})) ->
let mkCid = encrypt sid -- TODO: executed twice let mkCid = encrypt sid -- TODO: executed twice
@ -172,7 +175,7 @@ getSheetListR tid ssh csh = do
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|]) in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
, sortable (Just "rating") (i18nCell MsgRating) , sortable (Just "rating") (i18nCell MsgRating)
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
Nothing -> mempty Nothing -> mempty
(Just (Entity sid Submission{..})) -> (Just (Entity sid Submission{..})) ->
let mkCid = encrypt sid let mkCid = encrypt sid
@ -180,15 +183,15 @@ getSheetListR tid ssh csh = do
cid' <- mkCid cid' <- mkCid
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
in anchorCellM mkRoute $(widgetFile "widgets/rating") in anchorCellM mkRoute $(widgetFile "widgets/rating")
, sortable Nothing -- (Just "percent") , sortable Nothing -- (Just "percent")
(i18nCell MsgRatingPercent) (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})) -> (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
case preview (_grading . _maxPoints) sType of case preview (_grading . _maxPoints) sType of
Just maxPoints Just maxPoints
| maxPoints /= 0 -> | maxPoints /= 0 ->
let percent = sPoints / maxPoints let percent = sPoints / maxPoints
in textCell $ textPercent $ realToFrac percent in textCell $ textPercent $ realToFrac percent
_other -> mempty _other -> mempty
_other -> mempty _other -> mempty
] ]
@ -197,8 +200,8 @@ getSheetListR tid ssh csh = do
table <- runDB $ dbTableWidget' psValidator DBTable table <- runDB $ dbTableWidget' psValidator DBTable
{ dbtSQLQuery = sheetData { dbtSQLQuery = sheetData
, dbtColonnade = sheetCol , dbtColonnade = sheetCol
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False) -> dbr <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "name" [ ( "name"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
@ -228,7 +231,7 @@ getSheetListR tid ssh csh = do
, dbtIdent = "sheets" :: Text , dbtIdent = "sheets" :: Text
} }
-- Collect summary over all Sheets, not just the ones shown due to pagination: -- 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 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 $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet 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 return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
defaultLayout $ do defaultLayout $ do
$(widgetFile "sheetList") $(widgetFile "sheetList")
$(widgetFile "widgets/sheetTypeSummary")
data ButtonGeneratePseudonym = BtnGenerate data ButtonGeneratePseudonym = BtnGenerate
deriving (Enum, Eq, Ord, Bounded, Read, Show) deriving (Enum, Eq, Ord, Bounded, Read, Show)
@ -398,7 +400,7 @@ getSheetNewR tid ssh csh = do
{ sfName = stepTextCounterCI sheetName { sfName = stepTextCounterCI sheetName
, sfDescription = sheetDescription , sfDescription = sheetDescription
, sfType = sheetType , sfType = sheetType
, sfGrouping = sheetGrouping , sfGrouping = sheetGrouping
, sfVisibleFrom = addOneWeek <$> sheetVisibleFrom , sfVisibleFrom = addOneWeek <$> sheetVisibleFrom
, sfActiveFrom = addOneWeek sheetActiveFrom , sfActiveFrom = addOneWeek sheetActiveFrom
, sfActiveTo = addOneWeek sheetActiveTo , sfActiveTo = addOneWeek sheetActiveTo
@ -431,7 +433,7 @@ getSEditR tid ssh csh shn = do
{ sfName = sheetName { sfName = sheetName
, sfDescription = sheetDescription , sfDescription = sheetDescription
, sfType = sheetType , sfType = sheetType
, sfGrouping = sheetGrouping , sfGrouping = sheetGrouping
, sfVisibleFrom = sheetVisibleFrom , sfVisibleFrom = sheetVisibleFrom
, sfActiveFrom = sheetActiveFrom , sfActiveFrom = sheetActiveFrom
, sfActiveTo = sheetActiveTo , sfActiveTo = sheetActiveTo

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

@ -263,7 +263,7 @@ multiFileField permittedFiles' = Field{..}
pVals <- lift permittedFiles' pVals <- lift permittedFiles'
let let
decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId) decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
yieldMany vals yieldMany vals
.| C.filter (/= unpackZips) .| C.filter (/= unpackZips)
.| C.map fromPathPiece .| C.catMaybes .| C.map fromPathPiece .| C.catMaybes
@ -288,7 +288,7 @@ multiFileField permittedFiles' = Field{..}
let fuiChecked let fuiChecked
| Right sentVals' <- sentVals = fuiId' `elem` sentVals' | Right sentVals' <- sentVals = fuiId' `elem` sentVals'
| otherwise = True | otherwise = True
return FileUploadInfo{..} return FileUploadInfo{..}
fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals) E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
E.orderBy [E.asc $ file E.^. FileTitle] E.orderBy [E.asc $ file E.^. FileTitle]
@ -303,13 +303,13 @@ multiFileField permittedFiles' = Field{..}
data SheetGrading' = Points' | PassPoints' | PassBinary' data SheetGrading' = Points' | PassPoints' | PassBinary'
deriving (Eq, Ord, Read, Show, Enum, Bounded) deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance Universe SheetGrading' instance Universe SheetGrading'
instance Finite SheetGrading' instance Finite SheetGrading'
nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'") nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>) embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
data SheetType' = Bonus' | Normal' | Informational' | NotGraded' data SheetType' = Bonus' | Normal' | Informational' | NotGraded'
@ -319,7 +319,7 @@ instance Universe SheetType'
instance Finite SheetType' instance Finite SheetType'
nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'") nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>) embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)
data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups' data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
@ -333,31 +333,31 @@ embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template) sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
where where
selOptions = Map.fromList selOptions = Map.fromList
[ ( Points', Points <$> maxPointsReq ) [ ( Points', Points <$> maxPointsReq )
, ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq ) , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
, ( PassBinary', pure PassBinary) , ( PassBinary', pure PassBinary)
] ]
classify' :: SheetGrading -> SheetGrading' classify' :: SheetGrading -> SheetGrading'
classify' = \case classify' = \case
Points {} -> Points' Points {} -> Points'
PassPoints {} -> PassPoints' PassPoints {} -> PassPoints'
PassBinary {} -> PassBinary' 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) passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints)
sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template) sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
where where
selOptions = Map.fromList selOptions = Map.fromList
[ ( Bonus' , Bonus <$> gradingReq ) [ ( Bonus' , Bonus <$> gradingReq )
, ( Normal', Normal <$> gradingReq ) , ( Normal', Normal <$> gradingReq )
, ( Informational', Informational <$> gradingReq ) , ( Informational', Informational <$> gradingReq )
, ( NotGraded', pure NotGraded ) , ( NotGraded', pure NotGraded )
] ]
gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
& setTooltip MsgSheetGradingInfo) (template >>= preview _grading) & setTooltip MsgSheetGradingInfo) (template >>= preview _grading)
@ -440,8 +440,8 @@ utcTimeField = Field
fieldTimeFormat :: String fieldTimeFormat :: String
--fieldTimeFormat = "%e.%m.%y %k:%M" --fieldTimeFormat = "%e.%m.%y %k:%M"
fieldTimeFormat = "%Y-%m-%dT%H:%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 :: Text -> Either UniWorXMessage UTCTime
readTime t = readTime t =
case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
@ -595,7 +595,7 @@ formResultModal res finalDest handler = maybeT_ $ do
FormMissing -> mzero FormMissing -> mzero
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero
FormSuccess val -> lift . execWriterT $ handler val FormSuccess val -> lift . execWriterT $ handler val
isModal <- hasCustomHeader HeaderIsModal isModal <- hasCustomHeader HeaderIsModal
if if
| isModal -> sendResponse $ toJSON messages | isModal -> sendResponse $ toJSON messages

14
src/Handler/Utils/Rating.hs
View File

@ -41,7 +41,7 @@ import qualified Database.Esqueleto as E
import qualified Data.Conduit.List as Conduit import qualified Data.Conduit.List as Conduit
import Utils.Lens hiding ((<.>)) import Utils.Lens
instance HasResolution prec => Pretty (Fixed prec) where instance HasResolution prec => Pretty (Fixed prec) where
@ -51,7 +51,7 @@ instance Pretty x => Pretty (CI x) where
pretty = pretty . CI.original pretty = pretty . CI.original
instance Pretty SheetGrading where instance Pretty SheetGrading where
pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String) pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String)
pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String ) pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String ) pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
@ -59,12 +59,12 @@ instance Pretty SheetGrading where
validateRating :: SheetType -> Rating' -> [RatingException] validateRating :: SheetType -> Rating' -> [RatingException]
validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..} validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
| rp < 0 | rp < 0
= [RatingNegative] = [RatingNegative]
| NotGraded <- ratingSheetType | NotGraded <- ratingSheetType
= [RatingNotExpected] = [RatingNotExpected]
| (Just maxPoints ) <- ratingSheetType ^? _grading . _maxPoints | (Just maxPoints ) <- ratingSheetType ^? _grading . _maxPoints
, rp > maxPoints , rp > maxPoints
= [RatingExceedsMax] = [RatingExceedsMax]
| (Just PassBinary) <- ratingSheetType ^? _grading | (Just PassBinary) <- ratingSheetType ^? _grading
, not (rp == 0 || rp == 1) , not (rp == 0 || rp == 1)
@ -98,7 +98,7 @@ getRating submissionId = runMaybeT $ do
, E.unValue -> ratingComment , E.unValue -> ratingComment
, E.unValue -> ratingTime , E.unValue -> ratingTime
) ] <- lift query ) ] <- lift query
return Rating{ ratingValues = Rating'{..}, .. } return Rating{ ratingValues = Rating'{..}, .. }
formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString

39
src/Handler/Utils/SheetType.hs Normal file
View File

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

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

@ -183,7 +183,7 @@ instance Default (PSValidator m x) where
Just pi -> swap . (\act -> execRWS act pi def) $ do Just pi -> swap . (\act -> execRWS act pi def) $ do
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s }) asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f }) asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
l <- asks piLimit l <- asks piLimit
case l of case l of
Just l' Just l'
@ -258,7 +258,7 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
data DBCell m x :: * data DBCell m x :: *
dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget) dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x) -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
-- | Format @DBTable@ when sort-circuiting -- | Format @DBTable@ when sort-circuiting
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget 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 dbCell = iso
(\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents)) (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
(uncurry WidgetCell) (uncurry WidgetCell)
-- dbWidget Proxy Proxy = iso (, ()) $ view _1 -- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget _ _ = return . snd dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f dbHandler _ _ f = return . over _2 f
@ -331,7 +331,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
dbCell = iso dbCell = iso
(\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents)) (\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents))
(\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget) (\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget)
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi 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 instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
mempty = FormCell mempty (return mempty) mempty = FormCell mempty (return mempty)
(FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c') (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')
instance IsDBTable m a => IsString (DBCell m a) where instance IsDBTable m a => IsString (DBCell m a) where
fromString = cell . fromString fromString = cell . fromString
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x) 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 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" , fieldView = error "multiTextField: should not be rendered"
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
piResult <- lift . runInputGetResult $ PaginationInput piResult <- lift . runInputGetResult $ PaginationInput
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") <$> 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) <*> (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 -- Predefined colonnades
--Number column?
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) 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 dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex

4
src/Import/NoFoundation.hs
View File

@ -3,7 +3,7 @@ module Import.NoFoundation
, MForm , MForm
) where ) 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 as Import
import Model.Types.JSON as Import import Model.Types.JSON as Import
import Model.Migration as Import import Model.Migration as Import
@ -35,10 +35,12 @@ import Mail as Import
import Data.Data as Import (Data) import Data.Data as Import (Data)
import Data.Typeable as Import (Typeable) import Data.Typeable as Import (Typeable)
import GHC.Generics as Import (Generic) import GHC.Generics as Import (Generic)
import GHC.Exts as Import (IsList)
import Data.Hashable as Import import Data.Hashable as Import
import Data.List.NonEmpty as Import (NonEmpty(..)) import Data.List.NonEmpty as Import (NonEmpty(..))
import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Semigroup)
import Control.Monad.Morph as Import (MFunctor(..)) import Control.Monad.Morph as Import (MFunctor(..))

14
src/Jobs.hs
View File

@ -134,6 +134,7 @@ execCrontab = evalStateT go HashMap.empty
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
refT <- liftIO getCurrentTime refT <- liftIO getCurrentTime
settings <- getsYesod appSettings
currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
case crontab' of case crontab' of
@ -141,7 +142,7 @@ execCrontab = evalStateT go HashMap.empty
Just crontab -> Just <$> do Just crontab -> Just <$> do
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
prevExec <- State.get prevExec <- State.get
case earliestJob prevExec crontab refT of case earliestJob settings prevExec crontab refT of
Nothing -> liftBase retry Nothing -> liftBase retry
Just (_, MatchNone) -> liftBase retry Just (_, MatchNone) -> liftBase retry
Just x -> return (crontab, x) Just x -> return (crontab, x)
@ -189,6 +190,11 @@ execCrontab = evalStateT go HashMap.empty
acc :: NominalDiffTime acc :: NominalDiffTime
acc = 1e-3 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 :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
applyJitter seed t = do applyJitter seed t = do
appInstance <- getsYesod appInstanceID appInstance <- getsYesod appInstanceID
@ -197,8 +203,8 @@ execCrontab = evalStateT go HashMap.empty
diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed) diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
return $ addUTCTime diff t return $ addUTCTime diff t
earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime) earliestJob :: AppSettings -> HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
earliestJob lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab earliestJob settings lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
where where
go' (jobCtl, cron) mbPrev go' (jobCtl, cron) mbPrev
| Just (_, t') <- mbPrev | Just (_, t') <- mbPrev
@ -207,7 +213,7 @@ execCrontab = evalStateT go HashMap.empty
| otherwise | otherwise
= Just (jobCtl, t) = Just (jobCtl, t)
where 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 :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
waitUntil crontabTV crontab nextTime = runResourceT $ do waitUntil crontabTV crontab nextTime = runResourceT $ do

1
src/Model/Rating.hs
View File

@ -2,7 +2,6 @@ module Model.Rating where
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
import Model import Model
-- import Data.Text (Text) -- import Data.Text (Text)
import Data.Text.Encoding.Error (UnicodeException(..)) import Data.Text.Encoding.Error (UnicodeException(..))
import GHC.Generics (Generic) import GHC.Generics (Generic)

37
src/Model/Types.hs
View File

@ -135,10 +135,11 @@ gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints
gradingPassed (PassBinary {}) pts = Just $ pts /= 0 gradingPassed (PassBinary {}) pts = Just $ pts /= 0
data SheetGradeSummary = SheetGradeSummary data SheetGradeSummary = SheetGradeSummary
{ sumGradePoints :: Sum Points { numSheets :: Sum Int
, numGradePasses :: Sum Int , numGradePasses :: Sum Int
, achievedPoints :: Maybe (Sum Points) , sumGradePoints :: Sum Points
, achievedPasses :: Maybe (Sum Int) , achievedPasses :: Maybe (Sum Int)
, achievedPoints :: Maybe (Sum Points)
} deriving (Generic, Read, Show, Eq) } deriving (Generic, Read, Show, Eq)
instance Monoid SheetGradeSummary where instance Monoid SheetGradeSummary where
@ -146,18 +147,25 @@ instance Monoid SheetGradeSummary where
mappend = mappenddefault mappend = mappenddefault
instance Semigroup SheetGradeSummary where 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 :: SheetGrading -> Maybe Points -> SheetGradeSummary
sheetGradeSum gr (Just p) = sheetGradeSum gr (Just p) =
let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p } let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p }
in case gr of PassBinary -> baseSum in case gr of PassBinary -> baseSum
_other -> baseSum { achievedPoints = Just $ Sum $ p } _other -> baseSum { achievedPoints = Just $ Sum $ p }
sheetGradeSum (Points {..}) Nothing = mempty { sumGradePoints = Sum maxPoints } sheetGradeSum (Points {..}) Nothing = mempty { numSheets = Sum 1
sheetGradeSum (PassPoints{..}) Nothing = mempty { sumGradePoints = Sum maxPoints , sumGradePoints = Sum maxPoints
, numGradePasses = Sum 1 } }
sheetGradeSum (PassBinary) Nothing = mempty { numGradePasses = Sum 1 } 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 data SheetType
= Normal { grading :: SheetGrading } = Normal { grading :: SheetGrading }
@ -174,19 +182,26 @@ deriveJSON defaultOptions
derivePersistFieldJSON ''SheetType derivePersistFieldJSON ''SheetType
data SheetTypeSummary = SheetTypeSummary data SheetTypeSummary = SheetTypeSummary
{ normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary { normalSummary
, numNotGraded :: Sum Int , bonusSummary
, informationalSummary :: SheetGradeSummary
, numNotGraded :: Sum Int
} deriving (Generic, Read, Show, Eq) } deriving (Generic, Read, Show, Eq)
instance Monoid SheetTypeSummary where instance Monoid SheetTypeSummary where
mempty = memptydefault mempty = memptydefault
mappend = mappenddefault mappend = mappenddefault
instance Semigroup SheetTypeSummary where
(<>) = mappend -- TODO: remove for GHC > 8.4.x
makeLenses_ ''SheetTypeSummary
sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
sheetTypeSum Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps } sheetTypeSum Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps }
sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps } sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps }
sheetTypeSum Informational{..} mps = mempty { informationalSummary = 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 data SheetGroup
= Arbitrary { maxParticipants :: Natural } = Arbitrary { maxParticipants :: Natural }

44
src/Settings.hs
View File

@ -29,7 +29,7 @@ import Yesod.Default.Util (WidgetFileSettings,
widgetFileReload) widgetFileReload)
import qualified Yesod.Auth.Util.PasswordStore as PWStore import qualified Yesod.Auth.Util.PasswordStore as PWStore
import Data.Time (NominalDiffTime) import Data.Time (NominalDiffTime, nominalDay)
import Data.Scientific (toBoundedInteger) import Data.Scientific (toBoundedInteger)
import Data.Word (Word16) 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.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
import qualified Network.Socket as HaskellNet (PortNumber(..), HostName) import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
import qualified Network
import Network.Mail.Mime (Address) import Network.Mail.Mime (Address)
import Network.Mail.Mime.Instances () import Network.Mail.Mime.Instances ()
import Mail (VerpMode) import Mail (VerpMode)
import qualified Database.Memcached.Binary.Types as Memcached
import Model import Model
import Settings.Cluster import Settings.Cluster
@ -68,6 +71,8 @@ data AppSettings = AppSettings
-- ^ Configuration settings for accessing the LDAP-directory -- ^ Configuration settings for accessing the LDAP-directory
, appSmtpConf :: Maybe SmtpConf , appSmtpConf :: Maybe SmtpConf
-- ^ Configuration settings for accessing a SMTP Mailserver -- ^ Configuration settings for accessing a SMTP Mailserver
, appWidgetMemcachedConf :: Maybe WidgetMemcachedConf
-- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent`
, appRoot :: Maybe Text , appRoot :: Maybe Text
-- ^ Base for all generated URLs. If @Nothing@, determined -- ^ Base for all generated URLs. If @Nothing@, determined
-- from the request headers. -- from the request headers.
@ -167,6 +172,34 @@ data SmtpConf = SmtpConf
, smtpPool :: ResourcePoolConf , smtpPool :: ResourcePoolConf
} deriving (Show) } 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 data ResourcePoolConf = ResourcePoolConf
{ poolStripes :: Int { poolStripes :: Int
, poolTimeout :: NominalDiffTime , poolTimeout :: NominalDiffTime
@ -284,6 +317,15 @@ instance FromJSON AppSettings where
Ldap.Plain host -> not $ null host Ldap.Plain host -> not $ null host
appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap" appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" 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" appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host" appHost <- fromString <$> o .: "host"
appPort <- o .: "port" appPort <- o .: "port"

24
src/Settings/StaticFiles.hs
View File

@ -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 Settings (appStaticDir, compileTimeAppSettings)
import Yesod.Static (staticFiles) import Yesod.EmbeddedStatic
-- This generates easy references to files in the static directory at compile time, -- This generates easy references to files in the static directory at compile time,
-- giving you compile-time verification that referenced files exist. -- giving you compile-time verification that referenced files exist.
-- Warning: any files added to your static directory during run-time can't be -- 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: -- For example, to refer to @static/js/script.js@ via an identifier, you'd use:
-- --
-- js_script_js -- js_script_js
--
-- If the identifier is not available, you may use: #ifdef DEVELOPMENT
-- #define DEV_BOOL True
-- StaticFile ["js", "script.js"] [] #else
staticFiles (appStaticDir compileTimeAppSettings) #define DEV_BOOL False
#endif
mkEmbeddedStatic DEV_BOOL "embeddedStatic" [embedDir $ appStaticDir compileTimeAppSettings]

28
src/Utils.hs
View File

@ -63,6 +63,9 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Saltine.Class as Saltine
import qualified Crypto.Data.PKCS7 as PKCS7 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 (Unauthorized t) = permissionDenied t
guardAuthResult Authorized = return () guardAuthResult Authorized = return ()
data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route data UnsupportedAuthPredicate route = UnsupportedAuthPredicate Text route
deriving (Eq, Ord, Typeable, Show) deriving (Eq, Ord, Typeable, Show)
instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route) instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)
@ -95,8 +98,8 @@ unsupportedAuthPredicate :: ExpQ
unsupportedAuthPredicate = do unsupportedAuthPredicate = do
logFunc <- logErrorS logFunc <- logErrorS
[e| \tag route -> do [e| \tag route -> do
$(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|] $(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|]
unauthorizedI (UnsupportedAuthPredicate tag route) unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route)
|] |]
@ -204,15 +207,16 @@ instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out
display = pack . show 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) <> "%" textPercent x = lz <> pack (show rx) <> "%"
where where
round' :: Double -> Int -- avoids annoying warning rx :: Centi
round' = round rx = realToFrac (x * 100)
rx :: Double
rx = fromIntegral (round' $ 1000.0*x) / 10.0
lz = if rx < 10.0 then "0" else "" 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 Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
stepTextCounterCI = CI.map stepTextCounter stepTextCounterCI = CI.map stepTextCounter
@ -317,14 +321,13 @@ toNothing = const Nothing
toNothingS :: String -> Maybe b toNothingS :: String -> Maybe b
toNothingS = const Nothing 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 (Just x) (Just y) = Just (x + y)
maybeAdd Nothing y = y maybeAdd Nothing y = y
maybeAdd x Nothing = x maybeAdd x Nothing = x
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty (Just x) f = f x maybeEmpty = flip foldMap
maybeEmpty Nothing _ = mempty
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x whenIsJust (Just x) f = f x
@ -339,7 +342,7 @@ maybePositive a | a > 0 = Just a
| otherwise = Nothing | otherwise = Nothing
positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive 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 :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM dft act mb = mb >>= maybe dft act 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 compare (NTop (Just x)) (NTop (Just y)) = compare x y
------------ ------------
-- Either -- -- Either --
------------ ------------

2
src/Utils/Lens.hs
View File

@ -1,7 +1,7 @@
module Utils.Lens ( module Utils.Lens ) where module Utils.Lens ( module Utils.Lens ) where
import Import.NoFoundation 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 Control.Lens.Extras as Utils.Lens (is)
import Utils.Lens.TH as Utils.Lens (makeLenses_) import Utils.Lens.TH as Utils.Lens (makeLenses_)

4
stack.yaml
View File

@ -45,4 +45,8 @@ extra-deps:
- quickcheck-classes-0.4.14 - quickcheck-classes-0.4.14
- semirings-0.2.1.1 - semirings-0.2.1.1
- memcached-binary-0.2.0
allow-newer: true
resolver: lts-10.5 resolver: lts-10.5

0
embedded/favicon.ico → static/favicon.ico
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.3 KiB

After

Width:  |  Height:  |  Size: 1.3 KiB

0
embedded/robots.txt → static/robots.txt
View File

4
templates/corrections.hamlet
View File

@ -1,5 +1,7 @@
<div .container> <section>
<form method=POST enctype=#{tableEncoding} action=@{currentRoute}> <form method=POST enctype=#{tableEncoding} action=@{currentRoute}>
^{table} ^{table}
<button type=submit> <button type=submit>
_{MsgBtnSubmit} _{MsgBtnSubmit}
<section>
^{statistics}

5
templates/sheetList.hamlet
View File

@ -1 +1,4 @@
^{table} <section>
^{table}
<section>
^{statistics}

2
templates/standalone/alerts.julius
View File

@ -29,7 +29,7 @@
var iconEl = document.createElement('DIV'); var iconEl = document.createElement('DIV');
var closeEl = document.createElement('DIV'); var closeEl = document.createElement('DIV');
var dataDecay = alertEl.dataset.decay; var dataDecay = alertEl.dataset.decay;
var autoDecay = 30; var autoDecay = 10;
if (dataDecay) { if (dataDecay) {
autoDecay = parseInt(dataDecay, 10); autoDecay = parseInt(dataDecay, 10);
} }

2
templates/standalone/modal.julius
View File

@ -76,7 +76,7 @@
var scriptClone = document.createElement('script'); var scriptClone = document.createElement('script');
if (scriptTag.text) if (scriptTag.text)
scriptClone.text = striptTag.text; scriptClone.text = scriptTag.text;
if (scriptTag.hasAttributes()) { if (scriptTag.hasAttributes()) {
var attrs = scriptTag.attributes; var attrs = scriptTag.attributes;
for (var i = attrs.length - 1; i >= 0; i--) { for (var i = attrs.length - 1; i >= 0; i--) {

30
templates/widgets/gradingSummary.hamlet Normal file
View File

@ -0,0 +1,30 @@
$# Displays gradings Summary for various purposes
$# --
<div>
<h3>_{title $ getSum $ numSheets $ sumSummaries}
<table .table .table--striped>
<tr .table__row .table__row--head>
<th>
$# empty cell for row headers
$maybe _ <- hasPassings
<th .table__th colspan=2>_{MsgSheetGradingPassing'}
$maybe _ <- hasPoints
<th .table__th colspan=2>_{MsgSheetGradingPoints'}
<th .table__th>_{MsgSheetGradingCount'}
$# Number of Sheet/Submissions used for calculating maximum passes/points
$forall row <- rowWdgts
^{row}
$maybe nrNoGrade <- positiveSum $ numNotGraded
<tr .table__row>
<th .table__th>_{MsgSheetTypeNotGraded}
$maybe _ <- hasPassings
<td colspan=2>
$maybe _ <- hasPoints
<td .table__td colspan=2>
<td .table__td>#{display nrNoGrade}
$maybe _ <- positiveSum $ bonusSummary ^. _numSheets
<p>_{MsgSheetTypeInfoBonus}
$maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
_{MsgSheetGradingBonusIncluded}
$maybe _ <- positiveSum $ informationalSummary ^. _numSheets
<p>_{MsgSheetTypeInfoNotGraded}

33
templates/widgets/gradingSummaryRow.hamlet Normal file
View File

@ -0,0 +1,33 @@
$# Displays one row of the grading summary
$# Expects several variables:
$# hasPassing :: Maybe Int -- Should Passing be displayed?
$# hasPoints :: Maybe Poibts -- Should Points be displayed?
$# summary :: SheetGradeSummary -- summary to display
$# sumHeader :: UniWorXMessage -- row header
$#
$maybe nrSheets <- positiveSum $ summary ^. _numSheets
<tr .table__row >
<th .table__th>_{sumHeader}
$maybe _ <- hasPassings
$with Sum pmax <- summary ^. _numGradePasses
$maybe Sum pacv <- summary ^. _achievedPasses
<td .table__td>
$if pmax /= 0
#{textPercentInt pacv pmax}
<td .table__td>
#{display pacv} / #{display pmax}
$nothing
<td .table__td colspan=2>
#{display pmax }
$maybe _ <- hasPoints
$with Sum pmax <- summary ^. _sumGradePoints
$maybe Sum pacv <- summary ^. _achievedPoints
<td .table__td>
$if pmax /= 0
#{textPercent $ realToFrac $ pacv / pmax}
<td .table__td>
#{display pacv} / #{display pmax}
$nothing
<td .table__td colspan=2>
#{display pmax }
<td .table__td>#{display nrSheets}

17
templates/widgets/rating.hamlet
View File

@ -3,18 +3,19 @@ $# submissionRatingPoints :: Maybe points
$maybe points <- submissionRatingPoints $maybe points <- submissionRatingPoints
$maybe grading <- preview _grading sheetType $maybe grading <- preview _grading sheetType
$case grading $case grading
$of Points{..} $of Points{..}
_{MsgAchievedOf points maxPoints} _{MsgAchievedOf points maxPoints}
$of PassPoints{} $of PassPoints{maxPoints}
$if fromMaybe False (gradingPassed grading points) $if fromMaybe False (gradingPassed grading points)
_{MsgPassed} _{MsgPassed}, _{MsgAchievedOf points maxPoints}
$else $else
_{MsgNotPassed} _{MsgNotPassed}, _{MsgAchievedOf points maxPoints}
$of PassBinary $of PassBinary
$if fromMaybe False (gradingPassed grading points) $if fromMaybe False (gradingPassed grading points)
_{MsgPassed} _{MsgPassed}
$else $else
_{MsgNotPassed} _{MsgNotPassed}
, _{SheetTypeHeader sheetType}
$nothing $nothing
#{tickmarkS} #{tickmarkS}

22
templates/widgets/sheetTypeSummary.hamlet
View File

@ -1,9 +1,9 @@
$with realGrades <- normalSummary <> bonusSummary $# DEPRECATED IN FAVOUR OF widgets/gradingSummary.hamlet DO NOT USE !!!
$with realGrades <- normalSummary <> bonusSummary
$# $with allGrades <- realGrades <> informationalSummary $# $with allGrades <- realGrades <> informationalSummary
<div> <div>
<ul> $maybe realPoints <- positiveSum (sumGradePoints realGrades)
$maybe realPoints <- positiveSum (sumGradePoints realGrades) <p>
<li>
Gesamtpunktzahl #{display realPoints} Gesamtpunktzahl #{display realPoints}
$maybe nPts <- getSum <$> achievedPoints realGrades $maybe nPts <- getSum <$> achievedPoints realGrades
\ davon #{display nPts} erreicht \ davon #{display nPts} erreicht
@ -13,21 +13,21 @@ $with realGrades <- normalSummary <> bonusSummary
von #{display achievedBonus} erreichbaren # von #{display achievedBonus} erreichbaren #
Bonuspunkten) Bonuspunkten)
$if realPoints /= 0 $if realPoints /= 0
\ #{textPercent $ realToFrac $ nPts / realPoints} \ #{textPercent $ realToFrac $ nPts / realPoints}
\. \.
$maybe fakePoints <- positiveSum (sumGradePoints informationalSummary) $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
<li> <p>
<em>Hinweis: <em>Hinweis:
\ #{display fakePoints} Punkte gab es für Aufgabenblätter, # \ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
welche nicht gewertet wurden, sondern nur informativen Charakter besitzen welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
$maybe achievedFakes <- getSum <$> achievedPoints informationalSummary $maybe achievedFakes <- getSum <$> achievedPoints informationalSummary
, davon wurden #{display achievedFakes} erreicht , davon wurden #{display achievedFakes} erreicht
$if fakePoints /= 0 $if fakePoints /= 0
\ #{textPercent $ realToFrac $ achievedFakes / fakePoints} \ #{textPercent $ realToFrac $ achievedFakes / fakePoints}
\. \.
$maybe reqPasses <- positiveSum (numGradePasses normalSummary) $maybe reqPasses <- positiveSum (numGradePasses normalSummary)
<li> <p>
Aufgaben zum Bestehen: #{display reqPasses} Aufgaben zum Bestehen: #{display reqPasses}
$maybe passed <- getSum <$> achievedPasses realGrades $maybe passed <- getSum <$> achievedPasses realGrades
\ davon #{display passed} bestanden \ davon #{display passed} bestanden
@ -36,6 +36,6 @@ $with realGrades <- normalSummary <> bonusSummary
\. \.
$maybe noGradeSheets <- positiveSum numNotGraded $maybe noGradeSheets <- positiveSum numNotGraded
<li> <p>
#{display noGradeSheets} unbewertete Aufgabenblätter. #{display noGradeSheets} unbewertete Aufgabenblätter.

10
test/Database.hs
View File

@ -24,6 +24,9 @@ import qualified Data.ByteString as BS
import Data.Time import Data.Time
import Utils.Lens (review)
import Control.Monad.Random.Class (MonadRandom(..))
data DBAction = DBClear data DBAction = DBClear
| DBTruncate | DBTruncate
@ -151,7 +154,7 @@ fillDb = do
, userMailLanguages = MailLanguages ["de"] , userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def , userNotificationSettings = def
} }
void . insert $ User tinaTester <- insert $ User
{ userIdent = "tester@campus.lmu.de" { userIdent = "tester@campus.lmu.de"
, userAuthentication = AuthLDAP , userAuthentication = AuthLDAP
, userMatrikelnummer = Just "999" , userMatrikelnummer = Just "999"
@ -312,6 +315,7 @@ fillDb = do
insert_ $ CourseEdit jost now pmo insert_ $ CourseEdit jost now pmo
void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ DegreeCourse pmo sdBsc sdInf
void . insert $ Lecturer jost pmo void . insert $ Lecturer jost pmo
void . insertMany $ map (\u -> CourseParticipant pmo u now) [fhamann, maxMuster, tinaTester]
sh1 <- insert Sheet sh1 <- insert Sheet
{ sheetCourse = pmo { sheetCourse = pmo
, sheetName = "Blatt 1" , sheetName = "Blatt 1"
@ -328,6 +332,10 @@ fillDb = do
, sheetSolutionFrom = Nothing , sheetSolutionFrom = Nothing
} }
void . insert $ SheetEdit jost now sh1 void . insert $ SheetEdit jost now sh1
forM_ [fhamann, maxMuster, tinaTester] $ \u -> do
p <- liftIO getRandom
$logDebug (review _PseudonymText p)
void . insert $ SheetPseudonym sh1 p u
void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal
void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal
h102 <- insertFile "H10-2.hs" h102 <- insertFile "H10-2.hs"