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/routes b/routes index 16cf1b3fd..d009d0e6e 100644 --- a/routes +++ b/routes @@ -1,25 +1,25 @@ -{- - 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 --} +-- +-- 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 +-- /static StaticR Static appStatic !free /auth AuthR Auth getAuth !free diff --git a/src/Foundation.hs b/src/Foundation.hs index d8bbd682d..51aa79102 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -32,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 @@ -47,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) @@ -54,6 +62,7 @@ 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 @@ -92,70 +101,95 @@ 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 shn ptn = CourseR tid csh (SheetR shn ptn) +pattern CSheetR tid csh shn ptn + = CourseR tid csh (SheetR shn ptn) + +-- Messages +mkMessage "UniWorX" "messages" "de" + +-- This instance is required to use forms. You can modify renderMessage to +-- achieve customized and internationalized form validation messages. +instance RenderMessage UniWorX FormMessage where + renderMessage _ _ = defaultFormMessage + +instance RenderMessage UniWorX TermIdentifier where + renderMessage foundation ls TermIdentifier{..} = case season of + Summer -> renderMessage' $ MsgSummerTerm year + Winter -> renderMessage' $ MsgWinterTerm year + where renderMessage' = renderMessage foundation ls -- Access Control data AccessPredicate - = APPure (Route UniWorX -> Reader (forall msg. RenderMessage UniWorX msg => msg -> Text) AuthResult) - | APHandler (Route UniWorX -> Handler UniWorX AuthResult) - | APDB (Route UniWorX -> YesodDB UniWorX AuthResult) + = APPure (Route UniWorX -> Reader MsgRenderer AuthResult) + | APHandler (Route UniWorX -> Handler AuthResult) + | APDB (Route UniWorX -> DB AuthResult) -orAR, andAR :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> AuthResult -> AuthResult -> 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 . mr $ MsgUnauthorizedOr x y -andAR _ Authorzied Authorized = Authorized -andAR _ Authorzied other = other +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 . mr $ MsgUnauthorizedAnd x y +andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y + orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate -orAP = liftAR orAR -andAP = liftAR andAR +orAP = liftAR orAR (== Authorized) +andAP = liftAR andAR (const False) -liftAR :: ((forall msg. RenderMessage UniWorX msg => msg -> Text) -> AuthResult -> AuthResult -> AuthResult) +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 (APPure f) (APPure g) = APPure $ \r -> op <$> ask <*> f r <*> g r -liftAR op (APHandler f) (APHandler g) = APHandler $ \r -> op <$> getMessageRender <*> f r <*> g r -liftAR op (APDB f) (APDB g) = APDB $ \r -> op <$> getMessageRender <*> f r <*> g r -liftAR op (APPure f) apg = liftAR op (APHandler $ \r -> runReader (f r) <$> getMessageRender) apg -liftAR op apf apg@(APPure _) = liftAR op apg apf -liftAR op (APHandler f) apdb = liftAR op (APDB $ lift . f) apdb -liftAR op apdb apg@(APHandler _) = liftAR op apg apdb +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) <$> ask +falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- TODO: I believe falseAP := adminAP adminAP :: AccessPredicate adminAP = APDB $ \case - CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedSchoolAdmin) $ do - authId <- lift requireAuthId - -- SQL JOIN: - Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh - -- get schoolId for cid - -- check adminrights for schoolId - undefined -- CONTINUE HERE + 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 -> do - authId <- lift requireAuthId - adrights <- selectFirst [UserAdminUser ==. authId] - case adright of + _other -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] + case adrights of (Just _) -> return Authorized - Nothing -> unauthorizedI $ MsgUnauthorized + Nothing -> lift $ unauthorizedI $ MsgUnauthorized knownTags :: Map (CI Text) AccessPredicate -knownTags = +knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId [("free", trueAP) ,("deprecated", APHandler $ \r -> do $logWarnS "AccessControl" ("deprecated route: " <> tshow r) @@ -163,15 +197,14 @@ knownTags = return Authorized ) ,("lecturer", APDB $ \case - CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do - authId <- lift requireAuthId - -- TODO: why not a getBy404 if the course does not exist?hg getBy404 - + CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do + authId <- lift $ lift requireAuthId -- TODO SJ Continue + -- getBy404 would disclose that the course exists Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh void . MaybeT . getBy $ UniqueLecturer authId cid return Authorized _ -> do - authId <- requireAuthId + authId <- lift requireAuthId -- TODO SJ Continue mul <- selectFirst [UserLecturerUser ==. authId] [] case mul of Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer @@ -182,7 +215,7 @@ knownTags = ,("time", undefined) ,("registered", undefined) ,("materials", APDB $ \case - CourseR tid csh -> + CourseR tid csh _ -> do Entity cid _ <- getBy404 $ CourseTermShort tid csh undefined -- CONTINUE HERE ) @@ -190,27 +223,27 @@ knownTags = tag2ap :: Text -> AccessPredicate -tag2ap t = case Map.lookup t knownTags of +tag2ap t = case Map.lookup (CI.mk t) knownTags of (Just ap) -> ap Nothing -> APHandler $ \r -> do --TODO: can this be pure like falseAP? $logWarnS "AccessControl" ("route tag unknown for access control") unauthorizedI $ MsgUnauthorized route2ap :: Route UniWorX -> AccessPredicate -route2ap r = Set.foldr orAP adminAP attrsAND +route2ap r = foldr orAP adminAP attrsAND --TODO: adminAP causes all to be in DB!!! where - attrsAND = Set.map splitAnd $ routeAttrs r - splitAND = foldr1 andAP . map tag2access . splitOn "AND" + attrsAND = map splitAND $ Set.toList $ routeAttrs r + splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" -evalAccessDB :: Route -> DB Authorized -- all requests, regardless of POST/GET, use isWriteRequest otherwise -evalAccessDB r = case getAccess r of - (APPure p) -> lift $ runReader (p r) <$> getMessageRender +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 -> Handler UniWorX Authorized -evalAccess r = case getAccess r of - (APPure p) -> runReader (p r) <$> getMessageRender +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 @@ -239,23 +272,6 @@ 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) - -mkMessage "UniWorX" "messages" "de" - --- This instance is required to use forms. You can modify renderMessage to --- achieve customized and internationalized form validation messages. -instance RenderMessage UniWorX FormMessage where - renderMessage _ _ = defaultFormMessage - -instance RenderMessage UniWorX TermIdentifier where - renderMessage foundation ls TermIdentifier{..} = case season of - Summer -> renderMessage' $ MsgSummerTerm year - Winter -> renderMessage' $ MsgWinterTerm year - where renderMessage' = renderMessage foundation ls - -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. @@ -335,7 +351,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: @@ -435,14 +451,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 (CourseEditIDR cID) _ = do courseId <- decrypt cID @@ -518,17 +534,17 @@ 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 (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 (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) @@ -539,33 +555,33 @@ 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) + , menuItemRoute = CSheetR tid csh shn (SubmissionR newSubmission) , menuItemAccessCallback' = return True } ] @@ -577,7 +593,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 61b2c4eb3..80e636efa 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -154,7 +154,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 @@ -162,13 +162,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 @@ -181,8 +181,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 @@ -210,7 +210,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 ] @@ -235,8 +235,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 @@ -272,8 +272,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 @@ -307,8 +307,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 @@ -344,44 +344,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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 08996f47e..becc5ed2c 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -112,7 +112,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do (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] @@ -203,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 @@ -327,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 c0e3dcb81..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 -- @@ -51,10 +54,3 @@ altFun perm = lamE pat rhs fn = mkName "fn" ------------ --- Maybe -- ------------ - -maybeT :: Monad m => m a -> MaybeT m a -> m a -maybeT x m = runMaybeT m >>= maybe x return - 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}
diff --git a/templates/widgets/asidenav.hamlet b/templates/widgets/asidenav.hamlet index 8126fd770..1d8e82971 100644 --- a/templates/widgets/asidenav.hamlet +++ b/templates/widgets/asidenav.hamlet @@ -5,12 +5,12 @@ $newline never