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

Merge branch 'feat/materials' into 'master'

Browse Source 
Feat/materials

See merge request !207
This commit is contained in:
Gregor Kleen 2019-05-04 17:55:28 +02:00
commit 4d7d3f43a5
20 changed files with 757 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
messages/uniworx/de.msg
View File

@ -148,8 +148,8 @@ SheetNewOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetNa
SheetTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} SheetTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}
SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt
SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren
SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert. SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wurde gespeichert in Kurs #{display tid}-#{display ssh}-#{csh}
SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}. SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}
SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren! SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren!
SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht. SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}! SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}!
@ -172,7 +172,7 @@ SheetName: Name
SheetDescription: Hinweise für Teilnehmer SheetDescription: Hinweise für Teilnehmer
SheetGroup: Gruppenabgabe SheetGroup: Gruppenabgabe
SheetVisibleFrom: Sichtbar für Teilnehmer ab SheetVisibleFrom: Sichtbar für Teilnehmer ab
SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Fristen/Bewertung sich noch ändern kann SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Bewertung/Fristen sich noch ändern können
SheetActiveFrom: Beginn Abgabezeitraum SheetActiveFrom: Beginn Abgabezeitraum
SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich
SheetActiveTo: Ende Abgabezeitraum SheetActiveTo: Ende Abgabezeitraum
@ -214,6 +214,29 @@ CourseCorrectionsTitle: Korrekturen für diesen Kurs
CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName} CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
CorrectorAssignTitle: Korrektor zuweisen CorrectorAssignTitle: Korrektor zuweisen
MaterialName: Name
MaterialType: Art
MaterialTypePlaceholder: Folien, Code, Beispiel, ...
MaterialTypeSlides: Folien
MaterialTypeCode: Code
MaterialTypeExample: Beispiel
MaterialDescription: Beschreibung
MaterialVisibleFrom: Sichtbar für Teilnehmer ab
MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für unfertige Materialien oder zur ausschließlichen Verteilung an Korrektoren
MaterialInvisible: Dieses Material ist für Teilnehmer momentan unsichtbar!
MaterialInvisibleUntil date@Text: Dieses Material ist für Teilnehmer momentan unsichtbar bis #{date}!
MaterialFiles: Dateien
MaterialHeading materialName@MaterialName: Material "#{materialName}"
MaterialListHeading: Materialien
MaterialNewHeading: Neues Material veröffentlichen
MaterialNewTitle: Neues Material
MaterialEditHeading materialName@MaterialName: Material "#{materialName}" editieren
MaterialEditTitle materialName@MaterialName: Material "#{materialName}" editieren
MaterialSaveOk tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Material "#{materialName}" erfolgreich gespeichert in Kurs #{display tid}-#{display ssh}-#{csh}
MaterialNameDup tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Es gibt bereits Material mit Namen "#{materialName}" in diesem Kurs #{display tid}-#{display ssh}-#{csh}
MaterialDeleteQuestion: Wollen Sie das unten aufgeführte Material wirklich löschen?
MaterialDeleted materialName@MaterialName: Material "#{materialName}" gelöscht
Unauthorized: Sie haben hierfür keine explizite Berechtigung. Unauthorized: Sie haben hierfür keine explizite Berechtigung.
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
@ -237,6 +260,7 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert. UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
@ -382,6 +406,8 @@ Pseudonyms: Pseudonyme
FileTitle: Dateiname FileTitle: Dateiname
FileModified: Letzte Änderung FileModified: Letzte Änderung
VisibleFrom: Veröffentlicht
AccessibleSince: Verfügbar seit
Corrected: Korrigiert Corrected: Korrigiert
@ -591,6 +617,7 @@ SheetGroupNoGroups: Keine Gruppenabgabe
SheetGroupMaxGroupsize: Maximale Gruppengröße SheetGroupMaxGroupsize: Maximale Gruppengröße
SheetFiles: Übungsblatt-Dateien SheetFiles: Übungsblatt-Dateien
SheetFileTypeHeader: Zugehörigkeit
NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert
NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
@ -727,6 +754,10 @@ MenuCorrections: Korrekturen
MenuCorrectionsOwn: Meine Korrekturen MenuCorrectionsOwn: Meine Korrekturen
MenuSubmissions: Abgaben MenuSubmissions: Abgaben
MenuSheetList: Übungsblätter MenuSheetList: Übungsblätter
MenuMaterialList: Material
MenuMaterialNew: Neues Material veröffentlichen
MenuMaterialEdit: Material bearbeiten
MenuMaterialDelete: Material löschen
MenuTutorialList: Tutorien MenuTutorialList: Tutorien
MenuTutorialNew: Neues Tutorium anlegen MenuTutorialNew: Neues Tutorium anlegen
MenuSheetNew: Neues Übungsblatt anlegen MenuSheetNew: Neues Übungsblatt anlegen

12
models/materials Normal file
View File

@ -0,0 +1,12 @@
Material -- course material for disemination to course participants
course CourseId
name (CI Text)
type Text Maybe
description Html Maybe
visibleFrom UTCTime Maybe -- Invisible to enrolled participants before
lastEdit UTCTime
UniqueMaterial course name
deriving Generic
MaterialFile -- a file that is part of a material distribution
material MaterialId
file FileId

145
routes
View File

