281 lines
12 KiB
Haskell
281 lines
12 KiB
Haskell
module Handler.Term
|
||
( getTermShowR
|
||
, getTermEditR, postTermEditR
|
||
, getTermEditExistR, postTermEditExistR
|
||
) where
|
||
|
||
import Import
|
||
|
||
import Utils.Course (mayViewCourse)
|
||
|
||
import Handler.Utils
|
||
|
||
import qualified Data.Map as Map
|
||
|
||
import qualified Database.Esqueleto as E
|
||
|
||
import qualified Data.Set as Set
|
||
|
||
import qualified Control.Monad.State.Class as State
|
||
|
||
import Data.Time.Calendar.WeekDate
|
||
|
||
|
||
data TermDay
|
||
= TermDayStart | TermDayEnd
|
||
| TermDayLectureStart | TermDayLectureEnd
|
||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||
deriving anyclass (Universe, Finite)
|
||
|
||
guessDay :: TermIdentifier
|
||
-> TermDay
|
||
-> Day
|
||
guessDay TermIdentifier{ year, season = Winter } TermDayStart
|
||
= fromGregorian year 10 1
|
||
guessDay TermIdentifier{ year, season = Winter } TermDayEnd
|
||
= fromGregorian (succ year) 3 31
|
||
guessDay TermIdentifier{ year, season = Summer } TermDayStart
|
||
= fromGregorian year 4 1
|
||
guessDay TermIdentifier{ year, season = Summer } TermDayEnd
|
||
= fromGregorian year 9 30
|
||
guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureStart
|
||
= fromWeekDate year (wWeekStart + 2) 1
|
||
where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||
guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureEnd
|
||
= fromWeekDate (succ year) ((wWeekStart + 21) `div` bool 53 54 longYear) 5
|
||
where longYear = is _Just $ fromWeekDateValid year 53 1
|
||
(_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||
guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureStart
|
||
= fromWeekDate year (wWeekStart + 2) 1
|
||
where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||
guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureEnd
|
||
= fromWeekDate year (wWeekStart + 17) 5
|
||
where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||
|
||
|
||
validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||
=> FormValidator Term m ()
|
||
validateTerm = do
|
||
Term{..} <- State.get
|
||
guardValidation MsgTermStartMustMatchName $ termStart `withinTerm` termName
|
||
guardValidation MsgTermEndMustBeAfterStart $ termStart < termEnd
|
||
guardValidation MsgTermLectureEndMustBeAfterStart $ termLectureStart < termLectureEnd
|
||
guardValidation MsgTermStartMustBeBeforeLectureStart $ termStart <= termLectureStart
|
||
guardValidation MsgTermEndMustBeAfterLectureEnd $ termEnd >= termLectureEnd
|
||
|
||
|
||
getTermShowR :: Handler Html
|
||
getTermShowR = do
|
||
muid <- maybeAuthId
|
||
now <- liftIO getCurrentTime
|
||
ata <- getSessionActiveAuthTags
|
||
table <- runDB $
|
||
let termDBTable = DBTable{..}
|
||
where dbtSQLQuery term = return (term, courseCount)
|
||
where courseCount = E.subSelectCount . E.from $ \course ->
|
||
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
|
||
E.&&. mayViewCourse muid ata now course Nothing
|
||
dbtRowKey = (E.^. TermId)
|
||
dbtProj = return . dbrOutput
|
||
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) $ \(Entity _ Term{..},_)
|
||
-> tickmarkCell termActive
|
||
, 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 -> 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
|
||
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
|
||
in mempty
|
||
{ tftName = Just ntid
|
||
, tftStart = Just $ guessDay ntid TermDayStart
|
||
, tftEnd = Just $ guessDay ntid TermDayEnd
|
||
, tftLectureStart = Just $ guessDay ntid TermDayLectureStart
|
||
, tftLectureEnd = Just $ guessDay ntid TermDayLectureEnd
|
||
}
|
||
termEditHandler Nothing template
|
||
|
||
getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
|
||
getTermEditExistR = postTermEditExistR
|
||
postTermEditExistR tid = do
|
||
term <- runDB $ get tid
|
||
termEditHandler (Just tid) $ termToTemplate term
|
||
|
||
|
||
termEditHandler :: Maybe TermId -> TermFormTemplate -> Handler Html
|
||
termEditHandler mtid term = do
|
||
eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
|
||
((result, formWidget), formEnctype) <- runFormPost $ newTermForm mtid term
|
||
case result of
|
||
(FormSuccess res) -> do
|
||
let tid = fromMaybe (TermKey $ termName res) mtid
|
||
runDB $ do
|
||
repsert tid res
|
||
audit $ TransactionTermEdit tid
|
||
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
|
||
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 -> 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 :: Maybe TermId -> TermFormTemplate -> Form Term
|
||
newTermForm mtid template = validateForm validateTerm $ \html -> do
|
||
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 = massInputListA
|
||
dayField
|
||
(const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))
|
||
MsgTermHolidayMissing
|
||
(const Nothing)
|
||
("holidays" :: Text)
|
||
(fslI MsgTermHolidays)
|
||
True
|
||
(tftHolidays template)
|
||
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)
|