New Rights Managament compiles and seems to work (apart from TODOs); Problem with ASIDENAV
This commit is contained in:
SJost
parent
ad998b53d8
commit
c45fea6df3
@ -1,7 +1,7 @@
|
||||
** Sicherheitsabfragen?
|
||||
- Verschlüsselung des Zugriffs?
|
||||
|
||||
- SheetDelR tid csh sn : GET zeigt Sicherheitsabfrage
|
||||
- SDelR tid csh sn : GET zeigt Sicherheitsabfrage
|
||||
POST löscht.
|
||||
Ist das so sinnvoll?
|
||||
Sicherheitsabfrage als PopUpMessage?
|
||||
@ -9,7 +9,7 @@
|
||||
- Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq?
|
||||
(Sheet.hs -> fetchSheet)
|
||||
|
||||
- Handler.Sheet.postSheetDelR: deleteCascade für Files? Klappt das?
|
||||
- Handler.Sheet.postSDelR: deleteCascade für Files? Klappt das?
|
||||
Kann man abfragen, was bei deleteCascade alles gelöscht wird?
|
||||
|
||||
|
||||
@ -19,7 +19,7 @@
|
||||
Links -> MenuItems verwenden wie bisher
|
||||
Page Titles -> setTitleI
|
||||
Buttons? -> Kann leicht geändert werden!
|
||||
Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getCourseListTermR, Zeile 66 "pageActions" für menuItemLabel?
|
||||
Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getTermCourseListR, Zeile 66 "pageActions" für menuItemLabel?
|
||||
|
||||
** Page pageActions - Berechtigungen prüfen?
|
||||
=> Eigener Constructor statt NavbarLeft/Right?!
|
||||
|
||||
@ -109,7 +109,7 @@ TABLE "user";
|
||||
DROP TABLE "course" CASCADE;
|
||||
|
||||
-- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer)
|
||||
INSERT INTO "user_lecturer" (id,"user",school) VALUES (27,5,1);
|
||||
INSERT INTO "user_lecturer" (id,"user","school") VALUES (27,5,1);
|
||||
|
||||
-- Beenden:
|
||||
\q
|
||||
|
||||
44
routes
44
routes
@ -1,25 +1,25 @@
|
||||
{-
|
||||
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
|
||||
-}
|
||||
--
|
||||
-- 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
|
||||
--
|
||||
|
||||
/static StaticR Static appStatic !free
|
||||
/auth AuthR Auth getAuth !free
|
||||
|
||||
@ -32,6 +32,7 @@ import LDAP.Search (LDAPEntry(..))
|
||||
import Yesod.Default.Util (addStaticContentExternal)
|
||||
import Yesod.Core.Types (Logger)
|
||||
import qualified Yesod.Core.Unsafe as Unsafe
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text.Encoding as TE
|
||||
|
||||
@ -47,6 +48,13 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Data.List (foldr1)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
import Data.Conduit (($$))
|
||||
import Data.Conduit.List (sourceList)
|
||||
|
||||
@ -54,6 +62,7 @@ import qualified Database.Esqueleto as E
|
||||
|
||||
import Control.Monad.Except (MonadError(..), runExceptT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Trans.Reader (runReader)
|
||||
|
||||
import System.FilePath
|
||||
|
||||
@ -92,70 +101,95 @@ data UniWorX = UniWorX
|
||||
-- type Widget = WidgetT UniWorX IO ()
|
||||
mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
type DB a = YesodDB UniWorX a
|
||||
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
|
||||
type MsgRenderer = MsgRendererS UniWorX -- see Utils
|
||||
|
||||
-- Pattern Synonyms for convenience
|
||||
pattern CSheetR tid csh 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
|
||||
|
||||
data AccessPredicate
|
||||
= APPure (Route UniWorX -> Reader (forall msg. RenderMessage UniWorX msg => msg -> Text) AuthResult)
|
||||
| APHandler (Route UniWorX -> Handler UniWorX AuthResult)
|
||||
| APDB (Route UniWorX -> YesodDB UniWorX AuthResult)
|
||||
= APPure (Route UniWorX -> Reader MsgRenderer AuthResult)
|
||||
| APHandler (Route UniWorX -> Handler 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 _ AuthenticationRequired _ = AuthenticationRequired
|
||||
orAR _ _ AuthenticationRequired = AuthenticationRequired
|
||||
orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . mr $ MsgUnauthorizedOr x y
|
||||
andAR _ Authorzied Authorized = Authorized
|
||||
andAR _ Authorzied other = other
|
||||
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 . mr $ MsgUnauthorizedAnd x y
|
||||
andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
|
||||
|
||||
|
||||
|
||||
orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate
|
||||
orAP = liftAR orAR
|
||||
andAP = liftAR andAR
|
||||
orAP = liftAR orAR (== Authorized)
|
||||
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
|
||||
-- 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 (APHandler f) (APHandler g) = APHandler $ \r -> op <$> getMessageRender <*> f r <*> g r
|
||||
liftAR op (APDB f) (APDB g) = APDB $ \r -> op <$> getMessageRender <*> f r <*> g r
|
||||
liftAR op (APPure f) apg = liftAR op (APHandler $ \r -> runReader (f r) <$> getMessageRender) apg
|
||||
liftAR op apf apg@(APPure _) = liftAR op apg apf
|
||||
liftAR op (APHandler f) apdb = liftAR op (APDB $ lift . f) apdb
|
||||
liftAR op apdb apg@(APHandler _) = liftAR op apg apdb
|
||||
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) <$> ask
|
||||
falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask
|
||||
-- TODO: I believe falseAP := adminAP
|
||||
|
||||
adminAP :: AccessPredicate
|
||||
adminAP = APDB $ \case
|
||||
CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedSchoolAdmin) $ do
|
||||
authId <- lift requireAuthId
|
||||
-- SQL JOIN:
|
||||
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
-- get schoolId for cid
|
||||
-- check adminrights for schoolId
|
||||
undefined -- CONTINUE HERE
|
||||
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 -> do
|
||||
authId <- lift requireAuthId
|
||||
adrights <- selectFirst [UserAdminUser ==. authId]
|
||||
case adright of
|
||||
_other -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
|
||||
case adrights of
|
||||
(Just _) -> return Authorized
|
||||
Nothing -> unauthorizedI $ MsgUnauthorized
|
||||
Nothing -> lift $ unauthorizedI $ MsgUnauthorized
|
||||
|
||||
knownTags :: Map (CI Text) AccessPredicate
|
||||
knownTags =
|
||||
knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
|
||||
[("free", trueAP)
|
||||
,("deprecated", APHandler $ \r -> do
|
||||
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
|
||||
@ -163,15 +197,14 @@ knownTags =
|
||||
return Authorized
|
||||
)
|
||||
,("lecturer", APDB $ \case
|
||||
CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do
|
||||
authId <- lift requireAuthId
|
||||
-- TODO: why not a getBy404 if the course does not exist?hg getBy404
|
||||
|
||||
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do
|
||||
authId <- lift $ lift requireAuthId -- TODO SJ Continue
|
||||
-- getBy404 would disclose that the course exists
|
||||
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
void . MaybeT . getBy $ UniqueLecturer authId cid
|
||||
return Authorized
|
||||
_ -> do
|
||||
authId <- requireAuthId
|
||||
authId <- lift requireAuthId -- TODO SJ Continue
|
||||
mul <- selectFirst [UserLecturerUser ==. authId] []
|
||||
case mul of
|
||||
Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer
|
||||
@ -182,7 +215,7 @@ knownTags =
|
||||
,("time", undefined)
|
||||
,("registered", undefined)
|
||||
,("materials", APDB $ \case
|
||||
CourseR tid csh ->
|
||||
CourseR tid csh _ -> do
|
||||
Entity cid _ <- getBy404 $ CourseTermShort tid csh
|
||||
undefined -- CONTINUE HERE
|
||||
)
|
||||
@ -190,27 +223,27 @@ knownTags =
|
||||
|
||||
|
||||
tag2ap :: Text -> AccessPredicate
|
||||
tag2ap t = case Map.lookup t knownTags of
|
||||
tag2ap t = case Map.lookup (CI.mk t) knownTags of
|
||||
(Just ap) -> ap
|
||||
Nothing -> APHandler $ \r -> do --TODO: can this be pure like falseAP?
|
||||
$logWarnS "AccessControl" ("route tag unknown for access control")
|
||||
unauthorizedI $ MsgUnauthorized
|
||||
|
||||
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
|
||||
attrsAND = Set.map splitAnd $ routeAttrs r
|
||||
splitAND = foldr1 andAP . map tag2access . splitOn "AND"
|
||||
attrsAND = map splitAND $ Set.toList $ routeAttrs r
|
||||
splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
|
||||
|
||||
evalAccessDB :: Route -> DB Authorized -- all requests, regardless of POST/GET, use isWriteRequest otherwise
|
||||
evalAccessDB r = case getAccess r of
|
||||
(APPure p) -> lift $ runReader (p r) <$> getMessageRender
|
||||
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 -> Handler UniWorX Authorized
|
||||
evalAccess r = case getAccess r of
|
||||
(APPure p) -> runReader (p r) <$> getMessageRender
|
||||
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
|
||||
|
||||
@ -239,23 +272,6 @@ data MenuTypes -- Semantische Rolle:
|
||||
| PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig
|
||||
| PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
type DB a = YesodDB UniWorX a
|
||||
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
|
||||
|
||||
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
|
||||
-- of settings which can be configured by overriding methods here.
|
||||
@ -335,7 +351,7 @@ instance Yesod UniWorX where
|
||||
|
||||
favourites <- forM favourites' $ \(Entity _ c@Course{..})
|
||||
-> let
|
||||
courseRoute = CourseR courseTerm courseShorthand CourseShowR
|
||||
courseRoute = CourseR courseTerm courseShorthand CShowR
|
||||
in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
|
||||
|
||||
-- We break up the default layout into two components:
|
||||
@ -435,14 +451,14 @@ isAuthorizedDB (SubmissionDownloadArchiveR (ZIPArchiveName cID)) _ = submissionA
|
||||
isAuthorizedDB TermEditR _ = adminAccess Nothing
|
||||
isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing
|
||||
isAuthorizedDB CourseNewR _ = lecturerAccess Nothing
|
||||
isAuthorizedDB (CourseR t c CourseEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c CEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized --
|
||||
isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
|
||||
isAuthorizedDB (CourseR t c (SheetR (SShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
|
||||
isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SubmissionR s m))) _ = return Authorized -- TODO -- submissionAccess $ Right cID
|
||||
isAuthorizedDB (CourseEditIDR cID) _ = do
|
||||
courseId <- decrypt cID
|
||||
@ -518,17 +534,17 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR)
|
||||
|
||||
breadcrumb CourseListR = return ("Kurs", Just HomeR)
|
||||
breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR)
|
||||
breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term)
|
||||
breadcrumb (TermCourseListR term) = return (toPathPiece term, Just TermShowR)
|
||||
breadcrumb (CourseR term course CShowR) = return (course, Just $ TermCourseListR term)
|
||||
breadcrumb CourseNewR = return ("Neu", Just CourseListR)
|
||||
breadcrumb (CourseR _ _ CourseEditR) = return ("Editieren", Just CourseListR)
|
||||
breadcrumb (CourseR _ _ CEditR) = return ("Editieren", Just CourseListR)
|
||||
|
||||
breadcrumb (CourseR tid csh (SheetR SheetListR)) = return ("Übungen",Just $ CourseR tid csh CourseShowR)
|
||||
breadcrumb (CourseR tid csh (SheetR SheetNewR )) = return ("Neu", Just $ CourseR tid csh $ SheetR SheetListR)
|
||||
breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR)
|
||||
breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
|
||||
breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
|
||||
breadcrumb (CourseR tid csh (SheetR (SubmissionR shn _))) = return ("Abgabe", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
|
||||
breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR)
|
||||
breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR)
|
||||
breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR)
|
||||
breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
|
||||
breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
|
||||
|
||||
@ -539,33 +555,33 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb _ = return ("home", Nothing)
|
||||
|
||||
pageActions :: Route UniWorX -> [MenuTypes]
|
||||
pageActions (CourseR tid csh CourseShowR) =
|
||||
pageActions (CourseR tid csh CShowR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Übungsblätter"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh SheetListR
|
||||
, menuItemRoute = CourseR tid csh SheetListR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Kurs Editieren"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid csh CourseEditR
|
||||
, menuItemRoute = CourseR tid csh CEditR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSheetR tid csh SheetListR) =
|
||||
pageActions (CourseR tid csh SheetListR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Neues Übungsblatt"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh SheetNewR
|
||||
, menuItemRoute = CourseR tid csh SheetNewR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSheetR tid csh (SheetShowR shn)) =
|
||||
pageActions (CSheetR tid csh shn SShowR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgabe"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh (SubmissionR shn newSubmission)
|
||||
, menuItemRoute = CSheetR tid csh shn (SubmissionR newSubmission)
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
@ -577,7 +593,7 @@ pageActions TermShowR =
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CourseListTermR _) =
|
||||
pageActions (TermCourseListR _) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Neuer Kurs"
|
||||
, menuItemIcon = Just "book"
|
||||
|
||||
@ -26,8 +26,8 @@ import qualified Data.UUID.Cryptographic as UUID
|
||||
getCourseListR :: Handler TypedContent
|
||||
getCourseListR = redirect TermShowR
|
||||
|
||||
getCourseListTermR :: TermId -> Handler Html
|
||||
getCourseListTermR tidini = do
|
||||
getTermCourseListR :: TermId -> Handler Html
|
||||
getTermCourseListR tidini = do
|
||||
(term,courses) <- runDB $ (,)
|
||||
<$> get tidini
|
||||
<*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand]
|
||||
@ -40,7 +40,7 @@ getCourseListTermR tidini = do
|
||||
let c = entityVal ckv
|
||||
shd = courseShorthand c
|
||||
tid = courseTerm c
|
||||
in [whamlet| <a href=@{CourseR tid shd CourseShowR}>#{shd} |] )
|
||||
in [whamlet| <a href=@{CourseR tid shd CShowR}>#{shd} |] )
|
||||
-- , headed "Institut" $ [shamlet| #{course} |]
|
||||
, headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal
|
||||
, headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal
|
||||
@ -54,11 +54,11 @@ getCourseListTermR tidini = do
|
||||
shd = courseShorthand c
|
||||
tid = courseTerm c
|
||||
in do
|
||||
adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False
|
||||
-- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else ""
|
||||
adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CEditR) False
|
||||
-- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CEditR tid shd) else ""
|
||||
[whamlet|
|
||||
$if adminLink == Authorized
|
||||
<a href=@{CourseR tid shd CourseEditR}>
|
||||
<a href=@{CourseR tid shd CEditR}>
|
||||
editieren
|
||||
|]
|
||||
)
|
||||
@ -68,8 +68,8 @@ getCourseListTermR tidini = do
|
||||
setTitle "Semesterkurse"
|
||||
$(widgetFile "courses")
|
||||
|
||||
getCourseShowR :: TermId -> Text -> Handler Html
|
||||
getCourseShowR tid csh = do
|
||||
getCShowR :: TermId -> Text -> Handler Html
|
||||
getCShowR tid csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
|
||||
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
|
||||
@ -95,8 +95,8 @@ registerButton registered = renderAForm FormStandard $
|
||||
msg = if registered then "Abmelden" else "Anmelden"
|
||||
regMsg = msg :: BootstrapSubmit Text
|
||||
|
||||
postCourseShowR :: TermId -> Text -> Handler Html
|
||||
postCourseShowR tid csh = do
|
||||
postCShowR :: TermId -> Text -> Handler Html
|
||||
postCShowR tid csh = do
|
||||
aid <- requireAuthId
|
||||
(cid, registered) <- runDB $ do
|
||||
(Entity cid _) <- getBy404 $ CourseTermShort tid csh
|
||||
@ -114,7 +114,7 @@ postCourseShowR tid csh = do
|
||||
when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!"
|
||||
(_other) -> return () -- TODO check this!
|
||||
-- redirect or not?! I guess not, since we want GET now
|
||||
getCourseShowR tid csh
|
||||
getCShowR tid csh
|
||||
|
||||
getCourseNewR :: Handler Html
|
||||
getCourseNewR = do
|
||||
@ -124,13 +124,13 @@ getCourseNewR = do
|
||||
postCourseNewR :: Handler Html
|
||||
postCourseNewR = courseEditHandler Nothing
|
||||
|
||||
getCourseEditR :: TermId -> Text -> Handler Html
|
||||
getCourseEditR tid csh = do
|
||||
getCEditR :: TermId -> Text -> Handler Html
|
||||
getCEditR tid csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid csh
|
||||
courseEditHandler course
|
||||
|
||||
postCourseEditR :: TermId -> Text -> Handler Html
|
||||
postCourseEditR = getCourseEditR
|
||||
postCEditR :: TermId -> Text -> Handler Html
|
||||
postCEditR = getCEditR
|
||||
|
||||
getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
|
||||
getCourseEditIDR cID = do
|
||||
@ -147,7 +147,7 @@ courseDeleteHandler = undefined
|
||||
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
|
||||
let cti = toPathPiece $ cfTerm res
|
||||
addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
|
||||
redirect $ CourseListTermR $ cfTerm res
|
||||
redirect $ TermCourseListR $ cfTerm res
|
||||
-}
|
||||
|
||||
courseEditHandler :: Maybe (Entity Course) -> Handler Html
|
||||
@ -183,7 +183,7 @@ courseEditHandler course = do
|
||||
insert_ $ CourseEdit aid now cid
|
||||
insert_ $ Lecturer aid cid
|
||||
addMessageI "info" $ MsgCourseNewOk tident csh
|
||||
redirect $ CourseListTermR tid
|
||||
redirect $ TermCourseListR tid
|
||||
Nothing ->
|
||||
addMessageI "danger" $ MsgCourseNewDupShort tident csh
|
||||
|
||||
@ -238,7 +238,7 @@ courseEditHandler course = do
|
||||
-- if (isNothing updOkay)
|
||||
-- then do
|
||||
addMessageI "info" $ MsgCourseEditOk tident csh
|
||||
-- redirect $ CourseListTermR tid
|
||||
-- redirect $ TermCourseListR tid
|
||||
-- else addMessageI "danger" $ MsgCourseEditDupShort tident csh
|
||||
|
||||
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
|
||||
|
||||
@ -38,7 +38,7 @@ instance CryptoRoute UUID SubmissionId where
|
||||
Sheet{..} <- get404 shid
|
||||
Course{..} <- get404 sheetCourse
|
||||
return (courseTerm, courseShorthand, sheetName)
|
||||
return $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
|
||||
return $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID
|
||||
|
||||
|
||||
class Dispatch ciphertext (x :: [*]) where
|
||||
|
||||
@ -154,7 +154,7 @@ getSheetList courseEnt = do
|
||||
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
|
||||
return (sid, sheet, (submissions, rated))
|
||||
let colBase = mconcat
|
||||
[ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet
|
||||
[ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CSheetR tid csh (sheetName sheet) SShowR
|
||||
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
|
||||
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
|
||||
, headed "Bewertung" $ toWgt . show . sheetType . snd3
|
||||
@ -162,13 +162,13 @@ getSheetList courseEnt = do
|
||||
let colAdmin = mconcat -- only show edit button for allowed course assistants
|
||||
[ headed "Korrigiert" $ toWgt . snd . trd3
|
||||
, headed "Eingereicht" $ toWgt . fst . trd3
|
||||
, headed "" $ \s -> linkButton "Edit" BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s
|
||||
, headed "" $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR $ sheetName $ snd3 s
|
||||
, headed "" $ \s -> linkButton "Edit" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SEditR
|
||||
, headed "" $ \s -> linkButton "Delete" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SDelR
|
||||
]
|
||||
showAdmin <- case sheets of
|
||||
((_,firstSheet,_):_) -> do
|
||||
setUltDestCurrent
|
||||
(Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False
|
||||
(Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False
|
||||
_otherwise -> return False
|
||||
let colSheets = if showAdmin
|
||||
then colBase `mappend` colAdmin
|
||||
@ -181,8 +181,8 @@ getSheetList courseEnt = do
|
||||
|
||||
|
||||
-- Show single sheet
|
||||
getSheetShowR :: TermId -> Text -> Text -> Handler Html
|
||||
getSheetShowR tid csh shn = do
|
||||
getSShowR :: TermId -> Text -> Text -> Handler Html
|
||||
getSShowR tid csh shn = do
|
||||
entSheet <- runDB $ fetchSheet tid csh shn
|
||||
let sheet = entityVal entSheet
|
||||
sid = entityKey entSheet
|
||||
@ -210,7 +210,7 @@ getSheetShowR tid csh shn = do
|
||||
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = mconcat
|
||||
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName))
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
|
||||
(\(E.Value fName,_,_) -> str2widget fName)
|
||||
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT modified
|
||||
]
|
||||
@ -235,8 +235,8 @@ getSheetShowR tid csh shn = do
|
||||
$(widgetFile "sheetShow")
|
||||
[whamlet| Under Construction !!! |] -- TODO
|
||||
|
||||
getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSheetFileR tid csh shn typ title = do
|
||||
getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSFileR tid csh shn typ title = do
|
||||
content <- runDB $ E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
@ -272,8 +272,8 @@ postSheetNewR :: TermId -> Text -> Handler Html
|
||||
postSheetNewR = getSheetNewR
|
||||
|
||||
|
||||
getSheetEditR :: TermId -> Text -> Text -> Handler Html
|
||||
getSheetEditR tid csh shn = do
|
||||
getSEditR :: TermId -> Text -> Text -> Handler Html
|
||||
getSEditR tid csh shn = do
|
||||
(sheetEnt, sheetFileIds) <- runDB $ do
|
||||
ent <- fetchSheet tid csh shn
|
||||
fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
||||
@ -307,8 +307,8 @@ getSheetEditR tid csh shn = do
|
||||
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
|
||||
handleSheetEdit tid csh (Just sid) template action
|
||||
|
||||
postSheetEditR :: TermId -> Text -> Text -> Handler Html
|
||||
postSheetEditR = getSheetEditR
|
||||
postSEditR :: TermId -> Text -> Text -> Handler Html
|
||||
postSEditR = getSEditR
|
||||
|
||||
handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
|
||||
handleSheetEdit tid csh msId template dbAction = do
|
||||
@ -344,44 +344,44 @@ handleSheetEdit tid csh msId template dbAction = do
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI "info" $ MsgSheetEditOk tident csh sfName
|
||||
return True
|
||||
when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB
|
||||
when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
||||
_ -> return ()
|
||||
let pageTitle = maybe (MsgSheetTitleNew tident csh)
|
||||
(MsgSheetTitle tident csh) mbshn
|
||||
let formTitle = pageTitle
|
||||
let formText = Nothing :: Maybe UniWorXMessage
|
||||
actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute
|
||||
actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute
|
||||
defaultLayout $ do
|
||||
setTitleI pageTitle
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
|
||||
|
||||
getSheetDelR :: TermId -> Text -> Text -> Handler Html
|
||||
getSheetDelR tid csh shn = do
|
||||
getSDelR :: TermId -> Text -> Text -> Handler Html
|
||||
getSDelR tid csh shn = do
|
||||
let tident = unTermKey tid
|
||||
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
||||
case result of
|
||||
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn
|
||||
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR
|
||||
(FormSuccess BtnDelete) -> do
|
||||
runDB $ fetchSheetId tid csh shn >>= deleteCascade
|
||||
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
|
||||
addMessageI "info" $ MsgSheetDelOk tident csh shn
|
||||
redirect $ CSheetR tid csh SheetListR
|
||||
redirect $ CourseR tid csh SheetListR
|
||||
_other -> do
|
||||
submissionno <- runDB $ do
|
||||
sid <- fetchSheetId tid csh shn
|
||||
count [SubmissionSheet ==. sid]
|
||||
let formTitle = MsgSheetDelTitle tident csh shn
|
||||
let formText = Just $ MsgSheetDelText submissionno
|
||||
let actionUrl = CSheetR tid csh $ SheetDelR shn
|
||||
let actionUrl = CSheetR tid csh shn SDelR
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetTitle tident csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
postSheetDelR :: TermId -> Text -> Text -> Handler Html
|
||||
postSheetDelR = getSheetDelR
|
||||
postSDelR :: TermId -> Text -> Text -> Handler Html
|
||||
postSDelR = getSDelR
|
||||
|
||||
|
||||
|
||||
|
||||
@ -112,7 +112,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
|
||||
(E.Value smid:_) -> do
|
||||
cID <- encrypt smid
|
||||
addMessageI "info" $ MsgSubmissionAlreadyExists
|
||||
redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
|
||||
redirect $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID
|
||||
(Just smid) -> do
|
||||
shid' <- submissionSheet <$> get404 smid
|
||||
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||
@ -203,7 +203,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
|
||||
_other -> return Nothing
|
||||
|
||||
case mCID of
|
||||
Just cID -> redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
|
||||
Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID
|
||||
Nothing -> return ()
|
||||
|
||||
mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid
|
||||
@ -327,7 +327,7 @@ submissionTable = do
|
||||
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
|
||||
|
||||
let
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CourseShowR
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR
|
||||
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
|
||||
anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
|
||||
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
|
||||
|
||||
@ -60,7 +60,7 @@ getTermShowR = do
|
||||
textCell $ bool "" tickmark termActive
|
||||
, sortable Nothing "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
|
||||
cell [whamlet|
|
||||
<a href=@{CourseListTermR tid}>
|
||||
<a href=@{TermCourseListR tid}>
|
||||
#{show numCourses} Kurse
|
||||
|]
|
||||
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
|
||||
|
||||
75
src/Utils.hs
75
src/Utils.hs
@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
@ -14,10 +16,29 @@ import Utils.Common as Utils
|
||||
|
||||
import Text.Blaze (Markup, ToMarkup)
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.List as List
|
||||
-- import Data.Map (Map)
|
||||
-- import qualified Data.Map as Map
|
||||
-- import qualified Data.List as List
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
|
||||
-----------
|
||||
-- Yesod --
|
||||
-----------
|
||||
|
||||
newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) }
|
||||
|
||||
getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
|
||||
getMsgRenderer = do
|
||||
mr <- getMessageRender
|
||||
return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
|
||||
|
||||
|
||||
---------------------
|
||||
-- Text and String --
|
||||
---------------------
|
||||
|
||||
tickmark :: IsString a => a
|
||||
tickmark = fromString "✔"
|
||||
@ -42,12 +63,6 @@ withFragment :: ( Monad m
|
||||
) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
|
||||
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
|
||||
|
||||
-----------
|
||||
-- Maybe --
|
||||
-----------
|
||||
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenIsJust (Just x) f = f x
|
||||
whenIsJust Nothing _ = return ()
|
||||
|
||||
------------
|
||||
-- Tuples --
|
||||
@ -56,3 +71,45 @@ whenIsJust Nothing _ = return ()
|
||||
----------
|
||||
-- Maps --
|
||||
----------
|
||||
|
||||
|
||||
-----------
|
||||
-- Maybe --
|
||||
-----------
|
||||
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenIsJust (Just x) f = f x
|
||||
whenIsJust Nothing _ = return ()
|
||||
|
||||
maybeT :: Monad m => m a -> MaybeT m a -> m a
|
||||
maybeT x m = runMaybeT m >>= maybe x return
|
||||
|
||||
---------------
|
||||
-- Exception --
|
||||
---------------
|
||||
|
||||
maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
|
||||
maybeExceptT err act = lift act >>= maybe (throwE err) return
|
||||
|
||||
maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b
|
||||
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
|
||||
|
||||
guardExceptT :: Monad m => e -> Bool -> ExceptT e m ()
|
||||
guardExceptT err b = unless b $ throwE err
|
||||
|
||||
guardMExceptT :: Monad m => (m e) -> Bool -> ExceptT e m ()
|
||||
guardMExceptT err b = unless b $ lift err >>= throwE
|
||||
|
||||
exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
|
||||
exceptT f g = either f g <=< runExceptT
|
||||
|
||||
|
||||
------------
|
||||
-- Monads --
|
||||
------------
|
||||
|
||||
shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
|
||||
shortCircuitM sc mx my op = do
|
||||
x <- mx
|
||||
case sc x of
|
||||
True -> return x
|
||||
False -> op <$> pure x <*> my
|
||||
|
||||
@ -5,7 +5,10 @@ module Utils.Common where
|
||||
-- Common Utility Functions
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Except
|
||||
|
||||
------------
|
||||
-- Tuples --
|
||||
@ -51,10 +54,3 @@ altFun perm = lamE pat rhs
|
||||
fn = mkName "fn"
|
||||
|
||||
|
||||
-----------
|
||||
-- Maybe --
|
||||
-----------
|
||||
|
||||
maybeT :: Monad m => m a -> MaybeT m a -> m a
|
||||
maybeT x m = runMaybeT m >>= maybe x return
|
||||
|
||||
|
||||
@ -34,7 +34,7 @@
|
||||
<div .course__registration>
|
||||
<a href="#">Anmelden
|
||||
|
||||
$# <form method=post action=@{CourseR tid csh CourseShowR} enctype=#{regEnctype}>
|
||||
$# <form method=post action=@{CourseR tid csh CShow} enctype=#{regEnctype}>
|
||||
$# ^{regWidget}
|
||||
|
||||
<div .container>
|
||||
|
||||
@ -5,12 +5,12 @@ $newline never
|
||||
<ul .asidenav__list>
|
||||
$forall menuType <- menuTypes
|
||||
$case menuType
|
||||
$of NavbarAside (MenuItem label mIcon route _)
|
||||
<li .asidenav__list-item :Just route == mcurrentRoute:.asidenav__list-item--active>
|
||||
<a .asidenav__link-wrapper href=@{route}>
|
||||
$if isJust mIcon
|
||||
<div .glyphicon.glyphicon--#{fromMaybe "" mIcon}>
|
||||
<div .asidenav__link-label>#{label}
|
||||
$of NavbarAside mi
|
||||
<li .asidenav__list-item :Just (menuItemRoute mi) == mcurrentRoute:.asidenav__list-item--active>
|
||||
<a .asidenav__link-wrapper href=@{menuItemRoute mi}>
|
||||
$if isJust (menuItemIcon mi)
|
||||
<div .glyphicon.glyphicon--#{fromMaybe "" (menuItemIcon mi)}>
|
||||
<div .asidenav__link-label>#{menuItemLabel mi}
|
||||
$of _
|
||||
|
||||
<div .asidenav__box>
|
||||
@ -25,9 +25,9 @@ $newline never
|
||||
<ul .asidenav__nested-list>
|
||||
$forall action <- pageActions
|
||||
$case action
|
||||
$of PageActionPrime (MenuItem{..})
|
||||
$of PageActionPrime mi
|
||||
<li .asidenav__list-item>
|
||||
<a .asidenav__link-wrapper href=@{menuItemRoute}>#{menuItemLabel}
|
||||
<a .asidenav__link-wrapper href=@{menuItemRoute mi}>#{menuItemLabel mi}
|
||||
$of _
|
||||
|
||||
<div .asidenav__toggler>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user