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

New Rights Managament compiles and seems to work (apart from TODOs); Problem with ASIDENAV

Browse Source
This commit is contained in:
SJost 2018-05-28 18:27:30 +02:00
parent ad998b53d8
commit c45fea6df3
13 changed files with 253 additions and 184 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

44
routes
View File

@ -1,25 +1,25 @@
{- --
Accesss granted via tags; default is no accesss. -- Accesss granted via tags; default is no accesss.
Permission must be explicitly granted. -- Permission must be explicitly granted.
--
Access permission is the disjunction of permit tags -- Access permission is the disjunction of permit tags
Tags are split on "AND" to encode conjunction. -- Tags are split on "AND" to encode conjunction.
--
Note that nested routes automatically inherit all tags from the parent. -- Note that nested routes automatically inherit all tags from the parent.
--
Admins always have access to entities within their assigned schools. -- Admins always have access to entities within their assigned schools.
--
Access Tags: -- Access Tags:
!free -- free for all -- !free -- free for all
!lecturer -- lecturer for this course (or the school, if route is not connected to a course) -- !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 ) -- !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) -- !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) -- !materials -- only if course allows all materials to be free (no meaning outside of courses)
!time -- access depends on time somehow -- !time -- access depends on time somehow
--
!deprecated -- like free, but logs and gives a warning -- !deprecated -- like free, but logs and gives a warning
-} --
/static StaticR Static appStatic !free /static StaticR Static appStatic !free
/auth AuthR Auth getAuth !free /auth AuthR Auth getAuth !free

192
src/Foundation.hs
View File

