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

Rework dbtable forms, cleanup

Browse Source
This commit is contained in:
Gregor Kleen 2018-12-13 15:10:43 +01:00
parent 30a5aff70e
commit 19a25ec520
17 changed files with 235 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
src/Handler/Corrections.hs
View File

@ -127,8 +127,8 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
return $ CSubmissionR tid ssh csh shn cid SubShowR return $ CSubmissionR tid ssh csh shn cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId colSelect = dbSelect _2 id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
@ -174,12 +174,12 @@ colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b)))) colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b))))
colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done)) (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done))
colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b)))) colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b))))
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty) NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
@ -187,14 +187,14 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
) )
colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text)))) colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text))))
colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment)) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x) => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DBParams m x -> DB (DBResult m x)
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = do
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
dbtSQLQuery = correctionsTableQuery whereClause dbtSQLQuery = correctionsTableQuery whereClause
(\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
@ -279,6 +279,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
] ]
, dbtFilterUI = mempty , dbtFilterUI = mempty
, dbtStyle = def , dbtStyle = def
, dbtParams
, dbtIdent = "corrections" :: Text , dbtIdent = "corrections" :: Text
} }
@ -301,13 +302,19 @@ data ActionCorrectionsData = CorrDownloadData
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator return
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
(fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
(actionRes, action) <- multiAction actions Nothing
return ((,) <$> actionRes <*> selectionRes, table <> action)
Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
(actionRes', table) <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator return def
{ dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAddSubmit = True
, dbParamsFormAdditional = \frag -> do
(actionRes, action) <- multiAction actions Nothing
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
}
let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
& mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
case actionRes of case actionRes of
FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs
FormMissing -> return () FormMissing -> return ()
@ -795,14 +802,17 @@ postCorrectionsGradeR = do
, colCommentField , colCommentField
] -- Continue here ] -- Continue here
psValidator = def psValidator = def
& defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text))) & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) = do
cID <- encrypt subId
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
return i
tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator dbtProj' $ def
cID <- encrypt subId { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True , dbParamsFormAddSubmit = True
return i }
((fmap unFormResult -> tableRes, table), tableEncoding) <- runFormPost tableForm
case tableRes of case tableRes of
FormMissing -> return () FormMissing -> return ()

7
src/Handler/Course.hs
View File

@ -179,6 +179,7 @@ makeCourseTable whereClause colChoices psValidator = do
, Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing
] ]
, dbtStyle = def , dbtStyle = def
, dbtParams = def
, dbtIdent = "courses" :: Text , dbtIdent = "courses" :: Text
} }
@ -194,7 +195,7 @@ getCourseListR = do
] ]
whereClause = const $ E.val True whereClause = const $ E.val True
validator = def validator = def
& defaultSorting [("course", SortAsc), ("term", SortDesc)] & defaultSorting [SortAscBy "course", SortDescBy "term"]
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do defaultLayout $ do
setTitleI MsgCourseListTitle setTitleI MsgCourseListTitle
@ -225,7 +226,7 @@ getTermSchoolCourseListR tid ssh = do
course E.^. CourseTerm E.==. E.val tid course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
validator = def validator = def
& defaultSorting [("cshort", SortAsc)] & defaultSorting [SortAscBy "cshort"]
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgTermSchoolCourseListTitle tid school setTitleI $ MsgTermSchoolCourseListTitle tid school
@ -247,7 +248,7 @@ getTermCourseListR tid = do
] ]
whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
validator = def validator = def
& defaultSorting [("cshort", SortAsc)] & defaultSorting [SortAscBy "cshort"]
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do defaultLayout $ do
setTitleI . MsgTermCourseListTitle $ tid setTitleI . MsgTermCourseListTitle $ tid

4
src/Handler/Home.hs
View File

