diff --git a/FragenSJ.txt b/FragenSJ.txt index c2219f2c1..6ddd8de2b 100644 --- a/FragenSJ.txt +++ b/FragenSJ.txt @@ -1,7 +1,7 @@ ** Sicherheitsabfragen? - Verschlüsselung des Zugriffs? - - SheetDelR tid csh sn : GET zeigt Sicherheitsabfrage + - SDelR tid csh sn : GET zeigt Sicherheitsabfrage POST löscht. Ist das so sinnvoll? Sicherheitsabfrage als PopUpMessage? @@ -9,7 +9,7 @@ - Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq? (Sheet.hs -> fetchSheet) - - Handler.Sheet.postSheetDelR: deleteCascade für Files? Klappt das? + - Handler.Sheet.postSDelR: deleteCascade für Files? Klappt das? Kann man abfragen, was bei deleteCascade alles gelöscht wird? @@ -19,7 +19,7 @@ Links -> MenuItems verwenden wie bisher Page Titles -> setTitleI Buttons? -> Kann leicht geändert werden! - Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getCourseListTermR, Zeile 66 "pageActions" für menuItemLabel? + Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getTermCourseListR, Zeile 66 "pageActions" für menuItemLabel? ** Page pageActions - Berechtigungen prüfen? => Eigener Constructor statt NavbarLeft/Right?! diff --git a/README.md b/README.md index cf42dc5da..be734df7b 100644 --- a/README.md +++ b/README.md @@ -109,7 +109,7 @@ TABLE "user"; DROP TABLE "course" CASCADE; -- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer) -INSERT INTO "user_lecturer" (id,"user",school) VALUES (27,5,1); +INSERT INTO "user_lecturer" (id,"user","school") VALUES (27,5,1); -- Beenden: \q diff --git a/messages/de.msg b/messages/de.msg index 15f357010..57f9d7775 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -21,12 +21,16 @@ SheetDelTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Übun SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben. SheetDelOk tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. +Unauthorized: Sie haben hierfür keine explizite Berechtigung. +UnauthorizedAnd l@Text r@Text: "#{l}" und "#{r}" +UnauthorizedOr l@Text r@Text: "#{l}" oder "#{r}" UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen. UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert. OnlyUploadOneFile: Bitte nur eine Datei hochladen. +DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen. SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. diff --git a/models b/models index e9f9246da..4ebb5d3a0 100644 --- a/models +++ b/models @@ -143,8 +143,8 @@ SubmissionEdit SubmissionFile submission SubmissionId file FileId - isUpdate Bool - isDeletion Bool + isUpdate Bool -- is this the file updated by a corrector (original will always be retained) + isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector UniqueSubmissionFile file submission isUpdate deriving Show SubmissionUser diff --git a/routes b/routes index 8dc1ec910..78ba708aa 100644 --- a/routes +++ b/routes @@ -1,45 +1,64 @@ -/static StaticR Static appStatic -/auth AuthR Auth getAuth +-- +-- Accesss granted via tags; default is no accesss. +-- Permission must be explicitly granted. +-- +-- Access permission is the disjunction of permit tags +-- Tags are split on "AND" to encode conjunction. +-- +-- Note that nested routes automatically inherit all tags from the parent. +-- +-- Admins always have access to entities within their assigned schools. +-- +-- Access Tags: +-- !free -- free for all +-- !lecturer -- lecturer for this course (or the school, if route is not connected to a course) +-- !corrector -- corrector for this sheet (or the course, if route is not connected to a sheet ) +-- !registered -- participant for this course (no effect outside of courses) +-- +-- !materials -- only if course allows all materials to be free (no meaning outside of courses) +-- !time -- access depends on time somehow +-- +-- !deprecated -- like free, but logs and gives a warning +-- -/favicon.ico FaviconR GET -/robots.txt RobotsR GET +/static StaticR Static appStatic !free +/auth AuthR Auth getAuth !free -/ HomeR GET POST -/profile ProfileR GET -/users UsersR GET !adminAny +/favicon.ico FaviconR GET !free +/robots.txt RobotsR GET !free -/term TermShowR GET -/term/edit TermEditR GET POST !adminAny -/term/#TermId/edit TermEditExistR GET !adminAny +/ HomeR GET POST !free +/profile ProfileR GET !free +/users UsersR GET -- no tags, i.e. admins only + +/term TermShowR GET !free +/term/edit TermEditR GET POST +/term/#TermId/edit TermEditExistR GET +!/term/#TermId TermCourseListR GET !free -- For Pattern Synonyms see Foundation -/course/ CourseListR GET -!/course/new CourseNewR GET POST !lecturerAny -!/course/#TermId CourseListTermR GET -/course/#TermId/#Text CourseR !updateFavourite: - /show CourseShowR GET POST - /edit CourseEditR GET POST !lecturer - - /ex SheetR !registered: - / SheetListR GET - /#Text/show SheetShowR GET !time - /#Text/#SheetFileType/#FilePath SheetFileR GET !time - /new SheetNewR GET POST !lecturer - /#Text/edit SheetEditR GET POST !lecturer - /#Text/delete SheetDelR GET POST !lecturer - /#Text/correctors SheetCorrectorsR GET POST !lecturer - !/#Text/submission/#SubmissionMode SubmissionR GET POST !time +/course/ CourseListR GET !free +!/course/new CourseNewR GET POST !lecturer +/course/#TermId/#Text CourseR !lecturer: + /show CShowR GET POST !free + /edit CEditR GET POST + /ex SheetListR GET !materials + !/ex/new SheetNewR GET POST + /ex/#Text SheetR !materials: + /show SShowR GET !time !corrector + /#SheetFileType/#FilePath SFileR GET !time !corrector + /edit SEditR GET POST + /delete SDelR GET POST + !/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered + /correctors SCorrR GET POST -!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET -!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET - -!/#UUID CryptoUUIDDispatchR GET +!/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- TODO below -/submission SubmissionListR GET POST -/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST -/submissions.zip SubmissionDownloadMultiArchiveR POST +!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated +!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated --- For demonstration -/course/#CryptoUUIDCourse/edit CourseEditIDR GET +/submission SubmissionListR GET !deprecated +/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated +/submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated diff --git a/src/Foundation.hs b/src/Foundation.hs index 228d92f4f..01f64a96b 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,9 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} @@ -30,6 +32,7 @@ import LDAP.Search (LDAPEntry(..)) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe +import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Data.Text.Encoding as TE @@ -45,6 +48,13 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import Data.List (foldr1) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map + + import Data.Conduit (($$)) import Data.Conduit.List (sourceList) @@ -52,12 +62,14 @@ import qualified Database.Esqueleto as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.Reader (runReader) import System.FilePath import Handler.Utils.Templates import Handler.Utils.StudyFeatures - +import Control.Lens +import Utils.Lens -- infixl 9 :$: -- pattern a :$: b = a b @@ -89,10 +101,17 @@ data UniWorX = UniWorX -- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") +-- | Convenient Type Synonyms: +type DB a = YesodDB UniWorX a +type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) +type MsgRenderer = MsgRendererS UniWorX -- see Utils + -- Pattern Synonyms for convenience -pattern CSheetR tid csh ptn = CourseR tid csh (SheetR ptn) +pattern CSheetR tid csh shn ptn + = CourseR tid csh (SheetR shn ptn) +-- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text , menuItemIcon :: Maybe Text @@ -113,10 +132,7 @@ data MenuTypes -- Semantische Rolle: | PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten --- | Convenient Type Synonyms: -type DB a = YesodDB UniWorX a -type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) - +-- Messages mkMessage "UniWorX" "messages" "de" -- This instance is required to use forms. You can modify renderMessage to @@ -131,6 +147,135 @@ instance RenderMessage UniWorX TermIdentifier where where renderMessage' = renderMessage foundation ls +-- Access Control +data AccessPredicate + = APPure (Route UniWorX -> Reader MsgRenderer AuthResult) + | APHandler (Route UniWorX -> Handler AuthResult) + | APDB (Route UniWorX -> DB AuthResult) + +orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult +orAR _ Authorized _ = Authorized +orAR _ _ Authorized = Authorized +orAR _ AuthenticationRequired _ = AuthenticationRequired +orAR _ _ AuthenticationRequired = AuthenticationRequired +orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y +andAR _ Authorized Authorized = Authorized +andAR _ Authorized other = other +andAR _ other Authorized = other +andAR _ AuthenticationRequired other = other +andAR _ other AuthenticationRequired = other +andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y + + + +orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate +orAP = liftAR orAR (== Authorized) +andAP = liftAR andAR (const False) + +liftAR :: (MsgRenderer -> AuthResult -> AuthResult -> AuthResult) + -> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument + -> AccessPredicate -> AccessPredicate -> AccessPredicate +-- Ensure to first evaluate Pure conditions, then Handler before DB +liftAR op sc (APPure f) (APPure g) = APPure $ \r -> shortCircuitM sc (f r) (g r) . op =<< ask +liftAR op sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer +liftAR op sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer +liftAR op sc (APPure f) apg = liftAR op sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg +liftAR op sc apf apg@(APPure _) = liftAR op sc apg apf +liftAR op sc (APHandler f) apdb = liftAR op sc (APDB $ lift . f) apdb +liftAR op sc apdb apg@(APHandler _) = liftAR op sc apg apdb + + +trueAP,falseAP :: AccessPredicate +trueAP = APPure . const $ return Authorized +falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask +-- TODO: I believe falseAP := adminAP + +adminAP :: AccessPredicate +adminAP = APDB $ \case + CourseR tid csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do + E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool + E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (unauthorizedI MsgUnauthorizedSchoolAdmin) (c > 0) + return Authorized + + _other -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] + case adrights of + (Just _) -> return Authorized + Nothing -> lift $ unauthorizedI $ MsgUnauthorized + +knownTags :: Map (CI Text) AccessPredicate +knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId + [("free", trueAP) + ,("deprecated", APHandler $ \r -> do + $logWarnS "AccessControl" ("deprecated route: " <> tshow r) + setMessageI $ MsgDeprecatedRoute + return Authorized + ) + ,("lecturer", APDB $ \case + CourseR tid csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (unauthorizedI MsgUnauthorizedLecturer) (c > 0) + return Authorized + _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] + return Authorized + ) + -- TODO: Continue here!!! + ,("corrector", undefined) + ,("time", undefined) + ,("registered", undefined) + ,("materials", APDB $ \case + CourseR tid csh _ -> do + Entity cid _ <- getBy404 $ CourseTermShort tid csh + undefined -- CONTINUE HERE + ) + ] + + +tag2ap :: Text -> AccessPredicate +tag2ap t = case Map.lookup (CI.mk t) knownTags of + (Just acp) -> acp + Nothing -> APHandler $ \_route -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should) + $logWarnS "AccessControl" ("route tag unknown for access control") + unauthorizedI $ MsgUnauthorized + +route2ap :: Route UniWorX -> AccessPredicate +route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK: Due to shortCircuitM this (while still true) is no longer costly (we do a `runDB` but then only actually send off queries, if needed) + where + attrsAND = map splitAND $ Set.toList $ routeAttrs r + splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" + +evalAccessDB :: Route UniWorX -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise +evalAccessDB r = case route2ap r of + (APPure p) -> lift $ runReader (p r) <$> getMsgRenderer + (APHandler p) -> lift $ p r + (APDB p) -> p r + +evalAccess :: Route UniWorX -> Handler AuthResult +evalAccess r = case route2ap r of + (APPure p) -> runReader (p r) <$> getMsgRenderer + (APHandler p) -> p r + (APDB p) -> runDB $ p r + +-- TODO: isAuthorized = evalAccess' + + + + -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod UniWorX where @@ -157,9 +302,9 @@ instance Yesod UniWorX where yesodMiddleware handler = do res <- defaultYesodMiddleware handler void . runMaybeT $ do - route@(routeAttrs -> attrs) <- MaybeT getCurrentRoute - case route of - CourseR tid csh _ | "updateFavourite" `elem` attrs -> do + route <- MaybeT getCurrentRoute + case route of -- update Course Favourites here + CourseR tid csh _ -> do uid <- MaybeT maybeAuthId $(logDebug) "Favourites save" now <- liftIO $ getCurrentTime @@ -167,7 +312,7 @@ instance Yesod UniWorX where cid <- MaybeT . getKeyBy $ CourseTermShort tid csh user <- MaybeT $ get uid -- update Favourites - lift $ upsertBy + void . lift $ upsertBy (UniqueCourseFavourite uid cid) (CourseFavourite uid now cid) [CourseFavouriteTime =. now] @@ -209,7 +354,7 @@ instance Yesod UniWorX where favourites <- forM favourites' $ \(Entity _ c@Course{..}) -> let - courseRoute = CourseR courseTerm courseShorthand CourseShowR + courseRoute = CourseR courseTerm courseShorthand CShowR in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) -- We break up the default layout into two components: @@ -253,21 +398,7 @@ instance Yesod UniWorX where -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR - isAuthorized (AuthR _) _ = return Authorized - isAuthorized HomeR _ = return Authorized - isAuthorized FaviconR _ = return Authorized - isAuthorized RobotsR _ = return Authorized - isAuthorized (StaticR _) _ = return Authorized - isAuthorized ProfileR _ = isAuthenticated - isAuthorized TermShowR _ = return Authorized - isAuthorized CourseListR _ = return Authorized - isAuthorized (CourseListTermR _) _ = return Authorized - isAuthorized (CourseR _ _ CourseShowR) _ = return Authorized - isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized - isAuthorized SubmissionListR _ = isAuthenticated - isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated --- isAuthorized TestR _ = return Authorized - isAuthorized route isWrite = runDB $ isAuthorizedDB route isWrite + isAuthorized route _isWrite = evalAccess route -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows @@ -308,13 +439,14 @@ instance Yesod UniWorX where makeLogger = return . appLogger + +{- ALL DEPRECATED and will be deleted, once knownTags is completed + isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult isAuthorizedDB route@(routeAttrs -> attrs) writeable | "adminAny" `member` attrs = adminAccess Nothing | "lecturerAny" `member` attrs = lecturerAccess Nothing - - isAuthorizedDB UsersR _ = adminAccess Nothing isAuthorizedDB (SubmissionDemoR cID) _ = return Authorized -- submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID @@ -322,14 +454,14 @@ isAuthorizedDB (SubmissionDownloadArchiveR (ZIPArchiveName cID)) _ = submissionA isAuthorizedDB TermEditR _ = adminAccess Nothing isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB CourseNewR _ = lecturerAccess Nothing -isAuthorizedDB (CourseR t c CourseEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c CEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized -- isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor +isAuthorizedDB (CourseR t c (SheetR (SShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR (SEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR (SDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR (SubmissionR s m))) _ = return Authorized -- TODO -- submissionAccess $ Right cID isAuthorizedDB (CourseR t c (SheetR (SheetCorrectorsR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseEditIDR cID) _ = do @@ -396,6 +528,8 @@ isAuthorizedDB' route isWrite = (== Authorized) <$> isAuthorizedDB route isWrite isAuthorized' :: Route UniWorX -> Bool -> Handler Bool isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite +-} + -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where @@ -404,18 +538,18 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR) breadcrumb CourseListR = return ("Kurs", Just HomeR) - breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) - breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term) + breadcrumb (TermCourseListR term) = return (toPathPiece term, Just TermShowR) + breadcrumb (CourseR term course CShowR) = return (course, Just $ TermCourseListR term) breadcrumb CourseNewR = return ("Neu", Just CourseListR) - breadcrumb (CourseR _ _ CourseEditR) = return ("Editieren", Just CourseListR) + breadcrumb (CourseR _ _ CEditR) = return ("Editieren", Just CourseListR) - breadcrumb (CourseR tid csh (SheetR SheetListR)) = return ("Übungen",Just $ CourseR tid csh CourseShowR) - breadcrumb (CourseR tid csh (SheetR SheetNewR )) = return ("Neu", Just $ CourseR tid csh $ SheetR SheetListR) - breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR) - breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) - breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) - breadcrumb (CourseR tid csh (SheetR (SheetCorrectorsR shn))) = return ("Korrektoren", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) - breadcrumb (CourseR tid csh (SheetR (SubmissionR shn _))) = return ("Abgabe", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) + breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR) + breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR) + breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR) + breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR) + breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR) + -- breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR) + breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) @@ -426,41 +560,41 @@ instance YesodBreadcrumbs UniWorX where breadcrumb _ = return ("home", Nothing) pageActions :: Route UniWorX -> [MenuTypes] -pageActions (CourseR tid csh CourseShowR) = +pageActions (CourseR tid csh CShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Übungsblätter" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh SheetListR + , menuItemRoute = CourseR tid csh SheetListR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Kurs Editieren" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh CourseEditR + , menuItemRoute = CourseR tid csh CEditR , menuItemAccessCallback' = return True } ] -pageActions (CSheetR tid csh SheetListR) = +pageActions (CourseR tid csh SheetListR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh SheetNewR + , menuItemRoute = CourseR tid csh SheetNewR , menuItemAccessCallback' = return True } ] -pageActions (CSheetR tid csh (SheetShowR shn)) = +pageActions (CSheetR tid csh shn SShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Abgabe" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh (SubmissionR shn newSubmission) - , menuItemAccessCallback' = return True - } - , PageActionPrime $ MenuItem - { menuItemLabel = "Korrektoren" - , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh (SheetCorrectorsR shn) + , menuItemRoute = CSheetR tid csh shn (SubmissionR newSubmission) , menuItemAccessCallback' = return True } + -- , PageActionPrime $ MenuItem + -- { menuItemLabel = "Korrektoren" + -- , menuItemIcon = Nothing + -- , menuItemRoute = CSheetR tid csh shn SCorrR + -- , menuItemAccessCallback' = return True + -- } ] pageActions TermShowR = [ PageActionPrime $ MenuItem @@ -470,7 +604,7 @@ pageActions TermShowR = , menuItemAccessCallback' = return True } ] -pageActions (CourseListTermR _) = +pageActions (TermCourseListR _) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neuer Kurs" , menuItemIcon = Just "book" diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index a37acbbc4..555104172 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -26,8 +26,8 @@ import qualified Data.UUID.Cryptographic as UUID getCourseListR :: Handler TypedContent getCourseListR = redirect TermShowR -getCourseListTermR :: TermId -> Handler Html -getCourseListTermR tidini = do +getTermCourseListR :: TermId -> Handler Html +getTermCourseListR tidini = do (term,courses) <- runDB $ (,) <$> get tidini <*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand] @@ -40,7 +40,7 @@ getCourseListTermR tidini = do let c = entityVal ckv shd = courseShorthand c tid = courseTerm c - in [whamlet| #{shd} |] ) + in [whamlet| #{shd} |] ) -- , headed "Institut" $ [shamlet| #{course} |] , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal , headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal @@ -54,11 +54,11 @@ getCourseListTermR tidini = do shd = courseShorthand c tid = courseTerm c in do - adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False - -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else "" + adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CEditR) False + -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CEditR tid shd) else "" [whamlet| $if adminLink == Authorized - + editieren |] ) @@ -68,8 +68,8 @@ getCourseListTermR tidini = do setTitle "Semesterkurse" $(widgetFile "courses") -getCourseShowR :: TermId -> Text -> Handler Html -getCourseShowR tid csh = do +getCShowR :: TermId -> Text -> Handler Html +getCShowR tid csh = do mbAid <- maybeAuthId (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh @@ -95,8 +95,8 @@ registerButton registered = renderAForm FormStandard $ msg = if registered then "Abmelden" else "Anmelden" regMsg = msg :: BootstrapSubmit Text -postCourseShowR :: TermId -> Text -> Handler Html -postCourseShowR tid csh = do +postCShowR :: TermId -> Text -> Handler Html +postCShowR tid csh = do aid <- requireAuthId (cid, registered) <- runDB $ do (Entity cid _) <- getBy404 $ CourseTermShort tid csh @@ -114,7 +114,7 @@ postCourseShowR tid csh = do when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!" (_other) -> return () -- TODO check this! -- redirect or not?! I guess not, since we want GET now - getCourseShowR tid csh + getCShowR tid csh getCourseNewR :: Handler Html getCourseNewR = do @@ -124,13 +124,13 @@ getCourseNewR = do postCourseNewR :: Handler Html postCourseNewR = courseEditHandler Nothing -getCourseEditR :: TermId -> Text -> Handler Html -getCourseEditR tid csh = do +getCEditR :: TermId -> Text -> Handler Html +getCEditR tid csh = do course <- runDB $ getBy $ CourseTermShort tid csh courseEditHandler course -postCourseEditR :: TermId -> Text -> Handler Html -postCourseEditR = getCourseEditR +postCEditR :: TermId -> Text -> Handler Html +postCEditR = getCEditR getCourseEditIDR :: CryptoUUIDCourse -> Handler Html getCourseEditIDR cID = do @@ -147,7 +147,7 @@ courseDeleteHandler = undefined runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! let cti = toPathPiece $ cfTerm res addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|] - redirect $ CourseListTermR $ cfTerm res + redirect $ TermCourseListR $ cfTerm res -} courseEditHandler :: Maybe (Entity Course) -> Handler Html @@ -183,7 +183,7 @@ courseEditHandler course = do insert_ $ CourseEdit aid now cid insert_ $ Lecturer aid cid addMessageI "info" $ MsgCourseNewOk tident csh - redirect $ CourseListTermR tid + redirect $ TermCourseListR tid Nothing -> addMessageI "danger" $ MsgCourseNewDupShort tident csh @@ -238,7 +238,7 @@ courseEditHandler course = do -- if (isNothing updOkay) -- then do addMessageI "info" $ MsgCourseEditOk tident csh - -- redirect $ CourseListTermR tid + -- redirect $ TermCourseListR tid -- else addMessageI "danger" $ MsgCourseEditDupShort tident csh (FormFailure _) -> addMessageI "warning" MsgInvalidInput diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index f5a77cdbd..b02e95a0c 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -38,7 +38,7 @@ instance CryptoRoute UUID SubmissionId where Sheet{..} <- get404 shid Course{..} <- get404 sheetCourse return (courseTerm, courseShorthand, sheetName) - return $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID + return $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID class Dispatch ciphertext (x :: [*]) where diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 0b86114e8..084262b12 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -133,8 +133,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do -- TODO: continue validation here!!! ] ] - - -- List Sheets getSheetListCID :: CourseId -> Handler Html getSheetListCID cid = getSheetList =<< @@ -159,7 +157,7 @@ getSheetList courseEnt = do rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub return (sid, sheet, (submissions, rated)) let colBase = mconcat - [ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet + [ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CSheetR tid csh (sheetName sheet) SShowR , headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3 , headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3 , headed "Bewertung" $ toWgt . show . sheetType . snd3 @@ -167,13 +165,13 @@ getSheetList courseEnt = do let colAdmin = mconcat -- only show edit button for allowed course assistants [ headed "Korrigiert" $ toWgt . snd . trd3 , headed "Eingereicht" $ toWgt . fst . trd3 - , headed "" $ \s -> linkButton "Edit" BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s - , headed "" $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR $ sheetName $ snd3 s + , headed "" $ \s -> linkButton "Edit" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SEditR + , headed "" $ \s -> linkButton "Delete" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SDelR ] showAdmin <- case sheets of ((_,firstSheet,_):_) -> do setUltDestCurrent - (Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False + (Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False _otherwise -> return False let colSheets = if showAdmin then colBase `mappend` colAdmin @@ -186,8 +184,8 @@ getSheetList courseEnt = do -- Show single sheet -getSheetShowR :: TermId -> Text -> Text -> Handler Html -getSheetShowR tid csh shn = do +getSShowR :: TermId -> Text -> Text -> Handler Html +getSShowR tid csh shn = do entSheet <- runDB $ fetchSheet tid csh shn let sheet = entityVal entSheet sid = entityKey entSheet @@ -215,7 +213,7 @@ getSheetShowR tid csh shn = do return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = mconcat [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype - , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName)) + , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) (\(E.Value fName,_,_) -> str2widget fName) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT modified ] @@ -240,8 +238,8 @@ getSheetShowR tid csh shn = do $(widgetFile "sheetShow") [whamlet| Under Construction !!! |] -- TODO -getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent -getSheetFileR tid csh shn typ title = do +getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent +getSFileR tid csh shn typ title = do content <- 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 @@ -277,8 +275,8 @@ postSheetNewR :: TermId -> Text -> Handler Html postSheetNewR = getSheetNewR -getSheetEditR :: TermId -> Text -> Text -> Handler Html -getSheetEditR tid csh shn = do +getSEditR :: TermId -> Text -> Text -> Handler Html +getSEditR tid csh shn = do (sheetEnt, sheetFileIds) <- runDB $ do ent <- fetchSheet tid csh shn fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do @@ -311,8 +309,8 @@ getSheetEditR tid csh shn = do (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here handleSheetEdit tid csh (Just sid) template action -postSheetEditR :: TermId -> Text -> Text -> Handler Html -postSheetEditR = getSheetEditR +postSEditR :: TermId -> Text -> Text -> Handler Html +postSEditR = getSEditR handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit tid csh msId template dbAction = do @@ -348,44 +346,44 @@ handleSheetEdit tid csh msId template dbAction = do insert_ $ SheetEdit aid actTime sid addMessageI "info" $ MsgSheetEditOk tident csh sfName return True - when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB + when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml _ -> return () let pageTitle = maybe (MsgSheetTitleNew tident csh) (MsgSheetTitle tident csh) mbshn let formTitle = pageTitle let formText = Nothing :: Maybe UniWorXMessage - actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute + actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle $(widgetFile "formPageI18n") -getSheetDelR :: TermId -> Text -> Text -> Handler Html -getSheetDelR tid csh shn = do +getSDelR :: TermId -> Text -> Text -> Handler Html +getSDelR tid csh shn = do let tident = unTermKey tid ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) case result of - (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn + (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR (FormSuccess BtnDelete) -> do runDB $ fetchSheetId tid csh shn >>= deleteCascade -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! addMessageI "info" $ MsgSheetDelOk tident csh shn - redirect $ CSheetR tid csh SheetListR + redirect $ CourseR tid csh SheetListR _other -> do submissionno <- runDB $ do sid <- fetchSheetId tid csh shn count [SubmissionSheet ==. sid] let formTitle = MsgSheetDelTitle tident csh shn let formText = Just $ MsgSheetDelText submissionno - let actionUrl = CSheetR tid csh $ SheetDelR shn + let actionUrl = CSheetR tid csh shn SDelR defaultLayout $ do setTitleI $ MsgSheetTitle tident csh shn $(widgetFile "formPageI18n") -postSheetDelR :: TermId -> Text -> Text -> Handler Html -postSheetDelR = getSheetDelR +postSDelR :: TermId -> Text -> Text -> Handler Html +postSDelR = getSDelR @@ -556,12 +554,12 @@ correctorForm shid = do -- Eingabebox für Korrektor hinzufügen -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen -getSheetCorrectorsR, postSheetCorrectorsR :: TermId - -> Text -- ^ Course shorthand - -> Text -- ^ Sheet name - -> Handler Html -postSheetCorrectorsR = getSheetCorrectorsR -getSheetCorrectorsR tid@(unTermKey -> tident) csh shn = do +getSCorrR, postSCorrR :: TermId + -> Text -- ^ Course shorthand + -> Text -- ^ Sheet name + -> Handler Html +postSCorrR = getSCorrR +getSCorrR tid@(unTermKey -> tident) csh shn = do Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton @@ -577,7 +575,8 @@ getSheetCorrectorsR tid@(unTermKey -> tident) csh shn = do let formTitle = MsgSheetCorrectorsTitle tident csh shn formText = Nothing :: Maybe (SomeMessage UniWorX) - actionUrl = CSheetR tid csh $ SheetCorrectorsR shn + -- actionUrl = CSheetR tid csh shn SCorrR + actionUrl = CSheetR tid csh shn SShowR defaultLayout $ do setTitleI $ MsgSheetCorrectorsTitle tident csh shn $(widgetFile "formPageI18n") diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index b15ec6adf..becc5ed2c 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} @@ -11,6 +12,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeOperators #-} module Handler.Submission where @@ -51,6 +53,9 @@ import Yesod.Colonnade import qualified Text.Blaze.Html5.Attributes as HA +numberOfSubmissionEditDates :: Int64 +numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. + makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [Text] -> Form (Maybe (Source Handler File), [Text]) makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do @@ -75,7 +80,7 @@ getSubmissionR = postSubmissionR postSubmissionR tid csh shn (SubmissionMode mcid) = do uid <- requireAuthId msmid <- traverse decrypt mcid - (Entity shid Sheet{..}, buddies, oldfiles,lastEdits) <- runDB $ do + (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do sheet@(Entity shid Sheet{..}) <- fetchSheet tid csh shn case msmid of Nothing -> do @@ -103,11 +108,11 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.orderBy [E.asc $ user E.^. UserEmail] return $ user E.^. UserEmail - return (sheet,buddies,[],[]) + return (sheet,buddies,[]) (E.Value smid:_) -> do cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists - redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID + redirect $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID (Just smid) -> do shid' <- submissionSheet <$> get404 smid when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet] @@ -118,16 +123,15 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.orderBy [E.asc $ user E.^. UserEmail] return $ user E.^. UserEmail - oldfiles <- sourceToList $ submissionFileSource smid -- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime] lastEditValues <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser) E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] - E.limit 3 -- TODO for Debug Purposes + E.limit numberOfSubmissionEditDates return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime) let lastEdits = map (bimap E.unValue E.unValue) lastEditValues - return (sheet,buddies,oldfiles,lastEdits) + return (sheet,buddies,lastEdits) let unpackZips = True -- undefined -- TODO ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies mCID <- runDB $ do @@ -174,10 +178,10 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do now <- liftIO $ getCurrentTime smid <- do smid <- case (mFiles, msmid) of - (Nothing, Just smid) + (Nothing, Just smid) -- no new files, existing submission partners updated -> return smid - (Just files, Nothing) - -> runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid Nothing + (Just files, _) -- new files + -> runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid) _ -> error "Impossible, because of definition of `makeSubmissionForm`" -- Determine members of pre-registered group groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do @@ -199,7 +203,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do _other -> return Nothing case mCID of - Just cID -> redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID + Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID Nothing -> return () mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid @@ -208,6 +212,28 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do let formTitle = pageTitle let formText = Nothing :: Maybe UniWorXMessage actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute + -- Maybe construct a table to display uploaded archive files + let colonnadeFiles cid = mconcat + -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype + [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle) + (\(Entity _ File{..}) -> str2widget fileTitle) + , sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified + ] + smid2ArchiveTable (smid,cid) = DBTable + { dbtSQLQuery = submissionFileQuery smid + , dbtColonnade = colonnadeFiles cid + , dbtAttrs = tableDefault + , dbtIdent = "files" :: Text + , dbtSorting = [ ( "path" + , SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileTitle + ) + , ( "time" + , SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileModified + ) + ] + } + mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid + defaultLayout $ do setTitleI pageTitle $(widgetFile "formPageI18n") @@ -218,24 +244,25 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do Archiv $forall (name,time) <- lastEdits
last edited by #{name} at #{formatTimeGerDTlong time} - $maybe cid <- mcid + $maybe fileTable <- mFileTable

