Merge branch 'feat/routes' into feat/assign-correctors
This commit is contained in:
Gregor Kleen
commit
3fb7ff9f13
@ -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,16 @@ SheetDelTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Übun
|
||||
SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben.
|
||||
SheetDelOk tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
|
||||
|
||||
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
|
||||
UnauthorizedAnd l@Text r@Text: "#{l}" und "#{r}"
|
||||
UnauthorizedOr l@Text r@Text: "#{l}" oder "#{r}"
|
||||
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
|
||||
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
|
||||
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
|
||||
UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
|
||||
UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
|
||||
OnlyUploadOneFile: Bitte nur eine Datei hochladen.
|
||||
DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
|
||||
|
||||
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
|
||||
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
|
||||
|
||||
4
models
4
models
@ -143,8 +143,8 @@ SubmissionEdit
|
||||
SubmissionFile
|
||||
submission SubmissionId
|
||||
file FileId
|
||||
isUpdate Bool
|
||||
isDeletion Bool
|
||||
isUpdate Bool -- is this the file updated by a corrector (original will always be retained)
|
||||
isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector
|
||||
UniqueSubmissionFile file submission isUpdate
|
||||
deriving Show
|
||||
SubmissionUser
|
||||
|
||||
89
routes
89
routes
@ -1,45 +1,64 @@
|
||||
/static StaticR Static appStatic
|
||||
/auth AuthR Auth getAuth
|
||||
--
|
||||
-- Accesss granted via tags; default is no accesss.
|
||||
-- Permission must be explicitly granted.
|
||||
--
|
||||
-- Access permission is the disjunction of permit tags
|
||||
-- Tags are split on "AND" to encode conjunction.
|
||||
--
|
||||
-- Note that nested routes automatically inherit all tags from the parent.
|
||||
--
|
||||
-- Admins always have access to entities within their assigned schools.
|
||||
--
|
||||
-- Access Tags:
|
||||
-- !free -- free for all
|
||||
-- !lecturer -- lecturer for this course (or the school, if route is not connected to a course)
|
||||
-- !corrector -- corrector for this sheet (or the course, if route is not connected to a sheet )
|
||||
-- !registered -- participant for this course (no effect outside of courses)
|
||||
--
|
||||
-- !materials -- only if course allows all materials to be free (no meaning outside of courses)
|
||||
-- !time -- access depends on time somehow
|
||||
--
|
||||
-- !deprecated -- like free, but logs and gives a warning
|
||||
--
|
||||
|
||||
/favicon.ico FaviconR GET
|
||||
/robots.txt RobotsR GET
|
||||
/static StaticR Static appStatic !free
|
||||
/auth AuthR Auth getAuth !free
|
||||
|
||||
/ HomeR GET POST
|
||||
/profile ProfileR GET
|
||||
/users UsersR GET !adminAny
|
||||
/favicon.ico FaviconR GET !free
|
||||
/robots.txt RobotsR GET !free
|
||||
|
||||
/term TermShowR GET
|
||||
/term/edit TermEditR GET POST !adminAny
|
||||
/term/#TermId/edit TermEditExistR GET !adminAny
|
||||
/ HomeR GET POST !free
|
||||
/profile ProfileR GET !free
|
||||
/users UsersR GET -- no tags, i.e. admins only
|
||||
|
||||
/term TermShowR GET !free
|
||||
/term/edit TermEditR GET POST
|
||||
/term/#TermId/edit TermEditExistR GET
|
||||
!/term/#TermId TermCourseListR GET !free
|
||||
|
||||
-- For Pattern Synonyms see Foundation
|
||||
/course/ CourseListR GET
|
||||
!/course/new CourseNewR GET POST !lecturerAny
|
||||
!/course/#TermId CourseListTermR GET
|
||||
/course/#TermId/#Text CourseR !updateFavourite:
|
||||
/show CourseShowR GET POST
|
||||
/edit CourseEditR GET POST !lecturer
|
||||
|
||||
/ex SheetR !registered:
|
||||
/ SheetListR GET
|
||||
/#Text/show SheetShowR GET !time
|
||||
/#Text/#SheetFileType/#FilePath SheetFileR GET !time
|
||||
/new SheetNewR GET POST !lecturer
|
||||
/#Text/edit SheetEditR GET POST !lecturer
|
||||
/#Text/delete SheetDelR GET POST !lecturer
|
||||
/#Text/correctors SheetCorrectorsR GET POST !lecturer
|
||||
!/#Text/submission/#SubmissionMode SubmissionR GET POST !time
|
||||
/course/ CourseListR GET !free
|
||||
!/course/new CourseNewR GET POST !lecturer
|
||||
/course/#TermId/#Text CourseR !lecturer:
|
||||
/show CShowR GET POST !free
|
||||
/edit CEditR GET POST
|
||||
/ex SheetListR GET !materials
|
||||
!/ex/new SheetNewR GET POST
|
||||
/ex/#Text SheetR !materials:
|
||||
/show SShowR GET !time !corrector
|
||||
/#SheetFileType/#FilePath SFileR GET !time !corrector
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
!/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered
|
||||
/correctors SCorrR GET POST
|
||||
|
||||
|
||||
!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET
|
||||
!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
|
||||
|
||||
!/#UUID CryptoUUIDDispatchR GET
|
||||
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
|
||||
|
||||
-- TODO below
|
||||
/submission SubmissionListR GET POST
|
||||
/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST
|
||||
/submissions.zip SubmissionDownloadMultiArchiveR POST
|
||||
!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
|
||||
!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated
|
||||
|
||||
-- For demonstration
|
||||
/course/#CryptoUUIDCourse/edit CourseEditIDR GET
|
||||
/submission SubmissionListR GET !deprecated
|
||||
/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated
|
||||
/submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated
|
||||
|
||||
@ -1,9 +1,11 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
@ -30,6 +32,7 @@ import LDAP.Search (LDAPEntry(..))
|
||||
import Yesod.Default.Util (addStaticContentExternal)
|
||||
import Yesod.Core.Types (Logger)
|
||||
import qualified Yesod.Core.Unsafe as Unsafe
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text.Encoding as TE
|
||||
|
||||
@ -45,6 +48,13 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Data.List (foldr1)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
import Data.Conduit (($$))
|
||||
import Data.Conduit.List (sourceList)
|
||||
|
||||
@ -52,12 +62,14 @@ import qualified Database.Esqueleto as E
|
||||
|
||||
import Control.Monad.Except (MonadError(..), runExceptT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Trans.Reader (runReader)
|
||||
|
||||
import System.FilePath
|
||||
|
||||
import Handler.Utils.Templates
|
||||
import Handler.Utils.StudyFeatures
|
||||
|
||||
import Control.Lens
|
||||
import Utils.Lens
|
||||
|
||||
-- infixl 9 :$:
|
||||
-- pattern a :$: b = a b
|
||||
@ -89,10 +101,17 @@ data UniWorX = UniWorX
|
||||
-- type Widget = WidgetT UniWorX IO ()
|
||||
mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
type DB a = YesodDB UniWorX a
|
||||
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
|
||||
type MsgRenderer = MsgRendererS UniWorX -- see Utils
|
||||
|
||||
-- Pattern Synonyms for convenience
|
||||
pattern CSheetR tid csh ptn = CourseR tid csh (SheetR ptn)
|
||||
pattern CSheetR tid csh shn ptn
|
||||
= CourseR tid csh (SheetR shn ptn)
|
||||
|
||||
|
||||
-- Menus and Favourites
|
||||
data MenuItem = MenuItem
|
||||
{ menuItemLabel :: Text
|
||||
, menuItemIcon :: Maybe Text
|
||||
@ -113,10 +132,7 @@ data MenuTypes -- Semantische Rolle:
|
||||
| PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig
|
||||
| PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
type DB a = YesodDB UniWorX a
|
||||
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
|
||||
|
||||
-- Messages
|
||||
mkMessage "UniWorX" "messages" "de"
|
||||
|
||||
-- This instance is required to use forms. You can modify renderMessage to
|
||||
@ -131,6 +147,135 @@ instance RenderMessage UniWorX TermIdentifier where
|
||||
where renderMessage' = renderMessage foundation ls
|
||||
|
||||
|
||||
-- Access Control
|
||||
data AccessPredicate
|
||||
= APPure (Route UniWorX -> Reader MsgRenderer AuthResult)
|
||||
| APHandler (Route UniWorX -> Handler AuthResult)
|
||||
| APDB (Route UniWorX -> DB AuthResult)
|
||||
|
||||
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
|
||||
orAR _ Authorized _ = Authorized
|
||||
orAR _ _ Authorized = Authorized
|
||||
orAR _ AuthenticationRequired _ = AuthenticationRequired
|
||||
orAR _ _ AuthenticationRequired = AuthenticationRequired
|
||||
orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
|
||||
andAR _ Authorized Authorized = Authorized
|
||||
andAR _ Authorized other = other
|
||||
andAR _ other Authorized = other
|
||||
andAR _ AuthenticationRequired other = other
|
||||
andAR _ other AuthenticationRequired = other
|
||||
andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
|
||||
|
||||
|
||||
|
||||
orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate
|
||||
orAP = liftAR orAR (== Authorized)
|
||||
andAP = liftAR andAR (const False)
|
||||
|
||||
liftAR :: (MsgRenderer -> AuthResult -> AuthResult -> AuthResult)
|
||||
-> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument
|
||||
-> AccessPredicate -> AccessPredicate -> AccessPredicate
|
||||
-- Ensure to first evaluate Pure conditions, then Handler before DB
|
||||
liftAR op sc (APPure f) (APPure g) = APPure $ \r -> shortCircuitM sc (f r) (g r) . op =<< ask
|
||||
liftAR op sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer
|
||||
liftAR op sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer
|
||||
liftAR op sc (APPure f) apg = liftAR op sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg
|
||||
liftAR op sc apf apg@(APPure _) = liftAR op sc apg apf
|
||||
liftAR op sc (APHandler f) apdb = liftAR op sc (APDB $ lift . f) apdb
|
||||
liftAR op sc apdb apg@(APHandler _) = liftAR op sc apg apdb
|
||||
|
||||
|
||||
trueAP,falseAP :: AccessPredicate
|
||||
trueAP = APPure . const $ return Authorized
|
||||
falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask
|
||||
-- TODO: I believe falseAP := adminAP
|
||||
|
||||
adminAP :: AccessPredicate
|
||||
adminAP = APDB $ \case
|
||||
CourseR tid csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
|
||||
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
|
||||
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (unauthorizedI MsgUnauthorizedSchoolAdmin) (c > 0)
|
||||
return Authorized
|
||||
|
||||
_other -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
|
||||
case adrights of
|
||||
(Just _) -> return Authorized
|
||||
Nothing -> lift $ unauthorizedI $ MsgUnauthorized
|
||||
|
||||
knownTags :: Map (CI Text) AccessPredicate
|
||||
knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
|
||||
[("free", trueAP)
|
||||
,("deprecated", APHandler $ \r -> do
|
||||
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
|
||||
setMessageI $ MsgDeprecatedRoute
|
||||
return Authorized
|
||||
)
|
||||
,("lecturer", APDB $ \case
|
||||
CourseR tid csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (unauthorizedI MsgUnauthorizedLecturer) (c > 0)
|
||||
return Authorized
|
||||
_ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
|
||||
return Authorized
|
||||
)
|
||||
-- TODO: Continue here!!!
|
||||
,("corrector", undefined)
|
||||
,("time", undefined)
|
||||
,("registered", undefined)
|
||||
,("materials", APDB $ \case
|
||||
CourseR tid csh _ -> do
|
||||
Entity cid _ <- getBy404 $ CourseTermShort tid csh
|
||||
undefined -- CONTINUE HERE
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
tag2ap :: Text -> AccessPredicate
|
||||
tag2ap t = case Map.lookup (CI.mk t) knownTags of
|
||||
(Just acp) -> acp
|
||||
Nothing -> APHandler $ \_route -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should)
|
||||
$logWarnS "AccessControl" ("route tag unknown for access control")
|
||||
unauthorizedI $ MsgUnauthorized
|
||||
|
||||
route2ap :: Route UniWorX -> AccessPredicate
|
||||
route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK: Due to shortCircuitM this (while still true) is no longer costly (we do a `runDB` but then only actually send off queries, if needed)
|
||||
where
|
||||
attrsAND = map splitAND $ Set.toList $ routeAttrs r
|
||||
splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
|
||||
|
||||
evalAccessDB :: Route UniWorX -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
|
||||
evalAccessDB r = case route2ap r of
|
||||
(APPure p) -> lift $ runReader (p r) <$> getMsgRenderer
|
||||
(APHandler p) -> lift $ p r
|
||||
(APDB p) -> p r
|
||||
|
||||
evalAccess :: Route UniWorX -> Handler AuthResult
|
||||
evalAccess r = case route2ap r of
|
||||
(APPure p) -> runReader (p r) <$> getMsgRenderer
|
||||
(APHandler p) -> p r
|
||||
(APDB p) -> runDB $ p r
|
||||
|
||||
-- TODO: isAuthorized = evalAccess'
|
||||
|
||||
|
||||
|
||||
|
||||
-- Please see the documentation for the Yesod typeclass. There are a number
|
||||
-- of settings which can be configured by overriding methods here.
|
||||
instance Yesod UniWorX where
|
||||
@ -157,9 +302,9 @@ instance Yesod UniWorX where
|
||||
yesodMiddleware handler = do
|
||||
res <- defaultYesodMiddleware handler
|
||||
void . runMaybeT $ do
|
||||
route@(routeAttrs -> attrs) <- MaybeT getCurrentRoute
|
||||
case route of
|
||||
CourseR tid csh _ | "updateFavourite" `elem` attrs -> do
|
||||
route <- MaybeT getCurrentRoute
|
||||
case route of -- update Course Favourites here
|
||||
CourseR tid csh _ -> do
|
||||
uid <- MaybeT maybeAuthId
|
||||
$(logDebug) "Favourites save"
|
||||
now <- liftIO $ getCurrentTime
|
||||
@ -167,7 +312,7 @@ instance Yesod UniWorX where
|
||||
cid <- MaybeT . getKeyBy $ CourseTermShort tid csh
|
||||
user <- MaybeT $ get uid
|
||||
-- update Favourites
|
||||
lift $ upsertBy
|
||||
void . lift $ upsertBy
|
||||
(UniqueCourseFavourite uid cid)
|
||||
(CourseFavourite uid now cid)
|
||||
[CourseFavouriteTime =. now]
|
||||
@ -209,7 +354,7 @@ instance Yesod UniWorX where
|
||||
|
||||
favourites <- forM favourites' $ \(Entity _ c@Course{..})
|
||||
-> let
|
||||
courseRoute = CourseR courseTerm courseShorthand CourseShowR
|
||||
courseRoute = CourseR courseTerm courseShorthand CShowR
|
||||
in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
|
||||
|
||||
-- We break up the default layout into two components:
|
||||
@ -253,21 +398,7 @@ instance Yesod UniWorX where
|
||||
-- The page to be redirected to when authentication is required.
|
||||
authRoute _ = Just $ AuthR LoginR
|
||||
|
||||
isAuthorized (AuthR _) _ = return Authorized
|
||||
isAuthorized HomeR _ = return Authorized
|
||||
isAuthorized FaviconR _ = return Authorized
|
||||
isAuthorized RobotsR _ = return Authorized
|
||||
isAuthorized (StaticR _) _ = return Authorized
|
||||
isAuthorized ProfileR _ = isAuthenticated
|
||||
isAuthorized TermShowR _ = return Authorized
|
||||
isAuthorized CourseListR _ = return Authorized
|
||||
isAuthorized (CourseListTermR _) _ = return Authorized
|
||||
isAuthorized (CourseR _ _ CourseShowR) _ = return Authorized
|
||||
isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized
|
||||
isAuthorized SubmissionListR _ = isAuthenticated
|
||||
isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated
|
||||
-- isAuthorized TestR _ = return Authorized
|
||||
isAuthorized route isWrite = runDB $ isAuthorizedDB route isWrite
|
||||
isAuthorized route _isWrite = evalAccess route
|
||||
|
||||
-- This function creates static content files in the static folder
|
||||
-- and names them based on a hash of their content. This allows
|
||||
@ -308,13 +439,14 @@ instance Yesod UniWorX where
|
||||
|
||||
makeLogger = return . appLogger
|
||||
|
||||
|
||||
{- ALL DEPRECATED and will be deleted, once knownTags is completed
|
||||
|
||||
isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult
|
||||
isAuthorizedDB route@(routeAttrs -> attrs) writeable
|
||||
| "adminAny" `member` attrs = adminAccess Nothing
|
||||
| "lecturerAny" `member` attrs = lecturerAccess Nothing
|
||||
|
||||
|
||||
|
||||
isAuthorizedDB UsersR _ = adminAccess Nothing
|
||||
isAuthorizedDB (SubmissionDemoR cID) _ = return Authorized -- submissionAccess $ Right cID
|
||||
isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID
|
||||
@ -322,14 +454,14 @@ isAuthorizedDB (SubmissionDownloadArchiveR (ZIPArchiveName cID)) _ = submissionA
|
||||
isAuthorizedDB TermEditR _ = adminAccess Nothing
|
||||
isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing
|
||||
isAuthorizedDB CourseNewR _ = lecturerAccess Nothing
|
||||
isAuthorizedDB (CourseR t c CourseEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c CEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized --
|
||||
isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
|
||||
isAuthorizedDB (CourseR t c (SheetR (SShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
|
||||
isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SubmissionR s m))) _ = return Authorized -- TODO -- submissionAccess $ Right cID
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetCorrectorsR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseEditIDR cID) _ = do
|
||||
@ -396,6 +528,8 @@ isAuthorizedDB' route isWrite = (== Authorized) <$> isAuthorizedDB route isWrite
|
||||
|
||||
isAuthorized' :: Route UniWorX -> Bool -> Handler Bool
|
||||
isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite
|
||||
-}
|
||||
|
||||
|
||||
-- Define breadcrumbs.
|
||||
instance YesodBreadcrumbs UniWorX where
|
||||
@ -404,18 +538,18 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR)
|
||||
|
||||
breadcrumb CourseListR = return ("Kurs", Just HomeR)
|
||||
breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR)
|
||||
breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term)
|
||||
breadcrumb (TermCourseListR term) = return (toPathPiece term, Just TermShowR)
|
||||
breadcrumb (CourseR term course CShowR) = return (course, Just $ TermCourseListR term)
|
||||
breadcrumb CourseNewR = return ("Neu", Just CourseListR)
|
||||
breadcrumb (CourseR _ _ CourseEditR) = return ("Editieren", Just CourseListR)
|
||||
breadcrumb (CourseR _ _ CEditR) = return ("Editieren", Just CourseListR)
|
||||
|
||||
breadcrumb (CourseR tid csh (SheetR SheetListR)) = return ("Übungen",Just $ CourseR tid csh CourseShowR)
|
||||
breadcrumb (CourseR tid csh (SheetR SheetNewR )) = return ("Neu", Just $ CourseR tid csh $ SheetR SheetListR)
|
||||
breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR)
|
||||
breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
|
||||
breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
|
||||
breadcrumb (CourseR tid csh (SheetR (SheetCorrectorsR shn))) = return ("Korrektoren", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
|
||||
breadcrumb (CourseR tid csh (SheetR (SubmissionR shn _))) = return ("Abgabe", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
|
||||
breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR)
|
||||
breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR)
|
||||
breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR)
|
||||
breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
|
||||
-- breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
|
||||
breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
|
||||
|
||||
@ -426,41 +560,41 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb _ = return ("home", Nothing)
|
||||
|
||||
pageActions :: Route UniWorX -> [MenuTypes]
|
||||
pageActions (CourseR tid csh CourseShowR) =
|
||||
pageActions (CourseR tid csh CShowR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Übungsblätter"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh SheetListR
|
||||
, menuItemRoute = CourseR tid csh SheetListR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Kurs Editieren"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid csh CourseEditR
|
||||
, menuItemRoute = CourseR tid csh CEditR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSheetR tid csh SheetListR) =
|
||||
pageActions (CourseR tid csh SheetListR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Neues Übungsblatt"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh SheetNewR
|
||||
, menuItemRoute = CourseR tid csh SheetNewR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSheetR tid csh (SheetShowR shn)) =
|
||||
pageActions (CSheetR tid csh shn SShowR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgabe"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh (SubmissionR shn newSubmission)
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrektoren"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh (SheetCorrectorsR shn)
|
||||
, menuItemRoute = CSheetR tid csh shn (SubmissionR newSubmission)
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
-- , PageActionPrime $ MenuItem
|
||||
-- { menuItemLabel = "Korrektoren"
|
||||
-- , menuItemIcon = Nothing
|
||||
-- , menuItemRoute = CSheetR tid csh shn SCorrR
|
||||
-- , menuItemAccessCallback' = return True
|
||||
-- }
|
||||
]
|
||||
pageActions TermShowR =
|
||||
[ PageActionPrime $ MenuItem
|
||||
@ -470,7 +604,7 @@ pageActions TermShowR =
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CourseListTermR _) =
|
||||
pageActions (TermCourseListR _) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Neuer Kurs"
|
||||
, menuItemIcon = Just "book"
|
||||
|
||||
@ -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 $ SubmissionMode $ Just cID
|
||||
|
||||
|
||||
class Dispatch ciphertext (x :: [*]) where
|
||||
|
||||
@ -133,8 +133,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
-- TODO: continue validation here!!!
|
||||
] ]
|
||||
|
||||
|
||||
|
||||
-- List Sheets
|
||||
getSheetListCID :: CourseId -> Handler Html
|
||||
getSheetListCID cid = getSheetList =<<
|
||||
@ -159,7 +157,7 @@ getSheetList courseEnt = do
|
||||
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
|
||||
return (sid, sheet, (submissions, rated))
|
||||
let colBase = mconcat
|
||||
[ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet
|
||||
[ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CSheetR tid csh (sheetName sheet) SShowR
|
||||
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
|
||||
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
|
||||
, headed "Bewertung" $ toWgt . show . sheetType . snd3
|
||||
@ -167,13 +165,13 @@ getSheetList courseEnt = do
|
||||
let colAdmin = mconcat -- only show edit button for allowed course assistants
|
||||
[ headed "Korrigiert" $ toWgt . snd . trd3
|
||||
, headed "Eingereicht" $ toWgt . fst . trd3
|
||||
, headed "" $ \s -> linkButton "Edit" BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s
|
||||
, headed "" $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR $ sheetName $ snd3 s
|
||||
, headed "" $ \s -> linkButton "Edit" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SEditR
|
||||
, headed "" $ \s -> linkButton "Delete" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SDelR
|
||||
]
|
||||
showAdmin <- case sheets of
|
||||
((_,firstSheet,_):_) -> do
|
||||
setUltDestCurrent
|
||||
(Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False
|
||||
(Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False
|
||||
_otherwise -> return False
|
||||
let colSheets = if showAdmin
|
||||
then colBase `mappend` colAdmin
|
||||
@ -186,8 +184,8 @@ getSheetList courseEnt = do
|
||||
|
||||
|
||||
-- Show single sheet
|
||||
getSheetShowR :: TermId -> Text -> Text -> Handler Html
|
||||
getSheetShowR tid csh shn = do
|
||||
getSShowR :: TermId -> Text -> Text -> Handler Html
|
||||
getSShowR tid csh shn = do
|
||||
entSheet <- runDB $ fetchSheet tid csh shn
|
||||
let sheet = entityVal entSheet
|
||||
sid = entityKey entSheet
|
||||
@ -215,7 +213,7 @@ getSheetShowR tid csh shn = do
|
||||
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = mconcat
|
||||
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName))
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
|
||||
(\(E.Value fName,_,_) -> str2widget fName)
|
||||
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT modified
|
||||
]
|
||||
@ -240,8 +238,8 @@ getSheetShowR tid csh shn = do
|
||||
$(widgetFile "sheetShow")
|
||||
[whamlet| Under Construction !!! |] -- TODO
|
||||
|
||||
getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSheetFileR tid csh shn typ title = do
|
||||
getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSFileR tid csh shn typ title = do
|
||||
content <- runDB $ E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
@ -277,8 +275,8 @@ postSheetNewR :: TermId -> Text -> Handler Html
|
||||
postSheetNewR = getSheetNewR
|
||||
|
||||
|
||||
getSheetEditR :: TermId -> Text -> Text -> Handler Html
|
||||
getSheetEditR tid csh shn = do
|
||||
getSEditR :: TermId -> Text -> Text -> Handler Html
|
||||
getSEditR tid csh shn = do
|
||||
(sheetEnt, sheetFileIds) <- runDB $ do
|
||||
ent <- fetchSheet tid csh shn
|
||||
fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
||||
@ -311,8 +309,8 @@ getSheetEditR tid csh shn = do
|
||||
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
|
||||
handleSheetEdit tid csh (Just sid) template action
|
||||
|
||||
postSheetEditR :: TermId -> Text -> Text -> Handler Html
|
||||
postSheetEditR = getSheetEditR
|
||||
postSEditR :: TermId -> Text -> Text -> Handler Html
|
||||
postSEditR = getSEditR
|
||||
|
||||
handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
|
||||
handleSheetEdit tid csh msId template dbAction = do
|
||||
@ -348,44 +346,44 @@ handleSheetEdit tid csh msId template dbAction = do
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI "info" $ MsgSheetEditOk tident csh sfName
|
||||
return True
|
||||
when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB
|
||||
when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
||||
_ -> return ()
|
||||
let pageTitle = maybe (MsgSheetTitleNew tident csh)
|
||||
(MsgSheetTitle tident csh) mbshn
|
||||
let formTitle = pageTitle
|
||||
let formText = Nothing :: Maybe UniWorXMessage
|
||||
actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute
|
||||
actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute
|
||||
defaultLayout $ do
|
||||
setTitleI pageTitle
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
|
||||
|
||||
getSheetDelR :: TermId -> Text -> Text -> Handler Html
|
||||
getSheetDelR tid csh shn = do
|
||||
getSDelR :: TermId -> Text -> Text -> Handler Html
|
||||
getSDelR tid csh shn = do
|
||||
let tident = unTermKey tid
|
||||
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
||||
case result of
|
||||
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn
|
||||
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR
|
||||
(FormSuccess BtnDelete) -> do
|
||||
runDB $ fetchSheetId tid csh shn >>= deleteCascade
|
||||
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
|
||||
addMessageI "info" $ MsgSheetDelOk tident csh shn
|
||||
redirect $ CSheetR tid csh SheetListR
|
||||
redirect $ CourseR tid csh SheetListR
|
||||
_other -> do
|
||||
submissionno <- runDB $ do
|
||||
sid <- fetchSheetId tid csh shn
|
||||
count [SubmissionSheet ==. sid]
|
||||
let formTitle = MsgSheetDelTitle tident csh shn
|
||||
let formText = Just $ MsgSheetDelText submissionno
|
||||
let actionUrl = CSheetR tid csh $ SheetDelR shn
|
||||
let actionUrl = CSheetR tid csh shn SDelR
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetTitle tident csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
postSheetDelR :: TermId -> Text -> Text -> Handler Html
|
||||
postSheetDelR = getSheetDelR
|
||||
postSDelR :: TermId -> Text -> Text -> Handler Html
|
||||
postSDelR = getSDelR
|
||||
|
||||
|
||||
|
||||
@ -556,12 +554,12 @@ correctorForm shid = do
|
||||
-- Eingabebox für Korrektor hinzufügen
|
||||
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
||||
|
||||
getSheetCorrectorsR, postSheetCorrectorsR :: TermId
|
||||
-> Text -- ^ Course shorthand
|
||||
-> Text -- ^ Sheet name
|
||||
-> Handler Html
|
||||
postSheetCorrectorsR = getSheetCorrectorsR
|
||||
getSheetCorrectorsR tid@(unTermKey -> tident) csh shn = do
|
||||
getSCorrR, postSCorrR :: TermId
|
||||
-> Text -- ^ Course shorthand
|
||||
-> Text -- ^ Sheet name
|
||||
-> Handler Html
|
||||
postSCorrR = getSCorrR
|
||||
getSCorrR tid@(unTermKey -> tident) csh shn = do
|
||||
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
|
||||
|
||||
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
|
||||
@ -577,7 +575,8 @@ getSheetCorrectorsR tid@(unTermKey -> tident) csh shn = do
|
||||
let
|
||||
formTitle = MsgSheetCorrectorsTitle tident csh shn
|
||||
formText = Nothing :: Maybe (SomeMessage UniWorX)
|
||||
actionUrl = CSheetR tid csh $ SheetCorrectorsR shn
|
||||
-- actionUrl = CSheetR tid csh shn SCorrR
|
||||
actionUrl = CSheetR tid csh shn SShowR
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetCorrectorsTitle tident csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE ParallelListComp #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
@ -11,6 +12,7 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Handler.Submission where
|
||||
|
||||
@ -51,6 +53,9 @@ import Yesod.Colonnade
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
|
||||
|
||||
numberOfSubmissionEditDates :: Int64
|
||||
numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
|
||||
|
||||
|
||||
makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [Text] -> Form (Maybe (Source Handler File), [Text])
|
||||
makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
|
||||
@ -75,7 +80,7 @@ getSubmissionR = postSubmissionR
|
||||
postSubmissionR tid csh shn (SubmissionMode mcid) = do
|
||||
uid <- requireAuthId
|
||||
msmid <- traverse decrypt mcid
|
||||
(Entity shid Sheet{..}, buddies, oldfiles,lastEdits) <- runDB $ do
|
||||
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
|
||||
sheet@(Entity shid Sheet{..}) <- fetchSheet tid csh shn
|
||||
case msmid of
|
||||
Nothing -> do
|
||||
@ -103,11 +108,11 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
|
||||
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
|
||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||
return $ user E.^. UserEmail
|
||||
return (sheet,buddies,[],[])
|
||||
return (sheet,buddies,[])
|
||||
(E.Value smid:_) -> do
|
||||
cID <- encrypt smid
|
||||
addMessageI "info" $ MsgSubmissionAlreadyExists
|
||||
redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
|
||||
redirect $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID
|
||||
(Just smid) -> do
|
||||
shid' <- submissionSheet <$> get404 smid
|
||||
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||
@ -118,16 +123,15 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
|
||||
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
|
||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||
return $ user E.^. UserEmail
|
||||
oldfiles <- sourceToList $ submissionFileSource smid
|
||||
-- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime]
|
||||
lastEditValues <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
|
||||
E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser)
|
||||
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
|
||||
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
||||
E.limit 3 -- TODO for Debug Purposes
|
||||
E.limit numberOfSubmissionEditDates
|
||||
return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime)
|
||||
let lastEdits = map (bimap E.unValue E.unValue) lastEditValues
|
||||
return (sheet,buddies,oldfiles,lastEdits)
|
||||
return (sheet,buddies,lastEdits)
|
||||
let unpackZips = True -- undefined -- TODO
|
||||
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies
|
||||
mCID <- runDB $ do
|
||||
@ -174,10 +178,10 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
|
||||
now <- liftIO $ getCurrentTime
|
||||
smid <- do
|
||||
smid <- case (mFiles, msmid) of
|
||||
(Nothing, Just smid)
|
||||
(Nothing, Just smid) -- no new files, existing submission partners updated
|
||||
-> return smid
|
||||
(Just files, Nothing)
|
||||
-> runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid Nothing
|
||||
(Just files, _) -- new files
|
||||
-> runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid)
|
||||
_ -> error "Impossible, because of definition of `makeSubmissionForm`"
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
@ -199,7 +203,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
|
||||
_other -> return Nothing
|
||||
|
||||
case mCID of
|
||||
Just cID -> redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
|
||||
Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID
|
||||
Nothing -> return ()
|
||||
|
||||
mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid
|
||||
@ -208,6 +212,28 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
|
||||
let formTitle = pageTitle
|
||||
let formText = Nothing :: Maybe UniWorXMessage
|
||||
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
|
||||
-- Maybe construct a table to display uploaded archive files
|
||||
let colonnadeFiles cid = mconcat
|
||||
-- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
||||
[ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle)
|
||||
(\(Entity _ File{..}) -> str2widget fileTitle)
|
||||
, sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
|
||||
]
|
||||
smid2ArchiveTable (smid,cid) = DBTable
|
||||
{ dbtSQLQuery = submissionFileQuery smid
|
||||
, dbtColonnade = colonnadeFiles cid
|
||||
, dbtAttrs = tableDefault
|
||||
, dbtIdent = "files" :: Text
|
||||
, dbtSorting = [ ( "path"
|
||||
, SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileTitle
|
||||
)
|
||||
, ( "time"
|
||||
, SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileModified
|
||||
)
|
||||
]
|
||||
}
|
||||
mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI pageTitle
|
||||
$(widgetFile "formPageI18n")
|
||||
@ -218,24 +244,25 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
|
||||
<a href=@{SubmissionDownloadArchiveR arCid}>Archiv
|
||||
$forall (name,time) <- lastEdits
|
||||
<div>last edited by #{name} at #{formatTimeGerDTlong time}
|
||||
$maybe cid <- mcid
|
||||
$maybe fileTable <- mFileTable
|
||||
<h3>Enthaltene Dateien:
|
||||
$forall (Entity _ File{..}) <- oldfiles
|
||||
<a href=@{SubmissionDownloadSingleR cid fileTitle}>
|
||||
#{fileTitle}
|
||||
^{fileTable}
|
||||
|]
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
|
||||
submissionFileSource submissionID = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
||||
submissionFileSource = E.selectSource . E.from . submissionFileQuery
|
||||
|
||||
submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
|
||||
-> E.SqlQuery (E.SqlExpr (Entity File))
|
||||
submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
||||
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
||||
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
|
||||
return f
|
||||
|
||||
getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
|
||||
@ -300,7 +327,7 @@ submissionTable = do
|
||||
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
|
||||
|
||||
let
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CourseShowR
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR
|
||||
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
|
||||
anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
|
||||
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
|
||||
|
||||
@ -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{..},_) ->
|
||||
|
||||
75
src/Utils.hs
75
src/Utils.hs
@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
@ -14,10 +16,29 @@ import Utils.Common as Utils
|
||||
|
||||
import Text.Blaze (Markup, ToMarkup)
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.List as List
|
||||
-- import Data.Map (Map)
|
||||
-- import qualified Data.Map as Map
|
||||
-- import qualified Data.List as List
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
|
||||
-----------
|
||||
-- Yesod --
|
||||
-----------
|
||||
|
||||
newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) }
|
||||
|
||||
getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
|
||||
getMsgRenderer = do
|
||||
mr <- getMessageRender
|
||||
return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
|
||||
|
||||
|
||||
---------------------
|
||||
-- Text and String --
|
||||
---------------------
|
||||
|
||||
tickmark :: IsString a => a
|
||||
tickmark = fromString "✔"
|
||||
@ -42,12 +63,6 @@ withFragment :: ( Monad m
|
||||
) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
|
||||
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
|
||||
|
||||
-----------
|
||||
-- Maybe --
|
||||
-----------
|
||||
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenIsJust (Just x) f = f x
|
||||
whenIsJust Nothing _ = return ()
|
||||
|
||||
------------
|
||||
-- Tuples --
|
||||
@ -56,3 +71,45 @@ whenIsJust Nothing _ = return ()
|
||||
----------
|
||||
-- Maps --
|
||||
----------
|
||||
|
||||
|
||||
-----------
|
||||
-- Maybe --
|
||||
-----------
|
||||
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenIsJust (Just x) f = f x
|
||||
whenIsJust Nothing _ = return ()
|
||||
|
||||
maybeT :: Monad m => m a -> MaybeT m a -> m a
|
||||
maybeT x m = runMaybeT m >>= maybe x return
|
||||
|
||||
---------------
|
||||
-- Exception --
|
||||
---------------
|
||||
|
||||
maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
|
||||
maybeExceptT err act = lift act >>= maybe (throwE err) return
|
||||
|
||||
maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b
|
||||
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
|
||||
|
||||
guardExceptT :: Monad m => e -> Bool -> ExceptT e m ()
|
||||
guardExceptT err b = unless b $ throwE err
|
||||
|
||||
guardMExceptT :: Monad m => (m e) -> Bool -> ExceptT e m ()
|
||||
guardMExceptT err b = unless b $ lift err >>= throwE
|
||||
|
||||
exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
|
||||
exceptT f g = either f g <=< runExceptT
|
||||
|
||||
|
||||
------------
|
||||
-- Monads --
|
||||
------------
|
||||
|
||||
shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
|
||||
shortCircuitM sc mx my op = do
|
||||
x <- mx
|
||||
case sc x of
|
||||
True -> return x
|
||||
False -> op <$> pure x <*> my
|
||||
|
||||
@ -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