@ -99,6 +99,7 @@ homeAnonymous = do
] -} ] -}
, dbtFilterUI = mempty , dbtFilterUI = mempty
, dbtStyle = def , dbtStyle = def
, dbtParams = def
, dbtIdent = "upcomingdeadlines" :: Text , dbtIdent = "upcomingdeadlines" :: Text
} }
-- let features = $(widgetFile "featureList") -- let features = $(widgetFile "featureList")
@ -167,7 +168,7 @@ homeUser uid = do
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR) (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
tickmark tickmark
] ]
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] let validator = def & defaultSorting [SortDescBy "done", SortDescBy "deadline"]
sheetTable <- runDB $ dbTableWidget' validator DBTable sheetTable <- runDB $ dbTableWidget' validator DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtColonnade = colonnade , dbtColonnade = colonnade
@ -201,6 +202,7 @@ homeUser uid = do
] -} ] -}
, dbtFilterUI = mempty , dbtFilterUI = mempty
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
, dbtParams = def
, dbtIdent = "upcomingdeadlines" :: Text , dbtIdent = "upcomingdeadlines" :: Text
} }
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."

15
src/Handler/Profile.hs
View File

@ -262,7 +262,7 @@ mkOwnedCoursesTable =
courseCellCL <$> view _dbrOutput courseCellCL <$> view _dbrOutput
] ]
validator = def & defaultSorting [ ("term", SortDesc), ("school", SortAsc), ("course", SortAsc) ] validator = def & defaultSorting [ SortDescBy "term", SortAscBy "school", SortAscBy "course" ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
@ -274,6 +274,7 @@ mkOwnedCoursesTable =
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
] ]
dbtFilterUI = mempty dbtFilterUI = mempty
dbtParams = def
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
@ -285,7 +286,7 @@ mkEnrolledCoursesTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
withType = id withType = id
validator = def & defaultSorting [("time",SortDesc)] validator = def & defaultSorting [SortDescBy "time"]
in \uid -> dbTableWidget' validator in \uid -> dbTableWidget' validator
DBTable DBTable
@ -322,6 +323,7 @@ mkEnrolledCoursesTable =
] ]
, dbtFilterUI = mempty , dbtFilterUI = mempty
, dbtStyle = def , dbtStyle = def
, dbtParams = def
} }
@ -385,7 +387,7 @@ mkSubmissionTable =
validator = def -- DUPLICATED CODE: Handler.Corrections validator = def -- DUPLICATED CODE: Handler.Corrections
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
& restrictSorting (\name _ -> name /= "corrector") & restrictSorting (\name _ -> name /= "corrector")
& defaultSorting [("edit",SortDesc)] & defaultSorting [SortDescBy "edit"]
dbtSorting' uid = Map.fromList dbtSorting' uid = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand) [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm ) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm )
@ -399,6 +401,7 @@ mkSubmissionTable =
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
] ]
dbtFilterUI = mempty dbtFilterUI = mempty
dbtParams = def
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
dbtSorting = dbtSorting' uid dbtSorting = dbtSorting' uid
in dbTableWidget' validator DBTable{..} in dbTableWidget' validator DBTable{..}
@ -455,7 +458,7 @@ mkSubmissionGroupTable =
validator = def -- DUPLICATED CODE: Handler.Corrections validator = def -- DUPLICATED CODE: Handler.Corrections
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
& restrictSorting (\name _ -> name /= "corrector") & restrictSorting (\name _ -> name /= "corrector")
& defaultSorting [("edit",SortDesc)] & defaultSorting [SortDescBy "edit"]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand) [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm ) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
@ -469,6 +472,7 @@ mkSubmissionGroupTable =
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
] ]
dbtFilterUI = mempty dbtFilterUI = mempty
dbtParams = def
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator DBTable{..} in dbTableWidget' validator DBTable{..}
@ -529,7 +533,7 @@ mkCorrectionsTable =
int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue) int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
] ]
validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)] validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm ) [ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool )
@ -543,6 +547,7 @@ mkCorrectionsTable =
, ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
] ]
dbtFilterUI = mempty dbtFilterUI = mempty
dbtParams = def
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator DBTable{..} in dbTableWidget' validator DBTable{..}