@ -39,87 +39,94 @@
/favicon.ico FaviconR GET !free /favicon.ico FaviconR GET !free
/robots.txt RobotsR GET !free /robots.txt RobotsR GET !free
/ HomeR GET !free / HomeR GET !free
/users UsersR GET -- no tags, i.e. admins only /users UsersR GET -- no tags, i.e. admins only
/users/#CryptoUUIDUser AdminUserR GET POST /users/#CryptoUUIDUser AdminUserR GET POST
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST /users/#CryptoUUIDUser/delete AdminUserDeleteR POST
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self /users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self
/admin AdminR GET /admin AdminR GET
/admin/features AdminFeaturesR GET POST /admin/features AdminFeaturesR GET POST
/admin/test AdminTestR GET POST /admin/test AdminTestR GET POST
/admin/errMsg AdminErrMsgR GET POST /admin/errMsg AdminErrMsgR GET POST
/health HealthR GET !free /health HealthR GET !free
/instance InstanceR GET !free /instance InstanceR GET !free
/info InfoR GET !free /info InfoR GET !free
/info/lecturer InfoLecturerR GET !lecturer /info/lecturer InfoLecturerR GET !lecturer
/info/data DataProtR GET !free /info/data DataProtR GET !free
/impressum ImpressumR GET !free /impressum ImpressumR GET !free
/version VersionR GET !free /version VersionR GET !free
/help HelpR GET POST !free /help HelpR GET POST !free
/user ProfileR GET POST !free /user ProfileR GET POST !free
/user/profile ProfileDataR GET !free /user/profile ProfileDataR GET !free
/user/authpreds AuthPredsR GET POST !free /user/authpreds AuthPredsR GET POST !free
/term TermShowR GET !free /term TermShowR GET !free
/term/current TermCurrentR GET !free /term/current TermCurrentR GET !free
/term/edit TermEditR GET POST /term/edit TermEditR GET POST
/term/#TermId/edit TermEditExistR GET POST /term/#TermId/edit TermEditExistR GET POST
!/term/#TermId TermCourseListR GET !free !/term/#TermId TermCourseListR GET !free
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free !/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
/school SchoolListR GET !development /school SchoolListR GET !development
/school/#SchoolId SchoolShowR GET !development /school/#SchoolId SchoolShowR GET !development
-- For Pattern Synonyms see Foundation -- For Pattern Synonyms see Foundation
/course/ CourseListR GET !free /course/ CourseListR GET !free
!/course/new CourseNewR GET POST !lecturer !/course/new CourseNewR GET POST !lecturer
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !free / CShowR GET !free
/register CRegisterR GET POST !timeANDcapacity /register CRegisterR GET POST !timeANDcapacity
/edit CEditR GET POST /edit CEditR GET POST
/lecturer-invite/#UserEmail CLecInviteR GET POST /lecturer-invite/#UserEmail CLecInviteR GET POST
/delete CDeleteR GET POST !lecturerANDempty /delete CDeleteR GET POST !lecturerANDempty
/users CUsersR GET POST /users CUsersR GET POST
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
/correctors CHiWisR GET /correctors CHiWisR GET
/communication CCommR GET POST /communication CCommR GET POST
/notes CNotesR GET POST !corrector /notes CNotesR GET POST !corrector
/subs CCorrectionsR GET POST /subs CCorrectionsR GET POST
/ex SheetListR GET !course-registered !materials !corrector /ex SheetListR GET !course-registered !materials !corrector
/ex/new SheetNewR GET POST /ex/new SheetNewR GET POST
/ex/current SheetCurrentR GET !course-registered !materials !corrector /ex/current SheetCurrentR GET !course-registered !materials !corrector
/ex/unassigned SheetOldUnassigned GET /ex/unassigned SheetOldUnassigned GET
/ex/#SheetName SheetR: /ex/#SheetName SheetR:
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector
/edit SEditR GET POST /edit SEditR GET POST
/delete SDelR GET POST /delete SDelR GET POST
/subs SSubsR GET POST -- for lecturer only /subs SSubsR GET POST -- for lecturer only
!/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions
!/subs/own SubmissionOwnR GET !free -- just redirect !/subs/own SubmissionOwnR GET !free -- just redirect
/subs/#CryptoFileNameSubmission SubmissionR: /subs/#CryptoFileNameSubmission SubmissionR:
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector
/delete SubDelR GET POST !ownerANDtime /delete SubDelR GET POST !ownerANDtime
/assign SAssignR GET POST !lecturerANDtime /assign SAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated /correction CorrectionR GET POST !corrector !ownerANDreadANDrated
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
/correctors SCorrR GET POST /correctors SCorrR GET POST
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
/corrector-invite/#UserEmail SCorrInviteR GET POST /corrector-invite/#UserEmail SCorrInviteR GET POST
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector
/tuts CTutorialListR GET !tutor /file MaterialListR GET !course-registered !materials !corrector !tutor
/file/new MaterialNewR GET POST
/file/#MaterialName MaterialR:
/edit MEditR GET POST
/delete MDelR GET POST
/show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
/load/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
/tuts CTutorialListR GET !tutor
/tuts/new CTutorialNewR GET POST /tuts/new CTutorialNewR GET POST
/tuts/#TutorialName TutorialR: /tuts/#TutorialName TutorialR:
/edit TEditR GET POST /edit TEditR GET POST
/delete TDeleteR GET POST /delete TDeleteR GET POST
/participants TUsersR GET POST !tutor /participants TUsersR GET POST !tutor
/register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered
/communication TCommR GET POST !tutor /communication TCommR GET POST !tutor
/subs CorrectionsR GET POST !corrector !lecturer /subs CorrectionsR GET POST !corrector !lecturer

17
src/Application.hs
View File

@ -80,7 +80,7 @@ import System.Environment (lookupEnv)
import System.Posix.Process (getProcessID) import System.Posix.Process (getProcessID)
import Control.Monad.Trans.State (execStateT) import Control.Monad.Trans.State (execStateT)
-- 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.)
import Handler.Common import Handler.Common
@ -97,6 +97,7 @@ import Handler.Sheet
import Handler.Submission import Handler.Submission
import Handler.Tutorial import Handler.Tutorial
import Handler.Corrections import Handler.Corrections
import Handler.Material
import Handler.CryptoIDDispatch import Handler.CryptoIDDispatch
import Handler.SystemMessage import Handler.SystemMessage
import Handler.Health import Handler.Health
@ -189,7 +190,7 @@ makeFoundation appSettings'@AppSettings{..} = do
ldapPool <- for appLdapConf $ \LdapConf{..} -> do ldapPool <- for appLdapConf $ \LdapConf{..} -> do
$logDebugS "setup" "LDAP-Pool" $logDebugS "setup" "LDAP-Pool"
createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
-- Perform database migration using our application's logging settings. -- Perform database migration using our application's logging settings.
$logDebugS "setup" "Migration" $logDebugS "setup" "Migration"
migrateAll `runSqlPool` sqlPool migrateAll `runSqlPool` sqlPool
@ -231,7 +232,7 @@ clusterSetting proxy@(knownClusterSetting -> key) = do
new <- initClusterSetting proxy new <- initClusterSetting proxy
void . insert $ ClusterConfig key (Aeson.toJSON new) void . insert $ ClusterConfig key (Aeson.toJSON new)
return new return new
readInstanceIDFile :: MonadIO m => FilePath -> m UUID readInstanceIDFile :: MonadIO m => FilePath -> m UUID
readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
where where
@ -252,7 +253,7 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
let let
withLogging :: LoggingT IO a -> IO a withLogging :: LoggingT IO a -> IO a
withLogging = flip runLoggingT logFunc withLogging = flip runLoggingT logFunc
mkConnection = withLogging $ do mkConnection = withLogging $ do
$logInfoS "SMTP" "Opening new connection" $logInfoS "SMTP" "Opening new connection"
liftIO mkConnection' liftIO mkConnection'
@ -353,7 +354,7 @@ adjustSettings = execStateT $ do
Just wInterval Just wInterval
| maybe True (== myProcessID) watchdogProcess | maybe True (== myProcessID) watchdogProcess
-> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2) -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2)
_other -> return () _other -> return ()
-- | main function for use by yesod devel -- | main function for use by yesod devel
develMain :: IO () develMain :: IO ()
@ -373,7 +374,7 @@ appMain = runResourceT $ do
-- Generate the foundation from the settings -- Generate the foundation from the settings
foundation <- makeFoundation settings foundation <- makeFoundation settings
runAppLoggingT foundation $ do runAppLoggingT foundation $ do
$logDebugS "setup" "Job-Handling" $logDebugS "setup" "Job-Handling"
handleJobs foundation handleJobs foundation
@ -406,7 +407,7 @@ appMain = runResourceT $ do
-------------------------------------------------------------- --------------------------------------------------------------
foundationStoreNum :: Word32 foundationStoreNum :: Word32
foundationStoreNum = 2 foundationStoreNum = 2
getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application)
getApplicationRepl = do getApplicationRepl = do
settings <- getAppDevSettings settings <- getAppDevSettings
@ -418,7 +419,7 @@ getApplicationRepl = do
let foundationStore = Store foundationStoreNum let foundationStore = Store foundationStoreNum
liftIO $ deleteStore foundationStore liftIO $ deleteStore foundationStore
liftIO $ writeStore foundationStore foundation liftIO $ writeStore foundationStore foundation
return (getPort wsettings, foundation, app1) return (getPort wsettings, foundation, app1)
shutdownApp :: MonadIO m => UniWorX -> m () shutdownApp :: MonadIO m => UniWorX -> m ()

