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

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

Browse Source
This commit is contained in:
Gregor Kleen 2018-06-29 11:53:16 +02:00
commit 0ab7bbd7eb
28 changed files with 557 additions and 186 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
config/settings.yml
View File

@ -19,6 +19,7 @@ should-log-all: "_env:LOG_ALL:false"
# mutable-static: false
# skip-combining: false
auth-dummy-login: "_env:DUMMY_LOGIN:false"
allow-deprecated: "_env:ALLOW_DEPRECATED:false"
# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'")
# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings

30
messages/de.msg
View File

@ -1,3 +1,12 @@
BtnSubmit: Senden
BtnAbort: Abbrechen
BtnDelete: Löschen
BtnRegister: Anmelden
BtnDeregister: Abmelden
RegisterFrom: Anmeldungen von
RegisterTo: Anmeldungen bis
SummerTerm year@Integer: Sommersemester #{tshow year}
WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
PSLimitNonPositive: “pagesize” muss größer als null sein
@ -12,6 +21,7 @@ TermEditHeading: Semester editieren/anlegen
LectureStart: Beginn Vorlesungen
Course: Kurs
CourseSecret: Zugangspasswort
CourseNewOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt.
CourseEditOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert.
CourseNewDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
@ -44,6 +54,7 @@ UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung ein
UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
@ -53,6 +64,7 @@ UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein f
UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
Submission: Abgabenummer
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
@ -63,12 +75,25 @@ SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem
CorrectionsTitle: Zugewiesene Korrekturen
CourseCorrectionsTitle: Korrekturen für diesen Kurs
Corrector: Korrektor
EMail: E-Mail
EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer.
NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs #{termToText tid}-#{csh} angemeldet.
AddCorrector: Zusätzlicher Korrektor
CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen
SheetCorrectorsTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Korrektoren für #{termToText tid}-#{courseShortHand} #{sheetName}
CountTutProp: Tutorien zählen gegen Proportion
Corrector: Korrektor
Correctors: Korrektoren
CorByTut: Nach Tutorium
CorProportion: Anteil
DeleteRow: Zeile entfernen
ProportionNegative: Anteile dürfen nicht negativ sein
CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
CorrectorsPlaceholder: Korrektoren...
CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
HomeHeading: Aktuelle Termine
ProfileHeading: Benutzerprofil und Einstellungen
ProfileDataHeading: Gespeicherte Benutzerdaten
@ -97,4 +122,5 @@ NrColumn: Nr
SelectColumn: Auswahl
CorrDownload: Herunterladen
CorrSetCorrector: Korrektor zuweisen
CorrSetCorrector: Korrektor zuweisen
NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!

3
models
View File

@ -60,7 +60,7 @@ Course
term TermId
school SchoolId
capacity Int Maybe
hasRegistration Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
-- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
registerFrom UTCTime Maybe
registerTo UTCTime Maybe
deregisterUntil UTCTime Maybe
@ -119,6 +119,7 @@ SheetCorrector
sheet SheetId
load Load
UniqueSheetCorrector user sheet
deriving Show Eq Ord
SheetFile
sheet SheetId
file FileId

1
package.yaml
View File

@ -81,6 +81,7 @@ dependencies:
- exceptions
- lens
- MonadRandom
- email-validate
# The library contains all of our application code. The executable
# defined below is just a thin wrapper.

12
routes
View File

@ -21,7 +21,7 @@
-- !isRead -- only if it is read-only access (i.e. GET but not POST)
-- !isWrite -- only if it is write access (i.e. POST only) why needed???
--
-- !deprecated -- like free, but logs and gives a warning
-- !deprecated -- like free, but logs and gives a warning; entirely disabled in production
--
/static StaticR Static appStatic !free
@ -30,9 +30,10 @@
/favicon.ico FaviconR GET !free
/robots.txt RobotsR GET !free
/ HomeR GET !free
/users UsersR GET -- no tags, i.e. admins only
/ HomeR GET !free
/users UsersR GET -- no tags, i.e. admins only
/admin/test AdminTestR GET POST
/admin/user/#CryptoUUIDUser AdminUserR GET
/profile ProfileR GET POST !free !free
/profile/data ProfileDataR GET !free !free
@ -47,7 +48,8 @@
/course/ CourseListR GET !free
!/course/new CourseNewR GET POST !lecturer
/course/#TermId/#Text CourseR !lecturer:
/show CShowR GET POST !free
/show CShowR GET !free
/register CRegisterR POST !time
/edit CEditR GET POST
/corrections CourseCorrectionsR GET POST
/ex SheetListR GET !registered !materials
@ -60,9 +62,11 @@
!/sub/new SubmissionNewR GET POST !timeANDregistered
!/sub/own SubmissionOwnR GET !free
!/sub/#CryptoFileNameSubmission SubmissionR GET POST !owner !corrector
/correctors SCorrR GET POST
/corrections CorrectionsR GET POST !free
-- TODO below
!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
!/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !deprecated

5
src/CryptoID.hs
View File

