288 lines
11 KiB
Haskell
288 lines
11 KiB
Haskell
module Handler.Term where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Utils.Table.Cells
|
|
import qualified Data.Map as Map
|
|
|
|
import Utils.Lens
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
|
|
-- | Default start day of term for season,
|
|
-- @True@: start of term, @False@: end of term
|
|
defaultDay :: Bool -> Season -> Day
|
|
defaultDay True Winter = fromGregorian 2020 10 1
|
|
defaultDay False Winter = fromGregorian 2020 3 31
|
|
defaultDay True Summer = fromGregorian 2020 4 1
|
|
defaultDay False Summer = fromGregorian 2020 9 30
|
|
|
|
|
|
validateTerm :: Term -> [Text]
|
|
validateTerm Term{..} =
|
|
[ msg | (False, msg) <-
|
|
[ --startOk
|
|
( termStart `withinTerm` termName
|
|
, "Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein."
|
|
)
|
|
, -- endOk
|
|
( termStart < termEnd
|
|
, "Semester darf nicht enden, bevor es begann."
|
|
)
|
|
, -- startOk
|
|
( termLectureStart < termLectureEnd
|
|
, "Vorlesungszeit muss vor ihrem Ende anfgangen."
|
|
)
|
|
, -- lecStartOk
|
|
( termStart <= termLectureStart
|
|
, "Semester muss vor der Vorlesungszeit beginnen."
|
|
)
|
|
, -- lecEndOk
|
|
( termEnd >= termLectureEnd
|
|
, "Vorlesungszeit muss vor dem Semester enden."
|
|
)
|
|
] ]
|
|
|
|
|
|
|
|
|
|
getTermShowR :: Handler TypedContent
|
|
getTermShowR = do
|
|
-- terms <- runDB $ selectList [] [Desc TermStart]
|
|
------- ÄQUIVALENT:
|
|
-- term <- runDB $ E.select . E.from $ \(term) -> do
|
|
-- E.orderBy [E.desc $ term E.^. TermStart ]
|
|
-- return term
|
|
--
|
|
let
|
|
termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64))
|
|
termData term = do
|
|
-- E.orderBy [E.desc $ term E.^. TermStart ]
|
|
let courseCount = E.sub_select . E.from $ \course -> do
|
|
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
|
|
return E.countRows
|
|
return (term, courseCount)
|
|
selectRep $ do
|
|
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
|
|
provideRep $ do
|
|
let colonnadeTerms = widgetColonnade $ mconcat
|
|
[ sortable (Just "term-id") "Kürzel" $ \(Entity tid _, _) -> anchorCell
|
|
(TermCourseListR tid)
|
|
[whamlet|#{toPathPiece tid}|]
|
|
, sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
|
|
cell $ formatTime SelFormatDate termLectureStart >>= toWidget
|
|
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
|
|
cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
|
|
, sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
|
|
tickmarkCell termActive
|
|
, sortable Nothing "Kurse" $ \(_, E.Value numCourses) ->
|
|
cell [whamlet|_{MsgNumCourses numCourses}|]
|
|
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
|
|
cell $ formatTime SelFormatDate termStart >>= toWidget
|
|
, sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) ->
|
|
cell $ formatTime SelFormatDate termEnd >>= toWidget
|
|
, sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
|
|
cell $ do
|
|
termHolidays' <- mapM (formatTime SelFormatDate) termHolidays
|
|
[whamlet|
|
|
$newline never
|
|
<ul .list--inline .list--comma-separated>
|
|
$forall holiday <- termHolidays'
|
|
<li>#{holiday}
|
|
|]
|
|
]
|
|
-- let adminColonnade =
|
|
-- [ sortable Nothing "Edit" $ \(Entity tid Term{..},_) -> cell $ do
|
|
-- -- Scrap this if to slow, create term edit page instead
|
|
-- adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
|
|
-- [whamlet|
|
|
-- $if adminLink == Authorized
|
|
-- <a href=@{TermEditExistR tid}>
|
|
-- #{termToText termName}
|
|
-- $else
|
|
-- #{termToText termName}
|
|
-- |]
|
|
-- ]
|
|
let validator = def & defaultSorting [SortDescBy "term-id"]
|
|
table <- runDB $ dbTableWidget' validator DBTable
|
|
{ dbtSQLQuery = termData
|
|
, dbtRowKey = (E.^. TermId)
|
|
, dbtColonnade = colonnadeTerms
|
|
, dbtProj = return . dbrOutput
|
|
, dbtSorting = Map.fromList
|
|
[ ( "start"
|
|
, SortColumn $ \term -> term E.^. TermStart
|
|
)
|
|
, ( "end"
|
|
, SortColumn $ \term -> term E.^. TermEnd
|
|
)
|
|
, ( "lecture-start"
|
|
, SortColumn $ \term -> term E.^. TermLectureStart
|
|
)
|
|
, ( "lecture-end"
|
|
, SortColumn $ \term -> term E.^. TermLectureEnd
|
|
)
|
|
, ( "term-id"
|
|
, SortColumn $ \term -> term E.^. TermId
|
|
)
|
|
]
|
|
, dbtFilter = Map.fromList
|
|
[ ( "active"
|
|
, FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool)
|
|
)
|
|
, ( "course"
|
|
, FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
|
|
[] -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
cshs -> E.exists . E.from $ \course ->
|
|
E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
|
|
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
|
|
)
|
|
]
|
|
, dbtFilterUI = mempty
|
|
, dbtStyle = def
|
|
, dbtParams = def
|
|
, dbtIdent = "terms" :: Text
|
|
}
|
|
defaultLayout $ do
|
|
setTitleI MsgTermsHeading
|
|
$(widgetFile "terms")
|
|
|
|
getTermEditR, postTermEditR :: Handler Html
|
|
getTermEditR = do
|
|
mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
|
|
let template = case mbLastTerm of
|
|
Nothing -> mempty
|
|
(Just Entity{ entityVal=Term{..}}) -> let
|
|
ntid = succ termName
|
|
seas = season ntid
|
|
yr = year ntid
|
|
yr' = if seas == Summer then yr else succ yr
|
|
in mempty
|
|
{ tftName = Just ntid
|
|
, tftStart = Just $ defaultDay True seas & setYear yr
|
|
, tftEnd = Just $ defaultDay False seas & setYear yr'
|
|
}
|
|
termEditHandler template
|
|
postTermEditR = termEditHandler mempty
|
|
|
|
getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
|
|
getTermEditExistR = postTermEditExistR
|
|
postTermEditExistR tid = do
|
|
term <- runDB $ get tid
|
|
termEditHandler $ termToTemplate term
|
|
|
|
|
|
termEditHandler :: TermFormTemplate -> Handler Html
|
|
termEditHandler term = do
|
|
Just eHandler <- getCurrentRoute
|
|
((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
|
|
case result of
|
|
(FormSuccess res) -> do
|
|
let tid = TermKey $ termName res
|
|
-- term <- runDB $ get $ TermKey termName
|
|
runDB $ repsert tid res
|
|
-- VOR INTERNATIONALISIERUNG:
|
|
-- let tid = termToText $ termName res
|
|
-- let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."
|
|
-- addMessage Success [shamlet| #{msg} |]
|
|
-- MIT INTERNATIONALISIERUNG:
|
|
addMessageI Success $ MsgTermEdited tid
|
|
redirect TermShowR
|
|
FormMissing -> return ()
|
|
(FormFailure _) -> addMessageI Warning MsgInvalidInput
|
|
defaultLayout $ do
|
|
setTitleI MsgTermEditHeading
|
|
wrapForm formWidget def
|
|
{ formAction = Just $ SomeRoute eHandler
|
|
, formEncoding = formEnctype
|
|
}
|
|
|
|
data TermFormTemplate = TermFormTemplate
|
|
{ tftName :: Maybe TermIdentifier
|
|
, tftStart :: Maybe Day
|
|
, tftEnd :: Maybe Day
|
|
, tftHolidays :: Maybe [Day]
|
|
, tftLectureStart :: Maybe Day
|
|
, tftLectureEnd :: Maybe Day
|
|
, tftActive :: Maybe Bool
|
|
}
|
|
|
|
-- | TermFormTemplates form a pointwise-left biased Semigroup
|
|
instance Semigroup TermFormTemplate where
|
|
left <> right = TermFormTemplate
|
|
{ tftName = tftName left <|> tftName right
|
|
, tftStart = tftStart left <|> tftStart right
|
|
, tftEnd = tftEnd left <|> tftEnd right
|
|
, tftHolidays = tftHolidays left <|> tftHolidays right
|
|
, tftLectureStart = tftLectureStart left <|> tftLectureStart right
|
|
, tftLectureEnd = tftLectureEnd left <|> tftLectureEnd right
|
|
, tftActive = tftActive left <|> tftActive right
|
|
}
|
|
|
|
instance Monoid TermFormTemplate where
|
|
mappend = (<>)
|
|
mempty = TermFormTemplate
|
|
{ tftName = Nothing
|
|
, tftStart = Nothing
|
|
, tftEnd = Nothing
|
|
, tftHolidays = Nothing
|
|
, tftLectureStart = Nothing
|
|
, tftLectureEnd = Nothing
|
|
, tftActive = Nothing
|
|
}
|
|
|
|
termToTemplate ::Maybe Term -> TermFormTemplate
|
|
termToTemplate Nothing = mempty
|
|
termToTemplate (Just Term{..}) = TermFormTemplate
|
|
{ tftName = Just termName
|
|
, tftStart = Just termStart
|
|
, tftEnd = Just termEnd
|
|
, tftHolidays = Just termHolidays
|
|
, tftLectureStart = Just termLectureStart
|
|
, tftLectureEnd = Just termLectureEnd
|
|
, tftActive = Just termActive
|
|
}
|
|
|
|
newTermForm :: TermFormTemplate -> Form Term
|
|
newTermForm template html = do
|
|
mr <- getMessageRender
|
|
let
|
|
tidForm
|
|
| Just tid <- tftName template
|
|
= aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
|
|
| otherwise
|
|
= areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
|
|
holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) ("holidays" :: Text) (fslI MsgTermHolidays & setTooltip MsgMassInputTip) True (tftHolidays template) mempty
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ Term
|
|
<$> tidForm
|
|
<*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
|
|
<*> areq dayField (fslI MsgTermEndDay & setTooltip MsgTermEndDayTooltip) (tftEnd template)
|
|
<*> (Set.toList . Set.fromList <$> holidayForm)
|
|
<*> areq dayField (fslI MsgTermLectureStart) (tftLectureStart template)
|
|
<*> areq dayField (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
|
|
<*> areq checkBoxField (fslI MsgTermActive) (tftActive template)
|
|
return $ case result of
|
|
FormSuccess termResult
|
|
| errorMsgs <- validateTerm termResult
|
|
, 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
|
|
set :: Text -> FieldSettings site
|
|
set = bfs
|
|
-}
|