10
src/Database/Esqueleto/Utils.hs
View File

@ -19,9 +19,9 @@ import Database.Esqueleto.Utils.TH
-- --
-- Description : Convenience for using @Esqueleto@, -- Description : Convenience for using `Esqueleto`,
-- intended to be imported qualified -- intended to be imported qualified
-- just like Esqueleto -- just like @Esqueleto@
-- ezero = E.val (0 :: Int64) -- ezero = E.val (0 :: Int64)
@ -44,13 +44,13 @@ hasInfix :: (E.Esqueleto query expr backend, E.SqlString s2) =>
hasInfix = flip isInfixOf hasInfix = flip isInfixOf
-- | Given a test and a set of values, check whether anyone succeeds the test -- | Given a test and a set of values, check whether anyone succeeds the test
-- WARNING: SQL leaves it explicitely unspecified whether || is short curcuited (i.e. lazily evaluated) -- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated)
any :: Foldable f => any :: Foldable f =>
(a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
any test = F.foldr (\needle acc -> acc E.||. test needle) false any test = F.foldr (\needle acc -> acc E.||. test needle) false
-- | Given a test and a set of values, check whether all succeeds the test -- | Given a test and a set of values, check whether all succeeds the test
-- WARNING: SQL leaves it explicitely unspecified whether && is short curcuited (i.e. lazily evaluated) -- WARNING: SQL leaves it explicitely unspecified whether `&&` is short curcuited (i.e. lazily evaluated)
all :: Foldable f => all :: Foldable f =>
(a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
all test = F.foldr (\needle acc -> acc E.&&. test needle) true all test = F.foldr (\needle acc -> acc E.&&. test needle) true
@ -82,7 +82,7 @@ mkExactFilter :: (PersistField a)
-> E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool)
mkExactFilter = mkExactFilterWith id mkExactFilter = mkExactFilterWith id
-- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@ -- | like `mkExactFiler` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
mkExactFilterWith :: (PersistField b) mkExactFilterWith :: (PersistField b)
=> (a -> b) -- ^ type conversion => (a -> b) -- ^ type conversion
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element

65
src/Foundation.hs
View File

@ -163,9 +163,13 @@ pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR
pattern CSheetR tid ssh csh shn ptn pattern CSheetR tid ssh csh shn ptn
= CourseR tid ssh csh (SheetR shn ptn) = CourseR tid ssh csh (SheetR shn ptn)
pattern CMaterialR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> MaterialR -> Route UniWorX
pattern CMaterialR tid ssh csh mnm ptn
= CourseR tid ssh csh (MaterialR mnm ptn)
pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX
pattern CTutorialR tid ssh csh shn ptn pattern CTutorialR tid ssh csh tnm ptn
= CourseR tid ssh csh (TutorialR shn ptn) = CourseR tid ssh csh (TutorialR tnm ptn)
pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX
pattern CSubmissionR tid ssh csh shn cid ptn pattern CSubmissionR tid ssh csh shn cid ptn
@ -638,9 +642,9 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
-> return Authorized -> return Authorized
| otherwise | otherwise
-> mzero -> mzero
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
let let
@ -662,6 +666,14 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
return Authorized return Authorized
CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _mid Material{materialVisibleFrom} <- MaybeT . getBy $ UniqueMaterial cid mnm
cTime <- liftIO getCurrentTime
let visible = NTop materialVisibleFrom <= NTop (Just cTime)
guard visible
return Authorized
CourseR tid ssh csh CRegisterR -> do CourseR tid ssh csh CRegisterR -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
mbc <- getBy $ TermSchoolCourseShort tid ssh csh mbc <- getBy $ TermSchoolCourseShort tid ssh csh
@ -1397,6 +1409,14 @@ instance YesodBreadcrumbs UniWorX where
-- (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download -- (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download
breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR)
-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
breadcrumb (CourseR tid ssh csh MaterialListR) = return ("Material" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh MaterialNewR ) = return ("Neu" , Just $ CourseR tid ssh csh MaterialListR)
breadcrumb (CMaterialR tid ssh csh mnm MShowR) = return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR)
breadcrumb (CMaterialR tid ssh csh mnm MEditR) = return ("Bearbeiten" , Just $ CMaterialR tid ssh csh mnm MShowR)
breadcrumb (CMaterialR tid ssh csh mnm MDelR) = return ("Löschen" , Just $ CMaterialR tid ssh csh mnm MShowR)
-- (CMaterialR tid ssh csh mnm MFileR) -- just for Downloads
-- Others -- Others
breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR)
breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
@ -1755,6 +1775,14 @@ pageActions (CourseNewR) = [
] ]
pageActions (CourseR tid ssh csh CShowR) = pageActions (CourseR tid ssh csh CShowR) =
[ MenuItem [ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuMaterialList
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetList , menuItemLabel = MsgMenuSheetList
, menuItemIcon = Nothing , menuItemIcon = Nothing
@ -1883,6 +1911,34 @@ pageActions (CourseR tid ssh csh SheetListR) =
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CourseR tid ssh csh MaterialListR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuMaterialNew
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialNewR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
pageActions (CMaterialR tid ssh csh mnm MShowR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuMaterialEdit
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MEditR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuMaterialDelete
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MDelR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
pageActions (CourseR tid ssh csh CTutorialListR) = pageActions (CourseR tid ssh csh CTutorialListR) =
[ MenuItem [ MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
@ -2212,6 +2268,7 @@ pageHeading (CourseR tid ssh csh SheetNewR)
= Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh
pageHeading (CSheetR tid ssh csh shn SShowR) pageHeading (CSheetR tid ssh csh shn SShowR)
= Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn
-- = Just $ i18nHeading $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
pageHeading (CSheetR tid ssh csh shn SEditR) pageHeading (CSheetR tid ssh csh shn SEditR)
= Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn
pageHeading (CSheetR tid ssh csh shn SDelR) pageHeading (CSheetR tid ssh csh shn SDelR)

302
src/Handler/Material.hs Normal file
View File

@ -0,0 +1,302 @@
module Handler.Material where
import Import
import Data.Monoid (Any(..))
import Data.Set (Set)
import qualified Data.Set as Set
-- import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Conduit.List as C
-- import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils.TH
import Utils.Lens
import Utils.Form
import Handler.Utils
-- import Handler.Utils.Delete
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Control.Monad.Writer (MonadWriter(..), execWriterT)
data MaterialForm = MaterialForm
{ mfName :: MaterialName
, mfType :: Maybe Text
, mfDescription :: Maybe Html
, mfVisibleFrom :: Maybe UTCTime
, mfFiles :: Maybe (Source Handler (Either FileId File))
}
makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
MsgRenderer mr <- getMsgRenderer
let setIds :: Either FileId File -> Set FileId
setIds = either Set.singleton $ const Set.empty
oldFileIds
| Just source <- template >>= mfFiles
= runConduit $ source .| C.foldMap setIds
| otherwise = return Set.empty
typeOptions :: WidgetT UniWorX IO (Set Text)
typeOptions = do
let defaults = Set.fromList $ map mr [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
previouslyUsed <- liftHandlerT . runDB $
E.select $ E.from $ \material ->
E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do
E.where_ $ (material E.^. MaterialCourse E.==. E.val cid)
E.&&. (E.not_ $ E.isNothing $ material E.^. MaterialType)
return $ material E.^. MaterialType
return $ defaults <> (Set.fromList $ mapMaybe E.unValue previouslyUsed)
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
flip (renderAForm FormStandard) html $ MaterialForm
<$> areq ciField (fslI MsgMaterialName) (mfName <$> template)
<*> aopt (textField & addDatalist typeOptions)
(fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
(mfType <$> template)
<*> aopt htmlField (fslpI MsgMaterialDescription "Html")
(mfDescription <$> template)
<*> aopt utcTimeField (fslI MsgMaterialVisibleFrom
& setTooltip MsgMaterialVisibleFromTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime))
<*> aopt (multiFileField oldFileIds)
(fslI MsgMaterialFiles) (mfFiles <$> template)
fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
fetchMaterial tid ssh csh mnm = do
[matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints
\(course `E.InnerJoin` material) -> do
E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. material E.^. MaterialName E.==. E.val mnm
return material
return matEnt
getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getMaterialListR tid ssh csh = do
let matLink :: MaterialName -> Route UniWorX
matLink = CourseR tid ssh csh . flip MaterialR MShowR
now <- liftIO getCurrentTime
table <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let row2material = entityVal . dbrOutput -- no inner join, just Entity Material
psValidator = def & defaultSorting [SortDescBy "last-edit"]
table <- dbTableWidget' psValidator DBTable
{ dbtIdent = "material-list" :: Text
, dbtStyle = def
, dbtParams = def
, dbtSQLQuery = \material -> do
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
return material
, dbtRowKey = (E.^. MaterialId)
-- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
, dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->)
, dbtColonnade = widgetColonnade $ mconcat
[ dbRow
, sortable (Just "type") (i18nCell MsgMaterialType)
$ foldMap textCell . materialType . row2material
, sortable (Just "name") (i18nCell MsgMaterialName)
$ liftA2 anchorCell matLink toWgt . materialName . row2material
, sortable (toNothingS "description") mempty
$ foldMap modalCell . materialDescription . row2material
, sortable (Just "visble-from") (i18nCell MsgAccessibleSince)
$ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
, sortable (Just "last-edit") (i18nCell MsgFileModified)
$ dateTimeCell . materialLastEdit . row2material
]
, dbtSorting = Map.fromList
[ ( "type" , SortColumn (E.^. MaterialType) )
, ( "name" , SortColumn (E.^. MaterialName) )
, ( "visible-from" , SortColumn (E.^. MaterialVisibleFrom) )
, ( "last-edit" , SortColumn (E.^. MaterialLastEdit) )
]
, dbtFilter = mempty
, dbtFilterUI = mempty
}
return table
let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialListHeading
headingShort = prependCourseTitle tid ssh csh $ MsgMaterialListHeading
siteLayoutMsg headingLong $ do
setTitleI headingShort
$(widgetFile "material-list")
getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent
getMFileR tid ssh csh mnm title = serveOneFile fileQuery
where
fileQuery = E.select $ E.from $
\(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. matFile E.^. MaterialFileFile)
E.on (matFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId)
E.on (material E.^. MaterialCourse E.==. course E.^. CourseId)
-- filter to requested file
E.where_ ((file E.^. FileTitle E.==. E.val title)
E.&&. (material E.^. MaterialName E.==. E.val mnm )
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
E.&&. (course E.^. CourseTerm E.==. E.val tid )
)
-- return file entity
return file
getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
getMShowR tid ssh csh mnm = do
let matLink :: FilePath -> Route UniWorX
matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
( (Entity _mid material@Material{materialType, materialDescription})
, (Any hasFiles,fileTable)) <- runDB $ do
matEnt <- fetchMaterial tid ssh csh mnm
let psValidator = def & defaultSortingByFileTitle
fileTable' <- dbTable psValidator DBTable
{ dbtSQLQuery = \(matFile `E.InnerJoin` file) -> do
E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories
return (file E.^. FileTitle, file E.^. FileModified)
, dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
, dbtColonnade = widgetColonnade $ mconcat
[ dbRowIndicator -- important: contains writer to indicate that the tables is not empty
, colFilePathSimple (view $ _dbrOutput . _1) matLink
, colFileModification (view $ _dbrOutput . _2)
]
, dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr
, dbtStyle = def
, dbtParams = def
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtIdent = "material-files" :: Text
, dbtSorting = Map.fromList
[ sortFilePath $(sqlIJproj 2 2)
, sortFileModification $(sqlIJproj 2 2)
]
}
return (matEnt,fileTable')
let matVisFro = materialVisibleFrom material
now <- liftIO $ getCurrentTime
materialLastEdit <- formatTime SelFormatDateTime $ materialLastEdit material
materialVisibleFrom <- traverse (formatTime SelFormatDateTime) matVisFro
when (NTop matVisFro >= NTop (Just now)) $ addMessageI Warning $
maybe MsgMaterialInvisible MsgMaterialInvisibleUntil materialVisibleFrom
let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialHeading mnm
headingShort = prependCourseTitle tid ssh csh $ SomeMessage mnm
siteLayoutMsg headingLong $ do
setTitleI headingShort
$(widgetFile "material-show")
getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
getMEditR = postMEditR
postMEditR tid ssh csh mnm = do
(Entity mid Material{..}, files) <- runDB $ do
matEnt <- fetchMaterial tid ssh csh mnm
fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do
E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
return $ file E.^. FileId
return (matEnt, (Left . E.unValue) <$> fileIds)
-- let cid = materialCourse
let template = Just $ MaterialForm
{ mfName = materialName
, mfType = materialType
, mfDescription = materialDescription
, mfVisibleFrom = materialVisibleFrom
, mfFiles = Just $ yieldMany files
}
editWidget <- handleMaterialEdit tid ssh csh materialCourse template $ uniqueReplace mid
let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm
headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle mnm
siteLayoutMsg headingLong $ do
setTitleI headingShort
editWidget
getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getMaterialNewR = postMaterialNewR
postMaterialNewR tid ssh csh = do
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
editWidget <- handleMaterialEdit tid ssh csh cid Nothing insertUnique
let headingLong = prependCourseTitle tid ssh csh MsgMaterialNewHeading
headingShort = prependCourseTitle tid ssh csh MsgMaterialNewTitle
siteLayoutMsg headingLong $ do
setTitleI headingShort
editWidget
handleMaterialEdit :: TermId -> SchoolId -> CourseShorthand -> CourseId -> Maybe MaterialForm -> (Material -> DB (Maybe MaterialId)) -> Handler Widget
handleMaterialEdit tid ssh csh cid template dbMaterial = do
((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template
formResult res saveMaterial
-- actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute
return $ wrapForm formWidget def
{ formAction = Nothing -- Just $ SomeRoute actionUrl
, formEncoding = formEnctype
}
where
saveMaterial :: MaterialForm -> Handler ()
saveMaterial MaterialForm{..} = do
_aid <- requireAuthId
now <- liftIO getCurrentTime
let newMaterial = Material
{ materialCourse = cid
, materialName = mfName
, materialType = mfType
, materialDescription = mfDescription
, materialVisibleFrom = mfVisibleFrom
, materialLastEdit = now
}
saveOk <- runDB $ do
mbmid <- dbMaterial newMaterial
case mbmid of
Nothing -> False <$ addMessageI Error (MsgMaterialNameDup tid ssh csh mfName)
(Just mid) -> do -- save files in DB
whenIsJust mfFiles $ insertMaterialFile' mid
addMessageI Success $ MsgMaterialSaveOk tid ssh csh mfName
-- more info/warnings could go here
return True
when saveOk $ redirect -- redirect must happen outside of runDB
$ CourseR tid ssh csh (MaterialR mfName MShowR)
insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB ()
insertMaterialFile' mid fs = do
oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do
E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
return $ file E.^. FileId
let oldFileIds = setFromList $ map E.unValue oldFileIdVals
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
where
finsert (Left fileId) = tell $ singleton fileId
finsert (Right file) = lift $ do
fid <- insert file
void . insert $ MaterialFile mid fid -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
getMDelR = postMDelR
postMDelR tid ssh csh mnm = do
_matEnt <- runDB $ fetchMaterial tid ssh csh mnm
error "todo" -- CONTINUE HERE
{-
deleteR DeleteRoute
{ drRecords = Set.singleton $ entityKey matEnt
, drGetInfo = error "todo"
, drUnjoin = error "todo"
, drRenderRecord = error "todo"
, drRecordConfirmString = error "todo"
, drCaption = SomeMessage MsgMaterialDeleteQuestion
, drSuccessMessage = SomeMessage $ MsgMaterialDeleted mnm
, drSuccess = SomeRoute $ CourseR tid ssh csh MaterialListR
, drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
}
-}

108
src/Handler/Sheet.hs
View File

@ -4,12 +4,12 @@ import Import
import Jobs.Queue import Jobs.Queue
import System.FilePath (takeFileName) -- import Utils.Lens
import Utils.Sheet import Utils.Sheet
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.Table.Columns
import Handler.Utils.SheetType import Handler.Utils.SheetType
import Handler.Utils.Delete import Handler.Utils.Delete
import Handler.Utils.Form.MassInput import Handler.Utils.Form.MassInput
@ -38,8 +38,6 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT)
import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE) import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE)
import Network.Mime
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
@ -96,10 +94,11 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
Nothing -> return $ partitionFileType mempty Nothing -> return $ partitionFileType mempty
(Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
mr <- getMsgRenderer mr <- getMsgRenderer
ctime <- liftIO $ getCurrentTime ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
<$> areq ciField (fslI MsgSheetName) (sfName <$> template) <$> areq ciField (fslI MsgSheetName) (sfName <$> template)
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) <*> aopt htmlField (fslpI MsgSheetDescription "Html")
(sfDescription <$> template)
<*> sheetTypeAFormReq (fslI MsgSheetType <*> sheetTypeAFormReq (fslI MsgSheetType
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded])) & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
(sfType <$> template) (sfType <$> template)
@ -155,7 +154,8 @@ getSheetOldUnassigned tid ssh csh = runDB $ 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 now <- liftIO getCurrentTime
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let let
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
@ -176,9 +176,9 @@ getSheetListR tid ssh csh = do
, sortable (Just "name") (i18nCell MsgSheet) , sortable (Just "name") (i18nCell MsgSheet)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) $ \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)
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty dateTimeCell mEditTime $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> foldMap dateTimeCell mEditTime
, sortable (Just "visible-from") (i18nCell MsgSheetVisibleFrom) , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> maybe mempty dateTimeCell sheetVisibleFrom $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveFrom $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveFrom
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
@ -304,43 +304,43 @@ getSShowR tid ssh csh shn = do
-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes -- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
-- with Colonnade -- with Colonnade
let fileData (sheet' `E.InnerJoin` sheetFile `E.InnerJoin` file) = do let fileData (sheetFile `E.InnerJoin` file) = do
-- Restrict to consistent rows that correspond to each other -- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) E.on (sheetFile E.^. SheetFileFile E.==. file E.^. FileId)
E.on (sheetFile E.^. SheetFileSheet E.==. sheet' E.^. SheetId)
-- filter to requested file -- filter to requested file
E.where_ $ sheet' E.^. SheetId E.==. E.val sid E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
E.&&. E.not_ (E.isNothing $ file E.^. FileContent) E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories
-- return desired columns -- return desired columns
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
let colonnadeFiles = widgetColonnade $ mconcat let colonnadeFiles = widgetColonnade $ mconcat
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
, sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell
(CSheetR tid ssh csh shn (SFileR fType fName)) (CSheetR tid ssh csh shn (SFileR fType fName))
(str2widget fName) (str2widget fName)
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
-- , colFileModification (view _2)
, sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCell modified
] ]
let psValidator = def let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
& defaultSorting [SortAscBy "type", SortAscBy "path"]
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery = fileData { dbtSQLQuery = fileData
, dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
, dbtColonnade = colonnadeFiles , dbtColonnade = colonnadeFiles
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False) -> guardAuthorizedFor (CSheetR tid ssh csh shn $ SFileR fType fName) dbrOutput
, dbtStyle = def , dbtStyle = def
, dbtFilter = mempty , dbtFilter = mempty
, dbtFilterUI = mempty , dbtFilterUI = mempty
, dbtIdent = "files" :: Text , dbtIdent = "files" :: Text
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "type" [ ( "type"
, SortColumn $ \(_sheet `E.InnerJoin` sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType
) )
, ( "path" , ( "path"
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileTitle , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
) )
, ( "time" , ( "time"
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified
) )
] ]
, dbtParams = def , dbtParams = def
@ -365,7 +365,7 @@ getSShowR tid ssh csh shn = do
, formSubmit = FormNoSubmit , formSubmit = FormNoSubmit
} }
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetTitle tid ssh csh shn setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
@ -399,34 +399,24 @@ postSPseudonymR tid ssh csh shn = do
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
getSFileR tid ssh csh shn typ title = do getSFileR tid ssh csh shn typ title = serveOneFile fileQuery
results <- runDB $ E.select $ E.from $ where
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do fileQuery = E.select $ E.from $
-- Restrict to consistent rows that correspond to each other \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) -- Restrict to consistent rows that correspond to each other
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
-- filter to requested file E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
E.where_ ((file E.^. FileTitle E.==. E.val title) -- filter to requested file
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ ) E.where_ ((file E.^. FileTitle E.==. E.val title)
E.&&. (sheet E.^. SheetName E.==. E.val shn ) E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
E.&&. (course E.^. CourseShorthand E.==. E.val csh ) E.&&. (sheet E.^. SheetName E.==. E.val shn )
E.&&. (course E.^. CourseSchool E.==. E.val ssh ) E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseTerm E.==. E.val tid ) E.&&. (course E.^. CourseSchool E.==. E.val ssh )
) E.&&. (course E.^. CourseTerm E.==. E.val tid )
-- return desired columns )
return $ (file E.^. FileTitle, file E.^. FileContent) -- return file entity
case results of return file
[(E.Value fileTitle, E.Value fileContent)]
| Just fileContent' <- fileContent -> do
whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
| otherwise -> sendResponseStatus noContent204 ()
[] -> notFound
other -> do
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found."
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetNewR tid ssh csh = do getSheetNewR tid ssh csh = do
@ -502,11 +492,7 @@ getSEditR tid ssh csh shn = do
, sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
, sfMarkingText = sheetMarkingText , sfMarkingText = sheetMarkingText
} }
let action newSheet = do let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
replaceRes <- myReplaceUnique sid $ newSheet
case replaceRes of
Nothing -> return $ Just sid
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
handleSheetEdit tid ssh csh (Just sid) template action handleSheetEdit tid ssh csh (Just sid) template action
postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html

