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 d296157b4..5332201d5 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -21,12 +21,22 @@ 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.
+UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
+UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
+UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
+UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
+UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
OnlyUploadOneFile: Bitte nur eine Datei hochladen.
+DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
+UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
diff --git a/routes b/routes
index c04ca7ada..450bbcd99 100644
--- a/routes
+++ b/routes
@@ -1,44 +1,66 @@
-/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 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)
+-- !owner -- part of the group of owners of this submission
+--
+-- !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/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 !registered !materials
+ !/ex/new SheetNewR GET POST
+ /ex/#Text SheetR:
+ /show SShowR GET !timeANDregistered !timeANDmaterials !corrector
+ /#SheetFileType/#FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
+ /edit SEditR GET POST
+ /delete SDelR GET POST
+ !/sub/new SubmissionNewR GET POST !timeANDregistered
+ !/sub/own SubmissionOwnR GET !free
+ !/sub/#CryptoUUIDSubmission SubmissionR GET POST !owner !corrector
-!/#{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/CryptoID.hs b/src/CryptoID.hs
index 5eda0a941..d13e98425 100644
--- a/src/CryptoID.hs
+++ b/src/CryptoID.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module CryptoID
@@ -49,8 +50,10 @@ decCryptoIDs [ ''SubmissionId
newtype SubmissionMode = SubmissionMode (Maybe CryptoUUIDSubmission)
deriving (Show, Read, Eq)
-newSubmission :: SubmissionMode
-newSubmission = SubmissionMode Nothing
+pattern NewSubmission :: SubmissionMode
+pattern NewSubmission = SubmissionMode Nothing
+pattern ExistingSubmission :: CryptoUUIDSubmission -> SubmissionMode
+pattern ExistingSubmission cID = SubmissionMode (Just cID)
instance PathPiece SubmissionMode where
fromPathPiece "new" = Just $ SubmissionMode Nothing
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 659b00513..1faa152ff 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,204 @@ 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
+-- and
+andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
+andAR _ reason@(Unauthorized x) _ = reason
+andAR _ _ reason@(Unauthorized x) = reason
+andAR _ Authorized other = other
+andAR _ AuthenticationRequired _ = AuthenticationRequired
+
+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 -- access for admins (of appropriate school in case of course-routes)
+adminAP = APDB $ \case
+ -- Courses: access only to school admins
+ 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 (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
+ return Authorized
+ -- other routes: access to any admin is granted here
+ _other -> exceptT return return $ do
+ authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+ adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
+ guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized)
+ return Authorized
+
+
+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)
+ addMessageI "error" 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 (c>0) (unauthorizedI MsgUnauthorizedLecturer)
+ return Authorized
+ _ -> exceptT return return $ do
+ authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+ void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
+ return Authorized
+ )
+ ,("corrector", APDB $ \route -> exceptT return return $ do
+ authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+ resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
+ E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+ E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
+ E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
+ return (course E.^. CourseId, sheet E.^. SheetId)
+ let
+ resMap :: Map CourseId (Set SheetId)
+ resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
+ case route of
+ CSheetR _ _ _ (SubmissionR cID) -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
+ sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+ Submission{..} <- MaybeT . lift $ get sid
+ guard $ maybe False (== authId) submissionRatingBy
+ return Authorized
+ CSheetR tid csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
+ Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh
+ Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
+ guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
+ return Authorized
+ CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
+ Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh
+ guard $ cid `Set.member` Map.keysSet resMap
+ return Authorized
+ _ -> do
+ guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
+ return Authorized
+ )
+ ,("time", APDB $ \case
+ CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
+ Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
+ Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
+ cTime <- liftIO getCurrentTime
+ case subRoute of
+ SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
+ SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
+ SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
+ _ -> guard $ maybe False (<= cTime) sheetVisibleFrom
+ return Authorized
+ r -> do
+ $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r
+ unauthorizedI MsgUnauthorized
+ )
+ ,("registered", 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` courseParticipant) -> do
+ E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
+ E.where_ $ courseParticipant E.^. CourseParticipantUser 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 (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
+ return Authorized
+ r -> do
+ $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r
+ unauthorizedI MsgUnauthorized
+ )
+ ,("materials", APDB $ \case
+ CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
+ Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
+ guard courseMaterialFree
+ return Authorized
+ r -> do
+ $logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r
+ unauthorizedI MsgUnauthorized
+ )
+ ,("owner", APDB $ \case
+ CSheetR _ _ _ (SubmissionR cID) -> exceptT return return $ do
+ sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
+ authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+ void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
+ return Authorized
+ CSheetR _ _ _ SubmissionNewR -> unauthorizedI MsgUnauthorizedSubmissionOwner
+ r -> do
+ $logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r
+ unauthorizedI MsgUnauthorized
+ )
+ ]
+
+
+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" $ "'" <> t <> "' not known to 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 +371,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 +381,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 +423,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 +467,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 +508,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 +523,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
@@ -395,6 +596,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
@@ -403,17 +606,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)
@@ -424,34 +627,40 @@ 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 anlegen"
+ , menuItemIcon = Nothing
+ , menuItemRoute = CSheetR tid csh shn SubmissionNewR
+ , menuItemAccessCallback' = return True -- TODO: check that no submission already exists
+ }
+ , PageActionPrime $ MenuItem
{ menuItemLabel = "Abgabe"
, menuItemIcon = Nothing
- , menuItemRoute = CSheetR tid csh (SubmissionR shn newSubmission)
- , menuItemAccessCallback' = return True
+ , menuItemRoute = CSheetR tid csh shn SubmissionOwnR
+ , menuItemAccessCallback' = return True -- TODO: check that a submission already exists
}
]
pageActions TermShowR =
@@ -462,7 +671,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..da31ab516 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 cID
class Dispatch ciphertext (x :: [*]) where
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 14707a42f..1defbcce5 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 3e4975faf..528e9b966 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -74,10 +74,33 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
+getSubmissionNewR, postSubmissionNewR :: TermId -> Text -> Text -> Handler Html
+getSubmissionNewR = postSubmissionNewR
+postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission
-getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
+
+getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoUUIDSubmission -> Handler Html
getSubmissionR = postSubmissionR
-postSubmissionR tid csh shn (SubmissionMode mcid) = do
+postSubmissionR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
+
+getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html
+getSubmissionOwnR tid csh shn = do
+ authId <- requireAuthId
+ sid <- runDB $ do
+ shid <- fetchSheetId tid csh shn
+ submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
+ E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
+ E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId
+ E.&&. submission E.^. SubmissionSheet E.==. E.val shid
+ return $ submission E.^. SubmissionId
+ case submissions of
+ ((E.Value sid):_) -> return sid
+ [] -> notFound
+ cID <- encrypt sid
+ redirect . CourseR tid csh . SheetR shn $ SubmissionR cID
+
+submissionHelper :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
+submissionHelper tid csh shn (SubmissionMode mcid) = do
uid <- requireAuthId
msmid <- traverse decrypt mcid
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
@@ -112,7 +135,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 cID
(Just smid) -> do
shid' <- submissionSheet <$> get404 smid
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
@@ -203,7 +226,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 cID
Nothing -> return ()
mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid
@@ -327,7 +350,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 1309b666b..95ea678f4 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..e753dcbf2 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,30 @@ 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(..))
+import Control.Monad.Catch
+
+
+-----------
+-- 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 +64,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 +72,57 @@ 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
+
+catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
+catchIfMaybeT p act = catchIf p (lift act) (const mzero)
+
+---------------
+-- 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
+
+whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
+whenExceptT b err = when b $ throwE err
+
+whenMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
+whenMExceptT b err = when b $ lift err >>= throwE
+
+guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
+guardExceptT b err = unless b $ throwE err
+
+guardMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
+guardMExceptT b err = 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
+
+catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
+catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
+
+
+------------
+-- 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..3a2e6c804 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 @@