279 lines
11 KiB
Haskell
279 lines
11 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# 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 Yesod.Form.Bootstrap3
|
|
|
|
import Colonnade
|
|
import Yesod.Colonnade
|
|
|
|
import qualified Data.UUID.Cryptographic as UUID
|
|
|
|
|
|
getCourseListR :: Handler TypedContent
|
|
getCourseListR = redirect TermShowR
|
|
|
|
getCourseListTermR :: TermIdentifier -> Handler Html
|
|
getCourseListTermR tidini = do
|
|
(term,courses) <- runDB $ (,)
|
|
<$> get (TermKey tidini)
|
|
<*> selectList [CourseTermId ==. TermKey tidini] [Asc CourseShorthand]
|
|
when (isNothing term) $ do
|
|
setMessage [shamlet| Semester #{termToText tidini} nicht gefunden. |]
|
|
redirect TermShowR
|
|
let colonnadeTerms = mconcat
|
|
[ headed "Kürzel" $ (\c ->
|
|
let shd = courseShorthand c
|
|
tid = unTermKey $ courseTermId c
|
|
in [whamlet| <a href=@{CourseShowR tid shd}>#{shd} |] )
|
|
-- , headed "Institut" $ [shamlet| #{course} |]
|
|
, headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom
|
|
, headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo
|
|
, headed " " $ (\c ->
|
|
let shd = courseShorthand c
|
|
tid = unTermKey $ courseTermId c
|
|
in do
|
|
adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False
|
|
[whamlet|
|
|
$if adminLink == Authorized
|
|
<a href=@{CourseEditExistR tid shd}>
|
|
editieren
|
|
|] )
|
|
]
|
|
defaultLayout $ do
|
|
setTitle "Semesterkurse"
|
|
encodeHeadedWidgetTable tableDefault colonnadeTerms (map entityVal courses)
|
|
|
|
getCourseShowR :: TermIdentifier -> Text -> Handler Html
|
|
getCourseShowR tid csh = do
|
|
(courseEnt,(schoolMB,participants)) <- runDB $ do
|
|
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh
|
|
dependent <- (,)
|
|
<$> get (courseSchoolId course) -- join
|
|
<*> count [CourseParticipantCourseId ==. cid] -- join
|
|
return $ (courseEnt,dependent)
|
|
let course = entityVal courseEnt
|
|
defaultLayout $ do
|
|
setTitle $ [shamlet| #{termToText tid} - #{csh}|]
|
|
$(widgetFile "course")
|
|
|
|
|
|
getCourseEditR :: Handler Html
|
|
getCourseEditR = do
|
|
-- TODO: Defaults für Semester hier ermitteln und übergeben
|
|
courseEditHandler Nothing
|
|
|
|
postCourseEditR :: Handler Html
|
|
postCourseEditR = courseEditHandler Nothing
|
|
|
|
getCourseEditExistR :: TermIdentifier -> Text -> Handler Html
|
|
getCourseEditExistR tid csh = do
|
|
course <- runDB $ getBy $ CourseTermShort (TermKey tid) csh
|
|
courseEditHandler course
|
|
|
|
getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html
|
|
getCourseEditExistIDR cID = do
|
|
cIDKey <- getsYesod appCryptoIDKey
|
|
courseID <- UUID.decrypt cIDKey cID
|
|
courseEditHandler =<< runDB (getEntity courseID)
|
|
|
|
|
|
courseEditHandler :: Maybe (Entity Course) -> Handler Html
|
|
courseEditHandler course = do
|
|
aid <- requireAuthId
|
|
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
|
|
action <- lookupPostParam "formaction"
|
|
case (result,action) of
|
|
(FormSuccess res, fAct)
|
|
| fAct == formActionDelete
|
|
, Just cid <- cfCourseId res -> do
|
|
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
|
|
let cti = termToText $ cfTerm res
|
|
setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht! |]
|
|
redirect $ CourseListTermR $ cfTerm res
|
|
| fAct == formActionSave
|
|
, Just cid <- cfCourseId res -> do
|
|
actTime <- liftIO getCurrentTime
|
|
runDB $ do
|
|
update cid
|
|
[ CourseName =. cfName res
|
|
, CourseDescription =. cfDesc res
|
|
, CourseLinkExternal =. cfLink res
|
|
, CourseSchoolId =. cfSchool res
|
|
, CourseCapacity =. cfCapacity res
|
|
, CourseRegisterFrom =. cfRegFrom res
|
|
, CourseRegisterTo =. cfRegTo res
|
|
, CourseChangedBy =. aid
|
|
, CourseChanged =. actTime
|
|
]
|
|
let cti = termToText $ cfTerm res
|
|
setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |]
|
|
redirect $ CourseListTermR $ cfTerm res
|
|
| fAct == formActionSave
|
|
, Nothing <- cfCourseId res -> do
|
|
actTime <- liftIO getCurrentTime
|
|
insertOkay <- runDB $ insertUnique $ Course
|
|
{ courseName = cfName res
|
|
, courseDescription = cfDesc res
|
|
, courseLinkExternal = cfLink res
|
|
, courseShorthand = cfShort res
|
|
, courseTermId = TermKey $ cfTerm res
|
|
, courseSchoolId = cfSchool res
|
|
, courseCapacity = cfCapacity res
|
|
, courseHasRegistration = cfHasReg res
|
|
, courseRegisterFrom = cfRegFrom res
|
|
, courseRegisterTo = cfRegTo res
|
|
, courseCreated = actTime
|
|
, courseChanged = actTime
|
|
, courseCreatedBy = aid
|
|
, courseChangedBy = aid
|
|
}
|
|
case insertOkay of
|
|
(Just cid) -> do
|
|
runDB $ insert_ $ Lecturer aid cid
|
|
let cti = termToText $ cfTerm res
|
|
setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde angelegt. |]
|
|
redirect $ CourseListTermR $ cfTerm res
|
|
Nothing -> do
|
|
let cti = termToText $ cfTerm res
|
|
setMessage $ [shamlet|
|
|
<div .alert .alert-danger>
|
|
Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.
|
|
|]
|
|
(FormFailure _,_) -> setMessage "Bitte Eingabe korrigieren."
|
|
_other -> return ()
|
|
let formTitle = "Kurs editieren/anlegen" :: Text
|
|
let actionUrl = CourseEditR
|
|
let formActions = defaultFormActions
|
|
defaultLayout $ do
|
|
setTitle [shamlet| #{formTitle} |]
|
|
$(widgetFile "generic_form")
|
|
|
|
|
|
data CourseForm = CourseForm
|
|
{ cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse
|
|
, cfName :: Text
|
|
, cfDesc :: Maybe Html
|
|
, cfLink :: Maybe Text
|
|
, cfShort :: Text
|
|
, cfTerm :: TermIdentifier
|
|
, 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 = unTermKey $ courseTermId course
|
|
, cfSchool = courseSchoolId course
|
|
, cfCapacity = courseCapacity course
|
|
, cfHasReg = courseHasRegistration course
|
|
, cfRegFrom = courseRegisterFrom course
|
|
, cfRegTo = courseRegisterTo course
|
|
}
|
|
where
|
|
course = entityVal cEntity
|
|
|
|
newCourseForm :: Maybe CourseForm -> Form CourseForm
|
|
newCourseForm template html = do
|
|
-- mopt hiddenField
|
|
-- cidKey <- getsYesod appCryptoIDKey
|
|
-- courseId <- runMaybeT $ do
|
|
-- cid <- cfCourseId template
|
|
-- UUID.encrypt cidKey cid
|
|
(result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm
|
|
-- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
|
|
<$> aopt hiddenField "KursId" (cfCourseId <$> template)
|
|
<*> areq textField (set "Name") (cfName <$> template)
|
|
<*> aopt htmlField (set "Beschreibung") (cfDesc <$> template)
|
|
<*> aopt urlField (set "Homepage") (cfLink <$> template)
|
|
<*> areq textField (setToolt "Kürzel" "Muss innerhalb des Semesters eindeutig sein") (cfShort <$> template)
|
|
<*> areq termExistsField (set "Semester") (cfTerm <$> template)
|
|
<*> areq (selectField schools) (set "Institut") (cfSchool <$> template)
|
|
<*> aopt (natField "Kapazität") (set "Kapazität") (cfCapacity <$> template)
|
|
<*> areq checkBoxField (set "Anmeldung") (cfHasReg <$> template)
|
|
<*> aopt utcTimeField (set "Anmeldung von:") (cfRegFrom <$> template)
|
|
<*> aopt utcTimeField (set "Anmeldung bis:") (cfRegTo <$> template)
|
|
-- <* bootstrapSubmit (bsSubmit (show cid))
|
|
return $ case result of
|
|
FormSuccess courseResult
|
|
| errorMsgs <- validateCourse courseResult
|
|
, not $ null errorMsgs ->
|
|
(FormFailure errorMsgs,
|
|
[whamlet|
|
|
<div class="alert alert-danger">
|
|
<h4> Fehler:
|
|
<ul>
|
|
$forall errmsg <- errorMsgs
|
|
<li> #{errmsg}
|
|
^{widget}
|
|
|]
|
|
)
|
|
_ -> (result, widget)
|
|
where
|
|
cid :: Maybe CourseId
|
|
cid = join $ cfCourseId <$> template
|
|
|
|
set :: Text -> FieldSettings site
|
|
set = bfs
|
|
|
|
setAttrs :: Text -> [(Text,Text)] -> FieldSettings site
|
|
setAttrs t attrs =
|
|
let ifs = bfs t in ifs { fsAttrs= attrs++(fsAttrs ifs) }
|
|
|
|
setToolt :: Text -> String -> FieldSettings site
|
|
setToolt t tt =
|
|
let ifs = bfs t in ifs { fsTooltip= Just $ fromString tt }
|
|
|
|
-- schools :: GHandler UniWorX UniWorX (OptionList SchoolId)
|
|
schools = do
|
|
entities <- runDB $ selectList [] [Asc SchoolShorthand]
|
|
optionsPairs $ map (\school -> (schoolShorthand $ entityVal school, entityKey school)) entities
|
|
|
|
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"
|
|
)
|
|
] ]
|
|
|
|
|