29
src/Handler/Utils.hs
View File

@ -30,7 +30,9 @@ import Handler.Utils.Sheet as Handler.Utils
import Handler.Utils.Mail as Handler.Utils import Handler.Utils.Mail as Handler.Utils
import System.Directory (listDirectory) import System.Directory (listDirectory)
import System.FilePath.Posix (takeBaseName) import System.FilePath.Posix (takeBaseName, takeFileName)
import Network.Mime
import qualified Data.List as List import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
@ -45,6 +47,22 @@ downloadFiles = do
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
return userDefaultDownloadFiles return userDefaultDownloadFiles
-- | Serve a single file, identified through a given DB query
serveOneFile :: DB [Entity File] -> Handler TypedContent
serveOneFile query = do
results <- runDB query
case results of
[(Entity _fileId File{fileTitle, fileContent})]
| Just fileContent' <- fileContent -> do
whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
| otherwise -> sendResponseStatus noContent204 ()
[] -> notFound
other -> do
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found."
tidFromText :: Text -> Maybe TermId tidFromText :: Text -> Maybe TermId
tidFromText = fmap TermKey . maybeRight . termFromText tidFromText = fmap TermKey . maybeRight . termFromText
@ -171,3 +189,12 @@ i18nWidgetFile basename = do
| l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
] [e|selectLanguage availableTranslations' >>= $(varE ws)|] ] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
-- | return a value only if the current user ist authorized for a given route
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
, MonadTrans m, MonadPlus (m (ReaderT SqlBackend h)))
=> Route UniWorX -> a -> m (ReaderT SqlBackend h) a
guardAuthorizedFor link val =
val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)

