364 lines
15 KiB
Haskell
364 lines
15 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
module Handler.Course where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
|
|
-- import Data.Time
|
|
import qualified Data.Text as T
|
|
import Data.Function ((&))
|
|
import Yesod.Form.Bootstrap3
|
|
|
|
import Colonnade hiding (fromMaybe)
|
|
import Yesod.Colonnade
|
|
|
|
import qualified Data.UUID.Cryptographic as UUID
|
|
|
|
|
|
getCourseListR :: Handler TypedContent
|
|
getCourseListR = redirect TermShowR
|
|
|
|
getTermCurrentR :: Handler Html
|
|
getTermCurrentR = do
|
|
termIds <- runDB $ selectKeysList [TermActive ==. True] [] -- [Desc TermName] does not work, since database representation has wrong ordering
|
|
case fromNullable termIds of
|
|
Nothing -> notFound
|
|
(Just (maximum -> tid)) -> getTermCourseListR tid
|
|
|
|
getTermCourseListR :: TermId -> Handler Html
|
|
getTermCourseListR tidini = do
|
|
(term,courses) <- runDB $ (,)
|
|
<$> get tidini
|
|
<*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand]
|
|
when (isNothing term) $ do
|
|
addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |]
|
|
redirect TermShowR
|
|
-- TODO: several runDBs per TableRow are probably too inefficient!
|
|
let colonnadeTerms = mconcat
|
|
[ headed "Kürzel" $ (\ckv ->
|
|
let c = entityVal ckv
|
|
shd = courseShorthand c
|
|
tid = courseTerm c
|
|
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
|
|
, headed "Teilnehmer" $ (\ckv -> do
|
|
let cid = entityKey ckv
|
|
partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourse ==. cid]
|
|
[whamlet| #{show partiNum} |]
|
|
)
|
|
, headed " " $ (\ckv ->
|
|
let c = entityVal ckv
|
|
shd = courseShorthand c
|
|
tid = courseTerm c
|
|
in do
|
|
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 CEditR}>
|
|
editieren
|
|
|]
|
|
)
|
|
]
|
|
let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses
|
|
defaultLayout $ do
|
|
setTitleI . MsgTermCourseListTitle $ unTermKey tidini
|
|
$(widgetFile "courses")
|
|
|
|
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
|
|
dependent <- (,,)
|
|
<$> get (courseSchool course) -- join
|
|
<*> count [CourseParticipantCourse ==. cid] -- join
|
|
<*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
|
|
Nothing -> return False
|
|
(Just aid) -> do
|
|
regL <- getBy (UniqueParticipant aid cid)
|
|
return $ isJust regL)
|
|
return $ (courseEnt,dependent)
|
|
let course = entityVal courseEnt
|
|
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered
|
|
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
|
|
aid <- requireAuthId
|
|
(cid, registered) <- runDB $ do
|
|
(Entity cid _) <- getBy404 $ CourseTermShort tid csh
|
|
registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
|
|
return (cid, registered)
|
|
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered
|
|
case regResult of
|
|
(FormSuccess _)
|
|
| registered -> do
|
|
runDB $ deleteBy $ UniqueParticipant aid cid
|
|
addMessage "info" "Sie wurden abgemeldet."
|
|
| otherwise -> do
|
|
actTime <- liftIO $ getCurrentTime
|
|
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
|
|
when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!"
|
|
(_other) -> return () -- TODO check this!
|
|
-- redirect or not?! I guess not, since we want GET now
|
|
getCShowR tid csh
|
|
|
|
getCourseNewR :: Handler Html
|
|
getCourseNewR = do
|
|
-- TODO: Defaults für Semester hier ermitteln und übergeben
|
|
courseEditHandler True Nothing
|
|
|
|
postCourseNewR :: Handler Html
|
|
postCourseNewR = courseEditHandler False Nothing
|
|
|
|
getCEditR :: TermId -> Text -> Handler Html
|
|
getCEditR tid csh = do
|
|
course <- runDB $ getBy $ CourseTermShort tid csh
|
|
courseEditHandler True course
|
|
|
|
postCEditR :: TermId -> Text -> Handler Html
|
|
postCEditR tid csh = do
|
|
course <- runDB $ getBy $ CourseTermShort tid csh
|
|
courseEditHandler False course
|
|
|
|
getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
|
|
getCourseEditIDR cID = do
|
|
cIDKey <- getsYesod appCryptoIDKey
|
|
courseID <- UUID.decrypt cIDKey cID
|
|
courseEditHandler True =<< runDB (getEntity courseID)
|
|
|
|
|
|
courseDeleteHandler :: Handler Html -- not called anywhere yet
|
|
courseDeleteHandler = undefined
|
|
{- TODO
|
|
| False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
|
|
, Just cid <- cfCourseId res -> do
|
|
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
|
|
let cti = toPathPiece $ cfTerm res
|
|
addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
|
|
redirect $ TermCourseListR $ cfTerm res
|
|
-}
|
|
|
|
courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
|
|
courseEditHandler isGet course = do
|
|
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
|
|
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
|
|
case result of
|
|
(FormSuccess res@(
|
|
CourseForm { cfCourseId = Nothing
|
|
, cfShort = csh
|
|
, cfTerm = tid
|
|
})) -> do -- create new course
|
|
let tident = unTermKey tid
|
|
now <- liftIO getCurrentTime
|
|
insertOkay <- runDB $ insertUnique $ Course
|
|
{ courseName = cfName res
|
|
, courseDescription = cfDesc res
|
|
, courseLinkExternal = cfLink res
|
|
, courseShorthand = cfShort res
|
|
, courseTerm = cfTerm res
|
|
, courseSchool = cfSchool res
|
|
, courseCapacity = cfCapacity res
|
|
, courseHasRegistration = cfHasReg res
|
|
, courseRegisterFrom = cfRegFrom res
|
|
, courseRegisterTo = cfRegTo res
|
|
, courseDeregisterUntil = Nothing -- TODO
|
|
, courseRegisterSecret = Nothing -- TODO
|
|
, courseMaterialFree = True -- TODO
|
|
}
|
|
case insertOkay of
|
|
(Just cid) -> do
|
|
runDB $ do
|
|
insert_ $ CourseEdit aid now cid
|
|
insert_ $ Lecturer aid cid
|
|
addMessageI "info" $ MsgCourseNewOk tident csh
|
|
redirect $ TermCourseListR tid
|
|
Nothing ->
|
|
addMessageI "danger" $ MsgCourseNewDupShort tident csh
|
|
|
|
(FormSuccess res@(
|
|
CourseForm { cfCourseId = Just cid
|
|
, cfShort = csh
|
|
, cfTerm = tid
|
|
})) -> do -- edit existing course
|
|
let tident = unTermKey tid
|
|
now <- liftIO getCurrentTime
|
|
-- addMessage "debug" [shamlet| #{show res}|]
|
|
runDB $ do
|
|
old <- get cid
|
|
case old of
|
|
Nothing -> addMessageI "error" $ MsgInvalidInput
|
|
(Just oldCourse) -> do
|
|
-- existing <- getBy $ CourseTermShort tid csh
|
|
-- if ((entityKey <$> existing) /= Just cid)
|
|
-- then addMessageI "danger" $ MsgCourseEditDupShort tident csh
|
|
-- else do
|
|
-- addMessage "debug" $ fromMaybe [shamlet|No description given.|] $ cfDesc res
|
|
-- update cid
|
|
-- [ CourseName =. cfName res
|
|
-- , CourseDescription =. cfDesc res
|
|
-- , CourseLinkExternal =. cfLink res
|
|
-- , CourseShorthand =. cfShort res -- TODO: change here should generate a warning, or only allowed for Admins?!
|
|
-- , CourseTerm =. tid -- TODO: change here should generate a warning, or only allowed for Admins?!
|
|
-- , CourseSchool =. cfSchool res
|
|
-- , CourseCapacity =. cfCapacity res
|
|
-- , CourseRegisterFrom =. cfRegFrom res
|
|
-- , CourseRegisterTo =. cfRegTo res
|
|
-- , CourseChangedBy =. aid
|
|
-- , CourseChanged =. now
|
|
-- ]
|
|
_updOkay <- replace cid ( -- TODO replaceUnique requires Eq?!
|
|
Course { courseName = cfName res
|
|
, courseDescription = cfDesc res
|
|
, courseLinkExternal = cfLink res
|
|
, courseShorthand = cfShort res
|
|
, courseTerm = cfTerm res
|
|
, courseSchool = cfSchool res
|
|
, courseCapacity = cfCapacity res
|
|
, courseHasRegistration = cfHasReg res
|
|
, courseRegisterFrom = cfRegFrom res
|
|
, courseRegisterTo = cfRegTo res
|
|
, courseDeregisterUntil = Nothing -- TODO
|
|
, courseRegisterSecret = Nothing -- TODO
|
|
, courseMaterialFree = True -- TODO
|
|
}
|
|
)
|
|
insert_ $ CourseEdit aid now cid
|
|
-- if (isNothing updOkay)
|
|
-- then do
|
|
addMessageI "success" $ MsgCourseEditOk tident csh
|
|
-- redirect $ TermCourseListR tid
|
|
-- else addMessageI "danger" $ MsgCourseEditDupShort tident csh
|
|
|
|
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
|
|
(FormMissing) | isGet -> return ()
|
|
other -> addMessage "error" $ [shamlet| Error: #{show other}|]
|
|
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
|
|
defaultLayout $ do
|
|
setTitleI MsgCourseEditTitle
|
|
$(widgetFile "formPage")
|
|
|
|
|
|
data CourseForm = CourseForm
|
|
{ cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse
|
|
, cfName :: Text
|
|
, cfDesc :: Maybe Html
|
|
, cfLink :: Maybe Text
|
|
, cfShort :: Text
|
|
, cfTerm :: TermId
|
|
, cfSchool :: SchoolId
|
|
, cfCapacity :: Maybe Int
|
|
, cfHasReg :: Bool
|
|
, cfRegFrom :: Maybe UTCTime
|
|
, cfRegTo :: Maybe UTCTime
|
|
}
|
|
|
|
instance Show CourseForm where
|
|
show cf = T.unpack (cfShort cf) ++ ' ':(show $ cfCourseId cf)
|
|
|
|
|
|
courseToForm :: Entity Course -> CourseForm
|
|
courseToForm cEntity = CourseForm
|
|
{ cfCourseId = Just $ entityKey cEntity
|
|
, cfName = courseName course
|
|
, cfDesc = courseDescription course
|
|
, cfLink = courseLinkExternal course
|
|
, cfShort = courseShorthand course
|
|
, cfTerm = courseTerm course
|
|
, cfSchool = courseSchool course
|
|
, cfCapacity = courseCapacity course
|
|
, cfHasReg = courseHasRegistration course
|
|
, cfRegFrom = courseRegisterFrom course
|
|
, cfRegTo = courseRegisterTo course
|
|
}
|
|
where
|
|
course = entityVal cEntity
|
|
|
|
newCourseForm :: Maybe CourseForm -> Form CourseForm
|
|
newCourseForm template = identForm FIDcourse $ \html -> do
|
|
-- mopt hiddenField
|
|
-- cidKey <- getsYesod appCryptoIDKey
|
|
-- courseId <- runMaybeT $ do
|
|
-- cid <- cfCourseId template
|
|
-- UUID.encrypt cidKey cid
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
|
-- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
|
|
<$> aopt hiddenField "KursId" (cfCourseId <$> template)
|
|
<*> areq textField (fsb "Name") (cfName <$> template)
|
|
<*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template)
|
|
<*> aopt urlField (fsb "Homepage") (cfLink <$> template)
|
|
<*> areq textField (fsb "Kürzel"
|
|
-- & addAttr "disabled" "disabled"
|
|
& setTooltip "Muss innerhalb des Semesters eindeutig sein")
|
|
(cfShort <$> template)
|
|
<*> 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)
|
|
<* submitButton
|
|
return $ case result of
|
|
FormSuccess courseResult
|
|
| errorMsgs <- validateCourse courseResult
|
|
, not $ null errorMsgs ->
|
|
(FormFailure errorMsgs,
|
|
[whamlet|
|
|
<div class="alert alert-danger">
|
|
<div class="alert__content">
|
|
<h4> Fehler:
|
|
<ul>
|
|
$forall errmsg <- errorMsgs
|
|
<li> #{errmsg}
|
|
^{widget}
|
|
|]
|
|
)
|
|
_ -> (result, widget)
|
|
-- where
|
|
-- cid :: Maybe CourseId
|
|
-- cid = join $ cfCourseId <$> template
|
|
|
|
|
|
validateCourse :: CourseForm -> [Text]
|
|
validateCourse (CourseForm{..}) =
|
|
[ msg | (False, msg) <-
|
|
[
|
|
( cfRegFrom <= 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"
|
|
)
|
|
] ]
|