@ -39,7 +39,7 @@ instance PathPiece UUID where
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
fromPathPiece = fmap CI.mk . fromPathPiece
toPathPiece = toPathPiece . CI.original
toPathPiece = toPathPiece . CI.foldedCase
instance {-# OVERLAPS #-} PathMultiPiece FilePath where
fromPathMultiPiece = Just . unpack . intercalate "/"
@ -47,12 +47,13 @@ instance {-# OVERLAPS #-} PathMultiPiece FilePath where
instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
toPathMultiPiece = toPathMultiPiece . CI.original
toPathMultiPiece = toPathMultiPiece . CI.foldedCase
-- Generates CryptoUUID... and CryptoFileName... Datatypes
decCryptoIDs [ ''SubmissionId
, ''FileId
, ''UserId
]
{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}

92
src/Foundation.hs
View File

@ -1,6 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
@ -236,12 +235,13 @@ adminAP = APDB $ \case
knownTags :: Map (CI Text) AccessPredicate
knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId
[("free", trueAP)
,("deprecated", APHandler $ \r -> do
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
addMessageI "error" MsgDeprecatedRoute
return Authorized
allow <- appAllowDeprecated . appSettings <$> getYesod
return $ bool (Unauthorized "Deprecated Route") Authorized allow
)
,("lecturer", APDB $ \case
CourseR tid csh _ -> exceptT return return $ do
@ -289,20 +289,28 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
return Authorized
)
,("time", APDB $ \case
CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
cTime <- liftIO getCurrentTime
let started = sheetActiveFrom <= cTime || NTop sheetVisibleFrom <= (NTop $ Just cTime)
case subRoute of
SFileR SheetExercise _ -> guard started
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SFileR SheetMarking _ -> mzero -- only for correctors and lecturers
SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
_ -> guard started
return Authorized
r -> do
CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
cTime <- liftIO getCurrentTime
let started = sheetActiveFrom <= cTime || NTop sheetVisibleFrom <= (NTop $ Just cTime)
case subRoute of
SFileR SheetExercise _ -> guard started
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SFileR SheetMarking _ -> mzero -- only for correctors and lecturers
SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
_ -> guard started
return Authorized
CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime
&& NTop courseRegisterTo >= cTime
return Authorized
r -> do
$logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r
unauthorizedI MsgUnauthorized
)
@ -406,9 +414,9 @@ instance Yesod UniWorX where
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
yesodMiddleware handler = do
res <- defaultYesodMiddleware handler
void . runMaybeT $ do
route <- MaybeT getCurrentRoute
guardM . lift $ (== Authorized) <$> isAuthorized route False
case route of -- update Course Favourites here
CourseR tid csh _ -> do
uid <- MaybeT maybeAuthId
@ -431,7 +439,7 @@ instance Yesod UniWorX where
lift $ mapM_ delete oldFavs
_other -> return ()
return res
defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately
defaultLayout widget = do
master <- getYesod
@ -568,7 +576,6 @@ instance Yesod UniWorX where
makeLogger = return . appLogger
-- Define breadcrumbs.
instance YesodBreadcrumbs UniWorX where
breadcrumb TermShowR = return ("Semester", Just HomeR)
@ -579,38 +586,55 @@ instance YesodBreadcrumbs UniWorX where
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 _ _ CEditR) = return ("Editieren", Just CourseListR)
breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR)
breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR)
breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR)
breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR)
breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR)
breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR)
breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
breadcrumb HomeR = return ("UniWorkY", Nothing)
breadcrumb (AuthR _) = return ("Login", Just HomeR)
breadcrumb ProfileR = return ("Profile", Just HomeR)
breadcrumb HomeR = return ("UniWorkY", Nothing)
breadcrumb (AuthR _) = return ("Login", Just HomeR)
breadcrumb ProfileR = return ("Profile", Just HomeR)
breadcrumb ProfileDataR = return ("Data", Just ProfileR)
breadcrumb _ = return ("home", Nothing)
pageActions :: Route UniWorX -> [MenuTypes]
pageActions (CourseR tid csh CShowR) =
[ PageActionPrime $ MenuItem
{ menuItemLabel = "Übungsblätter"
, menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh SheetListR
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Kurs Editieren"
, menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh CEditR
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Übungsblätter"
, menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh SheetListR
, menuItemAccessCallback' = do --TODO always show for lecturer
let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid csh shn SShowR) False)
muid <- maybeAuthId
(sheets,lecturer) <- runDB $ do
cid <- getKeyBy404 $ CourseTermShort tid csh
sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
lecturer <- case muid of
Nothing -> return False
(Just uid) -> existsBy $ UniqueLecturer uid cid
return (sheets,lecturer)
or2M (return lecturer) $ anyM sheets sheetRouteAccess
}
, PageActionSecondary $ MenuItem
{ menuItemLabel = "Neues Übungsblatt anlegen"
, menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh SheetNewR
, menuItemAccessCallback' = return True
}
]
pageActions (CourseR tid csh SheetListR) =
[ PageActionPrime $ MenuItem
@ -628,11 +652,17 @@ pageActions (CSheetR tid csh shn SShowR) =
, menuItemAccessCallback' = return True -- TODO: check that no submission already exists
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Abgabe"
{ menuItemLabel = "Abgabe ansehen"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SubmissionOwnR
, menuItemAccessCallback' = return True -- TODO: check that a submission already exists
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Korrektoren"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SCorrR
, menuItemAccessCallback' = return True
}
]
pageActions TermShowR =
[ PageActionPrime $ MenuItem

11
src/Handler/Admin.hs
View File

@ -58,3 +58,14 @@ postAdminTestR = do
_other -> return ()
getAdminTestR
getAdminUserR :: CryptoUUIDUser -> Handler Html
getAdminUserR uuid = do
uid <- decrypt uuid
User{..} <- runDB $ get404 uid
defaultLayout $
[whamlet|
<h1>TODO
<h2>Admin Page for User #{display userDisplayName}
|]

79
src/Handler/Course.hs
View File

@ -16,9 +16,9 @@ import Handler.Utils
-- import Data.Time
import qualified Data.Text as T
import Data.Function ((&))
import Yesod.Form.Bootstrap3
-- import Yesod.Form.Bootstrap3
import Colonnade hiding (fromMaybe)
import Colonnade hiding (fromMaybe,bool)
import Yesod.Colonnade
import qualified Data.UUID.Cryptographic as UUID
@ -79,7 +79,7 @@ getTermCourseListR tidini = do
getCShowR :: TermId -> Text -> Handler Html
getCShowR tid csh = do
mbAid <- maybeAuthId
(courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
(courseEnt,(schoolMB,participants,registered)) <- runDB $ do
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
dependent <- (,,)
<$> get (courseSchool course) -- join
@ -91,38 +91,45 @@ getCShowR tid csh = do
return $ isJust regL)
return $ (courseEnt,dependent)
let course = entityVal courseEnt
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid csh CRegisterR) True
defaultLayout $ do
setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
$(widgetFile "course")
registerButton :: Bool -> Form ()
registerButton registered = renderAForm FormStandard $
pure () <* bootstrapSubmit regMsg
where
msg = if registered then "Abmelden" else "Anmelden"
regMsg = msg :: BootstrapSubmit Text
postCShowR :: TermId -> Text -> Handler Html
postCShowR tid csh = do
registerForm :: Bool -> Maybe Text -> Form Bool
registerForm registered msecret extra = do
(msecretRes', msecretView) <- case msecret of
(Just _) | not registered -> bimap Just Just <$> (mreq textField (fslpI MsgCourseSecret "Code") Nothing)
_ -> return (Nothing,Nothing)
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
let widget = $(widgetFile "widgets/registerForm")
let msecretRes | Just res <- msecretRes' = Just <$> res
| otherwise = FormSuccess Nothing
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
postCRegisterR :: TermId -> Text -> Handler Html
postCRegisterR tid csh = do
aid <- requireAuthId
(cid, registered) <- runDB $ do
(Entity cid _) <- getBy404 $ CourseTermShort tid csh
(cid, course, registered) <- runDB $ do
(Entity cid course) <- getBy404 $ CourseTermShort tid csh
registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
return (cid, registered)
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered
return (cid, course, registered)
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
case regResult of
(FormSuccess _)
(FormSuccess codeOk)
| registered -> do
runDB $ deleteBy $ UniqueParticipant aid cid
addMessage "info" "Sie wurden abgemeldet."
| otherwise -> do
| codeOk -> do
actTime <- liftIO $ getCurrentTime
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!"
| otherwise -> addMessage "danger" "Falsches Kennwort!"
(_other) -> return () -- TODO check this!
-- redirect or not?! I guess not, since we want GET now
getCShowR tid csh
redirect $ CourseR tid csh CShowR
getCourseNewR :: Handler Html
getCourseNewR = do
@ -174,11 +181,10 @@ courseEditHandler isGet course = do
, courseTerm = cfTerm res
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseHasRegistration = cfHasReg res
, courseRegisterSecret = cfSecret res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseDeregisterUntil = Nothing -- TODO
, courseRegisterSecret = Nothing -- TODO
, courseMaterialFree = True -- TODO
}
case insertOkay of
@ -230,11 +236,10 @@ courseEditHandler isGet course = do
, courseTerm = cfTerm res
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseHasRegistration = cfHasReg res
, courseRegisterSecret = cfSecret res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseDeregisterUntil = Nothing -- TODO
, courseRegisterSecret = Nothing -- TODO
, courseMaterialFree = True -- TODO
}
)
@ -263,7 +268,7 @@ data CourseForm = CourseForm
, cfTerm :: TermId
, cfSchool :: SchoolId
, cfCapacity :: Maybe Int
, cfHasReg :: Bool
, cfSecret :: Maybe Text
, cfRegFrom :: Maybe UTCTime
, cfRegTo :: Maybe UTCTime
}
@ -282,7 +287,7 @@ courseToForm cEntity = CourseForm
, cfTerm = courseTerm course
, cfSchool = courseSchool course
, cfCapacity = courseCapacity course
, cfHasReg = courseHasRegistration course
, cfSecret = courseRegisterSecret course
, cfRegFrom = courseRegisterFrom course
, cfRegTo = courseRegisterTo course
}
@ -309,9 +314,15 @@ newCourseForm template = identForm FIDcourse $ \html -> do
<*> areq termActiveField (fsb "Semester") (cfTerm <$> template)
<*> areq schoolField (fsb "Institut") (cfSchool <$> template)
<*> aopt (natField "Kapazität") (fsb "Kapazität") (cfCapacity <$> template)
<*> areq checkBoxField (fsb "Anmeldung") (cfHasReg <$> template)
<*> aopt utcTimeField (fsb "Anmeldung von:") (cfRegFrom <$> template)
<*> aopt utcTimeField (fsb "Anmeldung bis:") (cfRegTo <$> template)
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
& setTooltip "Optional: Anmeldung zum Kurs benötigt ein Passwort")
(cfSecret <$> template)
<*> aopt utcTimeField (fslpI MsgRegisterFrom "(ohne Datum keine Anmeldung möglich)"
& setTooltip "Ohne Datum ist keine Anmeldung zu diesem Kurs möglich!")
(cfRegFrom <$> template)
<*> aopt utcTimeField (fslpI MsgRegisterTo "(ohne Datum unbegrenzte Anmeldung möglich)"
& setTooltip "Die Anmeldung darf ohne Begrenzung sein")
(cfRegTo <$> template)
<* submitButton
return $ case result of
FormSuccess courseResult
@ -338,20 +349,12 @@ validateCourse :: CourseForm -> [Text]
validateCourse (CourseForm{..}) =
[ msg | (False, msg) <-
[
( cfRegFrom <= cfRegTo
( NTop cfRegFrom <= NTop cfRegTo
, "Ende des Anmeldezeitraums muss nach dem Anfang liegen"
)
,
-- No starting date is okay: effective immediately
-- ( cfHasReg <= (isNothing cfRegFrom)
-- , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren"
-- )
-- ,
( cfHasReg == (isJust cfRegTo)
, "Ende des Anmeldezeitraums angeben oder Anmeldungen deaktivieren"
)
,
( isJust cfRegFrom <= cfHasReg
, "Anmeldungen aktivieren oder Anmeldezeitraum löschen"
)
] ]

7
src/Handler/CryptoIDDispatch.hs
View File

@ -54,7 +54,11 @@ instance CryptoRoute (CI FilePath) SubmissionId where
Course{..} <- get404 sheetCourse
return (courseTerm, courseShorthand, sheetName)
return $ CSheetR tid csh shn $ SubmissionR cID
instance CryptoRoute UUID UserId where
cryptoIDRoute _ (CryptoID -> cID) = do
(_ :: UserId) <- decrypt cID
return $ AdminUserR cID
class Dispatch ciphertext (x :: [*]) where
dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
@ -79,6 +83,7 @@ getCryptoUUIDDispatchR :: UUID -> Handler ()
getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302)
where
p :: Proxy '[ SubmissionId
, UserId
]
p = Proxy