15
src/Handler/Utils/DateTime.hs
View File

@ -9,6 +9,7 @@ module Handler.Utils.DateTime
, addOneWeek, addWeeks , addOneWeek, addWeeks
, weeksToAdd , weeksToAdd
, setYear , setYear
, ceilingQuarterHour
) where ) where
import Import import Import
@ -190,3 +191,17 @@ weeksToAdd old new = loop 0 old
loop n t loop n t
| t > new = n | t > new = n
| otherwise = loop (succ n) (addOneWeek t) | otherwise = loop (succ n) (addOneWeek t)
-- | round up the next full quarter hour with a margin of at least 5 minutes
ceilingQuarterHour :: UTCTime -> UTCTime
ceilingQuarterHour = ceilingMinuteBy 5 15
-- | round up the next full @roundto@ minutes with a margin of at least @margin@ minutes
ceilingMinuteBy :: Int -> Int -> UTCTime -> UTCTime
ceilingMinuteBy margin roundto utct = addUTCTime bonus utct
where
oldTime = localTimeOfDay $ utcToLocalTime utct
oldMin = todMin oldTime
newMin = roundToNearestMultiple roundto $ oldMin + margin
newTime = oldTime { todMin = newMin, todSec = 0} -- might be invalid, but correctly treated by `timeOfDayToTime`
bonus = realToFrac $ (timeOfDayToTime newTime) - (timeOfDayToTime oldTime)

