fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'feat/routes' into feat/assign-correctors

Browse Source
This commit is contained in:
Gregor Kleen 2018-05-29 15:19:00 +02:00
commit 3fb7ff9f13
14 changed files with 422 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
FragenSJ.txt
View File

@ -1,7 +1,7 @@
** Sicherheitsabfragen? ** Sicherheitsabfragen?
- Verschlüsselung des Zugriffs? - Verschlüsselung des Zugriffs?
- SheetDelR tid csh sn : GET zeigt Sicherheitsabfrage - SDelR tid csh sn : GET zeigt Sicherheitsabfrage
POST löscht. POST löscht.
Ist das so sinnvoll? Ist das so sinnvoll?
Sicherheitsabfrage als PopUpMessage? Sicherheitsabfrage als PopUpMessage?
@ -9,7 +9,7 @@
- Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq? - Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq?
(Sheet.hs -> fetchSheet) (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? Kann man abfragen, was bei deleteCascade alles gelöscht wird?
@ -19,7 +19,7 @@
Links -> MenuItems verwenden wie bisher Links -> MenuItems verwenden wie bisher
Page Titles -> setTitleI Page Titles -> setTitleI
Buttons? -> Kann leicht geändert werden! 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? ** Page pageActions - Berechtigungen prüfen?
=> Eigener Constructor statt NavbarLeft/Right?! => Eigener Constructor statt NavbarLeft/Right?!

2
README.md
View File

@ -109,7 +109,7 @@ TABLE "user";
DROP TABLE "course" CASCADE; DROP TABLE "course" CASCADE;
-- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer) -- 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: -- Beenden:
\q \q

4
messages/de.msg
View File

@ -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. 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. 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. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter 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. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
UnauthorizedCorrector: Sie sind nicht als Korrektor 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. UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
OnlyUploadOneFile: Bitte nur eine Datei hochladen. 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. SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.

4
models
View File

@ -143,8 +143,8 @@ SubmissionEdit
SubmissionFile SubmissionFile
submission SubmissionId submission SubmissionId
file FileId file FileId
isUpdate Bool isUpdate Bool -- is this the file updated by a corrector (original will always be retained)
isDeletion Bool isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector
UniqueSubmissionFile file submission isUpdate UniqueSubmissionFile file submission isUpdate
deriving Show deriving Show
SubmissionUser SubmissionUser

89
routes
View File

@ -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 /static StaticR Static appStatic !free
/robots.txt RobotsR GET /auth AuthR Auth getAuth !free
/ HomeR GET POST /favicon.ico FaviconR GET !free
/profile ProfileR GET /robots.txt RobotsR GET !free
/users UsersR GET !adminAny
/term TermShowR GET / HomeR GET POST !free
/term/edit TermEditR GET POST !adminAny /profile ProfileR GET !free
/term/#TermId/edit TermEditExistR GET !adminAny /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 -- For Pattern Synonyms see Foundation
/course/ CourseListR GET /course/ CourseListR GET !free
!/course/new CourseNewR GET POST !lecturerAny !/course/new CourseNewR GET POST !lecturer
!/course/#TermId CourseListTermR GET /course/#TermId/#Text CourseR !lecturer:
/course/#TermId/#Text CourseR !updateFavourite: /show CShowR GET POST !free
/show CourseShowR GET POST /edit CEditR GET POST
/edit CourseEditR GET POST !lecturer /ex SheetListR GET !materials
!/ex/new SheetNewR GET POST
/ex SheetR !registered: /ex/#Text SheetR !materials:
/ SheetListR GET /show SShowR GET !time !corrector
/#Text/show SheetShowR GET !time /#SheetFileType/#FilePath SFileR GET !time !corrector
/#Text/#SheetFileType/#FilePath SheetFileR GET !time /edit SEditR GET POST
/new SheetNewR GET POST !lecturer /delete SDelR GET POST
/#Text/edit SheetEditR GET POST !lecturer !/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered
/#Text/delete SheetDelR GET POST !lecturer /correctors SCorrR GET POST
/#Text/correctors SheetCorrectorsR GET POST !lecturer
!/#Text/submission/#SubmissionMode SubmissionR GET POST !time
!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !/#UUID CryptoUUIDDispatchR GET !free -- just redirect
!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
!/#UUID CryptoUUIDDispatchR GET
-- TODO below -- TODO below
/submission SubmissionListR GET POST !/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated
/submissions.zip SubmissionDownloadMultiArchiveR POST
-- For demonstration /submission SubmissionListR GET !deprecated
/course/#CryptoUUIDCourse/edit CourseEditIDR GET /submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated
/submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated

246
src/Foundation.hs
View File

@ -1,9 +1,11 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -30,6 +32,7 @@ import LDAP.Search (LDAPEntry(..))
import Yesod.Default.Util (addStaticContentExternal) import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger) import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Core.Unsafe as Unsafe
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE 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 as Text
import qualified Data.Text.Encoding 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 (($$))
import Data.Conduit.List (sourceList) import Data.Conduit.List (sourceList)
@ -52,12 +62,14 @@ import qualified Database.Esqueleto as E
import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Except (MonadError(..), runExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Reader (runReader)
import System.FilePath import System.FilePath
import Handler.Utils.Templates import Handler.Utils.Templates
import Handler.Utils.StudyFeatures import Handler.Utils.StudyFeatures
import Control.Lens
import Utils.Lens
-- infixl 9 :$: -- infixl 9 :$:
-- pattern a :$: b = a b -- pattern a :$: b = a b
@ -89,10 +101,17 @@ data UniWorX = UniWorX
-- type Widget = WidgetT UniWorX IO () -- type Widget = WidgetT UniWorX IO ()
mkYesodData "UniWorX" $(parseRoutesFile "routes") 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 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 data MenuItem = MenuItem
{ menuItemLabel :: Text { menuItemLabel :: Text
, menuItemIcon :: Maybe Text , menuItemIcon :: Maybe Text
@ -113,10 +132,7 @@ data MenuTypes -- Semantische Rolle:
| PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig | PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig
| PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten
-- | Convenient Type Synonyms: -- Messages
type DB a = YesodDB UniWorX a
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
mkMessage "UniWorX" "messages" "de" mkMessage "UniWorX" "messages" "de"
-- This instance is required to use forms. You can modify renderMessage to -- 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 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 -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- of settings which can be configured by overriding methods here.
instance Yesod UniWorX where instance Yesod UniWorX where
@ -157,9 +302,9 @@ instance Yesod UniWorX where
yesodMiddleware handler = do yesodMiddleware handler = do
res <- defaultYesodMiddleware handler res <- defaultYesodMiddleware handler
void . runMaybeT $ do void . runMaybeT $ do
route@(routeAttrs -> attrs) <- MaybeT getCurrentRoute route <- MaybeT getCurrentRoute
case route of case route of -- update Course Favourites here
CourseR tid csh _ | "updateFavourite" `elem` attrs -> do CourseR tid csh _ -> do
uid <- MaybeT maybeAuthId uid <- MaybeT maybeAuthId
$(logDebug) "Favourites save" $(logDebug) "Favourites save"
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
@ -167,7 +312,7 @@ instance Yesod UniWorX where
cid <- MaybeT . getKeyBy $ CourseTermShort tid csh cid <- MaybeT . getKeyBy $ CourseTermShort tid csh
user <- MaybeT $ get uid user <- MaybeT $ get uid
-- update Favourites -- update Favourites
lift $ upsertBy void . lift $ upsertBy
(UniqueCourseFavourite uid cid) (UniqueCourseFavourite uid cid)
(CourseFavourite uid now cid) (CourseFavourite uid now cid)
[CourseFavouriteTime =. now] [CourseFavouriteTime =. now]
@ -209,7 +354,7 @@ instance Yesod UniWorX where
favourites <- forM favourites' $ \(Entity _ c@Course{..}) favourites <- forM favourites' $ \(Entity _ c@Course{..})
-> let -> let
courseRoute = CourseR courseTerm courseShorthand CourseShowR courseRoute = CourseR courseTerm courseShorthand CShowR
in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
-- We break up the default layout into two components: -- 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. -- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR authRoute _ = Just $ AuthR LoginR
isAuthorized (AuthR _) _ = return Authorized isAuthorized route _isWrite = evalAccess route
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
-- This function creates static content files in the static folder -- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows -- and names them based on a hash of their content. This allows
@ -308,13 +439,14 @@ instance Yesod UniWorX where
makeLogger = return . appLogger makeLogger = return . appLogger
{- ALL DEPRECATED and will be deleted, once knownTags is completed
isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult
isAuthorizedDB route@(routeAttrs -> attrs) writeable isAuthorizedDB route@(routeAttrs -> attrs) writeable
| "adminAny" `member` attrs = adminAccess Nothing | "adminAny" `member` attrs = adminAccess Nothing
| "lecturerAny" `member` attrs = lecturerAccess Nothing | "lecturerAny" `member` attrs = lecturerAccess Nothing
isAuthorizedDB UsersR _ = adminAccess Nothing isAuthorizedDB UsersR _ = adminAccess Nothing
isAuthorizedDB (SubmissionDemoR cID) _ = return Authorized -- submissionAccess $ Right cID isAuthorizedDB (SubmissionDemoR cID) _ = return Authorized -- submissionAccess $ Right cID
isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID
@ -322,14 +454,14 @@ isAuthorizedDB (SubmissionDownloadArchiveR (ZIPArchiveName cID)) _ = submissionA
isAuthorizedDB TermEditR _ = adminAccess Nothing isAuthorizedDB TermEditR _ = adminAccess Nothing
isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing
isAuthorizedDB CourseNewR _ = lecturerAccess 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)) False = return Authorized --
isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) 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 (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 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 (SEditR 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 (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 (SubmissionR s m))) _ = return Authorized -- TODO -- submissionAccess $ Right cID
isAuthorizedDB (CourseR t c (SheetR (SheetCorrectorsR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR (SheetCorrectorsR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
isAuthorizedDB (CourseEditIDR cID) _ = do isAuthorizedDB (CourseEditIDR cID) _ = do
@ -396,6 +528,8 @@ isAuthorizedDB' route isWrite = (== Authorized) <$> isAuthorizedDB route isWrite
isAuthorized' :: Route UniWorX -> Bool -> Handler Bool isAuthorized' :: Route UniWorX -> Bool -> Handler Bool
isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite
-}
-- Define breadcrumbs. -- Define breadcrumbs.
instance YesodBreadcrumbs UniWorX where instance YesodBreadcrumbs UniWorX where
@ -404,18 +538,18 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR) breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR)
breadcrumb CourseListR = return ("Kurs", Just HomeR) breadcrumb CourseListR = return ("Kurs", Just HomeR)
breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) breadcrumb (TermCourseListR term) = return (toPathPiece term, Just TermShowR)
breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term) breadcrumb (CourseR term course CShowR) = return (course, Just $ TermCourseListR term)
breadcrumb CourseNewR = return ("Neu", Just CourseListR) 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 SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR)
breadcrumb (CourseR tid csh (SheetR SheetNewR )) = return ("Neu", Just $ CourseR tid csh $ SheetR SheetListR) breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR)
breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR) breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR)
breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR)
breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
breadcrumb (CourseR tid csh (SheetR (SheetCorrectorsR shn))) = return ("Korrektoren", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) -- breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR)
breadcrumb (CourseR tid csh (SheetR (SubmissionR shn _))) = return ("Abgabe", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
@ -426,41 +560,41 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb _ = return ("home", Nothing) breadcrumb _ = return ("home", Nothing)
pageActions :: Route UniWorX -> [MenuTypes] pageActions :: Route UniWorX -> [MenuTypes]
pageActions (CourseR tid csh CourseShowR) = pageActions (CourseR tid csh CShowR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Übungsblätter" { menuItemLabel = "Übungsblätter"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh SheetListR , menuItemRoute = CourseR tid csh SheetListR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Kurs Editieren" { menuItemLabel = "Kurs Editieren"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh CourseEditR , menuItemRoute = CourseR tid csh CEditR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSheetR tid csh SheetListR) = pageActions (CourseR tid csh SheetListR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Neues Übungsblatt" { menuItemLabel = "Neues Übungsblatt"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh SheetNewR , menuItemRoute = CourseR tid csh SheetNewR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSheetR tid csh (SheetShowR shn)) = pageActions (CSheetR tid csh shn SShowR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Abgabe" { menuItemLabel = "Abgabe"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh (SubmissionR shn newSubmission) , menuItemRoute = CSheetR tid csh shn (SubmissionR newSubmission)
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Korrektoren"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh (SheetCorrectorsR shn)
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
-- , PageActionPrime $ MenuItem
-- { menuItemLabel = "Korrektoren"
-- , menuItemIcon = Nothing
-- , menuItemRoute = CSheetR tid csh shn SCorrR
-- , menuItemAccessCallback' = return True
-- }
] ]
pageActions TermShowR = pageActions TermShowR =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
@ -470,7 +604,7 @@ pageActions TermShowR =
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CourseListTermR _) = pageActions (TermCourseListR _) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Neuer Kurs" { menuItemLabel = "Neuer Kurs"
, menuItemIcon = Just "book" , menuItemIcon = Just "book"

36
src/Handler/Course.hs
View File

@ -26,8 +26,8 @@ import qualified Data.UUID.Cryptographic as UUID
getCourseListR :: Handler TypedContent getCourseListR :: Handler TypedContent
getCourseListR = redirect TermShowR getCourseListR = redirect TermShowR
getCourseListTermR :: TermId -> Handler Html getTermCourseListR :: TermId -> Handler Html
getCourseListTermR tidini = do getTermCourseListR tidini = do
(term,courses) <- runDB $ (,) (term,courses) <- runDB $ (,)
<$> get tidini <$> get tidini
<*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand] <*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand]
@ -40,7 +40,7 @@ getCourseListTermR tidini = do
let c = entityVal ckv let c = entityVal ckv
shd = courseShorthand c shd = courseShorthand c
tid = courseTerm 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 "Institut" $ [shamlet| #{course} |]
, headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal
, headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal , headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal
@ -54,11 +54,11 @@ getCourseListTermR tidini = do
shd = courseShorthand c shd = courseShorthand c
tid = courseTerm c tid = courseTerm c
in do in do
adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CEditR) False
-- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else "" -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CEditR tid shd) else ""
[whamlet| [whamlet|
$if adminLink == Authorized $if adminLink == Authorized
<a href=@{CourseR tid shd CourseEditR}> <a href=@{CourseR tid shd CEditR}>
editieren editieren
|] |]
) )
@ -68,8 +68,8 @@ getCourseListTermR tidini = do
setTitle "Semesterkurse" setTitle "Semesterkurse"
$(widgetFile "courses") $(widgetFile "courses")
getCourseShowR :: TermId -> Text -> Handler Html getCShowR :: TermId -> Text -> Handler Html
getCourseShowR tid csh = do getCShowR tid csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
@ -95,8 +95,8 @@ registerButton registered = renderAForm FormStandard $
msg = if registered then "Abmelden" else "Anmelden" msg = if registered then "Abmelden" else "Anmelden"
regMsg = msg :: BootstrapSubmit Text regMsg = msg :: BootstrapSubmit Text
postCourseShowR :: TermId -> Text -> Handler Html postCShowR :: TermId -> Text -> Handler Html
postCourseShowR tid csh = do postCShowR tid csh = do
aid <- requireAuthId aid <- requireAuthId
(cid, registered) <- runDB $ do (cid, registered) <- runDB $ do
(Entity cid _) <- getBy404 $ CourseTermShort tid csh (Entity cid _) <- getBy404 $ CourseTermShort tid csh
@ -114,7 +114,7 @@ postCourseShowR tid csh = do
when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!" when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!"
(_other) -> return () -- TODO check this! (_other) -> return () -- TODO check this!
-- redirect or not?! I guess not, since we want GET now -- redirect or not?! I guess not, since we want GET now
getCourseShowR tid csh getCShowR tid csh
getCourseNewR :: Handler Html getCourseNewR :: Handler Html
getCourseNewR = do getCourseNewR = do
@ -124,13 +124,13 @@ getCourseNewR = do
postCourseNewR :: Handler Html postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler Nothing postCourseNewR = courseEditHandler Nothing
getCourseEditR :: TermId -> Text -> Handler Html getCEditR :: TermId -> Text -> Handler Html
getCourseEditR tid csh = do getCEditR tid csh = do
course <- runDB $ getBy $ CourseTermShort tid csh course <- runDB $ getBy $ CourseTermShort tid csh
courseEditHandler course courseEditHandler course
postCourseEditR :: TermId -> Text -> Handler Html postCEditR :: TermId -> Text -> Handler Html
postCourseEditR = getCourseEditR postCEditR = getCEditR
getCourseEditIDR :: CryptoUUIDCourse -> Handler Html getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
getCourseEditIDR cID = do getCourseEditIDR cID = do
@ -147,7 +147,7 @@ courseDeleteHandler = undefined
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
let cti = toPathPiece $ cfTerm res let cti = toPathPiece $ cfTerm res
addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|] addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
redirect $ CourseListTermR $ cfTerm res redirect $ TermCourseListR $ cfTerm res
-} -}
courseEditHandler :: Maybe (Entity Course) -> Handler Html courseEditHandler :: Maybe (Entity Course) -> Handler Html
@ -183,7 +183,7 @@ courseEditHandler course = do
insert_ $ CourseEdit aid now cid insert_ $ CourseEdit aid now cid
insert_ $ Lecturer aid cid insert_ $ Lecturer aid cid
addMessageI "info" $ MsgCourseNewOk tident csh addMessageI "info" $ MsgCourseNewOk tident csh
redirect $ CourseListTermR tid redirect $ TermCourseListR tid
Nothing -> Nothing ->
addMessageI "danger" $ MsgCourseNewDupShort tident csh addMessageI "danger" $ MsgCourseNewDupShort tident csh
@ -238,7 +238,7 @@ courseEditHandler course = do
-- if (isNothing updOkay) -- if (isNothing updOkay)
-- then do -- then do
addMessageI "info" $ MsgCourseEditOk tident csh addMessageI "info" $ MsgCourseEditOk tident csh
-- redirect $ CourseListTermR tid -- redirect $ TermCourseListR tid
-- else addMessageI "danger" $ MsgCourseEditDupShort tident csh -- else addMessageI "danger" $ MsgCourseEditDupShort tident csh
(FormFailure _) -> addMessageI "warning" MsgInvalidInput (FormFailure _) -> addMessageI "warning" MsgInvalidInput