@ -32,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
@ -47,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)
@ -54,6 +62,7 @@ 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
@ -92,70 +101,95 @@ 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 shn ptn = CourseR tid csh (SheetR shn ptn) pattern CSheetR tid csh shn ptn
= CourseR tid csh (SheetR shn ptn)
-- Messages
mkMessage "UniWorX" "messages" "de"
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage UniWorX FormMessage where
renderMessage _ _ = defaultFormMessage
instance RenderMessage UniWorX TermIdentifier where
renderMessage foundation ls TermIdentifier{..} = case season of
Summer -> renderMessage' $ MsgSummerTerm year
Winter -> renderMessage' $ MsgWinterTerm year
where renderMessage' = renderMessage foundation ls
-- Access Control -- Access Control
data AccessPredicate data AccessPredicate
= APPure (Route UniWorX -> Reader (forall msg. RenderMessage UniWorX msg => msg -> Text) AuthResult) = APPure (Route UniWorX -> Reader MsgRenderer AuthResult)
| APHandler (Route UniWorX -> Handler UniWorX AuthResult) | APHandler (Route UniWorX -> Handler AuthResult)
| APDB (Route UniWorX -> YesodDB UniWorX AuthResult) | APDB (Route UniWorX -> DB AuthResult)
orAR, andAR :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> AuthResult -> AuthResult -> AuthResult orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
orAR _ Authorized _ = Authorized orAR _ Authorized _ = Authorized
orAR _ _ Authorized = Authorized orAR _ _ Authorized = Authorized
orAR _ AuthenticationRequired _ = AuthenticationRequired orAR _ AuthenticationRequired _ = AuthenticationRequired
orAR _ _ AuthenticationRequired = AuthenticationRequired orAR _ _ AuthenticationRequired = AuthenticationRequired
orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . mr $ MsgUnauthorizedOr x y orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
andAR _ Authorzied Authorized = Authorized andAR _ Authorized Authorized = Authorized
andAR _ Authorzied other = other andAR _ Authorized other = other
andAR _ other Authorized = other andAR _ other Authorized = other
andAR _ AuthenticationRequired other = other andAR _ AuthenticationRequired other = other
andAR _ other AuthenticationRequired = other andAR _ other AuthenticationRequired = other
andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . mr $ MsgUnauthorizedAnd x y andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate
orAP = liftAR orAR orAP = liftAR orAR (== Authorized)
andAP = liftAR andAR andAP = liftAR andAR (const False)
liftAR :: ((forall msg. RenderMessage UniWorX msg => msg -> Text) -> AuthResult -> AuthResult -> AuthResult) liftAR :: (MsgRenderer -> AuthResult -> AuthResult -> AuthResult)
-> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument
-> AccessPredicate -> AccessPredicate -> AccessPredicate -> AccessPredicate -> AccessPredicate -> AccessPredicate
-- Ensure to first evaluate Pure conditions, then Handler before DB -- Ensure to first evaluate Pure conditions, then Handler before DB
liftAR op (APPure f) (APPure g) = APPure $ \r -> op <$> ask <*> f r <*> g r liftAR op sc (APPure f) (APPure g) = APPure $ \r -> shortCircuitM sc (f r) (g r) . op =<< ask
liftAR op (APHandler f) (APHandler g) = APHandler $ \r -> op <$> getMessageRender <*> f r <*> g r liftAR op sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer
liftAR op (APDB f) (APDB g) = APDB $ \r -> op <$> getMessageRender <*> f r <*> g r liftAR op sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer
liftAR op (APPure f) apg = liftAR op (APHandler $ \r -> runReader (f r) <$> getMessageRender) apg liftAR op sc (APPure f) apg = liftAR op sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg
liftAR op apf apg@(APPure _) = liftAR op apg apf liftAR op sc apf apg@(APPure _) = liftAR op sc apg apf
liftAR op (APHandler f) apdb = liftAR op (APDB $ lift . f) apdb liftAR op sc (APHandler f) apdb = liftAR op sc (APDB $ lift . f) apdb
liftAR op apdb apg@(APHandler _) = liftAR op apg apdb liftAR op sc apdb apg@(APHandler _) = liftAR op sc apg apdb
trueAP,falseAP :: AccessPredicate trueAP,falseAP :: AccessPredicate
trueAP = APPure . const $ return Authorized trueAP = APPure . const $ return Authorized
falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) <$> ask falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask
-- TODO: I believe falseAP := adminAP -- TODO: I believe falseAP := adminAP
adminAP :: AccessPredicate adminAP :: AccessPredicate
adminAP = APDB $ \case adminAP = APDB $ \case
CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedSchoolAdmin) $ do CourseR tid csh _ -> exceptT return return $ do
authId <- lift requireAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
-- SQL JOIN: [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
-- get schoolId for cid E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
-- check adminrights for schoolId E.&&. course E.^. CourseTerm E.==. E.val tid
undefined -- CONTINUE HERE E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (unauthorizedI MsgUnauthorizedSchoolAdmin) (c > 0)
return Authorized
_other -> do _other -> exceptT return return $ do
authId <- lift requireAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
adrights <- selectFirst [UserAdminUser ==. authId] adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
case adright of case adrights of
(Just _) -> return Authorized (Just _) -> return Authorized
Nothing -> unauthorizedI $ MsgUnauthorized Nothing -> lift $ unauthorizedI $ MsgUnauthorized
knownTags :: Map (CI Text) AccessPredicate knownTags :: Map (CI Text) AccessPredicate
knownTags = knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
[("free", trueAP) [("free", trueAP)
,("deprecated", APHandler $ \r -> do ,("deprecated", APHandler $ \r -> do
$logWarnS "AccessControl" ("deprecated route: " <> tshow r) $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
@ -163,15 +197,14 @@ knownTags =
return Authorized return Authorized
) )
,("lecturer", APDB $ \case ,("lecturer", APDB $ \case
CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do
authId <- lift requireAuthId authId <- lift $ lift requireAuthId -- TODO SJ Continue
-- TODO: why not a getBy404 if the course does not exist?hg getBy404 -- getBy404 would disclose that the course exists
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
void . MaybeT . getBy $ UniqueLecturer authId cid void . MaybeT . getBy $ UniqueLecturer authId cid
return Authorized return Authorized
_ -> do _ -> do
authId <- requireAuthId authId <- lift requireAuthId -- TODO SJ Continue
mul <- selectFirst [UserLecturerUser ==. authId] [] mul <- selectFirst [UserLecturerUser ==. authId] []
case mul of case mul of
Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer
@ -182,7 +215,7 @@ knownTags =
,("time", undefined) ,("time", undefined)
,("registered", undefined) ,("registered", undefined)
,("materials", APDB $ \case ,("materials", APDB $ \case
CourseR tid csh -> CourseR tid csh _ -> do
Entity cid _ <- getBy404 $ CourseTermShort tid csh Entity cid _ <- getBy404 $ CourseTermShort tid csh
undefined -- CONTINUE HERE undefined -- CONTINUE HERE
) )
@ -190,27 +223,27 @@ knownTags =
tag2ap :: Text -> AccessPredicate tag2ap :: Text -> AccessPredicate
tag2ap t = case Map.lookup t knownTags of tag2ap t = case Map.lookup (CI.mk t) knownTags of
(Just ap) -> ap (Just ap) -> ap
Nothing -> APHandler $ \r -> do --TODO: can this be pure like falseAP? Nothing -> APHandler $ \r -> do --TODO: can this be pure like falseAP?
$logWarnS "AccessControl" ("route tag unknown for access control") $logWarnS "AccessControl" ("route tag unknown for access control")
unauthorizedI $ MsgUnauthorized unauthorizedI $ MsgUnauthorized
route2ap :: Route UniWorX -> AccessPredicate route2ap :: Route UniWorX -> AccessPredicate
route2ap r = Set.foldr orAP adminAP attrsAND route2ap r = foldr orAP adminAP attrsAND --TODO: adminAP causes all to be in DB!!!
where where
attrsAND = Set.map splitAnd $ routeAttrs r attrsAND = map splitAND $ Set.toList $ routeAttrs r
splitAND = foldr1 andAP . map tag2access . splitOn "AND" splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
evalAccessDB :: Route -> DB Authorized -- all requests, regardless of POST/GET, use isWriteRequest otherwise evalAccessDB :: Route UniWorX -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
evalAccessDB r = case getAccess r of evalAccessDB r = case route2ap r of
(APPure p) -> lift $ runReader (p r) <$> getMessageRender (APPure p) -> lift $ runReader (p r) <$> getMsgRenderer
(APHandler p) -> lift $ p r (APHandler p) -> lift $ p r
(APDB p) -> p r (APDB p) -> p r
evalAccess :: Route -> Handler UniWorX Authorized evalAccess :: Route UniWorX -> Handler AuthResult
evalAccess r = case getAccess r of evalAccess r = case route2ap r of
(APPure p) -> runReader (p r) <$> getMessageRender (APPure p) -> runReader (p r) <$> getMsgRenderer
(APHandler p) -> p r (APHandler p) -> p r
(APDB p) -> runDB $ p r (APDB p) -> runDB $ p r
@ -239,23 +272,6 @@ 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:
type DB a = YesodDB UniWorX a
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
mkMessage "UniWorX" "messages" "de"
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage UniWorX FormMessage where
renderMessage _ _ = defaultFormMessage
instance RenderMessage UniWorX TermIdentifier where
renderMessage foundation ls TermIdentifier{..} = case season of
Summer -> renderMessage' $ MsgSummerTerm year
Winter -> renderMessage' $ MsgWinterTerm year
where renderMessage' = renderMessage foundation ls
-- Please see the documentation for the Yesod typeclass. There are a number -- 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.
@ -335,7 +351,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:
@ -435,14 +451,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 (CourseEditIDR cID) _ = do isAuthorizedDB (CourseEditIDR cID) _ = do
courseId <- decrypt cID courseId <- decrypt cID
@ -518,17 +534,17 @@ 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 (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)
@ -539,33 +555,33 @@ 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 , menuItemAccessCallback' = return True
} }
] ]
@ -577,7 +593,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

44
src/Handler/Sheet.hs
View File

@ -154,7 +154,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
@ -162,13 +162,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
@ -181,8 +181,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
@ -210,7 +210,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
] ]
@ -235,8 +235,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
@ -272,8 +272,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
@ -307,8 +307,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
@ -344,44 +344,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