16
src/Handler/Utils/Table/Cells.hs
View File

@ -53,6 +53,13 @@ pathPieceCell = cell . toWidget . toPathPiece
sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a
sqlCell act = mempty & cellContents .~ lift act sqlCell act = mempty & cellContents .~ lift act
markCell :: (IsDBTable m a) => (a -> Bool) -> (a -> DBCell m a) -> a -> DBCell m a
markCell condition normal x
| condition x = (normal x) <> (cell $ isVisibleWidget False)
| otherwise = normal x
-- Recall: for line numbers, use dbRow
--------------------- ---------------------
-- Icon cells -- Icon cells
@ -75,6 +82,9 @@ commentCell Nothing = mempty
commentCell (Just link) = anchorCell link icon commentCell (Just link) = anchorCell link icon
where icon = toWidget $ hasComment True where icon = toWidget $ hasComment True
-- | Display an icon that opens a modal upon clicking
modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content)
----------------- -----------------
-- Datatype cells -- Datatype cells
@ -87,6 +97,12 @@ dateCell t = cell $ formatTime SelFormatDate t >>= toWidget
dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a
dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a
dateTimeCellVisible watershed t = cell $ do
tfw <- formatTime SelFormatDateTime t >>= toWidget
icn <- bool mempty (toWidget $ isVisible False) $ watershed < t
return $ tfw <> icn
userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell :: IsDBTable m a => Text -> Text -> DBCell m a
userCell displayName surname = cell $ nameWidget displayName surname userCell displayName surname = cell $ nameWidget displayName surname