2
src/Handler/CryptoIDDispatch.hs
View File

@ -38,7 +38,7 @@ instance CryptoRoute UUID SubmissionId where
Sheet{..} <- get404 shid Sheet{..} <- get404 shid
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
return (courseTerm, courseShorthand, sheetName) 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 class Dispatch ciphertext (x :: [*]) where

61
src/Handler/Sheet.hs
View File

@ -133,8 +133,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
-- TODO: continue validation here!!! -- TODO: continue validation here!!!
] ] ] ]
-- List Sheets -- List Sheets
getSheetListCID :: CourseId -> Handler Html getSheetListCID :: CourseId -> Handler Html
getSheetListCID cid = getSheetList =<< getSheetListCID cid = getSheetList =<<
@ -159,7 +157,7 @@ getSheetList courseEnt = do
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
return (sid, sheet, (submissions, rated)) return (sid, sheet, (submissions, rated))
let colBase = mconcat 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 ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3 , headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
, headed "Bewertung" $ toWgt . show . sheetType . 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 let colAdmin = mconcat -- only show edit button for allowed course assistants
[ headed "Korrigiert" $ toWgt . snd . trd3 [ headed "Korrigiert" $ toWgt . snd . trd3
, headed "Eingereicht" $ toWgt . fst . trd3 , headed "Eingereicht" $ toWgt . fst . trd3
, headed "" $ \s -> linkButton "Edit" BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s , headed "" $ \s -> linkButton "Edit" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SEditR
, headed "" $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR $ sheetName $ snd3 s , headed "" $ \s -> linkButton "Delete" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SDelR
] ]
showAdmin <- case sheets of showAdmin <- case sheets of
((_,firstSheet,_):_) -> do ((_,firstSheet,_):_) -> do
setUltDestCurrent setUltDestCurrent
(Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False (Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False
_otherwise -> return False _otherwise -> return False
let colSheets = if showAdmin let colSheets = if showAdmin
then colBase `mappend` colAdmin then colBase `mappend` colAdmin
@ -186,8 +184,8 @@ getSheetList courseEnt = do
-- Show single sheet -- Show single sheet
getSheetShowR :: TermId -> Text -> Text -> Handler Html getSShowR :: TermId -> Text -> Text -> Handler Html
getSheetShowR tid csh shn = do getSShowR tid csh shn = do
entSheet <- runDB $ fetchSheet tid csh shn entSheet <- runDB $ fetchSheet tid csh shn
let sheet = entityVal entSheet let sheet = entityVal entSheet
sid = entityKey entSheet sid = entityKey entSheet
@ -215,7 +213,7 @@ getSheetShowR tid csh shn = do
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
let colonnadeFiles = mconcat let colonnadeFiles = mconcat
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype [ 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) (\(E.Value fName,_,_) -> str2widget fName)
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT modified , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT modified
] ]
@ -240,8 +238,8 @@ getSheetShowR tid csh shn = do
$(widgetFile "sheetShow") $(widgetFile "sheetShow")
[whamlet| Under Construction !!! |] -- TODO [whamlet| Under Construction !!! |] -- TODO
getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
getSheetFileR tid csh shn typ title = do getSFileR tid csh shn typ title = do
content <- runDB $ E.select $ E.from $ content <- runDB $ E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other -- Restrict to consistent rows that correspond to each other
@ -277,8 +275,8 @@ postSheetNewR :: TermId -> Text -> Handler Html
postSheetNewR = getSheetNewR postSheetNewR = getSheetNewR
getSheetEditR :: TermId -> Text -> Text -> Handler Html getSEditR :: TermId -> Text -> Text -> Handler Html
getSheetEditR tid csh shn = do getSEditR tid csh shn = do
(sheetEnt, sheetFileIds) <- runDB $ do (sheetEnt, sheetFileIds) <- runDB $ do
ent <- fetchSheet tid csh shn ent <- fetchSheet tid csh shn
fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do 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 (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
handleSheetEdit tid csh (Just sid) template action handleSheetEdit tid csh (Just sid) template action
postSheetEditR :: TermId -> Text -> Text -> Handler Html postSEditR :: TermId -> Text -> Text -> Handler Html
postSheetEditR = getSheetEditR postSEditR = getSEditR
handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit tid csh msId template dbAction = do handleSheetEdit tid csh msId template dbAction = do
@ -348,44 +346,44 @@ handleSheetEdit tid csh msId template dbAction = do
insert_ $ SheetEdit aid actTime sid insert_ $ SheetEdit aid actTime sid
addMessageI "info" $ MsgSheetEditOk tident csh sfName addMessageI "info" $ MsgSheetEditOk tident csh sfName
return True 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 (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
_ -> return () _ -> return ()
let pageTitle = maybe (MsgSheetTitleNew tident csh) let pageTitle = maybe (MsgSheetTitleNew tident csh)
(MsgSheetTitle tident csh) mbshn (MsgSheetTitle tident csh) mbshn
let formTitle = pageTitle let formTitle = pageTitle
let formText = Nothing :: Maybe UniWorXMessage let formText = Nothing :: Maybe UniWorXMessage
actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute
defaultLayout $ do defaultLayout $ do
setTitleI pageTitle setTitleI pageTitle
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")
getSheetDelR :: TermId -> Text -> Text -> Handler Html getSDelR :: TermId -> Text -> Text -> Handler Html
getSheetDelR tid csh shn = do getSDelR tid csh shn = do
let tident = unTermKey tid let tident = unTermKey tid
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
case result of case result of
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR
(FormSuccess BtnDelete) -> do (FormSuccess BtnDelete) -> do
runDB $ fetchSheetId tid csh shn >>= deleteCascade runDB $ fetchSheetId tid csh shn >>= deleteCascade
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
addMessageI "info" $ MsgSheetDelOk tident csh shn addMessageI "info" $ MsgSheetDelOk tident csh shn
redirect $ CSheetR tid csh SheetListR redirect $ CourseR tid csh SheetListR
_other -> do _other -> do
submissionno <- runDB $ do submissionno <- runDB $ do
sid <- fetchSheetId tid csh shn sid <- fetchSheetId tid csh shn
count [SubmissionSheet ==. sid] count [SubmissionSheet ==. sid]
let formTitle = MsgSheetDelTitle tident csh shn let formTitle = MsgSheetDelTitle tident csh shn
let formText = Just $ MsgSheetDelText submissionno let formText = Just $ MsgSheetDelText submissionno
let actionUrl = CSheetR tid csh $ SheetDelR shn let actionUrl = CSheetR tid csh shn SDelR
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetTitle tident csh shn setTitleI $ MsgSheetTitle tident csh shn
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")
postSheetDelR :: TermId -> Text -> Text -> Handler Html postSDelR :: TermId -> Text -> Text -> Handler Html
postSheetDelR = getSheetDelR postSDelR = getSDelR
@ -556,12 +554,12 @@ correctorForm shid = do
-- Eingabebox für Korrektor hinzufügen -- Eingabebox für Korrektor hinzufügen
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
getSheetCorrectorsR, postSheetCorrectorsR :: TermId getSCorrR, postSCorrR :: TermId
-> Text -- ^ Course shorthand -> Text -- ^ Course shorthand
-> Text -- ^ Sheet name -> Text -- ^ Sheet name
-> Handler Html -> Handler Html
postSheetCorrectorsR = getSheetCorrectorsR postSCorrR = getSCorrR
getSheetCorrectorsR tid@(unTermKey -> tident) csh shn = do getSCorrR tid@(unTermKey -> tident) csh shn = do
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
@ -577,7 +575,8 @@ getSheetCorrectorsR tid@(unTermKey -> tident) csh shn = do
let let
formTitle = MsgSheetCorrectorsTitle tident csh shn formTitle = MsgSheetCorrectorsTitle tident csh shn
formText = Nothing :: Maybe (SomeMessage UniWorX) 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 defaultLayout $ do
setTitleI $ MsgSheetCorrectorsTitle tident csh shn setTitleI $ MsgSheetCorrectorsTitle tident csh shn
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")

65
src/Handler/Submission.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
@ -11,6 +12,7 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeOperators #-}
module Handler.Submission where module Handler.Submission where
@ -51,6 +53,9 @@ import Yesod.Colonnade
import qualified Text.Blaze.Html5.Attributes as HA 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 :: Maybe SubmissionId -> Bool -> SheetGroup -> [Text] -> Form (Maybe (Source Handler File), [Text])
makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
@ -75,7 +80,7 @@ getSubmissionR = postSubmissionR
postSubmissionR tid csh shn (SubmissionMode mcid) = do postSubmissionR tid csh shn (SubmissionMode mcid) = do
uid <- requireAuthId uid <- requireAuthId
msmid <- traverse decrypt mcid 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 sheet@(Entity shid Sheet{..}) <- fetchSheet tid csh shn
case msmid of case msmid of
Nothing -> do Nothing -> do
@ -103,11 +108,11 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail return $ user E.^. UserEmail
return (sheet,buddies,[],[]) return (sheet,buddies,[])
(E.Value smid:_) -> do (E.Value smid:_) -> do
cID <- encrypt smid cID <- encrypt smid
addMessageI "info" $ MsgSubmissionAlreadyExists 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 (Just smid) -> do
shid' <- submissionSheet <$> get404 smid shid' <- submissionSheet <$> get404 smid
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet] 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.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail return $ user E.^. UserEmail
oldfiles <- sourceToList $ submissionFileSource smid
-- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime] -- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime]
lastEditValues <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do lastEditValues <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser) E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser)
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
E.limit 3 -- TODO for Debug Purposes E.limit numberOfSubmissionEditDates
return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime) return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime)
let lastEdits = map (bimap E.unValue E.unValue) lastEditValues let lastEdits = map (bimap E.unValue E.unValue) lastEditValues
return (sheet,buddies,oldfiles,lastEdits) return (sheet,buddies,lastEdits)
let unpackZips = True -- undefined -- TODO let unpackZips = True -- undefined -- TODO
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies
mCID <- runDB $ do mCID <- runDB $ do
@ -174,10 +178,10 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
smid <- do smid <- do
smid <- case (mFiles, msmid) of smid <- case (mFiles, msmid) of
(Nothing, Just smid) (Nothing, Just smid) -- no new files, existing submission partners updated
-> return smid -> return smid
(Just files, Nothing) (Just files, _) -- new files
-> runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid Nothing -> runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid)
_ -> error "Impossible, because of definition of `makeSubmissionForm`" _ -> error "Impossible, because of definition of `makeSubmissionForm`"
-- Determine members of pre-registered group -- Determine members of pre-registered group
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do 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 _other -> return Nothing
case mCID of 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 () Nothing -> return ()
mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid
@ -208,6 +212,28 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
let formTitle = pageTitle let formTitle = pageTitle
let formText = Nothing :: Maybe UniWorXMessage let formText = Nothing :: Maybe UniWorXMessage
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute 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 defaultLayout $ do
setTitleI pageTitle setTitleI pageTitle
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")
@ -218,24 +244,25 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
<a href=@{SubmissionDownloadArchiveR arCid}>Archiv <a href=@{SubmissionDownloadArchiveR arCid}>Archiv
$forall (name,time) <- lastEdits $forall (name,time) <- lastEdits
<div>last edited by #{name} at #{formatTimeGerDTlong time} <div>last edited by #{name} at #{formatTimeGerDTlong time}
$maybe cid <- mcid $maybe fileTable <- mFileTable
<h3>Enthaltene Dateien: <h3>Enthaltene Dateien:
$forall (Entity _ File{..}) <- oldfiles ^{fileTable}
<a href=@{SubmissionDownloadSingleR cid fileTitle}>
#{fileTitle}
|] |]
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) 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.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion 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.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
return f return f
getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
@ -300,7 +327,7 @@ submissionTable = do
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
let let
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CourseShowR anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID

2
src/Handler/Term.hs
View File

@ -60,7 +60,7 @@ getTermShowR = do
textCell $ bool "" tickmark termActive textCell $ bool "" tickmark termActive
, sortable Nothing "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) -> , sortable Nothing "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
cell [whamlet| cell [whamlet|
<a href=@{CourseListTermR tid}> <a href=@{TermCourseListR tid}>
#{show numCourses} Kurse #{show numCourses} Kurse
|] |]
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->

75
src/Utils.hs
View File

@ -1,5 +1,7 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
@ -14,10 +16,29 @@ import Utils.Common as Utils
import Text.Blaze (Markup, ToMarkup) import Text.Blaze (Markup, ToMarkup)
import Data.Map (Map) -- import Data.Map (Map)
import qualified Data.Map as Map -- import qualified Data.Map as Map
import qualified Data.List as List -- 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 :: IsString a => a
tickmark = fromString "✔" tickmark = fromString "✔"
@ -42,12 +63,6 @@ withFragment :: ( Monad m
) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) ) => 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) 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 -- -- Tuples --
@ -56,3 +71,45 @@ whenIsJust Nothing _ = return ()
---------- ----------
-- Maps -- -- 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

6
src/Utils/Common.hs
View File

@ -5,7 +5,10 @@ module Utils.Common where
-- Common Utility Functions -- Common Utility Functions
import Language.Haskell.TH import Language.Haskell.TH
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Except
------------ ------------
-- Tuples -- -- Tuples --
@ -50,3 +53,4 @@ altFun perm = lamE pat rhs
ps = [ xs !! (j-1) | j <- perm ] ps = [ xs !! (j-1) | j <- perm ]
fn = mkName "fn" fn = mkName "fn"

2
templates/course.hamlet
View File

@ -34,7 +34,7 @@
<div .course__registration> <div .course__registration>
<a href="#">Anmelden <a href="#">Anmelden
$# <form method=post action=@{CourseR tid csh CourseShowR} enctype=#{regEnctype}> $# <form method=post action=@{CourseR tid csh CShow} enctype=#{regEnctype}>
$# ^{regWidget} $# ^{regWidget}
<div .container> <div .container>