fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(terms): improve term display/editing

Browse Source 
Fixes #485
This commit is contained in:
Gregor Kleen 2020-06-15 16:49:31 +02:00
parent 08c53cdae7
commit 8b7e8e4bd5
3 changed files with 131 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

226
src/Handler/Term.hs
View File

@ -1,4 +1,8 @@
module Handler.Term where module Handler.Term
( getTermShowR
, getTermEditR, postTermEditR
, getTermEditExistR, postTermEditExistR
) where
import Import import Import
import Handler.Utils import Handler.Utils
@ -31,110 +35,101 @@ validateTerm = do
guardValidation MsgTermEndMustBeAfterLectureEnd $ termEnd >= termLectureEnd guardValidation MsgTermEndMustBeAfterLectureEnd $ termEnd >= termLectureEnd
getTermShowR :: Handler TypedContent getTermShowR :: Handler Html
getTermShowR = do getTermShowR = do
-- terms <- runDB $ selectList [] [Desc TermStart] table <- runDB $
------- ÄQUIVALENT: let termDBTable = DBTable{..}
-- term <- runDB $ E.select . E.from $ \(term) -> do where dbtSQLQuery term = return (term, courseCount)
-- E.orderBy [E.desc $ term E.^. TermStart ] where courseCount = E.subSelectCount . E.from $ \course ->
-- return term E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
-- dbtRowKey = (E.^. TermId)
let dbtProj = return . dbrOutput
termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64)) dbtColonnade = widgetColonnade $ mconcat
termData term = do [ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _)
-- E.orderBy [E.desc $ term E.^. TermStart ] -> cell $ do
let courseCount = E.subSelectCount . E.from $ \course -> mayEdit <- hasWriteAccessTo $ TermEditExistR tid
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm [whamlet|
return (term, courseCount) $newline never
selectRep $ do <a href=@{TermCourseListR tid}>
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) #{toPathPiece tid}
provideRep $ do $if mayEdit
let colonnadeTerms = widgetColonnade $ mconcat &nbsp;
[ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _) -> anchorCell <a href=@{TermEditExistR tid}>
(TermCourseListR tid) #{iconMenuAdmin}
[whamlet|#{toPathPiece tid}|] |]
, sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) -> , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_)
cell $ formatTime SelFormatDate termLectureStart >>= toWidget -> cell $ formatTime SelFormatDate termLectureStart >>= toWidget
, sortable (Just "lecture-end") (i18nCell MsgTermLectureEnd) $ \(Entity _ Term{..},_) -> , sortable (Just "lecture-end") (i18nCell MsgTermLectureEnd) $ \(Entity _ Term{..},_)
cell $ formatTime SelFormatDate termLectureEnd >>= toWidget -> cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
, sortable Nothing (i18nCell MsgTermActive) $ \(Entity _ Term{..},_) -> , sortable Nothing (i18nCell MsgTermActive) $ \(Entity _ Term{..},_)
tickmarkCell termActive -> tickmarkCell termActive
, sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses) -> , sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses)
cell [whamlet|_{MsgNumCourses numCourses}|] -> cell [whamlet|_{MsgNumCourses numCourses}|]
, sortable (Just "start") (i18nCell MsgTermStart) $ \(Entity _ Term{..},_) -> , sortable (Just "start") (i18nCell MsgTermStart) $ \(Entity _ Term{..},_)
cell $ formatTime SelFormatDate termStart >>= toWidget -> cell $ formatTime SelFormatDate termStart >>= toWidget
, sortable (Just "end") (i18nCell MsgTermEnd) $ \(Entity _ Term{..},_) -> , sortable (Just "end") (i18nCell MsgTermEnd) $ \(Entity _ Term{..},_)
cell $ formatTime SelFormatDate termEnd >>= toWidget -> cell $ formatTime SelFormatDate termEnd >>= toWidget
, sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_) -> , sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_)
cell $ do -> cell $ do
termHolidays' <- mapM (formatTime SelFormatDate) termHolidays let termHolidays' = groupHolidays termHolidays
[whamlet| [whamlet|
$newline never $newline never
<ul .list--inline .list--comma-separated> <ul .list--inline .list--comma-separated>
$forall holiday <- termHolidays' $forall holiday <- termHolidays'
<li>#{holiday} $case holiday
|] $of Left singleHoliday
] <li>^{formatTimeW SelFormatDate singleHoliday}
-- let adminColonnade = $of Right (startD, endD)
-- [ sortable Nothing "Edit" $ \(Entity tid Term{..},_) -> cell $ do <li>
-- -- Scrap this if to slow, create term edit page instead ^{formatTimeW SelFormatDate startD}
-- adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False –
-- [whamlet| ^{formatTimeW SelFormatDate endD}
-- $if adminLink == Authorized |]
-- <a href=@{TermEditExistR tid}> ]
-- #{termToText termName} dbtSorting = Map.fromList
-- $else [ ( "start"
-- #{termToText termName} , SortColumn $ \term -> term E.^. TermStart
-- |] )
-- ] , ( "end"
let validator = def & defaultSorting [SortDescBy "term-id"] , SortColumn $ \term -> term E.^. TermEnd
table <- runDB $ dbTableWidget' validator DBTable )
{ dbtSQLQuery = termData , ( "lecture-start"
, dbtRowKey = (E.^. TermId) , SortColumn $ \term -> term E.^. TermLectureStart
, dbtColonnade = colonnadeTerms )
, dbtProj = return . dbrOutput , ( "lecture-end"
, dbtSorting = Map.fromList , SortColumn $ \term -> term E.^. TermLectureEnd
[ ( "start" )
, SortColumn $ \term -> term E.^. TermStart , ( "term-id"
) , SortColumn $ \term -> term E.^. TermId
, ( "end" )
, SortColumn $ \term -> term E.^. TermEnd ]
) dbtFilter = Map.fromList
, ( "lecture-start" [ ( "active"
, SortColumn $ \term -> term E.^. TermLectureStart , FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool)
) )
, ( "lecture-end" , ( "course"
, SortColumn $ \term -> term E.^. TermLectureEnd , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
) [] -> E.val True :: E.SqlExpr (E.Value Bool)
, ( "term-id" cshs -> E.exists . E.from $ \course ->
, SortColumn $ \term -> term E.^. TermId E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
) E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
] )
, dbtFilter = Map.fromList ]
[ ( "active" dbtFilterUI = mempty
, FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool) dbtStyle = def
) dbtParams = def
, ( "course" dbtIdent = "terms" :: Text
, FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are dbtCsvEncode = noCsvEncode
[] -> E.val True :: E.SqlExpr (E.Value Bool) dbtCsvDecode = Nothing
cshs -> E.exists . E.from $ \course -> termDBTableValidator = def & defaultSorting [SortDescBy "term-id"]
E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId in dbTableWidget' termDBTableValidator termDBTable
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs defaultLayout $ do
) setTitleI MsgTermsHeading
] $(widgetFile "terms")
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams = def
, dbtIdent = "terms" :: Text
, dbtCsvEncode = noCsvEncode
, dbtCsvDecode = Nothing
}
defaultLayout $ do
setTitleI MsgTermsHeading
$(widgetFile "terms")
getTermEditR, postTermEditR :: Handler Html getTermEditR, postTermEditR :: Handler Html
getTermEditR = do getTermEditR = postTermEditR
postTermEditR = do
mbLastTerm <- runDB $ selectFirst [] [Desc TermName] mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
let template = case mbLastTerm of let template = case mbLastTerm of
Nothing -> mempty Nothing -> mempty
@ -148,32 +143,25 @@ getTermEditR = do
, tftStart = Just $ defaultDay True seas & setYear yr , tftStart = Just $ defaultDay True seas & setYear yr
, tftEnd = Just $ defaultDay False seas & setYear yr' , tftEnd = Just $ defaultDay False seas & setYear yr'
} }
termEditHandler template termEditHandler Nothing template
postTermEditR = termEditHandler mempty
getTermEditExistR, postTermEditExistR :: TermId -> Handler Html getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
getTermEditExistR = postTermEditExistR getTermEditExistR = postTermEditExistR
postTermEditExistR tid = do postTermEditExistR tid = do
term <- runDB $ get tid term <- runDB $ get tid
termEditHandler $ termToTemplate term termEditHandler (Just tid) $ termToTemplate term
termEditHandler :: TermFormTemplate -> Handler Html termEditHandler :: Maybe TermId -> TermFormTemplate -> Handler Html
termEditHandler term = do termEditHandler mtid term = do
eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute 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 case result of
(FormSuccess res) -> do (FormSuccess res) -> do
let tid = TermKey $ termName res let tid = fromMaybe (TermKey $ termName res) mtid
-- term <- runDB $ get $ TermKey termName
runDB $ do runDB $ do
repsert tid res repsert tid res
audit $ TransactionTermEdit tid 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 addMessageI Success $ MsgTermEdited tid
redirect TermShowR redirect TermShowR
FormMissing -> return () FormMissing -> return ()
@ -231,15 +219,15 @@ termToTemplate (Just Term{..}) = TermFormTemplate
, tftActive = Just termActive , tftActive = Just termActive
} }
newTermForm :: TermFormTemplate -> Form Term newTermForm :: Maybe TermId -> TermFormTemplate -> Form Term
newTermForm template = validateForm validateTerm $ \html -> do newTermForm mtid template = validateForm validateTerm $ \html -> do
mr <- getMessageRender mr <- getMessageRender
let let
tidForm tidForm
| Just tid <- tftName template | Just tid <- unTermKey <$> mtid
= aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
| otherwise | otherwise
= areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
holidayForm = massInputListA holidayForm = massInputListA
dayField dayField
(const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))

2
src/Handler/Utils.hs
View File

@ -26,6 +26,8 @@ import Handler.Utils.Database as Handler.Utils
import Handler.Utils.Occurrences as Handler.Utils import Handler.Utils.Occurrences as Handler.Utils
import Handler.Utils.Memcached as Handler.Utils import Handler.Utils.Memcached as Handler.Utils
import Handler.Utils.Term as Handler.Utils
import Control.Monad.Logger import Control.Monad.Logger

22
src/Handler/Utils/Term.hs Normal file
View 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