49
src/Handler/Utils/Table/Columns.hs
View File

@ -11,6 +11,7 @@ import Import
-- import Text.Blaze (ToMarkup(..)) -- import Text.Blaze (ToMarkup(..))
import Data.Monoid (Any(..))
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils as E import Database.Esqueleto.Utils as E
@ -34,6 +35,54 @@ import Handler.Utils.Table.Cells
-- * additional helper, such as default sorting -- * additional helper, such as default sorting
-----------------------
-- Numbers and Indices
-- | Simple index column, also indicating whether there is a row at all
-- For a version without indication, use `Handler.Utils.Pagination.dbRow` instead.
dbRowIndicator :: IsDBTable m Any => Colonnade Sortable (DBRow r) (DBCell m Any)
dbRowIndicator = sortable Nothing (i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> tellCell (Any True) $ textCell $ tshow dbrIndex
---------------
-- Files
-- | Generic column for links to FilePaths, where the link depends on the entire table row
colFilePath :: (IsDBTable m c) => (t -> E.Value FilePath) -> (t -> Route UniWorX) -> Colonnade Sortable t (DBCell m c)
colFilePath row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) makeCell
where
makeCell row =
let filePath = E.unValue $ row2path row
link = row2link row
in anchorCell link $ str2widget filePath
-- | Generic column for links to FilePaths, where the link only depends on the FilePath itself
colFilePathSimple :: (IsDBTable m c) => (t -> E.Value FilePath) -> (FilePath -> Route UniWorX) -> Colonnade Sortable t (DBCell m c)
colFilePathSimple row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) makeCell
where
makeCell row =
let filePath = E.unValue $ row2path row
link = row2link filePath
in anchorCell link $ str2widget filePath
-- | Generic column for File Modification
colFileModification :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
colFileModification row2time = sortable (Just "time") (i18nCell MsgFileModified) (dateTimeCell . E.unValue . row2time)
sortFilePath :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r)
sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle))
sortFileModification :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r)
sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. FileModified))
defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x
defaultSortingByFileTitle = defaultSorting [SortAscBy "path"]
defaultSortingByFileModification :: PSValidator m x -> PSValidator m x
defaultSortingByFileModification = defaultSorting [SortAscBy "time"]
--------------- ---------------
-- User names -- User names

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

@ -931,7 +931,7 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
-- Predefined colonnades -- Predefined colonnades
--Number column? -- | Simple number column, also see Handler.Utils.Table.Columns.dbRowIndicator
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

9
src/Model.hs
View File

@ -32,10 +32,11 @@ import Data.Binary (Binary)
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"] share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
$(persistDirectoryWith lowerCaseSettings "models") $(persistDirectoryWith lowerCaseSettings "models")
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only; comments helpful for searching in code
deriving instance Eq (Unique Course) deriving instance Eq (Unique Course) -- instance Eq TermSchoolCourseShort; instance Eq TermSchoolCourseName
deriving instance Eq (Unique Sheet) deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet
deriving instance Eq (Unique Tutorial) deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial
deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial
-- Primary keys mentioned in dbtable row-keys must be Binary -- Primary keys mentioned in dbtable row-keys must be Binary
-- Automatically generated (i.e. numeric) ids are already taken care of -- Automatically generated (i.e. numeric) ids are already taken care of

9
src/Model/Types.hs
View File