6
src/Handler/Submission.hs
View File

@ -112,7 +112,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
(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]
@ -203,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
@ -327,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

10
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.Maybe
import Control.Monad.Trans.Except
------------ ------------
-- Tuples -- -- Tuples --
@ -51,10 +54,3 @@ altFun perm = lamE pat rhs
fn = mkName "fn" fn = mkName "fn"
-----------
-- Maybe --
-----------
maybeT :: Monad m => m a -> MaybeT m a -> m a
maybeT x m = runMaybeT m >>= maybe x return

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>

16
templates/widgets/asidenav.hamlet
View File

@ -5,12 +5,12 @@ $newline never
<ul .asidenav__list> <ul .asidenav__list>
$forall menuType <- menuTypes $forall menuType <- menuTypes
$case menuType $case menuType
$of NavbarAside (MenuItem label mIcon route _) $of NavbarAside mi
<li .asidenav__list-item :Just route == mcurrentRoute:.asidenav__list-item--active> <li .asidenav__list-item :Just (menuItemRoute mi) == mcurrentRoute:.asidenav__list-item--active>
<a .asidenav__link-wrapper href=@{route}> <a .asidenav__link-wrapper href=@{menuItemRoute mi}>
$if isJust mIcon $if isJust (menuItemIcon mi)
<div .glyphicon.glyphicon--#{fromMaybe "" mIcon}> <div .glyphicon.glyphicon--#{fromMaybe "" (menuItemIcon mi)}>
<div .asidenav__link-label>#{label} <div .asidenav__link-label>#{menuItemLabel mi}
$of _ $of _
<div .asidenav__box> <div .asidenav__box>
@ -25,9 +25,9 @@ $newline never
<ul .asidenav__nested-list> <ul .asidenav__nested-list>
$forall action <- pageActions $forall action <- pageActions
$case action $case action
$of PageActionPrime (MenuItem{..}) $of PageActionPrime mi
<li .asidenav__list-item> <li .asidenav__list-item>
<a .asidenav__link-wrapper href=@{menuItemRoute}>#{menuItemLabel} <a .asidenav__link-wrapper href=@{menuItemRoute mi}>#{menuItemLabel mi}
$of _ $of _
<div .asidenav__toggler> <div .asidenav__toggler>