6
src/Handler/Sheet.hs
View File

@ -201,7 +201,7 @@ getSheetListR tid ssh csh = do
] ]
psValidator = def psValidator = def
& defaultSorting [("submission-since", SortAsc)] & defaultSorting [SortAscBy "submission-since"]
(table,raw_statistics) <- runDB $ liftA2 (,) (table,raw_statistics) <- runDB $ liftA2 (,)
(dbTableWidget' psValidator DBTable (dbTableWidget' psValidator DBTable
@ -236,6 +236,7 @@ getSheetListR tid ssh csh = do
, dbtFilter = mempty , dbtFilter = mempty
, dbtFilterUI = mempty , dbtFilterUI = mempty
, dbtStyle = def , dbtStyle = def
, dbtParams = def
, dbtIdent = "sheets" :: Text , dbtIdent = "sheets" :: Text
} }
) ( ) (
@ -298,7 +299,7 @@ getSShowR tid ssh csh shn = do
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
] ]
let psValidator = def let psValidator = def
& defaultSorting [("type", SortAsc), ("path", SortAsc)] & defaultSorting [SortAscBy "type", SortAscBy "path"]
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery = fileData { dbtSQLQuery = fileData
, dbtColonnade = colonnadeFiles , dbtColonnade = colonnadeFiles
@ -319,6 +320,7 @@ getSShowR tid ssh csh shn = do
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified
) )
] ]
, dbtParams = def
} }
(hasHints, hasSolution) <- runDB $ do (hasHints, hasSolution) <- runDB $ do
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ] hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]

1
src/Handler/Submission.hs
View File

@ -312,6 +312,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
] ]
, dbtFilter = mempty , dbtFilter = mempty
, dbtFilterUI = mempty , dbtFilterUI = mempty
, dbtParams = def
} }
mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid

50
src/Handler/SystemMessage.hs
View File

@ -13,6 +13,8 @@ import Handler.Utils
import Utils.Lens import Utils.Lens
import qualified Database.Esqueleto as E
htmlField' :: Field (HandlerT UniWorX IO) Html htmlField' :: Field (HandlerT UniWorX IO) Html
htmlField' = htmlField htmlField' = htmlField
@ -154,7 +156,7 @@ postMessageListR = do
let let
dbtSQLQuery = return dbtSQLQuery = return
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId [ dbSelect _2 id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
, dbRow , dbRow
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext) , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext)
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
@ -173,28 +175,46 @@ postMessageListR = do
{ dbrOutput = (smE, smT) { dbrOutput = (smE, smT)
, .. , ..
} }
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool)) psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
tableForm <- runDB $ dbTable psValidator DBTable (tableRes', tableView) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery { dbtSQLQuery
, dbtColonnade , dbtColonnade
, dbtProj , dbtProj
, dbtSorting = mempty -- TODO: from, to, authenticated, severity , dbtSorting = Map.fromList
[ ( "from"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageFrom
)
, ( "to"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageTo
)
, ( "authenticated"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly
)
, ( "severity"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity
)
]
, dbtFilter = mempty , dbtFilter = mempty
, dbtFilterUI = mempty , dbtFilterUI = mempty
, dbtStyle = def , dbtStyle = def
, dbtParams = def
{ dbParamsFormAction = Just $ SomeRoute MessageListR
, dbParamsFormAddSubmit = True
, dbParamsFormAdditional = \frag -> do
now <- liftIO getCurrentTime
let actions = Map.fromList
[ (SMDelete, pure SMDDelete)
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
, (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
]
(actionRes, action) <- multiAction actions (Just SMActivate)
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
}
, dbtIdent = "messages" :: Text , dbtIdent = "messages" :: Text
} }
((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
(fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
now <- liftIO getCurrentTime & mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
let actions = Map.fromList
[ (SMDelete, pure SMDDelete)
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
, (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
]
(actionRes, action) <- multiAction actions (Just SMActivate)
$logDebugS "SystemMessage" $ tshow (actionRes, selectionRes)
return ((,) <$> actionRes <*> selectionRes, table <> action)
case tableRes of case tableRes of
FormMissing -> return () FormMissing -> return ()

1
src/Handler/Term.hs
View File

@ -128,6 +128,7 @@ getTermShowR = do
] ]
, dbtFilterUI = mempty , dbtFilterUI = mempty
, dbtStyle = def , dbtStyle = def
, dbtParams = def
, dbtIdent = "terms" :: Text , dbtIdent = "terms" :: Text
} }
defaultLayout $ do defaultLayout $ do

