368 lines
16 KiB
Haskell
368 lines
16 KiB
Haskell
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.LeftOuterJoin` allocation) -> do
|
||
E.on . E.exists . E.from $ \allocationCourse ->
|
||
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||
E.&&. E.just (allocationCourse E.^. AllocationCourseAllocation) E.==. allocation E.?. AllocationId
|
||
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
|
||
E.&&. mayViewCourse muid ata now course (allocation E.?. AllocationId)
|
||
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'
|
||
$case holiday
|
||
$of Left singleHoliday
|
||
<li>^{formatTimeW SelFormatDate singleHoliday}
|
||
$of Right (startD, endD)
|
||
<li>
|
||
^{formatTimeW SelFormatDate startD}
|
||
–
|
||
^{formatTimeW SelFormatDate 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
|