From d5e1c92794368c2bb324181e61131b27ca1c604c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Apr 2019 14:01:24 +0200 Subject: [PATCH 01/17] Initial Stubs --- messages/uniworx/de.msg | 15 +++++++-- models/materials | 11 +++++++ routes | 9 +++-- src/Application.hs | 13 ++++---- src/Handler/Material.hs | 73 +++++++++++++++++++++++++++++++++++++++++ src/Handler/Sheet.hs | 3 +- src/Model/Types.hs | 5 +-- src/Utils/Form.hs | 1 + 8 files changed, 117 insertions(+), 13 deletions(-) create mode 100644 models/materials create mode 100644 src/Handler/Material.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7a8c55085..4d0be8c42 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -166,7 +166,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 @@ -208,11 +208,22 @@ 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 +MaterialFiles: Dateien + Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) -UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. +UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden. diff --git a/models/materials b/models/materials new file mode 100644 index 000000000..d715abc63 --- /dev/null +++ b/models/materials @@ -0,0 +1,11 @@ +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 +MaterialFile -- a file that is part of a material distribution + material MaterialId + file FileId \ No newline at end of file diff --git a/routes b/routes index 0e801e22b..a86f39945 100644 --- a/routes +++ b/routes @@ -13,7 +13,7 @@ -- !free -- free for all -- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course) -- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course) --- !registered -- participant for this course (no effect outside of courses) +-- !registered -- current user is participant for this course (no effect outside of courses) -- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses) -- !owner -- part of the group of owners of this submission -- !self -- route refers to the currently logged in user themselves @@ -106,7 +106,12 @@ /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions /corrector-invite/#UserEmail SCorrInviteR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector - + /mat MaterialListR GET !materials !registered !corrector + /mat/new MaterialNewR GET POST + /mat/#MaterialName MaterialR: + /show MShowR GET !timeANDregistered !timeANDmaterials !corrector + /edit MEditR GET POST + /delete MDelR GET POST /subs CorrectionsR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/Application.hs b/src/Application.hs index 5b130dd50..e1dc1904e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -71,7 +71,7 @@ import qualified Data.Aeson as Aeson import System.Exit (exitFailure) import qualified Database.Memcached.Binary.IO as Memcached - + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -87,6 +87,7 @@ import Handler.Course import Handler.Sheet import Handler.Submission import Handler.Corrections +import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage @@ -172,7 +173,7 @@ makeFoundation appSettings'@AppSettings{..} = do (pgPoolSize appDatabaseConf) ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) - + -- Perform database migration using our application's logging settings. migrateAll `runSqlPool` sqlPool appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool @@ -205,7 +206,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 @@ -226,7 +227,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' @@ -346,7 +347,7 @@ appMain = runResourceT $ do -------------------------------------------------------------- foundationStoreNum :: Word32 foundationStoreNum = 2 - + getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) getApplicationRepl = do settings <- getAppDevSettings @@ -357,7 +358,7 @@ getApplicationRepl = do let foundationStore = Store foundationStoreNum liftIO $ deleteStore foundationStore liftIO $ writeStore foundationStore foundation - + return (getPort wsettings, foundation, app1) shutdownApp :: MonadIO m => UniWorX -> m () diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs new file mode 100644 index 000000000..b738e0105 --- /dev/null +++ b/src/Handler/Material.hs @@ -0,0 +1,73 @@ +module Handler.Material where + +import Import + +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Conduit.List as C + +import qualified Database.Esqueleto as E + +import Utils.Lens +import Utils.Form +import Handler.Utils.Form + + +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 <- 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) + +getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getMaterialListR = error "unimplemented" -- TODO + +getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getMaterialNewR = postMaterialNewR +postMaterialNewR = error "unimplemented" -- TODO + +getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMShowR = error "unimplemented" -- TODO + +getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMEditR = postMEditR +postMEditR = error "unimplemented" -- TODO + +getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMDelR = postMDelR +postMDelR = error "unimplemented" -- TODO \ No newline at end of file diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 5016f8662..92f79ed39 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -99,7 +99,8 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do ctime <- 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) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index ab73b6ba7..05d063e6a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -83,7 +83,7 @@ import Data.Text.Metrics (damerauLevenshtein) import Data.Binary (Binary) import qualified Data.Binary as Binary - + instance PathPiece UUID where fromPathPiece = UUID.fromString . unpack @@ -350,7 +350,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,6 +880,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 PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 25180df04..0cd5d0335 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -168,6 +168,7 @@ data FormIdentifier = FIDcourse | FIDcourseRegister | FIDsheet + | FIDmaterial | FIDsubmission | FIDsettings | FIDcorrectors From 80cf36bc3743b735b2a2477b30ab26808ac0c3e9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Sat, 27 Apr 2019 14:46:08 +0200 Subject: [PATCH 02/17] Rounded time for visibility defaults --- src/Handler/Material.hs | 6 +++--- src/Handler/Sheet.hs | 2 +- src/Handler/Utils/DateTime.hs | 15 +++++++++++++++ src/Utils.hs | 13 ++++++++++++- 4 files changed, 31 insertions(+), 5 deletions(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index b738e0105..b644fe3f4 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -10,7 +10,7 @@ import qualified Database.Esqueleto as E import Utils.Lens import Utils.Form -import Handler.Utils.Form +import Handler.Utils data MaterialForm = MaterialForm { @@ -41,7 +41,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do return $ material E.^. MaterialType return $ defaults <> (Set.fromList $ mapMaybe E.unValue previouslyUsed) - ctime <- liftIO $ getCurrentTime + ctime <- ceilingQuarterHour <$> liftIO getCurrentTime flip (renderAForm FormStandard) html $ MaterialForm <$> areq ciField (fslI MsgMaterialName) (mfName <$> template) <*> aopt (textField & addDatalist typeOptions) @@ -50,7 +50,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do <*> aopt htmlField (fslpI MsgMaterialDescription "Html") (mfDescription <$> template) <*> aopt utcTimeField (fslI MsgMaterialVisibleFrom - & setTooltip MsgMaterialVisibleFromTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) + & setTooltip MsgMaterialVisibleFromTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) <*> aopt (multiFileField oldFileIds) (fslI MsgMaterialFiles) (mfFiles <$> template) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 92f79ed39..bd65e4d09 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -96,7 +96,7 @@ 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 (fslpI MsgSheetDescription "Html") diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 15ecfc780..8c42f549d 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -9,6 +9,7 @@ module Handler.Utils.DateTime , addOneWeek, addWeeks , weeksToAdd , setYear + , ceilingQuarterHour ) where import Import @@ -185,3 +186,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) \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs index 40fa580ee..3ac062bcf 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -269,6 +269,17 @@ notUsedT = notUsed +------------- +-- Numeric -- +------------- + +-- | round n to nearest multiple of m +roundToNearestMultiple :: Int -> Int -> Int +roundToNearestMultiple m n = (n `div` m + 1) * m + + + + ------------ -- Monoid -- ------------ @@ -495,7 +506,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 From 212533d88e4cc68d711839ebc207362ce65aa4e9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Sat, 27 Apr 2019 20:33:28 +0200 Subject: [PATCH 03/17] Stubs expanded --- messages/uniworx/de.msg | 4 +++ src/Handler/Material.hs | 62 ++++++++++++++++++++++++++++++++++++----- 2 files changed, 59 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ca9cab2a8..a13812838 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -218,6 +218,10 @@ 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 MaterialFiles: Dateien +MaterialNewHeading: Neues Material veröffentlichen +MaterialNewTitle: Neues Material +MaterialEditHeading name@Text: Material "#{name}" editieren +MaterialEditTitle name@Text: Material "#{name}" editieren Unauthorized: Sie haben hierfür keine explizite Berechtigung. diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index b644fe3f4..754672053 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -5,6 +5,7 @@ import Import import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Conduit.List as C +import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto as E @@ -13,8 +14,8 @@ import Utils.Form import Handler.Utils -data MaterialForm = MaterialForm { - mfName :: MaterialName +data MaterialForm = MaterialForm + { mfName :: MaterialName , mfType :: Maybe Text , mfDescription :: Maybe Html , mfVisibleFrom :: Maybe UTCTime @@ -57,16 +58,63 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR = error "unimplemented" -- TODO -getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getMaterialNewR = postMaterialNewR -postMaterialNewR = error "unimplemented" -- TODO getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMShowR = error "unimplemented" -- TODO -getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMEditR = postMEditR -postMEditR = error "unimplemented" -- TODO +postMEditR tid ssh csh mnm = do + (cid, Entity mid Material{..}, files) <- runDB $ do + [(E.Value cid, matEnt)] <- E.select . E.from $ -- uniqueness guaranteed + \(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 (course E.^. CourseId, material) + 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 (cid, matEnt, (Left . E.unValue) <$> fileIds) + let template = Just $ MaterialForm + { mfName = materialName + , mfType = materialType + , mfDescription = materialDescription + , mfVisibleFrom = materialVisibleFrom + , mfFiles = Just $ yieldMany files + } + editWidget <- handleMaterialEdit tid ssh csh template + let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading $ CI.original mnm + headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle $ CI.original mnm + siteLayoutMsg headingLong $ do + setTitleI headingShort + editWidget + + +getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getMaterialNewR = postMaterialNewR +postMaterialNewR tid ssh csh = do + editWidget <- handleMaterialEdit tid ssh csh Nothing + let headingLong = prependCourseTitle tid ssh csh MsgMaterialNewHeading + headingShort = prependCourseTitle tid ssh csh MsgMaterialNewTitle + siteLayoutMsg headingLong $ do + setTitleI headingShort + editWidget + +handleMaterialEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe MaterialForm -> Handler Widget +handleMaterialEdit tid ssh csh template = do + aid <- requireAuthId + Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + ((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template + actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute + return $ wrapForm formWidget def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = formEnctype + } + getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMDelR = postMDelR From 22ffa3477d342660f82a469c46e33b15004c7c22 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 29 Apr 2019 18:22:07 +0200 Subject: [PATCH 04/17] Saving material mostly implemented --- messages/uniworx/de.msg | 10 +++++--- models/materials | 1 + src/Handler/Material.hs | 57 ++++++++++++++++++++++++++++++----------- src/Handler/Sheet.hs | 6 +---- src/Model.hs | 5 ++-- src/Utils.hs | 6 +++++ src/Utils/DB.hs | 21 ++++++++++++++- src/Utils/Form.hs | 2 +- 8 files changed, 80 insertions(+), 28 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index a13812838..1f391452a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -142,8 +142,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"}! @@ -220,8 +220,10 @@ MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist MaterialFiles: Dateien MaterialNewHeading: Neues Material veröffentlichen MaterialNewTitle: Neues Material -MaterialEditHeading name@Text: Material "#{name}" editieren -MaterialEditTitle name@Text: Material "#{name}" editieren +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} Unauthorized: Sie haben hierfür keine explizite Berechtigung. diff --git a/models/materials b/models/materials index d715abc63..062ab3232 100644 --- a/models/materials +++ b/models/materials @@ -6,6 +6,7 @@ Material -- course material for disemination to course participants 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 \ No newline at end of file diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 754672053..fd484d8ec 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -5,7 +5,7 @@ import Import import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Conduit.List as C -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto as E @@ -86,9 +86,9 @@ postMEditR tid ssh csh mnm = do , mfVisibleFrom = materialVisibleFrom , mfFiles = Just $ yieldMany files } - editWidget <- handleMaterialEdit tid ssh csh template - let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading $ CI.original mnm - headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle $ CI.original mnm + editWidget <- handleMaterialEdit tid ssh csh cid template $ uniqueReplace mid + let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm + headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle mnm siteLayoutMsg headingLong $ do setTitleI headingShort editWidget @@ -97,23 +97,50 @@ postMEditR tid ssh csh mnm = do getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialNewR = postMaterialNewR postMaterialNewR tid ssh csh = do - editWidget <- handleMaterialEdit tid ssh csh Nothing + 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 -> Maybe MaterialForm -> Handler Widget -handleMaterialEdit tid ssh csh template = do - aid <- requireAuthId - Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh - ((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template - actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute - return $ wrapForm formWidget def - { formAction = Just $ SomeRoute actionUrl - , formEncoding = formEnctype - } +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' = error "TODO" getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index bd65e4d09..5f5dfe896 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -503,11 +503,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 diff --git a/src/Model.hs b/src/Model.hs index 7de0d7c1e..6198a2724 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -33,8 +33,9 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll $(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 Course) -- instance Eq TermSchoolCourseShort; instance Eq TermSchoolCourseName +deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet +deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial -- Primary keys mentioned in dbtable row-keys must be Binary -- Automatically generated (i.e. numeric) ids are already taken care of diff --git a/src/Utils.hs b/src/Utils.hs index 3ac062bcf..2db129c24 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -405,6 +405,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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 9700dd88f..fbfcd7e8c 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -10,6 +10,16 @@ import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Persist -- currently not needed here + +-- | 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 @@ -41,7 +51,16 @@ 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) +-- | 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 + +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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 0cd5d0335..082a90b33 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -572,7 +572,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 From c4f47c4856e958dbc9fb94850eb747b2bc21b39e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 30 Apr 2019 10:25:50 +0200 Subject: [PATCH 05/17] minor --- src/Handler/Material.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index fd484d8ec..ca7a05b62 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -140,7 +140,11 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do $ CourseR tid ssh csh (MaterialR mfName MShowR) insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB () - insertMaterialFile' = error "TODO" + insertMaterialFile' mid fs = do + oldFileIds <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do + error "TODO" + + error "TODO" getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html From 3e00f4255a04d72a57dd3d3a13091317b0d99bce Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 30 Apr 2019 19:19:09 +0200 Subject: [PATCH 06/17] saving probably complete --- src/Handler/Material.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index ca7a05b62..a0e2097b7 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -13,6 +13,9 @@ import Utils.Lens import Utils.Form import Handler.Utils +import Control.Monad.Writer (MonadWriter(..), execWriterT) + + data MaterialForm = MaterialForm { mfName :: MaterialName @@ -141,10 +144,18 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB () insertMaterialFile' mid fs = do - oldFileIds <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do - error "TODO" - - error "TODO" + 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 From 09d8c0bb07e05edcf44ed309d3a9b5ddc8bf01aa Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 30 Apr 2019 22:20:21 +0200 Subject: [PATCH 07/17] Deletion stub --- messages/uniworx/de.msg | 2 ++ src/Handler/Material.hs | 40 +++++++++++++++++++++++++++++++--------- 2 files changed, 33 insertions(+), 9 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1f391452a..746d60dce 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -224,6 +224,8 @@ MaterialEditHeading materialName@MaterialName: Material "#{materialName}" editie 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. diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index a0e2097b7..b989e45e0 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -12,6 +12,7 @@ import qualified Database.Esqueleto as E import Utils.Lens import Utils.Form import Handler.Utils +import Handler.Utils.Delete import Control.Monad.Writer (MonadWriter(..), execWriterT) @@ -58,6 +59,19 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do <*> aopt (multiFileField oldFileIds) (fslI MsgMaterialFiles) (mfFiles <$> template) +fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (CourseId, Entity Material) +fetchMaterial tid ssh csh mnm = do + [(E.Value cid, 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 (course E.^. CourseId, material) + return (cid, matEnt) + + getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR = error "unimplemented" -- TODO @@ -69,14 +83,7 @@ getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName - getMEditR = postMEditR postMEditR tid ssh csh mnm = do (cid, Entity mid Material{..}, files) <- runDB $ do - [(E.Value cid, matEnt)] <- E.select . E.from $ -- uniqueness guaranteed - \(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 (course E.^. CourseId, material) + (cid, 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) @@ -160,4 +167,19 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMDelR = postMDelR -postMDelR = error "unimplemented" -- TODO \ No newline at end of file +postMDelR tid ssh csh mnm = do + (_cid, _matEnt) <- runDB $ fetchMaterial tid ssh csh mnm + error "todo" + {- + 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 + } + -} \ No newline at end of file From 09467c21f3213d12eda2e0309b44a5608fd039bd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 2 May 2019 09:51:09 +0200 Subject: [PATCH 08/17] Refactor Sheet Show: unnecessary join removed --- src/Handler/Material.hs | 26 +++++++++++++++++++++++--- src/Handler/Sheet.hs | 15 +++++++-------- 2 files changed, 30 insertions(+), 11 deletions(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index b989e45e0..5dd8ce020 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -12,7 +12,7 @@ import qualified Database.Esqueleto as E import Utils.Lens import Utils.Form import Handler.Utils -import Handler.Utils.Delete +-- import Handler.Utils.Delete import Control.Monad.Writer (MonadWriter(..), execWriterT) @@ -72,12 +72,32 @@ fetchMaterial tid ssh csh mnm = do return (cid, matEnt) + + getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR = error "unimplemented" -- TODO getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html -getMShowR = error "unimplemented" -- TODO +getMShowR = do -- tid ssh csh mnm = do + -- <- runDB $ do + -- (cid, matEnt) <- fetchMaterial tid ssh csh mnm + -- dbTable psValidator DBTable + -- { dbtSQLQuery + + + -- } + + + + -- (cid, Entity mid Material{..}, files) <- runDB $ do + -- (cid, 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 (cid, matEnt, (Left . E.unValue) <$> fileIds) + error "unimplemented" -- TODO getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMEditR = postMEditR @@ -169,7 +189,7 @@ getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> getMDelR = postMDelR postMDelR tid ssh csh mnm = do (_cid, _matEnt) <- runDB $ fetchMaterial tid ssh csh mnm - error "todo" + error "todo" -- CONTINUE HERE {- deleteR DeleteRoute { drRecords = Set.singleton $ entityKey matEnt diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 5f5dfe896..461c23d67 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -305,12 +305,11 @@ 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.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) @@ -325,7 +324,7 @@ getSShowR tid ssh csh shn = do & 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) @@ -335,13 +334,13 @@ getSShowR tid ssh csh shn = do , 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 From 88fc32e13ffb93d623111e7159f2feadd6c77feb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 2 May 2019 17:13:32 +0200 Subject: [PATCH 09/17] Material dbTable almost done, sorting type error --- messages/uniworx/de.msg | 1 + routes | 4 +- src/Handler/Material.hs | 67 +++++++++++++++++++++++----- src/Handler/Sheet.hs | 71 +++++++++++++----------------- src/Handler/Utils.hs | 29 +++++++++++- src/Handler/Utils/Table/Columns.hs | 43 ++++++++++++++++++ 6 files changed, 160 insertions(+), 55 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 746d60dce..ef6ce57ae 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -596,6 +596,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 diff --git a/routes b/routes index a86f39945..135c9baa1 100644 --- a/routes +++ b/routes @@ -109,9 +109,11 @@ /mat MaterialListR GET !materials !registered !corrector /mat/new MaterialNewR GET POST /mat/#MaterialName MaterialR: - /show MShowR GET !timeANDregistered !timeANDmaterials !corrector /edit MEditR GET POST /delete MDelR GET POST + /show MShowR GET !timeANDregistered !timeANDmaterials !corrector + /file/*FilePath MFileR GET !timeANDregistered !timeANDmaterials !corrector + /subs CorrectionsR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 5dd8ce020..528e06d84 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -4,20 +4,25 @@ import Import 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.Columns import Control.Monad.Writer (MonadWriter(..), execWriterT) + data MaterialForm = MaterialForm { mfName :: MaterialName , mfType :: Maybe Text @@ -72,24 +77,62 @@ fetchMaterial tid ssh csh mnm = do return (cid, matEnt) - - getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR = error "unimplemented" -- TODO +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 = do -- tid ssh csh mnm = do - -- <- runDB $ do - -- (cid, matEnt) <- fetchMaterial tid ssh csh mnm - -- dbTable psValidator DBTable - -- { dbtSQLQuery - - - -- } - - +getMShowR tid ssh csh mnm = do + let matLink :: FilePath -> Route UniWorX + matLink = CourseR tid ssh csh . MaterialR mnm . MFileR + _ <- runDB $ do + (cid, matEnt) <- fetchMaterial tid ssh csh mnm + let psValidator = def & defaultSortingByFileTitle + 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 + [ colFilePathSimple (view _1) matLink + , colFileModification (view _2) + ] + , dbtProj = \row -> + let dbrOutput = row ^. _dbrOutput + fPath = dbrOutput ^. _1 . _Value + in guardAuthorizedFor (matLink fPath) dbrOutput + , dbtStyle = def + , dbtParams = def + , dbtFilter = mempty + , dbtFilterUI = mempty + , dbtIdent = "material-files" :: Text + , dbtSorting = Map.fromList + [ sortFilePath $ $(sqlIJproj 2 2) E.^. FileTitle + , sortFileModification $ $(sqlIJproj 2 2) E.^. FileModified + ] + } + -- DEAD CODE TO DELETE: -- (cid, Entity mid Material{..}, files) <- runDB $ do -- (cid, matEnt) <- fetchMaterial tid ssh csh mnm -- fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 461c23d67..0ca8a2698 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 @@ -310,24 +308,25 @@ getSShowR tid ssh csh shn = do E.on (sheetFile E.^. SheetFileFile E.==. file E.^. FileId) -- filter to requested file 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 $ (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` 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 @@ -399,34 +398,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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 46c4e8631..dfca11b4c 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -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) diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 25279fb96..f3be69490 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -34,6 +34,49 @@ import Handler.Utils.Table.Cells -- * additional helper, such as default sorting + +--------------- +-- 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) (timeCell . E.unValue . row2time) + +-- sortFilePath :: IsString a => (t -> E.SqlExpr (Entity ???)) -> (a, SortColumn t) +sortFilePath :: (PersistField a2, IsString a1) => + (t -> E.SqlExpr (E.Value a2)) -> (a1, SortColumn t) +sortFilePath queryPath = ("path", SortColumn queryPath) + +sortFileModification :: (PersistField a2, IsString a1) => + (t -> E.SqlExpr (E.Value a2)) -> (a1, SortColumn t) +sortFileModification queryModification = ("time", SortColumn queryModification) + +defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x +defaultSortingByFileTitle = defaultSorting [SortAscBy "path"] + +defaultSortingByFileModification :: PSValidator m x -> PSValidator m x +defaultSortingByFileModification = defaultSorting [SortAscBy "time"] + + + --------------- -- User names From 126381a409541503e60ad848a010ff42ab4521be Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 May 2019 08:27:11 +0200 Subject: [PATCH 10/17] fix db columns for files --- src/Handler/Material.hs | 4 ++-- src/Handler/Utils/Table/Columns.hs | 11 ++++------- 2 files changed, 6 insertions(+), 9 deletions(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 528e06d84..cf5c46aca 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -127,8 +127,8 @@ getMShowR tid ssh csh mnm = do , dbtFilterUI = mempty , dbtIdent = "material-files" :: Text , dbtSorting = Map.fromList - [ sortFilePath $ $(sqlIJproj 2 2) E.^. FileTitle - , sortFileModification $ $(sqlIJproj 2 2) E.^. FileModified + [ sortFilePath $(sqlIJproj 2 2) + , sortFileModification $(sqlIJproj 2 2) ] } diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index f3be69490..30d2e6a4a 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -60,14 +60,11 @@ colFilePathSimple row2path row2link = sortable (Just "path") (i18nCell MsgFileTi colFileModification :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) colFileModification row2time = sortable (Just "time") (i18nCell MsgFileModified) (timeCell . E.unValue . row2time) --- sortFilePath :: IsString a => (t -> E.SqlExpr (Entity ???)) -> (a, SortColumn t) -sortFilePath :: (PersistField a2, IsString a1) => - (t -> E.SqlExpr (E.Value a2)) -> (a1, SortColumn t) -sortFilePath queryPath = ("path", SortColumn queryPath) +sortFilePath :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r) +sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle)) -sortFileModification :: (PersistField a2, IsString a1) => - (t -> E.SqlExpr (E.Value a2)) -> (a1, SortColumn t) -sortFileModification queryModification = ("time", SortColumn queryModification) +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"] From e0c9f4987a398e07ee1cfe6ea28844902e7b3ad4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 May 2019 12:55:46 +0200 Subject: [PATCH 11/17] Showing material implemented, missing overview --- messages/uniworx/de.msg | 4 +++ src/Foundation.hs | 1 + src/Handler/Material.hs | 51 ++++++++++++++++++++-------------- src/Handler/Sheet.hs | 2 +- src/Utils.hs | 10 +++++-- templates/material-show.hamlet | 22 +++++++++++++++ 6 files changed, 66 insertions(+), 24 deletions(-) create mode 100644 templates/material-show.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ef6ce57ae..e77dd2055 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -217,7 +217,10 @@ 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} MaterialNewHeading: Neues Material veröffentlichen MaterialNewTitle: Neues Material MaterialEditHeading materialName@MaterialName: Material "#{materialName}" editieren @@ -390,6 +393,7 @@ Pseudonyms: Pseudonyme FileTitle: Dateiname FileModified: Letzte Änderung +VisibleFrom: Veröffentlicht Corrected: Korrigiert diff --git a/src/Foundation.hs b/src/Foundation.hs index 46e176a19..150792300 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2027,6 +2027,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) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index cf5c46aca..e7ce5134c 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -2,6 +2,7 @@ module Handler.Material where import Import +import Data.Monoid (Any(..)) import Data.Set (Set) import qualified Data.Set as Set -- import Data.Map (Map) @@ -64,17 +65,17 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do <*> aopt (multiFileField oldFileIds) (fslI MsgMaterialFiles) (mfFiles <$> template) -fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (CourseId, Entity Material) +fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material) fetchMaterial tid ssh csh mnm = do - [(E.Value cid, matEnt)] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints + [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 (course E.^. CourseId, material) - return (cid, matEnt) + return material + return matEnt getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -103,10 +104,11 @@ getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Ht getMShowR tid ssh csh mnm = do let matLink :: FilePath -> Route UniWorX matLink = CourseR tid ssh csh . MaterialR mnm . MFileR - _ <- runDB $ do - (cid, matEnt) <- fetchMaterial tid ssh csh mnm + ( (Entity _mid material@Material{materialType, materialDescription}) + , (Any hasFiles,fileTable)) <- runDB $ do + matEnt <- fetchMaterial tid ssh csh mnm let psValidator = def & defaultSortingByFileTitle - dbTable psValidator DBTable + 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) @@ -131,27 +133,34 @@ getMShowR tid ssh csh mnm = do , sortFileModification $(sqlIJproj 2 2) ] } + return (matEnt,fileTable') + + now <- liftIO $ getCurrentTime + materialLastEdit <- formatTime SelFormatDateTime $ materialLastEdit material + let matVisFro = materialVisibleFrom 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") - -- DEAD CODE TO DELETE: - -- (cid, Entity mid Material{..}, files) <- runDB $ do - -- (cid, 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 (cid, matEnt, (Left . E.unValue) <$> fileIds) - error "unimplemented" -- TODO getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMEditR = postMEditR postMEditR tid ssh csh mnm = do - (cid, Entity mid Material{..}, files) <- runDB $ do - (cid, matEnt) <- fetchMaterial tid ssh csh mnm + (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 (cid, matEnt, (Left . E.unValue) <$> fileIds) + return (matEnt, (Left . E.unValue) <$> fileIds) + -- let cid = materialCourse let template = Just $ MaterialForm { mfName = materialName , mfType = materialType @@ -159,7 +168,7 @@ postMEditR tid ssh csh mnm = do , mfVisibleFrom = materialVisibleFrom , mfFiles = Just $ yieldMany files } - editWidget <- handleMaterialEdit tid ssh csh cid template $ uniqueReplace mid + 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 @@ -231,7 +240,7 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMDelR = postMDelR postMDelR tid ssh csh mnm = do - (_cid, _matEnt) <- runDB $ fetchMaterial tid ssh csh mnm + _matEnt <- runDB $ fetchMaterial tid ssh csh mnm error "todo" -- CONTINUE HERE {- deleteR DeleteRoute diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 0ca8a2698..5d8d7c634 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -364,7 +364,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 diff --git a/src/Utils.hs b/src/Utils.hs index 2db129c24..57f7d2cc2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -159,12 +159,18 @@ isNew False = mempty -- 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 () diff --git a/templates/material-show.hamlet b/templates/material-show.hamlet new file mode 100644 index 000000000..cd8daa63c --- /dev/null +++ b/templates/material-show.hamlet @@ -0,0 +1,22 @@ +$newline never +$maybe descr <- materialDescription +
+