Enthaltene Dateien: - $forall (Entity _ File{..}) <- oldfiles - - #{fileTitle} + ^{fileTable} |] - submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) -submissionFileSource submissionID = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do +submissionFileSource = E.selectSource . E.from . submissionFileQuery + +submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File) + -> E.SqlQuery (E.SqlExpr (Entity File)) +submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID - E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion - E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] + E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor + E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first return f getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent @@ -300,7 +327,7 @@ submissionTable = do (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s let - anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CourseShowR + anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index cfbd92ced..e6fcc3615 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -60,7 +60,7 @@ getTermShowR = do textCell $ bool "" tickmark termActive , sortable Nothing "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) -> cell [whamlet| - + #{show numCourses} Kurse |] , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> diff --git a/src/Utils.hs b/src/Utils.hs index e1aebc0b6..0024dc117 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE QuasiQuotes #-} @@ -14,10 +16,29 @@ import Utils.Common as Utils import Text.Blaze (Markup, ToMarkup) -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.List as List +-- import Data.Map (Map) +-- import qualified Data.Map as Map +-- import qualified Data.List as List +import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) +import Control.Monad.Trans.Maybe (MaybeT(..)) + + +----------- +-- Yesod -- +----------- + +newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) } + +getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site) +getMsgRenderer = do + mr <- getMessageRender + return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text) + + +--------------------- +-- Text and String -- +--------------------- tickmark :: IsString a => a tickmark = fromString "✔" @@ -42,12 +63,6 @@ withFragment :: ( Monad m ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) ------------ --- Maybe -- ------------ -whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenIsJust (Just x) f = f x -whenIsJust Nothing _ = return () ------------ -- Tuples -- @@ -56,3 +71,45 @@ whenIsJust Nothing _ = return () ---------- -- Maps -- ---------- + + +----------- +-- Maybe -- +----------- +whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenIsJust (Just x) f = f x +whenIsJust Nothing _ = return () + +maybeT :: Monad m => m a -> MaybeT m a -> m a +maybeT x m = runMaybeT m >>= maybe x return + +--------------- +-- Exception -- +--------------- + +maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b +maybeExceptT err act = lift act >>= maybe (throwE err) return + +maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b +maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return + +guardExceptT :: Monad m => e -> Bool -> ExceptT e m () +guardExceptT err b = unless b $ throwE err + +guardMExceptT :: Monad m => (m e) -> Bool -> ExceptT e m () +guardMExceptT err b = unless b $ lift err >>= throwE + +exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b +exceptT f g = either f g <=< runExceptT + + +------------ +-- Monads -- +------------ + +shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a +shortCircuitM sc mx my op = do + x <- mx + case sc x of + True -> return x + False -> op <$> pure x <*> my diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs index 7ef941d4d..56c437905 100644 --- a/src/Utils/Common.hs +++ b/src/Utils/Common.hs @@ -5,7 +5,10 @@ module Utils.Common where -- Common Utility Functions import Language.Haskell.TH - +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Except ------------ -- Tuples -- @@ -50,3 +53,4 @@ altFun perm = lamE pat rhs ps = [ xs !! (j-1) | j <- perm ] fn = mkName "fn" + diff --git a/templates/course.hamlet b/templates/course.hamlet index 4b837d18d..958e4024a 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -34,7 +34,7 @@
Anmelden - $#
+ $# $# ^{regWidget}