259 lines
10 KiB
Haskell
259 lines
10 KiB
Haskell
module Handler.Term where
|
|
|
|
import Import
|
|
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
|
|
|
|
|
|
-- | 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 :: (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 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.subSelectCount . E.from $ \course ->
|
|
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
|
|
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") (i18nCell MsgTermShort) $ \(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") (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
|
|
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
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
}
|
|
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
|
|
eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
|
|
((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
|
|
case result of
|
|
(FormSuccess res) -> do
|
|
let tid = TermKey $ termName res
|
|
-- term <- runDB $ get $ TermKey termName
|
|
runDB $ do
|
|
repsert tid res
|
|
audit $ TransactionTermEdit tid
|
|
-- 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 = validateForm validateTerm $ \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 = massInputListA
|
|
dayField
|
|
(const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))
|
|
(const Nothing)
|
|
("holidays" :: Text)
|
|
(fslI MsgTermHolidays & setTooltip MsgMassInputTip)
|
|
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)
|