3
src/Handler/Users.hs
View File

@ -67,7 +67,7 @@ getUsersR = do
|] |]
] ]
psValidator = def psValidator = def
& defaultSorting [("name", SortAsc),("display-name", SortAsc)] & defaultSorting [SortAscBy "name", SortAscBy "display-name"]
((), userList) <- runDB $ dbTable psValidator DBTable ((), userList) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
@ -87,6 +87,7 @@ getUsersR = do
, dbtFilter = mempty , dbtFilter = mempty
, dbtFilterUI = mempty , dbtFilterUI = mempty
, dbtStyle = def , dbtStyle = def
, dbtParams = def
, dbtIdent = "users" :: Text , dbtIdent = "users" :: Text
} }

160
src/Handler/Utils/Table/Pagination.hs
View File

@ -1,15 +1,18 @@
module Handler.Utils.Table.Pagination module Handler.Utils.Table.Pagination
( SortColumn(..), SortDirection(..) ( module Handler.Utils.Table.Pagination.Types
, SortColumn(..), SortDirection(..)
, pattern SortAscBy, pattern SortDescBy
, FilterColumn(..), IsFilterColumn , FilterColumn(..), IsFilterColumn
, DBRow(..), _dbrOutput, _dbrIndex, _dbrCount , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
, DBStyle(..), DBEmptyStyle(..) , DBStyle(..), DBEmptyStyle(..)
, DBTable(..), IsDBTable(..), DBCell(..) , DBTable(..), IsDBTable(..), DBCell(..)
, DBParams(..)
, cellAttrs, cellContents , cellAttrs, cellContents
, PaginationSettings(..), PaginationInput(..), piIsUnset , PaginationSettings(..), PaginationInput(..), piIsUnset
, PSValidator(..) , PSValidator(..)
, defaultFilter, defaultSorting , defaultFilter, defaultSorting
, restrictFilter, restrictSorting , restrictFilter, restrictSorting
, ToSortable(..), Sortable(..), sortable , ToSortable(..), Sortable(..)
, dbTable , dbTable
, dbTableWidget, dbTableWidget' , dbTableWidget, dbTableWidget'
, widgetColonnade, formColonnade, dbColonnade , widgetColonnade, formColonnade, dbColonnade
@ -38,9 +41,6 @@ import qualified Data.Binary.Builder as Builder
import qualified Network.Wai as Wai import qualified Network.Wai as Wai
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Control.Monad.RWS hiding ((<>), mapM_) import Control.Monad.RWS hiding ((<>), mapM_)
import Control.Monad.Writer hiding ((<>), mapM_) import Control.Monad.Writer hiding ((<>), mapM_)
import Control.Monad.Reader (ReaderT(..), mapReaderT) import Control.Monad.Reader (ReaderT(..), mapReaderT)
@ -65,18 +65,21 @@ import Data.Aeson (Options(..), defaultOptions, decodeStrict')
import Data.Aeson.Text import Data.Aeson.Text
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
import qualified Data.Text as Text
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
data SortDirection = SortAsc | SortDesc data SortDirection = SortAsc | SortDesc
deriving (Eq, Ord, Enum, Show, Read) deriving (Eq, Ord, Enum, Bounded, Show, Read)
instance Universe SortDirection
instance Finite SortDirection
instance PathPiece SortDirection where instance PathPiece SortDirection where
toPathPiece SortAsc = "asc" toPathPiece SortAsc = "asc"
toPathPiece SortDesc = "desc" toPathPiece SortDesc = "desc"
fromPathPiece (CI.mk -> t) fromPathPiece = finiteFromPathPiece
| t == "asc" = Just SortAsc
| t == "desc" = Just SortDesc
| otherwise = Nothing
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 { constructorTagModifier = camelToPathPiece' 1
@ -87,6 +90,29 @@ sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
data SortingSetting = SortingSetting
{ sortKey :: SortingKey
, sortDir :: SortDirection
} deriving (Eq, Ord, Show, Read)
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
} ''SortingSetting
instance PathPiece SortingSetting where
toPathPiece SortingSetting{..} = toPathPiece sortKey <> "-" <> toPathPiece sortDir
fromPathPiece str = do
let sep = "-"
let (Text.dropEnd (Text.length sep) -> key, dir) = Text.breakOnEnd sep str
SortingSetting <$> fromPathPiece key <*> fromPathPiece dir
pattern SortAscBy :: SortingKey -> SortingSetting
pattern SortAscBy key = SortingSetting key SortAsc
pattern SortDescBy :: SortingKey -> SortingSetting
pattern SortDescBy key = SortingSetting key SortDesc
data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a
filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool) filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
@ -111,8 +137,8 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon
| otherwise = go (acc, is3 . (i:)) is2 | otherwise = go (acc, is3 . (i:)) is2
data PaginationSettings = PaginationSettings data PaginationSettings = PaginationSettings
{ psSorting :: [(CI Text, SortDirection)] { psSorting :: [SortingSetting]
, psFilter :: Map (CI Text) [Text] , psFilter :: Map FilterKey [Text]
, psLimit :: Int64 , psLimit :: Int64
, psPage :: Int64 , psPage :: Int64
} }
@ -132,8 +158,8 @@ deriveJSON defaultOptions
} ''PaginationSettings } ''PaginationSettings
data PaginationInput = PaginationInput data PaginationInput = PaginationInput
{ piSorting :: Maybe [(CI Text, SortDirection)] { piSorting :: Maybe [SortingSetting]
, piFilter :: Maybe (Map (CI Text) [Text]) , piFilter :: Maybe (Map FilterKey [Text])
, piLimit :: Maybe Int64 , piLimit :: Maybe Int64
, piPage :: Maybe Int64 , piPage :: Maybe Int64
} deriving (Eq, Ord, Show, Read, Generic) } deriving (Eq, Ord, Show, Read, Generic)
@ -194,29 +220,29 @@ instance Default (PSValidator m x) where
asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p }) asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x defaultFilter :: Map FilterKey [Text] -> PSValidator m x -> PSValidator m x
defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable' defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
where where
injectDefault x = case x >>= piFilter of injectDefault x = case x >>= piFilter of
Just _ -> id Just _ -> id
Nothing -> set (_2._psFilter) psFilter Nothing -> set (_2._psFilter) psFilter
defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x defaultSorting :: [SortingSetting] -> PSValidator m x -> PSValidator m x
defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable' defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
where where
injectDefault x = case x >>= piSorting of injectDefault x = case x >>= piSorting of
Just _ -> id Just _ -> id
Nothing -> set (_2._psSorting) psSorting Nothing -> set (_2._psSorting) psSorting
restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x restrictFilter :: (FilterKey -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
where where
restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p } restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x restrictSorting :: (SortingKey -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
where where
restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p } restrict' p = p { psSorting = filter (\SortingSetting{..} -> restrict sortKey sortDir) $ psSorting p }
data DBEmptyStyle = DBESNoHeading | DBESHeading data DBEmptyStyle = DBESNoHeading | DBESHeading
@ -244,9 +270,6 @@ instance Default DBStyle where
, dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default") , dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default")
} }
type FilterKey = CI Text
type SortingKey = CI Text
data DBTable m x = forall a r r' h i t. data DBTable m x = forall a r r' h i t.
( ToSortable h, Functor h ( ToSortable h, Functor h
, E.SqlSelect a r , E.SqlSelect a r
@ -260,10 +283,12 @@ data DBTable m x = forall a r r' h i t.
, dbtFilter :: Map FilterKey (FilterColumn t) , dbtFilter :: Map FilterKey (FilterColumn t)
, dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text]) , dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
, dbtStyle :: DBStyle , dbtStyle :: DBStyle
, dbtParams :: DBParams m x
, dbtIdent :: i , dbtIdent :: i
} }
class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where class (MonadHandler m, Monoid x, Monoid (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
data DBParams m x :: *
type DBResult m x :: * type DBResult m x :: *
-- type DBResult' m x :: * -- type DBResult' m x :: *
@ -275,7 +300,7 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget
-- | Format @DBTable@ when not short-circuiting -- | Format @DBTable@ when not short-circuiting
dbHandler :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x) dbHandler :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x) runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)] cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
cellAttrs = dbCell . _1 cellAttrs = dbCell . _1
@ -284,6 +309,7 @@ cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
cellContents = dbCell . _2 cellContents = dbCell . _2
instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
data DBParams (HandlerT UniWorX IO) x = DBParamsWidget
type DBResult (HandlerT UniWorX IO) x = (x, Widget) type DBResult (HandlerT UniWorX IO) x = (x, Widget)
-- type DBResult' (WidgetT UniWorX IO) () = () -- type DBResult' (WidgetT UniWorX IO) () = ()
@ -299,13 +325,17 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
-- dbWidget Proxy Proxy = iso (, ()) $ view _1 -- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget _ _ = return . snd dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f dbHandler _ _ f = return . over _2 f
runDBTable = liftHandlerT runDBTable _ _ = liftHandlerT
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
mempty = WidgetCell mempty $ return mempty mempty = WidgetCell mempty $ return mempty
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c') (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
instance Default (DBParams (HandlerT UniWorX IO) x) where
def = DBParamsWidget
instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
data DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBParamsDB
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget) type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
@ -320,15 +350,25 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
dbWidget _ _ = return . snd dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f dbHandler _ _ f = return . over _2 f
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget) -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
runDBTable = mapReaderT liftHandlerT runDBTable _ _ = mapReaderT liftHandlerT
instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
mempty = DBCell mempty $ return mempty mempty = DBCell mempty $ return mempty
(DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c') (DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
def = DBParamsDB
instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
-- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype) data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = DBParamsForm
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a { dbParamsFormMethod :: StdMethod
, dbParamsFormAction :: Maybe (SomeRoute UniWorX)
, dbParamsFormAttrs :: [(Text, Text)]
, dbParamsFormAddSubmit :: Bool
, dbParamsFormAdditional :: Form a
, dbParamsFormEvaluate :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => Form a -> m' ((FormResult a, Widget), Enctype)
}
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Widget)
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype) -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
@ -345,15 +385,37 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi dbWidget _ _ = return . snd
dbHandler dbtable pi f form = return $ fmap (over _2 f) . addPIHiddenField dbtable pi form dbHandler _ _ f = return . over _2 f
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype) -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget)) -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
runDBTable = return . withFragment runDBTable dbtable pi = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . (dbParamsFormWrap (dbtParams dbtable)) . addPIHiddenField dbtable pi . withFragment
instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
def = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
, dbParamsFormAttrs = []
, dbParamsFormAddSubmit = False
, dbParamsFormAdditional = \_ -> return mempty
, dbParamsFormEvaluate = liftHandlerT . runFormPost
}
dbParamsFormWrap :: Monoid a => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) -> Form a -> Form a
dbParamsFormWrap DBParamsForm{..} tableForm frag = do
let form = mappend <$> tableForm frag <*> dbParamsFormAdditional mempty
((res, fWidget), enctype) <- listen form
return . (res,) $ do
btnId <- newIdent
act <- traverse toTextUrl dbParamsFormAction
let submitField = buttonField BtnSubmit
enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype
$(widgetFile "table/form-wrap")
addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a
addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet| addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet|
$newline never
<input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}> <input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
|] |]
where where
@ -373,10 +435,10 @@ dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DB
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
let let
sortingOptions = mkOptionList sortingOptions = mkOptionList
[ Option t' (t, d) t' [ Option t' (SortingSetting t d) t'
| (t, _) <- mapToList dbtSorting | (t, _) <- mapToList dbtSorting
, d <- [SortAsc, SortDesc] , d <- [SortAsc, SortDesc]
, let t' = CI.foldedCase t <> "-" <> toPathPiece d , let t' = toPathPiece $ SortingSetting t d
] ]
wIdent n wIdent n
| not $ null dbtIdent = dbtIdent <> "-" <> n | not $ null dbtIdent = dbtIdent <> "-" <> n
@ -394,7 +456,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
piInput <- lift . runInputGetResult $ PaginationInput piInput <- lift . runInputGetResult $ PaginationInput
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ toPathPiece k) dbtFilter)
<*> iopt intField (wIdent "pagesize") <*> iopt intField (wIdent "pagesize")
<*> iopt intField (wIdent "page") <*> iopt intField (wIdent "page")
@ -427,7 +489,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
= pi = pi
| otherwise | otherwise
= def = def
psSorting' = map (first (dbtSorting !)) psSorting psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
mapM_ (addMessageI Warning) errs mapM_ (addMessageI Warning) errs
@ -454,7 +516,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
filterAction = tblLink filterAction = tblLink
$ setParam (wIdent "page") Nothing $ setParam (wIdent "page") Nothing
. Map.foldrWithKey (\k _ f -> setParam (wIdent $ CI.foldedCase k) Nothing . f) id dbtFilter . Map.foldrWithKey (\k _ f -> setParam (wIdent $ toPathPiece k) Nothing . f) id dbtFilter
table' :: WriterT x m Widget table' :: WriterT x m Widget
table' = do table' = do
@ -463,7 +525,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
widget <- sortableContent ^. cellContents widget <- sortableContent ^. cellContents
let let
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ] directions = [dir | SortingSetting k dir <- psSorting, Just k == sortableKey ]
isSortable = isJust sortableKey isSortable = isJust sortableKey
isSorted = (`elem` directions) isSorted = (`elem` directions)
attrs = sortableContent ^. cellAttrs attrs = sortableContent ^. cellAttrs
@ -485,7 +547,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
return $(widgetFile "table/layout") return $(widgetFile "table/layout")
bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table' bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable dbtable paginationInput . fmap swap $ runWriterT table'
where where
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
tblLayout tbl' = do tblLayout tbl' = do
@ -585,16 +647,17 @@ instance Ord i => Monoid (DBFormResult r i a) where
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
formCell :: forall r i a. Ord i formCell :: forall res r i a. (Ord i, Monoid res)
=> (r -> MForm (HandlerT UniWorX IO) i) => Lens' res (DBFormResult r i a)
-> (r -> MForm (HandlerT UniWorX IO) i)
-> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
-> (r -> DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a))) -> (r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
formCell genIndex genForm input = FormCell formCell resLens genIndex genForm input = FormCell
{ formCellAttrs = [] { formCellAttrs = []
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget) , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
i <- genIndex input i <- genIndex input
(edit, w) <- genForm input i (edit, w) <- genForm input i
return (DBFormResult . Map.singleton i . (input,) <$> edit, w) return (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w)
} }
@ -604,10 +667,11 @@ formCell genIndex genForm input = FormCell
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i) dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res)
=> Setter' a Bool => Lens' res (DBFormResult r i a)
-> Setter' a Bool
-> (r -> MForm (HandlerT UniWorX IO) i) -> (r -> MForm (HandlerT UniWorX IO) i)
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a))) -> Colonnade h r (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell resLens genIndex) r $ \_ i -> do
(selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False) (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|]) return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])