19
src/Handler/Home.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@ -15,6 +14,8 @@ module Handler.Home where
import Import
import Handler.Utils
import qualified Data.Map as Map
import Data.Time
-- import qualified Data.Text as T
-- import Yesod.Form.Bootstrap3
@ -56,10 +57,10 @@ homeAnonymous = do
let tableData :: E.SqlExpr (Entity Course)
-> E.SqlQuery (E.SqlExpr (Entity Course))
tableData course = do
E.where_ $ course E.^. CourseHasRegistration E.==. E.val True
E.&&. course E.^. CourseRegisterFrom E.<=. E.val (Just cTime)
E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom)
E.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
E.limit nrSheetDeadlines
E.orderBy [ E.asc $ course E.^. CourseRegisterTo
, E.desc $ course E.^. CourseShorthand
@ -74,13 +75,14 @@ homeAnonymous = do
let tid = courseTerm course
csh = courseShorthand course
cell [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
textCell $ display $ courseRegisterTo course
]
courseTable <- dbTable def $ DBTable
{ dbtSQLQuery = tableData
, dbtColonnade = colonnade
, dbtSorting = [ ( "term"
, dbtSorting = Map.fromList
[ ( "term"
, SortColumn $ \(course) -> course E.^. CourseTerm
)
, ( "course"
@ -147,7 +149,8 @@ homeUser uid = do
sheetTable <- dbTable def $ DBTable
{ dbtSQLQuery = tableData
, dbtColonnade = colonnade
, dbtSorting = [ ( "term"
, dbtSorting = Map.fromList
[ ( "term"
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ ) -> course E.^. CourseTerm
)
, ( "course"

5
src/Handler/Profile.hs
View File

@ -28,7 +28,7 @@ makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template = identForm FIDsettings $ \html -> do
let themeList = [(display t,t) | t <- allThemes]
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
<$> areq (natField "Favoriten") -- TODO: natFieldI not working here
<$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
(fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
<*> areq (selectFieldList themeList)
(fslI MsgTheme ) (stgTheme <$> template)
@ -58,8 +58,9 @@ getProfileR = do
, OffsetBy $ stgMaxFavourties
]
mapM_ delete oldFavs
addMessageI "info" $ MsgSettingsUpdate
redirect ProfileR -- TODO: them change does not happen without redirect
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
_ -> return ()

236
src/Handler/Sheet.hs
View File

@ -8,8 +8,12 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE MultiWayIf, LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Handler.Sheet where
@ -23,9 +27,10 @@ import Handler.Utils.Zip
import qualified Data.Text as T
-- import Data.Function ((&))
--
import Colonnade hiding (fromMaybe, singleton)
import Colonnade hiding (fromMaybe, singleton, bool)
import qualified Yesod.Colonnade as Yesod
--
import Text.Blaze (text)
--
import qualified Data.UUID.Cryptographic as UUID
import qualified Data.Conduit.List as C
@ -33,12 +38,24 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E
import Control.Monad.Writer (MonadWriter(..), execWriterT)
import Control.Monad.Trans.RWS.Lazy (RWST, local)
import qualified Text.Email.Validate as Email
import qualified Data.List as List
import Network.Mime
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Map (Map, (!), (!?))
import qualified Data.Map as Map
import Control.Lens
import Utils.Lens
instance Eq (Unique Sheet) where
(CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
@ -65,7 +82,6 @@ data SheetForm = SheetForm
, sfSolutionFrom :: Maybe UTCTime
, sfSolutionF :: Maybe FileInfo
-- Keine SheetId im Formular!
, sfCorrectors :: [(UserId,Load)]
}
@ -93,7 +109,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
<*> fileAFormOpt (fsb "Hinweis")
<*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
<*> fileAFormOpt (fsb "Lösung")
<*> formToAForm (correctorForm msId (maybe [] sfCorrectors template))
<* submitButton
return $ case result of
FormSuccess sheetResult
@ -124,16 +139,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
-- TODO: continue validation here!!!
] ]
correctorForm :: Maybe SheetId -> [(UserId,Load)] -> MForm Handler (FormResult [(UserId,Load)], [FieldView UniWorX])
correctorForm _msid templates = return mempty -- TODO deprecated
-- Datenbank UserId -> UserName
-- Eingabelist für Colonnade
-- enthält die benötigten Felder
-- FormResult konstruieren
-- Eingabebox für Korrektor hinzufügen
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
-- List Sheets
getSheetListCID :: CourseId -> Handler Html
getSheetListCID cid = getSheetList =<<
@ -160,7 +165,7 @@ getSheetList courseEnt = do
let colBase = mconcat
[ headed "Blatt" $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
, headed "Abgabe lbis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
, headed "Bewertung" $ toWgt . display . sheetType . snd3
]
let colAdmin = mconcat -- only show edit button for allowed course assistants
@ -178,7 +183,7 @@ getSheetList courseEnt = do
then colBase `mappend` colAdmin
else colBase
defaultLayout $ do
setTitle $ toHtml $ T.append "Übungsblätter " csh
setTitle $ toHtml $ csh <> " Übungsblätter"
if null sheets
then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
else Yesod.encodeWidgetTable tableDefault colSheets sheets
@ -304,7 +309,6 @@ getSEditR tid csh shn = do
, sfHintF = Nothing -- TODO
, sfSolutionFrom = sheetSolutionFrom
, sfSolutionF = Nothing -- TODO
, sfCorrectors = [] -- TODO read correctors from list
}
let action newSheet = do
replaceRes <- myReplaceUnique sid $ newSheet
@ -413,3 +417,201 @@ insertSheetFile' sid ftype fs = do
finsert (Right file) = lift $ do
fid <- insert file
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
data CorrectorForm = CorrectorForm
{ cfUserId :: UserId
, cfUserName :: Text
, cfResult :: FormResult Load
, cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX
}
type Loads = Map UserId Load
defaultLoads :: SheetId -> DB Loads
-- ^ Generate `Loads` in such a way that minimal editing is required
--
-- For every user, that ever was a corrector for this course, return their last `Load`.
-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
defaultLoads shid = do
cId <- sheetCourse <$> getJust shid
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
let creationTime = E.sub_select . E.from $ \sheetEdit -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.min_ $ sheetEdit E.^. SheetEditTime
E.where_ $ sheet E.^. SheetCourse E.==. E.val cId
E.orderBy [E.desc creationTime]
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad)
where
toMap :: [(E.Value UserId, E.Value Load)] -> Loads
toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load
correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
correctorForm shid = do
cListIdent <- newFormIdent
let
guardNonDeleted :: UserId -> Handler (Maybe UserId)
guardNonDeleted uid = do
cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser
deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
return $ bool Just (const Nothing) (isJust deleted) uid
formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
let
currentLoads :: DB Loads
currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
(defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if
| Map.null currentLoads'
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warn" MsgCorrectorsDefaulted)
| otherwise -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads'
deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
didDelete = any (flip Set.member deletions) formCIDs
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads'
let
tutorField :: Field Handler [Text]
tutorField = multiEmailField
{ fieldView = \theId name attrs val isReq -> asWidgetT $ do
listIdent <- newIdent
userId <- handlerToWidget requireAuthId
previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
return $ user E.^. UserEmail
[whamlet|
$newline never
<input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
<datalist id=#{listIdent}>
$forall E.Value prev <- previousCorrectors
<option value=#{prev}>
|]
}
(addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
loads <- case addTutRes of
FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
case mUid of
Nothing -> loads'' <$ addMessageI "error" (MsgEMailUnknown email)
Just uid
| not (Map.member uid loads') -> return $ Map.insert uid mempty loads''
| otherwise -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email)
FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs
_ -> return loads''
let deletions' = deletions `Set.difference` Map.keysSet loads
names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys loads)
return $ (user E.^. UserId, user E.^. UserDisplayName)
let
constructFields :: (UserId, Text, Load) -> MForm Handler CorrectorForm
constructFields (uid, uname, Load{..}) = do
cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser
let
fs name = ""
{ fsName = Just $ tshow ciphertext <> "-" <> name
}
rationalField = convertField toRational fromRational doubleField
(byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
(propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
(_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
let
cfResult :: FormResult Load
cfResult = Load <$> tutRes' <*> propRes
tutRes'
| FormSuccess True <- byTutRes = Just <$> countTutRes
| otherwise = Nothing <$ byTutRes
cfUserId = uid
cfUserName = uname
return CorrectorForm{..}
corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
mr <- getMessageRender
$logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
let
corrColonnade = mconcat
[ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
, headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
, headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
, headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
]
corrResults
| FormSuccess (Just es) <- addTutRes
, not $ null es = FormMissing
| didDelete = FormMissing
| otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult
| CorrectorForm{..} <- corrData
]
idField CorrectorForm{..} = do
cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
delField uid = do
cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
return (corrResults, [ countTutView
, FieldView
{ fvLabel = text $ mr MsgCorrectors
, fvTooltip = Nothing
, fvId = ""
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions
, fvErrors = Nothing
, fvRequired = True
}
, addTutView
{ fvInput = [whamlet|
<div>
^{fvInput addTutView}
<button type=submit formnovalidate>Hinzufügen
|]
}
])
-- Eingabebox für Korrektor hinzufügen
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
getSCorrR, postSCorrR :: TermId
-> Text -- ^ Course shorthand
-> Text -- ^ Sheet name
-> Handler Html
postSCorrR = getSCorrR
getSCorrR tid@(unTermKey -> tident) csh shn = do
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
case res of
FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
FormSuccess res -> runDB $ do
deleteWhere [SheetCorrectorSheet ==. shid]
insertMany_ $ Set.toList res
addMessageI "success" MsgCorrectorsUpdated
FormMissing -> return ()
let
formTitle = MsgSheetCorrectorsTitle tident csh shn
formText = Nothing :: Maybe (SomeMessage UniWorX)
actionUrl = CSheetR tid csh shn SCorrR
-- actionUrl = CSheetR tid csh shn SShowR
defaultLayout $ do
setTitleI $ MsgSheetCorrectorsTitle tident csh shn
$(widgetFile "formPageI18n")

6
src/Handler/Users.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
@ -34,7 +35,10 @@ getUsersR = do
Nothing -> "???"
(Just school) -> schoolShorthand school
let colonnadeUsers = mconcat $
[ headed "User" $ text2widget.userDisplayName.entityVal.fst3
[ headed "User" $ \u -> do
cID <- encrypt $ entityKey $ fst3 u
let name = display $ userDisplayName $ entityVal $ fst3 u
[whamlet|<a href=@{AdminUserR cID}>#{name}|]
, headed "Admin for Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool .entityVal) $ snd3 u)
, headed "Lecturer at Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u)
]

30
src/Handler/Utils/Form.hs
View File

@ -52,7 +52,7 @@ import Control.Monad.Writer.Class
-- Unique Form Identifiers to avoid accidents --
------------------------------------------------
data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings
data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors
deriving (Enum, Eq, Ord, Bounded, Read, Show)
@ -104,8 +104,8 @@ instance PathPiece BtnDelete where -- for displaying the button only, not rea
fromPathPiece = readFromPathPiece
instance Button BtnDelete where
label BtnDelete = "Löschen"
label BtnAbort = "Abrechen"
label BtnDelete = [whamlet|_{MsgBtnDelete}|]
label BtnAbort = [whamlet|_{MsgBtnAbort}|]
cssClass BtnDelete = BCDanger
cssClass BtnAbort = BCDefault
@ -119,10 +119,26 @@ instance PathPiece SubmitButton where
fromPathPiece = readFromPathPiece
instance Button SubmitButton where
label BtnSubmit = "Submit"
label BtnSubmit = [whamlet|_{MsgBtnSubmit}|]
cssClass BtnSubmit = BCPrimary
data RegisterButton = BtnRegister | BtnDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance PathPiece RegisterButton where
toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece
instance Button RegisterButton where
label BtnRegister = [whamlet|_{MsgBtnRegister}|]
label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]
cssClass BtnRegister = BCPrimary
cssClass BtnDeregister = BCDanger
-- -- Looks like a button, but is just a link (e.g. for create course, etc.)
-- data LinkButton = LinkButton (Route UniWorX)
-- deriving (Enum, Eq, Ord, Bounded, Read, Show)
@ -142,7 +158,7 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
simpleLink :: Widget -> Route UniWorX -> Widget
simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]
buttonField :: Button a => a -> Field Handler a
buttonField :: Button a => a -> Field Handler a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
where
fieldEnctype = UrlEncoded
@ -231,7 +247,7 @@ buttonForm csrf = do
------------
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => FormMessage -> Field m i
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = checkBool (>= 0) msg intField
natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
@ -471,7 +487,7 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass)
setTooltip :: String -> FieldSettings site -> FieldSettings site
setTooltip tt fs
| null tt = fs { fsTooltip = Nothing }
| otherwise = fs { fsTooltip = Just $ fromString tt }
| otherwise = fs { fsTooltip = Just $ fromString tt, fsAttrs=("info",fromString tt):(fsAttrs fs) }
optionsPersistCryptoId :: forall site backend a msg.
( YesodPersist site

2
src/Model/Types.hs
View File

@ -101,7 +101,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
= Load { byTutorial :: Maybe Bool -- ^ Just all from Tutorial, True if counting towards overall workload
, byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders
}
deriving (Show, Read, Eq)
deriving (Show, Read, Eq, Ord)
derivePersistField "Load"
instance Semigroup Load where

3
src/Settings.hs
View File

@ -71,6 +71,8 @@ data AppSettings = AppSettings
, appAuthDummyLogin :: Bool
-- ^ Indicate if auth dummy login should be enabled.
, appAllowDeprecated :: Bool
-- ^ Indicate if deprecated routes are accessible for everyone
}
instance FromJSON AppSettings where
@ -104,6 +106,7 @@ instance FromJSON AppSettings where
appCryptoIDKeyFile <- o .: "cryptoid-keyfile"
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
return AppSettings {..}

36
src/Utils.hs
View File

@ -13,6 +13,7 @@ module Utils
import ClassyPrelude.Yesod
import Data.List (foldl)
import Data.Foldable as Fold
import qualified Data.Char as Char
import Utils.DB as Utils
@ -211,3 +212,38 @@ shortCircuitM sc mx my op = do
case sc x of
True -> return x
False -> op <$> pure x <*> my
guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f
-- Some Utility Functions from Agda.Utils.Monad
-- | Monadic if-then-else.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM c m m' =
do b <- c
if b then m else m'
-- | @ifNotM mc = ifM (not <$> mc)@
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
ifNotM c = flip $ ifM c
-- | Lazy monadic conjunction.
and2M :: Monad m => m Bool -> m Bool -> m Bool
and2M ma mb = ifM ma mb (return False)
andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
andM = Fold.foldr and2M (return True)
allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
allM xs f = andM $ fmap f xs
-- | Lazy monadic disjunction.
or2M :: Monad m => m Bool -> m Bool -> m Bool
or2M ma mb = ifM ma (return True) mb
orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
orM = Fold.foldr or2M (return False)
anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
anyM xs f = orM $ fmap f xs

4
src/Utils/DB.hs
View File

@ -25,6 +25,10 @@ getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity
=> Unique record -> ReaderT backend m (Key record)
getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m Bool
existsBy = fmap isJust . getBy
myReplaceUnique
:: (MonadIO m

1
start.sh
View File

@ -4,5 +4,6 @@ unset HOST
export DETAILED_LOGGING=true
export LOG_ALL=true
export DUMMY_LOGIN=true
export ALLOW_DEPRECATED=true
exec -- stack exec -- yesod devel

97
templates/course.hamlet
View File

@ -1,54 +1,53 @@
<div .container>
<table>
$maybe school <- schoolMB
<tr>
<th #school>Fakultät/Institut
<div .scrolltable>
<table .table.table--striped.table--hover.table--vertical>
$maybe school <- schoolMB
<tr .table__row>
<th #school>Fakultät/Institut
<td>
#{schoolName school}
$maybe descr <- courseDescription course
<tr .table__row>
<th #description>Beschreibung
<td>
#{descr}
$maybe link <- courseLinkExternal course
<tr .table__row>
<th #website>Website
<td>
<a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
<tr .table__row>
<th #participants>Teilnehmer
<td>
#{schoolName school}
$maybe descr <- courseDescription course
<tr>
<th #description>Beschreibung
#{participants}
$maybe capacity <- courseCapacity course
\ von #{capacity}
<tr .table__row>
<th #registration>Anmeldezeitraum
<td>
#{descr}
$maybe link <- courseLinkExternal course
<tr>
<th #website>Website
$maybe regFrom <- courseRegisterFrom course
#{formatTimeGerWD regFrom}
$maybe regTo <- courseRegisterTo course
\ bis #{formatTimeGerWD regTo}
<tr .table__row>
<th>
<td>
<a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
<tr>
<th #participants>Teilnehmer
<td>
#{participants}
$maybe capacity <- courseCapacity course
\ von #{capacity}
<tr>
<th #registration>Anmeldezeitraum
<td>
$maybe regFrom <- courseRegisterFrom course
#{formatTimeGerWD regFrom}
$maybe regTo <- courseRegisterTo course
\ bis #{formatTimeGerWD regTo}
$if registrationOpen
<div .course__registration.container>
<form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}>
$# regWidget is defined through templates/widgets/registerForm
^{regWidget}
<tr>
<th>
<td>
$# if allowed to register
<div .course__registration.container>
<button class="btn btn-primary">
<a href="#">TODO: Kurs-Anmeldung
$# <form method=post action=@{CourseR tid csh CShow} enctype=#{regEnctype}>
$# ^{regWidget}
<div .container>
<div .tab-group>
<div .tab data-tab-name="Übungsblätter">
^{modal "#modal-toggler__new-sheet" Nothing}
<h3 .tab-title>Übungsblätter
<h1>TODO: Sortierbare Tabelle der bisherigen Übungsblätter
<div .tab data-tab-name="Übungsgruppen">
<h3 .tab-title>Übungsgruppen
<h1>TODO: Sortierbare Tabelle der Übungsgruppen
<div .tab data-tab-name="Klausuren">
<h3 .tab-title>Klausuren
<div>...
$# <div .container>
$# <div .tab-group>
$# <div .tab data-tab-name="Übungsblätter">
$# ^{modal "#modal-toggler__new-sheet" Nothing}
$# <h3 .tab-title>Übungsblätter
$# <h1>TODO: Sortierbare Tabelle der bisherigen Übungsblätter
$# <div .tab data-tab-name="Übungsgruppen">
$# <h3 .tab-title>Übungsgruppen
$# <h1>TODO: Sortierbare Tabelle der Übungsgruppen
$# <div .tab data-tab-name="Klausuren">
$# <h3 .tab-title>Klausuren
$# <div>...

4
templates/course.lucius
View File

@ -1,7 +1,3 @@
.course__registration {
margin-top: 20px;
}
th {
vertical-align: top;
text-align: left;

4
templates/default-layout.lucius
View File

@ -118,11 +118,11 @@ h1 {
}
h2 {
font-size: 24px;
margin: 10px 0 5px;
margin: 10px 0;
}
h3 {
font-size: 20px;
margin: 5px 0;
margin: 10px 0;
}
h4 {
font-size: 16px;

4
templates/formPageI18n.hamlet
View File

@ -1,5 +1,5 @@
$maybe text <- formText
<p>
<h3>
_{text}
<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
^{formWidget}
^{formWidget}

20
templates/standalone/inputs.lucius
View File

@ -1,7 +1,4 @@
/* GENERAL STYLES FOR FORMS */
form {
margin: 20px 0;
}
/* FORM GROUPS */
.form-group {
@ -12,7 +9,7 @@ form {
grid-gap: 5px;
justify-content: flex-start;
align-items: flex-start;
padding: 4px;
padding: 4px 0;
border-left: 2px solid transparent;
+ .form-group {
@ -75,10 +72,16 @@ input[type*="time"] {
padding: 4px 13px;
}
input[type="number"] {
width: 100px;
text-align: right;
}
input[type*="date"],
input[type*="time"] {
input[type*="time"],
.flatpickr-input[type="text"] {
width: 50%;
min-width: 240px;
width: 250px;
}
input[type="text"]:focus,
@ -130,6 +133,7 @@ option {
border-radius: 2px;
outline: 0;
color: #363636;
min-width: 200px;
background-color: #f3f3f3;
box-shadow: inset 0 1px 2px 1px rgba(50,50,50,.05);
}
@ -206,7 +210,7 @@ input[type="checkbox"]:checked::after {
}
:checked + label {
background-color: var(--color-light);
background-color: var(--color-primary);
text-decoration: underline;
}
@ -249,9 +253,7 @@ input[type="checkbox"]:checked::after {
padding: 10px 17px;
border-radius: 3px;
}
.file-input__list {
}
.file-input__input--hidden {
display: none;
}

7
templates/widgets/navbar.julius
View File

@ -18,8 +18,7 @@
}
function update() {
var sticky = window.scrollY > 0;
sticky = sticky && window.innerHeight < (document.scrollingElement.scrollHeight - 200);
var sticky = window.scrollY > 30;
nav.classList.toggle('navbar--sticky', sticky);
ticking = false;
}
@ -28,7 +27,5 @@
})();
document.addEventListener('DOMContentLoaded', function () {
utils.stickynav(document.querySelector('.js-sticky-navbar'));
// utils.stickynav(document.querySelector('.js-sticky-navbar'));
});

16
templates/widgets/navbar.lucius
View File

@ -208,3 +208,19 @@
height: var(--header-height-collapsed);
}
}
@media (max-height: 768px) {
.navbar,
.navbar__pushdown {
height: var(--header-height-collapsed);
}
.navbar__link-wrapper {
height: var(--header-height-collapsed);
}
.navbar__logo {
top: 5px;
}
}

8
templates/widgets/registerForm.hamlet Normal file
View File

@ -0,0 +1,8 @@
$# extra protects us against CSRF
#{extra}
$# Maybe display textField for passcode
$maybe secretView <- msecretView
^{fvInput secretView}
$# Always display register/deregister button
^{fvInput btnView}