@ -90,7 +90,7 @@ import Data.Time.LocalTime (LocalTime, TimeOfDay)
import Data.Semigroup (Min(..)) import Data.Semigroup (Min(..))
import Control.Monad.Trans.Writer (execWriter) import Control.Monad.Trans.Writer (execWriter)
import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Writer.Class (MonadWriter(..))
instance PathPiece UUID where instance PathPiece UUID where
fromPathPiece = UUID.fromString . unpack fromPathPiece = UUID.fromString . unpack
@ -357,7 +357,7 @@ classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector
classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth
data ExamStatus = Attended | NoShow | Voided data ExamStatus = Attended | NoShow | Voided
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
@ -880,11 +880,11 @@ derivePersistFieldJSON ''LecturerType
instance Hashable LecturerType instance Hashable LecturerType
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece { constructorTagModifier = camelToPathPiece
} ''WeekDay } ''WeekDay
data OccurenceSchedule = ScheduleWeekly data OccurenceSchedule = ScheduleWeekly
{ scheduleDayOfWeek :: WeekDay { scheduleDayOfWeek :: WeekDay
, scheduleStart :: TimeOfDay , scheduleStart :: TimeOfDay
@ -984,6 +984,7 @@ type SchoolShorthand = CI Text
type CourseName = CI Text type CourseName = CI Text
type CourseShorthand = CI Text type CourseShorthand = CI Text
type SheetName = CI Text type SheetName = CI Text
type MaterialName = CI Text
type UserEmail = CI Email type UserEmail = CI Email
type TutorialName = CI Text type TutorialName = CI Text

29
src/Utils.hs
View File

@ -168,12 +168,18 @@ boolSymbol False = [shamlet|<i .fas .fa-times>|]
-- DEPRECATED: use hasTickmark instead; -- DEPRECATED: use hasTickmark instead;
-- maybe reinstate if needed for @bewertung.txt@ files -- maybe reinstate if needed for @bewertung.txt@ files
-- tickmark :: IsString a => a -- tickmark :: IsString a => a
-- tickmark = fromString "✔" -- tickmark = fromString "✔"
-- | Convert text as it is to Html, may prevent ambiguous types
-- This function definition is mainly for documentation purposes
text2Html :: Text -> Html text2Html :: Text -> Html
text2Html = toHtml -- prevents ambiguous types text2Html = toHtml
-- | Convert text as it is to Message, may prevent ambiguous types
-- This function definition is mainly for documentation purposes
text2message :: Text -> SomeMessage site
text2message = SomeMessage
toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m)
=> a -> WidgetT site m () => a -> WidgetT site m ()
@ -278,6 +284,17 @@ notUsedT = notUsed
-------------
-- Numeric --
-------------
-- | round n to nearest multiple of m
roundToNearestMultiple :: Int -> Int -> Int
roundToNearestMultiple m n = (n `div` m + 1) * m
------------ ------------
-- Monoid -- -- Monoid --
------------ ------------
@ -403,6 +420,12 @@ toNothing = const Nothing
toNothingS :: String -> Maybe b toNothingS :: String -> Maybe b
toNothingS = const Nothing toNothingS = const Nothing
-- MOVED TO UTILS.DB due to cyclic dependency
-- Swap 'Nothing' for 'Just' and vice versa
-- flipMaybe :: b -> Maybe b -> Maybe b
-- flipMaybe x Nothing = Just x
-- flipMaybe _ (Just _) = Nothing
maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap 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
@ -504,7 +527,7 @@ maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b
maybeTExceptT err act = maybeExceptT err $ runMaybeT act maybeTExceptT err act = maybeExceptT err $ runMaybeT act
maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b
maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act

59
src/Utils/DB.hs
View File

@ -10,8 +10,18 @@ import qualified Data.Set as Set
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
-- import Database.Persist -- currently not needed here -- import Database.Persist -- currently not needed here
emptyOrIn :: PersistField typ =>
E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) -- | Swap 'Nothing' for 'Just' and vice versa
-- This belongs into Module 'Utils' but we have a weird cyclic
-- dependency
flipMaybe :: b -> Maybe a -> Maybe b
flipMaybe x Nothing = Just x
flipMaybe _ (Just _) = Nothing
emptyOrIn :: PersistField typ
=> E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
emptyOrIn criterion testSet emptyOrIn criterion testSet
| Set.null testSet = E.val True | Set.null testSet = E.val True
| otherwise = criterion `E.in_` E.valList (Set.toList testSet) | otherwise = criterion `E.in_` E.valList (Set.toList testSet)
@ -20,33 +30,44 @@ entities2map :: PersistEntity record => [Entity record] -> Map (Key record) reco
entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m (Maybe (Key record)) => Unique record -> ReaderT backend m (Maybe (Key record))
getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record! getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m (Key record) => Unique record -> ReaderT backend m (Key record)
getKeyBy404 = fmap entityKey . getBy404 -- TODO optimize this, so that DB does not deliver entire record! getKeyBy404 = fmap entityKey . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m Bool => Unique record -> ReaderT backend m Bool
existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record
existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m) existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
=> Key record -> ReaderT backend m Bool => Key record -> ReaderT backend m Bool
existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend ) updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
=> Unique record -> [Update record] -> ReaderT backend m () => Unique record -> [Update record] -> ReaderT backend m ()
updateBy uniq updates = do updateBy uniq updates = do
key <- getKeyBy uniq key <- getKeyBy uniq
for_ key $ flip update updates for_ key $ flip update updates
myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq record which is not needed anyway) -- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible,
:: (MonadIO m -- and 'Just key' for the successfully replaced record
,Eq (Unique record) uniqueReplace :: ( MonadIO m
,PersistRecordBackend record backend , Eq (Unique record)
,PersistUniqueWrite backend) , PersistRecordBackend record backend
=> Key record -> record -> ReaderT backend m (Maybe (Unique record)) , PersistUniqueWrite backend
)
=> Key record -> record -> ReaderT backend m (Maybe (Key record))
uniqueReplace key datumNew = flipMaybe key <$> myReplaceUnique key datumNew
-- | Identical to 'Database.Persist.Class', except for the better type signature (original requires Eq record which is not needed anyway)
myReplaceUnique :: ( MonadIO m
, Eq (Unique record)
, PersistRecordBackend record backend
, PersistUniqueWrite backend
)
=> Key record -> record -> ReaderT backend m (Maybe (Unique record))
myReplaceUnique key datumNew = getJust key >>= replaceOriginal myReplaceUnique key datumNew = getJust key >>= replaceOriginal
where where
uniqueKeysNew = persistUniqueKeys datumNew uniqueKeysNew = persistUniqueKeys datumNew
@ -59,12 +80,12 @@ myReplaceUnique key datumNew = getJust key >>= replaceOriginal
changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal
uniqueKeysOriginal = persistUniqueKeys original uniqueKeysOriginal = persistUniqueKeys original
checkUniqueKeys checkUniqueKeys :: ( MonadIO m
:: (MonadIO m , PersistEntity record
,PersistEntity record , PersistUniqueRead backend
,PersistUniqueRead backend , PersistRecordBackend record backend
,PersistRecordBackend record backend) )
=> [Unique record] -> ReaderT backend m (Maybe (Unique record)) => [Unique record] -> ReaderT backend m (Maybe (Unique record))
checkUniqueKeys [] = return Nothing checkUniqueKeys [] = return Nothing
checkUniqueKeys (x:xs) = do checkUniqueKeys (x:xs) = do
y <- getBy x y <- getBy x

3
src/Utils/Form.hs
View File

@ -169,6 +169,7 @@ data FormIdentifier
= FIDcourse = FIDcourse
| FIDcourseRegister | FIDcourseRegister
| FIDsheet | FIDsheet
| FIDmaterial
| FIDsubmission | FIDsubmission
| FIDsettings | FIDsettings
| FIDcorrectors | FIDcorrectors
@ -574,7 +575,7 @@ formFailure errs' = do
mr <- getMessageRender mr <- getMessageRender
return . FormFailure $ map mr errs' return . FormFailure $ map mr errs'
-- | Turns errors into alerts, ignores missing forms and applies processing function
formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m () formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x

2
templates/material-list.hamlet Normal file
View File

@ -0,0 +1,2 @@
<section>
^{table}

22
templates/material-show.hamlet Normal file
View File

@ -0,0 +1,22 @@
$newline never
$maybe descr <- materialDescription
<section>
<h2 #description>_{MsgMaterialDescription}
<p>
#{descr}
<section>
<dl .deflist>
$maybe matKind <- materialType
<dt .deflist__dt>_{MsgMaterialType}
<dd .deflist__dd>#{matKind}
$maybe matVisible <- materialVisibleFrom
<dt .deflist__dt>_{MsgVisibleFrom}
<dd .deflist__dd>#{matVisible}
<dt .deflist__dt>_{MsgFileModified}
<dd .deflist__dd>#{materialLastEdit}
$if hasFiles || True
<section>
<h2>_{MsgMaterialFiles}
^{fileTable}