367 lines
16 KiB
Haskell
367 lines
16 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Term
|
|
( getTermShowR
|
|
, getTermEditR, postTermEditR
|
|
, getTermEditExistR, postTermEditExistR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Course (mayViewCourse)
|
|
import Utils.Holidays (bankHolidaysAreaSet, Feiertagsgebiet(..))
|
|
|
|
import Handler.Utils
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Map.Strict ((!))
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
|
|
|
|
validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
|
=> FormValidator TermForm m ()
|
|
validateTerm = do
|
|
TermForm{..} <- State.get
|
|
guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
|
|
guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
|
|
guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart
|
|
guardValidation MsgTermEndMustBeAfterLectureEnd $ tfEnd >= tfLectureEnd
|
|
|
|
|
|
getTermShowR :: Handler Html
|
|
getTermShowR = do
|
|
muid <- maybeAuthId
|
|
now <- liftIO getCurrentTime
|
|
ata <- getSessionActiveAuthTags
|
|
table <- runDB $
|
|
let termDBTable = DBTable{..}
|
|
where dbtSQLQuery term = return (term, courseCount, isActive)
|
|
where courseCount = E.subSelectCount . E.from $ \course ->
|
|
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
|
|
E.&&. mayViewCourse muid ata now course
|
|
isActive = termIsActiveE (E.val now) (E.val muid) (term E.^. TermId)
|
|
dbtRowKey = (E.^. TermId)
|
|
dbtProj = dbrOutput <$> dbtProjId
|
|
dbtColonnade = widgetColonnade $ mconcat
|
|
[ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _, _)
|
|
-> cell $ do
|
|
mayEdit <- hasWriteAccessTo $ TermEditExistR tid
|
|
[whamlet|
|
|
$newline never
|
|
<a href=@{TermCourseListR tid}>
|
|
#{toPathPiece tid}
|
|
$if mayEdit
|
|
|
|
<a href=@{TermEditExistR tid}>
|
|
#{iconMenuAdmin}
|
|
|]
|
|
, sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_,_)
|
|
-> cell $ formatTime SelFormatDate termLectureStart >>= toWidget
|
|
, sortable (Just "lecture-end") (i18nCell MsgTermLectureEnd) $ \(Entity _ Term{..},_,_)
|
|
-> cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
|
|
, sortable Nothing (i18nCell MsgTermActive) $ \(_, _, E.Value isActive)
|
|
-> tickmarkCell isActive
|
|
, sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses, _)
|
|
-> cell [whamlet|_{MsgNumCourses numCourses}|]
|
|
, sortable (Just "start") (i18nCell MsgTermStart) $ \(Entity _ Term{..},_, _)
|
|
-> cell $ formatTime SelFormatDate termStart >>= toWidget
|
|
, sortable (Just "end") (i18nCell MsgTermEnd) $ \(Entity _ Term{..},_, _)
|
|
-> cell $ formatTime SelFormatDate termEnd >>= toWidget
|
|
, sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_, _)
|
|
-> cell $ do
|
|
let termHolidays' = groupHolidays termHolidays
|
|
[whamlet|
|
|
$newline never
|
|
<ul .list--inline .list--comma-separated>
|
|
$forall holiday <- termHolidays'
|
|
<li>
|
|
$case holiday
|
|
$of Left singleHoliday
|
|
^{formatTimeW SelFormatDate singleHoliday}
|
|
$of Right (startD, endD)
|
|
^{formatTimeRangeW SelFormatDate startD (Just endD)}
|
|
|]
|
|
]
|
|
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 -> termIsActiveE (E.val now) (E.val muid) (term E.^. TermId) :: 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
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
termDBTableValidator = def & defaultSorting [SortDescBy "term-id"]
|
|
in dbTableWidget' termDBTableValidator termDBTable
|
|
defaultLayout $ do
|
|
setTitleI MsgTermsHeading
|
|
$(widgetFile "terms")
|
|
|
|
getTermEditR, postTermEditR :: Handler Html
|
|
getTermEditR = postTermEditR
|
|
postTermEditR = do
|
|
mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
|
|
let template = case mbLastTerm of
|
|
Nothing -> mempty
|
|
(Just Entity{ entityVal=Term{..}})
|
|
-> let ntid = succ termName
|
|
tStart = guessDay ntid TermDayStart
|
|
tEnd = guessDay ntid TermDayEnd
|
|
tLecStart = guessDay ntid TermDayLectureStart
|
|
tLecEnd = guessDay ntid TermDayLectureEnd
|
|
tHolys = Set.toAscList $
|
|
Set.filter (tStart <=) $
|
|
Set.filter (tEnd >=) $
|
|
Set.unions $ bankHolidaysAreaSet Fraport <$> [getYear tStart..getYear tEnd]
|
|
in mempty
|
|
{ tftName = Just ntid
|
|
, tftStart = Just tStart
|
|
, tftEnd = Just tEnd
|
|
, tftLectureStart = Just tLecStart
|
|
, tftLectureEnd = Just tLecEnd
|
|
, tftHolidays = Just tHolys
|
|
}
|
|
termEditHandler Nothing template
|
|
|
|
getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
|
|
getTermEditExistR = postTermEditExistR
|
|
postTermEditExistR tid = do
|
|
(term, active) <- runDB $ do
|
|
term <- get tid
|
|
active <- selectList [ TermActiveTerm ==. tid ] []
|
|
return (term, map entityVal active)
|
|
termEditHandler (Just tid) $ termToTemplate term (map termActiveToForm active)
|
|
|
|
|
|
termEditHandler :: Maybe TermId -> TermFormTemplate -> Handler Html
|
|
termEditHandler mtid template = do
|
|
eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
|
|
((result, formWidget), formEnctype) <- runFormPost $ newTermForm mtid template
|
|
case result of
|
|
(FormSuccess TermForm{..}) -> exceptT (addMessageI Error) return $ do
|
|
let tid = TermKey tfName
|
|
hoist runDB $ do
|
|
let term = Term
|
|
{ termName = tfName
|
|
, termStart = tfStart
|
|
, termEnd = tfEnd
|
|
, termHolidays = tfHolidays
|
|
, termLectureStart = tfLectureStart
|
|
, termLectureEnd = tfLectureEnd
|
|
}
|
|
case mtid of
|
|
Just oTId | tid == oTId ->
|
|
lift $ replace tid term
|
|
_other -> do
|
|
whenM (lift $ exists [TermName ==. tfName]) $
|
|
throwE MsgTermExists
|
|
lift $ insertKey tid term
|
|
|
|
lift $ deleteWhere [TermActiveTerm ==. tid]
|
|
forM_ tfActive $ \TermActiveForm{..} ->
|
|
lift $ insert_ TermActive
|
|
{ termActiveTerm = tid
|
|
, termActiveFrom = tafFrom
|
|
, termActiveTo = tafTo
|
|
, termActiveFor = tafFor
|
|
}
|
|
lift . audit $ TransactionTermEdit tid
|
|
addMessageI Success $ MsgTermEdited tid
|
|
redirect TermShowR
|
|
FormMissing -> return ()
|
|
FormFailure [] -> addMessageI Error MsgInvalidInput
|
|
FormFailure msgs -> forM_ msgs (addMessage Error . toHtml)
|
|
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 [TermActiveForm]
|
|
}
|
|
|
|
-- | TermFormTemplates form a pointwise-left biased Semigroup
|
|
instance Semigroup TermFormTemplate where
|
|
l <> r = TermFormTemplate
|
|
{ tftName = tftName l <|> tftName r
|
|
, tftStart = tftStart l <|> tftStart r
|
|
, tftEnd = tftEnd l <|> tftEnd r
|
|
, tftHolidays = tftHolidays l <|> tftHolidays r
|
|
, tftLectureStart = tftLectureStart l <|> tftLectureStart r
|
|
, tftLectureEnd = tftLectureEnd l <|> tftLectureEnd r
|
|
, tftActive = tftActive l <|> tftActive r
|
|
}
|
|
|
|
instance Monoid TermFormTemplate where
|
|
mappend = (<>)
|
|
mempty = TermFormTemplate
|
|
{ tftName = Nothing
|
|
, tftStart = Nothing
|
|
, tftEnd = Nothing
|
|
, tftHolidays = Nothing
|
|
, tftLectureStart = Nothing
|
|
, tftLectureEnd = Nothing
|
|
, tftActive = Nothing
|
|
}
|
|
|
|
termToTemplate :: Maybe Term -> [TermActiveForm] -> TermFormTemplate
|
|
termToTemplate Nothing active = mempty { tftActive = Just active }
|
|
termToTemplate (Just Term{..}) active = TermFormTemplate
|
|
{ tftName = Just termName
|
|
, tftStart = Just termStart
|
|
, tftEnd = Just termEnd
|
|
, tftHolidays = Just termHolidays
|
|
, tftLectureStart = Just termLectureStart
|
|
, tftLectureEnd = Just termLectureEnd
|
|
, tftActive = Just active
|
|
}
|
|
|
|
data TermActiveForm = TermActiveForm
|
|
{ tafFrom :: UTCTime
|
|
, tafTo :: Maybe UTCTime
|
|
, tafFor :: Maybe UserId
|
|
} deriving (Eq)
|
|
|
|
termActiveToForm :: TermActive -> TermActiveForm
|
|
termActiveToForm TermActive{..} = TermActiveForm
|
|
{ tafFrom = termActiveFrom
|
|
, tafTo = termActiveTo
|
|
, tafFor = termActiveFor
|
|
}
|
|
|
|
data TermForm = TermForm
|
|
{ tfName :: TermIdentifier
|
|
, tfStart :: Day
|
|
, tfEnd :: Day
|
|
, tfHolidays :: [Day]
|
|
, tfLectureStart :: Day
|
|
, tfLectureEnd :: Day
|
|
, tfActive :: [TermActiveForm]
|
|
}
|
|
|
|
newTermForm :: Maybe TermId -> TermFormTemplate -> Form TermForm
|
|
newTermForm mtid template = validateForm validateTerm $ \html -> do
|
|
cRoute <- fromMaybe (error "newTermForm called from 404-Handler") <$> getCurrentRoute
|
|
mr <- getMessageRender
|
|
let
|
|
tidForm
|
|
| Just tid <- unTermKey <$> mtid
|
|
= aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
|
|
| otherwise
|
|
= areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
|
|
holidayForm = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired
|
|
where
|
|
miAdd mkUnique submitView csrf = do
|
|
(fromRes, fromView) <- mpreq dayField ("" & addName (mkUnique "from") & addPlaceholder (mr MsgTermHolidayPlaceholder)) Nothing
|
|
(toRes, toView) <- mopt dayField ("" & addName (mkUnique "to") & addPlaceholder (mr MsgTermHolidayPlaceholder)) Nothing
|
|
let
|
|
holidaysRes = case (fromRes, toRes) of
|
|
(FormSuccess f, FormSuccess (Just t)) -> FormSuccess $ Right (f, t)
|
|
(FormSuccess f, FormSuccess Nothing) -> FormSuccess $ Left f
|
|
(FormSuccess f, FormMissing) -> FormSuccess $ Left f
|
|
(f, tRes) -> fmap Left f <* tRes
|
|
holidaysRes' = holidaysRes <&> \newDat oldDat -> if
|
|
| let newUngrouped = Set.fromList . ungroupHolidays $ pure newDat
|
|
oldUngrouped = Set.fromList $ ungroupHolidays oldDat
|
|
, newUngrouped `Set.isSubsetOf` oldUngrouped
|
|
-> FormFailure [mr MsgTermFormHolidaysAlreadyAdded]
|
|
| otherwise
|
|
-> FormSuccess $ pure newDat
|
|
return (holidaysRes', $(widgetFile "term/holiday-mass-input/add"))
|
|
miCell x = $(widgetFile "term/holiday-mass-input/cell")
|
|
where (f, t) = case x of
|
|
Left d -> (d, Nothing)
|
|
Right (f', t') -> (f', Just t')
|
|
miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction = Just . SomeRoute . (cRoute :#:)
|
|
miLayout :: MassInputLayout ListLength (Either Day (Day, Day)) ()
|
|
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "term/holiday-mass-input/layout")
|
|
miIdent :: Text
|
|
miIdent = "holidays"
|
|
fSettings = fslI MsgTermHolidays
|
|
fRequired = False
|
|
ungroupHolidays = foldMap $ \case
|
|
Left d -> pure d
|
|
Right (f, t) -> [f..t]
|
|
activeForm = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired
|
|
where
|
|
miAdd mkUnique submitView csrf = do
|
|
(fromRes, fromView) <- mpreq utcTimeField ("" & addName (mkUnique "from")) Nothing
|
|
(toRes, toView) <- mopt utcTimeField ("" & addName (mkUnique "to")) Nothing
|
|
(forRes, forView) <- mopt (checkMap (first $ const MsgTermFormActiveUserNotFound) Right $ userField False Nothing) ("" & addName (mkUnique "for") & addPlaceholder (mr MsgTermActiveForPlaceholder)) Nothing
|
|
|
|
let res = TermActiveForm <$> fromRes <*> toRes <*> forRes
|
|
res' = res <&> \newDat oldDat -> if
|
|
| newDat `elem` oldDat
|
|
-> FormFailure [mr MsgTermFormActiveAlreadyAdded]
|
|
| otherwise
|
|
-> FormSuccess $ pure newDat
|
|
return (res', $(widgetFile "term/active-mass-input/add"))
|
|
miCell TermActiveForm{..} = do
|
|
user <- for tafFor $ liftHandler . runDB . get404
|
|
$(widgetFile "term/active-mass-input/cell")
|
|
miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction = Just . SomeRoute . (cRoute :#:)
|
|
miLayout :: MassInputLayout ListLength TermActiveForm ()
|
|
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "term/active-mass-input/layout")
|
|
miIdent :: Text
|
|
miIdent = "active-periods"
|
|
fSettings = fslI MsgTermActive & setTooltip MsgTermActiveTooltip
|
|
fRequired = False
|
|
flip (renderAForm FormStandard) html $ TermForm
|
|
<$> tidForm
|
|
<*> areq dayField (fslI MsgTermStartDay) (tftStart template)
|
|
<*> areq dayField (fslI MsgTermEndDay ) (tftEnd template)
|
|
<*> (ungroupHolidays <$> holidayForm (groupHolidays <$> tftHolidays template))
|
|
<*> areq dayField (fslI MsgTermLectureStart & setTooltip MsgTermLectureStartTooltip) (tftLectureStart template)
|
|
<*> areq dayField (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
|
|
<*> activeForm (tftActive template)
|
|
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
} ''TermActiveForm
|