_{MsgMaterialDescription} +

+ #{descr} + +

+
+ $maybe matKind <- materialType +
_{MsgMaterialType} +
#{matKind} + $maybe matVisible <- materialVisibleFrom +
_{MsgVisibleFrom} +
#{matVisible} +
_{MsgFileModified} +
#{materialLastEdit} + +$if hasFiles +
+

_{MsgMaterialFiles} + ^{fileTable} From d2546745dad6ea7de47de96874ba5397b0a6a8fd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 May 2019 14:39:16 +0200 Subject: [PATCH 12/17] Workaround: hasFiles material-show not working --- messages/uniworx/de.msg | 1 + src/Database/Esqueleto/Utils.hs | 10 +++++----- src/Handler/Material.hs | 17 +++++++++++++---- src/Handler/Sheet.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 1 + src/Handler/Utils/Table/Columns.hs | 13 +++++++++++-- src/Handler/Utils/Table/Pagination.hs | 2 +- templates/material-list.hamlet | 2 ++ templates/material-show.hamlet | 2 +- 9 files changed, 36 insertions(+), 14 deletions(-) create mode 100644 templates/material-list.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e77dd2055..7873810fe 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -221,6 +221,7 @@ 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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 6c89e6c96..32eed0a58 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -18,9 +18,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) @@ -43,13 +43,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 @@ -81,7 +81,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 diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index e7ce5134c..29b3a0792 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -79,7 +79,16 @@ fetchMaterial tid ssh csh mnm = do getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getMaterialListR = error "unimplemented" -- TODO +getMaterialListR _tid _ssh _csh = do + -- muid <- maybeAuthId + -- cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + -- table <- return $ error "unimplemented" -- TODO + -- let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialListHeading + -- headingShort = prependCourseTitle tid ssh csh $ MsgMaterialListHeading + -- siteLayoutMsg headingLong $ do + -- setTitleI headingShort + -- $(widgetFile "material-list") + error "unimplemented" -- TODO getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent getMFileR tid ssh csh mnm title = serveOneFile fileQuery @@ -116,7 +125,8 @@ getMShowR tid ssh csh mnm = do return (file E.^. FileTitle, file E.^. FileModified) , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId , dbtColonnade = widgetColonnade $ mconcat - [ colFilePathSimple (view _1) matLink + [ -- dbRowIndicator -- important: contains writer to indicate that the tables is not empty + colFilePathSimple (view _1) matLink , colFileModification (view _2) ] , dbtProj = \row -> @@ -135,16 +145,15 @@ getMShowR tid ssh csh mnm = do } return (matEnt,fileTable') + let matVisFro = materialVisibleFrom material now <- liftIO $ getCurrentTime materialLastEdit <- formatTime SelFormatDateTime $ materialLastEdit material - let matVisFro = materialVisibleFrom 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") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 5d8d7c634..449c906c2 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -154,7 +154,7 @@ 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 + 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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 28b3df6b2..e01f9115a 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -49,6 +49,7 @@ pathPieceCell = cell . toWidget . toPathPiece sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a sqlCell act = mempty & cellContents .~ lift act +-- Recfor line numbers, use dbRow --------------------- -- Icon cells diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 30d2e6a4a..d31f6365f 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -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,14 @@ 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 @@ -48,7 +57,7 @@ colFilePath row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) m 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 :: (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 = @@ -57,7 +66,7 @@ colFilePathSimple row2path row2link = sortable (Just "path") (i18nCell MsgFileTi 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 :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) colFileModification row2time = sortable (Just "time") (i18nCell MsgFileModified) (timeCell . E.unValue . row2time) sortFilePath :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index ce39f6300..6caaebca0 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -910,7 +910,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 diff --git a/templates/material-list.hamlet b/templates/material-list.hamlet new file mode 100644 index 000000000..503a88d43 --- /dev/null +++ b/templates/material-list.hamlet @@ -0,0 +1,2 @@ +
+ ^{table} diff --git a/templates/material-show.hamlet b/templates/material-show.hamlet index cd8daa63c..92dba855e 100644 --- a/templates/material-show.hamlet +++ b/templates/material-show.hamlet @@ -16,7 +16,7 @@ $maybe descr <- materialDescription
_{MsgFileModified}
#{materialLastEdit} -$if hasFiles +$if hasFiles || True

_{MsgMaterialFiles} ^{fileTable} From dc4ec6148f26accb136a057ef29868f18cf640b7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 May 2019 17:18:22 +0200 Subject: [PATCH 13/17] Bugfix: MaterialShow empty table indicator working --- src/Handler/Material.hs | 60 +++++++++++++++++++++++++++++------------ 1 file changed, 43 insertions(+), 17 deletions(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 29b3a0792..483f35671 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -79,16 +79,44 @@ fetchMaterial tid ssh csh mnm = do getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getMaterialListR _tid _ssh _csh = do - -- muid <- maybeAuthId - -- cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh - -- table <- return $ error "unimplemented" -- TODO - -- let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialListHeading - -- headingShort = prependCourseTitle tid ssh csh $ MsgMaterialListHeading - -- siteLayoutMsg headingLong $ do - -- setTitleI headingShort - -- $(widgetFile "material-list") - error "unimplemented" -- TODO +getMaterialListR tid ssh csh = do + let matLink :: MaterialName -> Route UniWorX + matLink = CourseR tid ssh csh . flip MaterialR MShowR + _muid <- maybeAuthId + table <- runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + let 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@DBRow{ dbrOutput=(Entity _ Material{..}) } -> + let link = matLink materialName + in guardAuthorizedFor link dbr + , dbtColonnade = widgetColonnade $ mconcat + [ dbRow + , sortable (Just "name") (i18nCell MsgMaterialName) + $ \DBRow{dbrOutput=(Entity _ Material{..})} -> cell $ toWgt materialName + ] + , dbtSorting = const Map.empty -- Map.fromList + [ + + ] + , 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 @@ -125,14 +153,12 @@ getMShowR tid ssh csh mnm = do 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 _1) matLink - , colFileModification (view _2) + [ dbRowIndicator -- important: contains writer to indicate that the tables is not empty + , colFilePathSimple (view $ _dbrOutput . _1) matLink + , colFileModification (view $ _dbrOutput . _2) ] - , dbtProj = \row -> - let dbrOutput = row ^. _dbrOutput - fPath = dbrOutput ^. _1 . _Value - in guardAuthorizedFor (matLink fPath) dbrOutput + , dbtProj = \dbr@DBRow{ dbrOutput=(E.Value fPath, _) } -> + guardAuthorizedFor (matLink fPath) dbr , dbtStyle = def , dbtParams = def , dbtFilter = mempty From 3021435350af743f77bc7f6a7f5001fe832a11c3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 May 2019 18:08:15 +0200 Subject: [PATCH 14/17] Material working; just links and right missing --- messages/uniworx/de.msg | 2 +- routes | 8 ++++---- src/Handler/Material.hs | 25 +++++++++++++++---------- src/Handler/Utils/Table/Columns.hs | 2 +- 4 files changed, 21 insertions(+), 16 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7873810fe..37a5523e6 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -220,7 +220,7 @@ MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist 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} +MaterialHeading materialName@MaterialName: Material "#{materialName}" MaterialListHeading: Materialien MaterialNewHeading: Neues Material veröffentlichen MaterialNewTitle: Neues Material diff --git a/routes b/routes index 135c9baa1..70c4b50d0 100644 --- a/routes +++ b/routes @@ -106,13 +106,13 @@ /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions /corrector-invite/#UserEmail SCorrInviteR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector - /mat MaterialListR GET !materials !registered !corrector - /mat/new MaterialNewR GET POST - /mat/#MaterialName MaterialR: + /file MaterialListR GET !materials !registered !corrector + /file/new MaterialNewR GET POST + /file/#MaterialName MaterialR: /edit MEditR GET POST /delete MDelR GET POST /show MShowR GET !timeANDregistered !timeANDmaterials !corrector - /file/*FilePath MFileR GET !timeANDregistered !timeANDmaterials !corrector + /part/*FilePath MFileR GET !timeANDregistered !timeANDmaterials !corrector /subs CorrectionsR GET POST !corrector !lecturer diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 483f35671..07a88b731 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -17,6 +17,7 @@ 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) @@ -85,7 +86,8 @@ getMaterialListR tid ssh csh = do _muid <- maybeAuthId table <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - let psValidator = def & defaultSorting [SortDescBy "last-edit"] + 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 @@ -94,17 +96,21 @@ getMaterialListR tid ssh csh = do E.where_ $ material E.^. MaterialCourse E.==. E.val cid return material , dbtRowKey = (E.^. MaterialId) - , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Material{..}) } -> - let link = matLink materialName - in guardAuthorizedFor link dbr + -- , 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) - $ \DBRow{dbrOutput=(Entity _ Material{..})} -> cell $ toWgt materialName + $ liftA2 anchorCell matLink toWgt . materialName . row2material + , sortable (Just "last-edit") (i18nCell MsgFileModified) + $ dateTimeCell . materialLastEdit . row2material ] - , dbtSorting = const Map.empty -- Map.fromList - [ - + , dbtSorting = Map.fromList + [ ( "type" , SortColumn (E.^. MaterialType) ) + , ( "name" , SortColumn (E.^. MaterialName) ) + , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) ) ] , dbtFilter = mempty , dbtFilterUI = mempty @@ -157,8 +163,7 @@ getMShowR tid ssh csh mnm = do , colFilePathSimple (view $ _dbrOutput . _1) matLink , colFileModification (view $ _dbrOutput . _2) ] - , dbtProj = \dbr@DBRow{ dbrOutput=(E.Value fPath, _) } -> - guardAuthorizedFor (matLink fPath) dbr + , dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr , dbtStyle = def , dbtParams = def , dbtFilter = mempty diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index d31f6365f..1c125344b 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -67,7 +67,7 @@ colFilePathSimple row2path row2link = sortable (Just "path") (i18nCell MsgFileTi -- | 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) (timeCell . E.unValue . row2time) +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)) From 071d22ee569057cd0b4ace00c482649dc69541df Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Sat, 4 May 2019 13:14:07 +0200 Subject: [PATCH 15/17] time predicate for materials --- messages/uniworx/de.msg | 3 +- routes | 148 ++++++++++++++++++++-------------------- src/Foundation.hs | 12 +++- 3 files changed, 86 insertions(+), 77 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4586461e8..2ccc7c667 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -171,7 +171,7 @@ SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan SheetName: Name SheetDescription: Hinweise für Teilnehmer SheetGroup: Gruppenabgabe -SheetVisibleFrom: Sichtbar für Teilnehmer ab +SheetVisibleFrom: Verfügbar seit 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 @@ -260,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. diff --git a/routes b/routes index 26fe33c4d..c98fd9131 100644 --- a/routes +++ b/routes @@ -39,94 +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 - /file MaterialListR GET !timeANDcourse-registered !timeANDmaterials !corrector + / 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 - /part/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector - /tuts CTutorialListR GET !tutor + /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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 71eb9835a..3376ef527 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -638,9 +638,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 +662,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 + reutrn Authorized + CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime mbc <- getBy $ TermSchoolCourseShort tid ssh csh From f4b93644a817c79a6e12a0719ede8d5aabf09ddd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Sat, 4 May 2019 15:13:03 +0200 Subject: [PATCH 16/17] PageActions done, all tested --- messages/uniworx/de.msg | 7 ++++- src/Foundation.hs | 54 ++++++++++++++++++++++++++++++-- src/Handler/Material.hs | 13 +++++--- src/Handler/Sheet.hs | 7 +++-- src/Handler/Utils/Table/Cells.hs | 17 +++++++++- 5 files changed, 86 insertions(+), 12 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2ccc7c667..91eb63eeb 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -171,7 +171,7 @@ SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan SheetName: Name SheetDescription: Hinweise für Teilnehmer SheetGroup: Gruppenabgabe -SheetVisibleFrom: Verfügbar seit +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 Bewertung/Fristen sich noch ändern können SheetActiveFrom: Beginn Abgabezeitraum SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich @@ -407,6 +407,7 @@ Pseudonyms: Pseudonyme FileTitle: Dateiname FileModified: Letzte Änderung VisibleFrom: Veröffentlicht +AccessibleSince: Verfügbar seit Corrected: Korrigiert @@ -753,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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 3376ef527..d6aa98f7d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 @@ -668,7 +672,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of cTime <- liftIO getCurrentTime let visible = NTop materialVisibleFrom <= NTop (Just cTime) guard visible - reutrn Authorized + return Authorized CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime @@ -1405,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) @@ -1763,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 @@ -1891,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 diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 07a88b731..56e696daf 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -83,7 +83,7 @@ getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR tid ssh csh = do let matLink :: MaterialName -> Route UniWorX matLink = CourseR tid ssh csh . flip MaterialR MShowR - _muid <- maybeAuthId + now <- liftIO getCurrentTime table <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh let row2material = entityVal . dbrOutput -- no inner join, just Entity Material @@ -104,13 +104,18 @@ getMaterialListR tid ssh csh = do $ 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) ) - , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) ) + [ ( "type" , SortColumn (E.^. MaterialType) ) + , ( "name" , SortColumn (E.^. MaterialName) ) + , ( "visible-from" , SortColumn (E.^. MaterialVisibleFrom) ) + , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) ) ] , dbtFilter = mempty , dbtFilterUI = mempty diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index d12e2723e..e5c86ed26 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -154,6 +154,7 @@ getSheetOldUnassigned tid ssh csh = runDB $ do getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetListR tid ssh csh = do muid <- maybeAuthId + now <- liftIO getCurrentTime cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh let lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do @@ -175,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) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 307336e70..5f7a29e52 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -53,7 +53,13 @@ pathPieceCell = cell . toWidget . toPathPiece sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a sqlCell act = mempty & cellContents .~ lift act --- Recfor line numbers, use dbRow +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 @@ -76,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 @@ -88,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 From c0b2991c16d37a328c3f5ae3500a7eb13d3e6646 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 4 May 2019 17:20:53 +0200 Subject: [PATCH 17/17] Fix haddock --- src/Utils/DB.hs | 50 +++++++++++++++++++++++++------------------------ 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index fbfcd7e8c..b6e7b9950 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -20,8 +20,8 @@ flipMaybe _ (Just _) = Nothing -emptyOrIn :: PersistField typ => - E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) +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) @@ -30,42 +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 -- | 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 :: ( 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 -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)) +-- | 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 @@ -78,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