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

@ -25,6 +25,8 @@ import Handler.Utils.Widgets as Handler.Utils
import Handler.Utils.Database as Handler.Utils 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