Merge branch 'master' into feat/exercises
This commit is contained in:
Gregor Kleen
commit
7db3d3f272
@ -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?!
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
90
routes
90
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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| <a href=@{CourseR tid shd CourseShowR}>#{shd} |] )
|
||||
in [whamlet| <a href=@{CourseR tid shd CShowR}>#{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
|
||||
<a href=@{CourseR tid shd CourseEditR}>
|
||||
<a href=@{CourseR tid shd CEditR}>
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -60,7 +60,7 @@ getTermShowR = do
|
||||
textCell $ bool "" tickmark termActive
|
||||
, sortable Nothing "Kursliste" $ \(_, (Entity tid Term{..}, E.Value numCourses)) ->
|
||||
cell [whamlet|
|
||||
<a href=@{CourseListTermR tid}>
|
||||
<a href=@{TermCourseListR tid}>
|
||||
#{show numCourses} Kurse
|
||||
|]
|
||||
, sortable (Just "start") "Semesteranfang" $ \(_, (Entity _ Term{..},_)) ->
|
||||
|
||||
88
src/Utils.hs
88
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
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
|
||||
@ -34,7 +34,7 @@
|
||||
<div .course__registration>
|
||||
<a href="#">Anmelden
|
||||
|
||||
$# <form method=post action=@{CourseR tid csh CourseShowR} enctype=#{regEnctype}>
|
||||
$# <form method=post action=@{CourseR tid csh CShow} enctype=#{regEnctype}>
|
||||
$# ^{regWidget}
|
||||
|
||||
<div .container>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user