25
src/Handler/Utils/Table/Pagination/Types.hs
View File

@ -1,4 +1,12 @@
module Handler.Utils.Table.Pagination.Types where {-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Handler.Utils.Table.Pagination.Types
( FilterKey, SortingKey
, Sortable(..)
, sortable
, ToSortable(..)
, SortableP(..)
) where
import Import hiding (singleton) import Import hiding (singleton)
@ -7,12 +15,23 @@ import Colonnade.Encode
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
deriving (Show, Read)
deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
newtype SortingKey = SortingKey { _unSortingKey :: CI Text }
deriving (Show, Read)
deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
data Sortable a = Sortable data Sortable a = Sortable
{ sortableKey :: Maybe (CI Text) { sortableKey :: Maybe SortingKey
, sortableContent :: a , sortableContent :: a
} }
sortable :: Maybe (CI Text) -> c -> (a -> c) -> Colonnade Sortable a c sortable :: Maybe SortingKey -> c -> (a -> c) -> Colonnade Sortable a c
sortable k h = singleton (Sortable k h) sortable k h = singleton (Sortable k h)
instance Headedness Sortable where instance Headedness Sortable where

1
src/Import/NoFoundation.hs
View File

@ -41,6 +41,7 @@ import Data.Hashable as Import
import Data.List.NonEmpty as Import (NonEmpty(..)) import Data.List.NonEmpty as Import (NonEmpty(..))
import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Semigroup) import Data.Semigroup as Import (Semigroup)
import Data.Monoid as Import (Last(..), First(..))
import Data.Monoid.Instances as Import () import Data.Monoid.Instances as Import ()
import Control.Monad.Morph as Import (MFunctor(..)) import Control.Monad.Morph as Import (MFunctor(..))

