Merge branch 'feat/materials' into 'master'
Feat/materials See merge request !207
This commit is contained in:
Gregor Kleen
commit
4d7d3f43a5
@ -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}
|
||||
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
|
||||
SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert.
|
||||
SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}.
|
||||
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}
|
||||
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.
|
||||
SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}!
|
||||
@ -172,7 +172,7 @@ SheetName: Name
|
||||
SheetDescription: Hinweise für Teilnehmer
|
||||
SheetGroup: Gruppenabgabe
|
||||
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
|
||||
SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich
|
||||
SheetActiveTo: Ende Abgabezeitraum
|
||||
@ -214,6 +214,29 @@ CourseCorrectionsTitle: Korrekturen für diesen Kurs
|
||||
CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
|
||||
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.
|
||||
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.
|
||||
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
|
||||
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
|
||||
UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
|
||||
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
|
||||
@ -382,6 +406,8 @@ Pseudonyms: Pseudonyme
|
||||
|
||||
FileTitle: Dateiname
|
||||
FileModified: Letzte Änderung
|
||||
VisibleFrom: Veröffentlicht
|
||||
AccessibleSince: Verfügbar seit
|
||||
|
||||
|
||||
Corrected: Korrigiert
|
||||
@ -591,6 +617,7 @@ SheetGroupNoGroups: Keine Gruppenabgabe
|
||||
SheetGroupMaxGroupsize: Maximale Gruppengröße
|
||||
|
||||
SheetFiles: Übungsblatt-Dateien
|
||||
SheetFileTypeHeader: Zugehörigkeit
|
||||
|
||||
NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert
|
||||
NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
|
||||
@ -727,6 +754,10 @@ MenuCorrections: Korrekturen
|
||||
MenuCorrectionsOwn: Meine Korrekturen
|
||||
MenuSubmissions: Abgaben
|
||||
MenuSheetList: Übungsblätter
|
||||
MenuMaterialList: Material
|
||||
MenuMaterialNew: Neues Material veröffentlichen
|
||||
MenuMaterialEdit: Material bearbeiten
|
||||
MenuMaterialDelete: Material löschen
|
||||
MenuTutorialList: Tutorien
|
||||
MenuTutorialNew: Neues Tutorium anlegen
|
||||
MenuSheetNew: Neues Übungsblatt anlegen
|
||||
|
||||
12
models/materials
Normal file
12
models/materials
Normal 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
145
routes
@ -39,87 +39,94 @@
|
||||
/favicon.ico FaviconR GET !free
|
||||
/robots.txt RobotsR GET !free
|
||||
|
||||
/ HomeR GET !free
|
||||
/users UsersR GET -- no tags, i.e. admins only
|
||||
/users/#CryptoUUIDUser AdminUserR GET POST
|
||||
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST
|
||||
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
|
||||
/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self
|
||||
/admin AdminR GET
|
||||
/admin/features AdminFeaturesR GET POST
|
||||
/admin/test AdminTestR GET POST
|
||||
/admin/errMsg AdminErrMsgR GET POST
|
||||
/ HomeR GET !free
|
||||
/users UsersR GET -- no tags, i.e. admins only
|
||||
/users/#CryptoUUIDUser AdminUserR GET POST
|
||||
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST
|
||||
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
|
||||
/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self
|
||||
/admin AdminR GET
|
||||
/admin/features AdminFeaturesR GET POST
|
||||
/admin/test AdminTestR GET POST
|
||||
/admin/errMsg AdminErrMsgR GET POST
|
||||
|
||||
/health HealthR GET !free
|
||||
/instance InstanceR GET !free
|
||||
/info InfoR GET !free
|
||||
/info/lecturer InfoLecturerR GET !lecturer
|
||||
/info/data DataProtR GET !free
|
||||
/impressum ImpressumR GET !free
|
||||
/version VersionR GET !free
|
||||
/health HealthR GET !free
|
||||
/instance InstanceR GET !free
|
||||
/info InfoR GET !free
|
||||
/info/lecturer InfoLecturerR GET !lecturer
|
||||
/info/data DataProtR GET !free
|
||||
/impressum ImpressumR GET !free
|
||||
/version VersionR GET !free
|
||||
|
||||
/help HelpR GET POST !free
|
||||
/help HelpR GET POST !free
|
||||
|
||||
/user ProfileR GET POST !free
|
||||
/user/profile ProfileDataR GET !free
|
||||
/user/authpreds AuthPredsR GET POST !free
|
||||
/user ProfileR GET POST !free
|
||||
/user/profile ProfileDataR GET !free
|
||||
/user/authpreds AuthPredsR GET POST !free
|
||||
|
||||
/term TermShowR GET !free
|
||||
/term/current TermCurrentR GET !free
|
||||
/term/edit TermEditR GET POST
|
||||
/term/#TermId/edit TermEditExistR GET POST
|
||||
!/term/#TermId TermCourseListR GET !free
|
||||
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
|
||||
/term TermShowR GET !free
|
||||
/term/current TermCurrentR GET !free
|
||||
/term/edit TermEditR GET POST
|
||||
/term/#TermId/edit TermEditExistR GET POST
|
||||
!/term/#TermId TermCourseListR GET !free
|
||||
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
|
||||
|
||||
/school SchoolListR GET !development
|
||||
/school/#SchoolId SchoolShowR GET !development
|
||||
/school SchoolListR GET !development
|
||||
/school/#SchoolId SchoolShowR GET !development
|
||||
|
||||
|
||||
-- For Pattern Synonyms see Foundation
|
||||
/course/ CourseListR GET !free
|
||||
!/course/new CourseNewR GET POST !lecturer
|
||||
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
|
||||
/ CShowR GET !free
|
||||
/register CRegisterR GET POST !timeANDcapacity
|
||||
/edit CEditR GET POST
|
||||
/lecturer-invite/#UserEmail CLecInviteR GET POST
|
||||
/delete CDeleteR GET POST !lecturerANDempty
|
||||
/users CUsersR GET POST
|
||||
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
|
||||
/correctors CHiWisR GET
|
||||
/communication CCommR GET POST
|
||||
/notes CNotesR GET POST !corrector
|
||||
/subs CCorrectionsR GET POST
|
||||
/ex SheetListR GET !course-registered !materials !corrector
|
||||
/ex/new SheetNewR GET POST
|
||||
/ex/current SheetCurrentR GET !course-registered !materials !corrector
|
||||
/ex/unassigned SheetOldUnassigned GET
|
||||
/course/ CourseListR GET !free
|
||||
!/course/new CourseNewR GET POST !lecturer
|
||||
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
|
||||
/ CShowR GET !free
|
||||
/register CRegisterR GET POST !timeANDcapacity
|
||||
/edit CEditR GET POST
|
||||
/lecturer-invite/#UserEmail CLecInviteR GET POST
|
||||
/delete CDeleteR GET POST !lecturerANDempty
|
||||
/users CUsersR GET POST
|
||||
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
|
||||
/correctors CHiWisR GET
|
||||
/communication CCommR GET POST
|
||||
/notes CNotesR GET POST !corrector
|
||||
/subs CCorrectionsR GET POST
|
||||
/ex SheetListR GET !course-registered !materials !corrector
|
||||
/ex/new SheetNewR GET POST
|
||||
/ex/current SheetCurrentR GET !course-registered !materials !corrector
|
||||
/ex/unassigned SheetOldUnassigned GET
|
||||
/ex/#SheetName SheetR:
|
||||
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
/subs SSubsR GET POST -- for lecturer only
|
||||
!/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions
|
||||
!/subs/own SubmissionOwnR GET !free -- just redirect
|
||||
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
/subs SSubsR GET POST -- for lecturer only
|
||||
!/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions
|
||||
!/subs/own SubmissionOwnR GET !free -- just redirect
|
||||
/subs/#CryptoFileNameSubmission SubmissionR:
|
||||
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
|
||||
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector
|
||||
/delete SubDelR GET POST !ownerANDtime
|
||||
/assign SAssignR GET POST !lecturerANDtime
|
||||
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
|
||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
|
||||
/correctors SCorrR GET POST
|
||||
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
|
||||
/corrector-invite/#UserEmail SCorrInviteR GET POST
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector
|
||||
/tuts CTutorialListR GET !tutor
|
||||
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
|
||||
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector
|
||||
/delete SubDelR GET POST !ownerANDtime
|
||||
/assign SAssignR GET POST !lecturerANDtime
|
||||
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
|
||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
|
||||
/correctors SCorrR GET POST
|
||||
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
|
||||
/corrector-invite/#UserEmail SCorrInviteR GET POST
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector
|
||||
/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/#TutorialName TutorialR:
|
||||
/edit TEditR GET POST
|
||||
/delete TDeleteR GET POST
|
||||
/participants TUsersR GET POST !tutor
|
||||
/register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered
|
||||
/communication TCommR GET POST !tutor
|
||||
/edit TEditR GET POST
|
||||
/delete TDeleteR GET POST
|
||||
/participants TUsersR GET POST !tutor
|
||||
/register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered
|
||||
/communication TCommR GET POST !tutor
|
||||
|
||||
|
||||
/subs CorrectionsR GET POST !corrector !lecturer
|
||||
|
||||
@ -80,7 +80,7 @@ import System.Environment (lookupEnv)
|
||||
import System.Posix.Process (getProcessID)
|
||||
|
||||
import Control.Monad.Trans.State (execStateT)
|
||||
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
||||
import Handler.Common
|
||||
@ -97,6 +97,7 @@ import Handler.Sheet
|
||||
import Handler.Submission
|
||||
import Handler.Tutorial
|
||||
import Handler.Corrections
|
||||
import Handler.Material
|
||||
import Handler.CryptoIDDispatch
|
||||
import Handler.SystemMessage
|
||||
import Handler.Health
|
||||
@ -189,7 +190,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
ldapPool <- for appLdapConf $ \LdapConf{..} -> do
|
||||
$logDebugS "setup" "LDAP-Pool"
|
||||
createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
|
||||
|
||||
|
||||
-- Perform database migration using our application's logging settings.
|
||||
$logDebugS "setup" "Migration"
|
||||
migrateAll `runSqlPool` sqlPool
|
||||
@ -231,7 +232,7 @@ clusterSetting proxy@(knownClusterSetting -> key) = do
|
||||
new <- initClusterSetting proxy
|
||||
void . insert $ ClusterConfig key (Aeson.toJSON new)
|
||||
return new
|
||||
|
||||
|
||||
readInstanceIDFile :: MonadIO m => FilePath -> m UUID
|
||||
readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
|
||||
where
|
||||
@ -252,7 +253,7 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
|
||||
let
|
||||
withLogging :: LoggingT IO a -> IO a
|
||||
withLogging = flip runLoggingT logFunc
|
||||
|
||||
|
||||
mkConnection = withLogging $ do
|
||||
$logInfoS "SMTP" "Opening new connection"
|
||||
liftIO mkConnection'
|
||||
@ -353,7 +354,7 @@ adjustSettings = execStateT $ do
|
||||
Just wInterval
|
||||
| maybe True (== myProcessID) watchdogProcess
|
||||
-> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2)
|
||||
_other -> return ()
|
||||
_other -> return ()
|
||||
|
||||
-- | main function for use by yesod devel
|
||||
develMain :: IO ()
|
||||
@ -373,7 +374,7 @@ appMain = runResourceT $ do
|
||||
|
||||
-- Generate the foundation from the settings
|
||||
foundation <- makeFoundation settings
|
||||
|
||||
|
||||
runAppLoggingT foundation $ do
|
||||
$logDebugS "setup" "Job-Handling"
|
||||
handleJobs foundation
|
||||
@ -406,7 +407,7 @@ appMain = runResourceT $ do
|
||||
--------------------------------------------------------------
|
||||
foundationStoreNum :: Word32
|
||||
foundationStoreNum = 2
|
||||
|
||||
|
||||
getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application)
|
||||
getApplicationRepl = do
|
||||
settings <- getAppDevSettings
|
||||
@ -418,7 +419,7 @@ getApplicationRepl = do
|
||||
let foundationStore = Store foundationStoreNum
|
||||
liftIO $ deleteStore foundationStore
|
||||
liftIO $ writeStore foundationStore foundation
|
||||
|
||||
|
||||
return (getPort wsettings, foundation, app1)
|
||||
|
||||
shutdownApp :: MonadIO m => UniWorX -> m ()
|
||||
|
||||
@ -19,9 +19,9 @@ import Database.Esqueleto.Utils.TH
|
||||
|
||||
|
||||
--
|
||||
-- Description : Convenience for using @Esqueleto@,
|
||||
-- Description : Convenience for using `Esqueleto`,
|
||||
-- intended to be imported qualified
|
||||
-- just like Esqueleto
|
||||
-- just like @Esqueleto@
|
||||
|
||||
|
||||
-- ezero = E.val (0 :: Int64)
|
||||
@ -44,13 +44,13 @@ hasInfix :: (E.Esqueleto query expr backend, E.SqlString s2) =>
|
||||
hasInfix = flip isInfixOf
|
||||
|
||||
-- | 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 =>
|
||||
(a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
|
||||
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
|
||||
-- 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 =>
|
||||
(a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
|
||||
all test = F.foldr (\needle acc -> acc E.&&. test needle) true
|
||||
@ -82,7 +82,7 @@ mkExactFilter :: (PersistField a)
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
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)
|
||||
=> (a -> b) -- ^ type conversion
|
||||
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
|
||||
|
||||
@ -163,9 +163,13 @@ pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR
|
||||
pattern CSheetR tid ssh csh 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 tid ssh csh shn ptn
|
||||
= CourseR tid ssh csh (TutorialR shn ptn)
|
||||
pattern CTutorialR tid ssh csh tnm ptn
|
||||
= CourseR tid ssh csh (TutorialR tnm ptn)
|
||||
|
||||
pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX
|
||||
pattern CSubmissionR tid ssh csh shn cid ptn
|
||||
@ -638,9 +642,9 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
-> return Authorized
|
||||
| otherwise
|
||||
-> mzero
|
||||
|
||||
|
||||
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
|
||||
cTime <- liftIO getCurrentTime
|
||||
let
|
||||
@ -662,6 +666,14 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
|
||||
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
|
||||
now <- liftIO getCurrentTime
|
||||
mbc <- getBy $ TermSchoolCourseShort tid ssh csh
|
||||
@ -1397,6 +1409,14 @@ instance YesodBreadcrumbs UniWorX where
|
||||
-- (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)
|
||||
-- (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
|
||||
breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR)
|
||||
breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
|
||||
@ -1755,6 +1775,14 @@ pageActions (CourseNewR) = [
|
||||
]
|
||||
pageActions (CourseR tid ssh csh CShowR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuMaterialList
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuSheetList
|
||||
, menuItemIcon = Nothing
|
||||
@ -1883,6 +1911,34 @@ pageActions (CourseR tid ssh csh SheetListR) =
|
||||
, 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) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
@ -2212,6 +2268,7 @@ pageHeading (CourseR tid ssh csh SheetNewR)
|
||||
= Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh
|
||||
pageHeading (CSheetR tid ssh csh shn SShowR)
|
||||
= 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)
|
||||
= Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn
|
||||
pageHeading (CSheetR tid ssh csh shn SDelR)
|
||||
|
||||
302
src/Handler/Material.hs
Normal file
302
src/Handler/Material.hs
Normal 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
|
||||
}
|
||||
-}
|
||||
@ -4,12 +4,12 @@ import Import
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
import System.FilePath (takeFileName)
|
||||
|
||||
-- import Utils.Lens
|
||||
import Utils.Sheet
|
||||
import Handler.Utils
|
||||
-- import Handler.Utils.Zip
|
||||
import Handler.Utils.Table.Cells
|
||||
-- import Handler.Utils.Table.Columns
|
||||
import Handler.Utils.SheetType
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Form.MassInput
|
||||
@ -38,8 +38,6 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
||||
|
||||
import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE)
|
||||
|
||||
import Network.Mime
|
||||
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
@ -96,10 +94,11 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
|
||||
Nothing -> return $ partitionFileType mempty
|
||||
(Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
|
||||
mr <- getMsgRenderer
|
||||
ctime <- liftIO $ getCurrentTime
|
||||
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
||||
<$> areq ciField (fslI MsgSheetName) (sfName <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
||||
<*> aopt htmlField (fslpI MsgSheetDescription "Html")
|
||||
(sfDescription <$> template)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType
|
||||
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
|
||||
(sfType <$> template)
|
||||
@ -155,7 +154,8 @@ getSheetOldUnassigned tid ssh csh = runDB $ do
|
||||
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetListR tid ssh csh = do
|
||||
muid <- maybeAuthId
|
||||
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
now <- liftIO getCurrentTime
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let
|
||||
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
@ -176,9 +176,9 @@ getSheetListR tid ssh csh = do
|
||||
, sortable (Just "name") (i18nCell MsgSheet)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
|
||||
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
|
||||
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty dateTimeCell mEditTime
|
||||
, sortable (Just "visible-from") (i18nCell MsgSheetVisibleFrom)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> maybe mempty dateTimeCell sheetVisibleFrom
|
||||
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> foldMap dateTimeCell mEditTime
|
||||
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
|
||||
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveFrom
|
||||
, 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
|
||||
-- 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
|
||||
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
|
||||
E.on (sheetFile E.^. SheetFileSheet E.==. sheet' E.^. SheetId)
|
||||
E.on (sheetFile E.^. SheetFileFile E.==. file E.^. FileId)
|
||||
-- filter to requested file
|
||||
E.where_ $ sheet' E.^. SheetId E.==. E.val sid
|
||||
E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
|
||||
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
|
||||
E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories
|
||||
-- return desired columns
|
||||
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = widgetColonnade $ mconcat
|
||||
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
|
||||
, sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell
|
||||
(CSheetR tid ssh csh shn (SFileR fType fName))
|
||||
(str2widget fName)
|
||||
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
|
||||
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
|
||||
, sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell
|
||||
(CSheetR tid ssh csh shn (SFileR fType fName))
|
||||
(str2widget fName)
|
||||
-- , 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
|
||||
& defaultSorting [SortAscBy "type", SortAscBy "path"]
|
||||
let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
|
||||
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
|
||||
{ dbtSQLQuery = fileData
|
||||
, dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId
|
||||
, dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
|
||||
, dbtColonnade = colonnadeFiles
|
||||
, 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
|
||||
, dbtFilter = mempty
|
||||
, dbtFilterUI = mempty
|
||||
, dbtIdent = "files" :: Text
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "type"
|
||||
, SortColumn $ \(_sheet `E.InnerJoin` sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType
|
||||
, SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType
|
||||
)
|
||||
, ( "path"
|
||||
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
|
||||
, SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
|
||||
)
|
||||
, ( "time"
|
||||
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified
|
||||
, SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified
|
||||
)
|
||||
]
|
||||
, dbtParams = def
|
||||
@ -365,7 +365,7 @@ getSShowR tid ssh csh shn = do
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetTitle tid ssh csh shn
|
||||
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
|
||||
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
|
||||
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo 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 tid ssh csh shn typ title = do
|
||||
results <- runDB $ E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
|
||||
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
|
||||
-- filter to requested file
|
||||
E.where_ ((file E.^. FileTitle E.==. E.val title)
|
||||
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
|
||||
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
||||
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 desired columns
|
||||
return $ (file E.^. FileTitle, file E.^. FileContent)
|
||||
case results of
|
||||
[(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."
|
||||
getSFileR tid ssh csh shn typ title = serveOneFile fileQuery
|
||||
where
|
||||
fileQuery = E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
|
||||
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
|
||||
-- filter to requested file
|
||||
E.where_ ((file E.^. FileTitle E.==. E.val title)
|
||||
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
|
||||
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
||||
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
|
||||
|
||||
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetNewR tid ssh csh = do
|
||||
@ -502,11 +492,7 @@ getSEditR tid ssh csh shn = do
|
||||
, sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
|
||||
, sfMarkingText = sheetMarkingText
|
||||
}
|
||||
let action newSheet = do
|
||||
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
|
||||
let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
|
||||
handleSheetEdit tid ssh csh (Just sid) template action
|
||||
|
||||
postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
|
||||
@ -30,7 +30,9 @@ import Handler.Utils.Sheet as Handler.Utils
|
||||
import Handler.Utils.Mail as Handler.Utils
|
||||
|
||||
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.NonEmpty as NonEmpty
|
||||
@ -45,6 +47,22 @@ downloadFiles = do
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
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 = fmap TermKey . maybeRight . termFromText
|
||||
|
||||
@ -171,3 +189,12 @@ i18nWidgetFile basename = do
|
||||
| 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
|
||||
] [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)
|
||||
|
||||
@ -9,6 +9,7 @@ module Handler.Utils.DateTime
|
||||
, addOneWeek, addWeeks
|
||||
, weeksToAdd
|
||||
, setYear
|
||||
, ceilingQuarterHour
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -190,3 +191,17 @@ weeksToAdd old new = loop 0 old
|
||||
loop n t
|
||||
| t > new = n
|
||||
| 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)
|
||||
@ -53,6 +53,13 @@ pathPieceCell = cell . toWidget . toPathPiece
|
||||
sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a
|
||||
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
|
||||
@ -75,6 +82,9 @@ commentCell Nothing = mempty
|
||||
commentCell (Just link) = anchorCell link icon
|
||||
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
|
||||
@ -87,6 +97,12 @@ dateCell t = cell $ formatTime SelFormatDate t >>= toWidget
|
||||
dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a
|
||||
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 displayName surname = cell $ nameWidget displayName surname
|
||||
|
||||
|
||||
@ -11,6 +11,7 @@ import Import
|
||||
|
||||
-- import Text.Blaze (ToMarkup(..))
|
||||
|
||||
import Data.Monoid (Any(..))
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils as E
|
||||
|
||||
@ -34,6 +35,54 @@ import Handler.Utils.Table.Cells
|
||||
-- * 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
|
||||
|
||||
|
||||
@ -931,7 +931,7 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
|
||||
|
||||
-- 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 = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
|
||||
|
||||
|
||||
@ -32,10 +32,11 @@ import Data.Binary (Binary)
|
||||
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
|
||||
$(persistDirectoryWith lowerCaseSettings "models")
|
||||
|
||||
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
|
||||
deriving instance Eq (Unique Course)
|
||||
deriving instance Eq (Unique Sheet)
|
||||
deriving instance Eq (Unique Tutorial)
|
||||
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only; comments helpful for searching in code
|
||||
deriving instance Eq (Unique Course) -- instance Eq TermSchoolCourseShort; instance Eq TermSchoolCourseName
|
||||
deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet
|
||||
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
|
||||
-- Automatically generated (i.e. numeric) ids are already taken care of
|
||||
|
||||
@ -90,7 +90,7 @@ import Data.Time.LocalTime (LocalTime, TimeOfDay)
|
||||
import Data.Semigroup (Min(..))
|
||||
import Control.Monad.Trans.Writer (execWriter)
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
|
||||
|
||||
|
||||
instance PathPiece UUID where
|
||||
fromPathPiece = UUID.fromString . unpack
|
||||
@ -357,7 +357,7 @@ classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
|
||||
classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector
|
||||
classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
|
||||
classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth
|
||||
|
||||
|
||||
|
||||
data ExamStatus = Attended | NoShow | Voided
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
|
||||
@ -880,11 +880,11 @@ derivePersistFieldJSON ''LecturerType
|
||||
|
||||
instance Hashable LecturerType
|
||||
|
||||
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece
|
||||
} ''WeekDay
|
||||
|
||||
|
||||
data OccurenceSchedule = ScheduleWeekly
|
||||
{ scheduleDayOfWeek :: WeekDay
|
||||
, scheduleStart :: TimeOfDay
|
||||
@ -984,6 +984,7 @@ type SchoolShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
type CourseShorthand = CI Text
|
||||
type SheetName = CI Text
|
||||
type MaterialName = CI Text
|
||||
type UserEmail = CI Email
|
||||
type TutorialName = CI Text
|
||||
|
||||
|
||||
29
src/Utils.hs
29
src/Utils.hs
@ -168,12 +168,18 @@ boolSymbol False = [shamlet|<i .fas .fa-times>|]
|
||||
|
||||
-- DEPRECATED: use hasTickmark instead;
|
||||
-- maybe reinstate if needed for @bewertung.txt@ files
|
||||
|
||||
-- tickmark :: IsString a => a
|
||||
-- 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 = 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)
|
||||
=> 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 --
|
||||
------------
|
||||
@ -403,6 +420,12 @@ toNothing = const Nothing
|
||||
toNothingS :: String -> Maybe b
|
||||
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 (Just x) (Just y) = Just (x + 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 err act = maybeExceptT err $ runMaybeT act
|
||||
|
||||
|
||||
maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b
|
||||
maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act
|
||||
|
||||
|
||||
@ -10,8 +10,18 @@ import qualified Data.Set as Set
|
||||
import qualified Database.Esqueleto as E
|
||||
-- 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
|
||||
| Set.null testSet = E.val True
|
||||
| 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
|
||||
|
||||
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!
|
||||
|
||||
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!
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
key <- getKeyBy uniq
|
||||
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)
|
||||
:: (MonadIO m
|
||||
,Eq (Unique record)
|
||||
,PersistRecordBackend record backend
|
||||
,PersistUniqueWrite backend)
|
||||
=> Key record -> record -> ReaderT backend m (Maybe (Unique record))
|
||||
-- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible,
|
||||
-- and 'Just key' for the successfully replaced record
|
||||
uniqueReplace :: ( MonadIO m
|
||||
, Eq (Unique record)
|
||||
, PersistRecordBackend record backend
|
||||
, 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
|
||||
where
|
||||
uniqueKeysNew = persistUniqueKeys datumNew
|
||||
@ -59,12 +80,12 @@ myReplaceUnique key datumNew = getJust key >>= replaceOriginal
|
||||
changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal
|
||||
uniqueKeysOriginal = persistUniqueKeys original
|
||||
|
||||
checkUniqueKeys
|
||||
:: (MonadIO m
|
||||
,PersistEntity record
|
||||
,PersistUniqueRead backend
|
||||
,PersistRecordBackend record backend)
|
||||
=> [Unique record] -> ReaderT backend m (Maybe (Unique record))
|
||||
checkUniqueKeys :: ( MonadIO m
|
||||
, PersistEntity record
|
||||
, PersistUniqueRead backend
|
||||
, PersistRecordBackend record backend
|
||||
)
|
||||
=> [Unique record] -> ReaderT backend m (Maybe (Unique record))
|
||||
checkUniqueKeys [] = return Nothing
|
||||
checkUniqueKeys (x:xs) = do
|
||||
y <- getBy x
|
||||
|
||||
@ -169,6 +169,7 @@ data FormIdentifier
|
||||
= FIDcourse
|
||||
| FIDcourseRegister
|
||||
| FIDsheet
|
||||
| FIDmaterial
|
||||
| FIDsubmission
|
||||
| FIDsettings
|
||||
| FIDcorrectors
|
||||
@ -574,7 +575,7 @@ formFailure errs' = do
|
||||
mr <- getMessageRender
|
||||
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 res f = void . formResultMaybe res $ \x -> Nothing <$ f x
|
||||
|
||||
|
||||
2
templates/material-list.hamlet
Normal file
2
templates/material-list.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
<section>
|
||||
^{table}
|
||||
22
templates/material-show.hamlet
Normal file
22
templates/material-show.hamlet
Normal 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}
|
||||
Loading…
Reference in New Issue
Block a user