Gregor Kleen
parent
08c53cdae7
commit
8b7e8e4bd5
@ -1,4 +1,8 @@
|
||||
module Handler.Term where
|
||||
module Handler.Term
|
||||
( getTermShowR
|
||||
, getTermEditR, postTermEditR
|
||||
, getTermEditExistR, postTermEditExistR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
@ -31,110 +35,101 @@ validateTerm = do
|
||||
guardValidation MsgTermEndMustBeAfterLectureEnd $ termEnd >= termLectureEnd
|
||||
|
||||
|
||||
getTermShowR :: Handler TypedContent
|
||||
getTermShowR :: Handler Html
|
||||
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")
|
||||
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
|
||||
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
|
||||
termDBTableValidator = def & defaultSorting [SortDescBy "term-id"]
|
||||
in dbTableWidget' termDBTableValidator termDBTable
|
||||
defaultLayout $ do
|
||||
setTitleI MsgTermsHeading
|
||||
$(widgetFile "terms")
|
||||
|
||||
getTermEditR, postTermEditR :: Handler Html
|
||||
getTermEditR = do
|
||||
getTermEditR = postTermEditR
|
||||
postTermEditR = do
|
||||
mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
|
||||
let template = case mbLastTerm of
|
||||
Nothing -> mempty
|
||||
@ -148,32 +143,25 @@ getTermEditR = do
|
||||
, tftStart = Just $ defaultDay True seas & setYear yr
|
||||
, tftEnd = Just $ defaultDay False seas & setYear yr'
|
||||
}
|
||||
termEditHandler template
|
||||
postTermEditR = termEditHandler mempty
|
||||
termEditHandler Nothing template
|
||||
|
||||
getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
|
||||
getTermEditExistR = postTermEditExistR
|
||||
postTermEditExistR tid = do
|
||||
term <- runDB $ get tid
|
||||
termEditHandler $ termToTemplate term
|
||||
termEditHandler (Just tid) $ termToTemplate term
|
||||
|
||||
|
||||
termEditHandler :: TermFormTemplate -> Handler Html
|
||||
termEditHandler term = do
|
||||
termEditHandler :: Maybe TermId -> TermFormTemplate -> Handler Html
|
||||
termEditHandler mtid term = do
|
||||
eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
|
||||
((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
|
||||
((result, formWidget), formEnctype) <- runFormPost $ newTermForm mtid term
|
||||
case result of
|
||||
(FormSuccess res) -> do
|
||||
let tid = TermKey $ termName res
|
||||
-- term <- runDB $ get $ TermKey termName
|
||||
let tid = fromMaybe (TermKey $ termName res) mtid
|
||||
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 ()
|
||||
@ -231,15 +219,15 @@ termToTemplate (Just Term{..}) = TermFormTemplate
|
||||
, tftActive = Just termActive
|
||||
}
|
||||
|
||||
newTermForm :: TermFormTemplate -> Form Term
|
||||
newTermForm template = validateForm validateTerm $ \html -> do
|
||||
newTermForm :: Maybe TermId -> TermFormTemplate -> Form Term
|
||||
newTermForm mtid template = validateForm validateTerm $ \html -> do
|
||||
mr <- getMessageRender
|
||||
let
|
||||
tidForm
|
||||
| Just tid <- tftName template
|
||||
| Just tid <- unTermKey <$> mtid
|
||||
= aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
|
||||
| otherwise
|
||||
= areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
|
||||
= areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
|
||||
holidayForm = massInputListA
|
||||
dayField
|
||||
(const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))
|
||||
|
||||
@ -25,6 +25,8 @@ import Handler.Utils.Widgets as Handler.Utils
|
||||
import Handler.Utils.Database as Handler.Utils
|
||||
import Handler.Utils.Occurrences as Handler.Utils
|
||||
import Handler.Utils.Memcached as Handler.Utils
|
||||
|
||||
import Handler.Utils.Term as Handler.Utils
|
||||
|
||||
import Control.Monad.Logger
|
||||
|
||||
|
||||
22
src/Handler/Utils/Term.hs
Normal file
22
src/Handler/Utils/Term.hs
Normal file
@ -0,0 +1,22 @@
|
||||
module Handler.Utils.Term
|
||||
( groupHolidays
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
groupHolidays :: ( MonoFoldable mono
|
||||
, Enum (Element mono)
|
||||
, Ord (Element mono)
|
||||
)
|
||||
=> mono -> [Either (Element mono) (Element mono, Element mono)]
|
||||
groupHolidays = go Seq.empty . foldMap Set.singleton
|
||||
where go (acc Seq.:|> Left x') (Set.minView -> Just (x, xs))
|
||||
| x <= succ x' = go (acc Seq.:|> Right (x', x)) xs
|
||||
go (acc Seq.:|> Right (x', x'')) (Set.minView -> Just (x, xs))
|
||||
| x <= succ x'' = go (acc Seq.:|> Right (x', x)) xs
|
||||
go acc xs'
|
||||
| Just (x, xs) <- Set.minView xs' = go (acc Seq.:|> Left x) xs
|
||||
| otherwise = toList acc
|
||||
Loading…
Reference in New Issue
Block a user