5
templates/corrections-grade.hamlet
View File

@ -1,5 +1,2 @@
<div .container> <div .container>
<form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}> ^{table}
^{table}
<button type=submit>
_{MsgBtnSubmit}

7
templates/corrections.hamlet
View File

@ -1,7 +1,4 @@
<section> <section>
<form method=POST enctype=#{tableEncoding} action=@{currentRoute}> ^{table}
^{table}
<button type=submit>
_{MsgBtnSubmit}
<section> <section>
^{statistics} ^{statistics}

5
templates/system-message-list.hamlet
View File

@ -1,8 +1,5 @@
<section> <section>
<form method=post action=@{MessageListR} encytpe=#{tableEncoding}> ^{tableView}
^{tableView}
<button type=submit>
_{MsgBtnSubmit}
<section> <section>
<form method=post action=@{MessageListR} enctype=#{addEncoding}> <form method=post action=@{MessageListR} enctype=#{addEncoding}>

4
templates/table/cell/header.hamlet
View File

@ -2,10 +2,10 @@
$maybe flag <- sortableKey $maybe flag <- sortableKey
$case directions $case directions
$of [SortAsc] $of [SortAsc]
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ CI.foldedCase flag <> "-desc")}> <a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ toPathPiece (SortingSetting flag SortDesc))}>
^{widget} ^{widget}
$of _ $of _
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ CI.foldedCase flag <> "-asc")}> <a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ toPathPiece (SortingSetting flag SortAsc))}>
^{widget} ^{widget}
$nothing $nothing
^{widget} ^{widget}

5
templates/table/form-wrap.hamlet Normal file
View File

@ -0,0 +1,5 @@
$newline never
<form method=#{decodeUtf8 (renderStdMethod dbParamsFormMethod)} action=#{fromMaybe "" act} *{dbParamsFormAttrs} enctype=#{enctype'}>
^{fWidget}
$if dbParamsFormAddSubmit
^{fieldView submitField btnId "" mempty (Right BtnSubmit) False}