Rework dbtable forms, cleanup
This commit is contained in:
Gregor Kleen
parent
30a5aff70e
commit
19a25ec520
@ -127,8 +127,8 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
return $ CSubmissionR tid ssh csh shn cid SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
|
||||
|
||||
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
|
||||
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
|
||||
colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
|
||||
colSelect = dbSelect _2 id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
|
||||
|
||||
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
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")]
|
||||
|
||||
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 _ (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 = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell
|
||||
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
|
||||
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 = sortable Nothing (i18nCell MsgRatingComment) $ formCell
|
||||
colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id
|
||||
(\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))
|
||||
|
||||
|
||||
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
||||
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
|
||||
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
||||
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DBParams m x -> DB (DBResult m x)
|
||||
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = do
|
||||
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery = correctionsTableQuery whereClause
|
||||
(\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
|
||||
@ -279,6 +279,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
||||
]
|
||||
, dbtFilterUI = mempty
|
||||
, dbtStyle = def
|
||||
, dbtParams
|
||||
, dbtIdent = "corrections" :: Text
|
||||
}
|
||||
|
||||
@ -301,13 +302,19 @@ data ActionCorrectionsData = CorrDownloadData
|
||||
|
||||
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
|
||||
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
|
||||
|
||||
(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
|
||||
FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs
|
||||
FormMissing -> return ()
|
||||
@ -795,14 +802,17 @@ postCorrectionsGradeR = do
|
||||
, colCommentField
|
||||
] -- Continue here
|
||||
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)
|
||||
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
|
||||
cID <- encrypt subId
|
||||
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
|
||||
return i
|
||||
((fmap unFormResult -> tableRes, table), tableEncoding) <- runFormPost tableForm
|
||||
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator dbtProj' $ def
|
||||
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
|
||||
, dbParamsFormAddSubmit = True
|
||||
}
|
||||
|
||||
case tableRes of
|
||||
FormMissing -> return ()
|
||||
|
||||
@ -179,6 +179,7 @@ makeCourseTable whereClause colChoices psValidator = do
|
||||
, Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing
|
||||
]
|
||||
, dbtStyle = def
|
||||
, dbtParams = def
|
||||
, dbtIdent = "courses" :: Text
|
||||
}
|
||||
|
||||
@ -194,7 +195,7 @@ getCourseListR = do
|
||||
]
|
||||
whereClause = const $ E.val True
|
||||
validator = def
|
||||
& defaultSorting [("course", SortAsc), ("term", SortDesc)]
|
||||
& defaultSorting [SortAscBy "course", SortDescBy "term"]
|
||||
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
||||
defaultLayout $ do
|
||||
setTitleI MsgCourseListTitle
|
||||
@ -225,7 +226,7 @@ getTermSchoolCourseListR tid ssh = do
|
||||
course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
validator = def
|
||||
& defaultSorting [("cshort", SortAsc)]
|
||||
& defaultSorting [SortAscBy "cshort"]
|
||||
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgTermSchoolCourseListTitle tid school
|
||||
@ -247,7 +248,7 @@ getTermCourseListR tid = do
|
||||
]
|
||||
whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
|
||||
validator = def
|
||||
& defaultSorting [("cshort", SortAsc)]
|
||||
& defaultSorting [SortAscBy "cshort"]
|
||||
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
||||
defaultLayout $ do
|
||||
setTitleI . MsgTermCourseListTitle $ tid
|
||||
|
||||
@ -99,6 +99,7 @@ homeAnonymous = do
|
||||
] -}
|
||||
, dbtFilterUI = mempty
|
||||
, dbtStyle = def
|
||||
, dbtParams = def
|
||||
, dbtIdent = "upcomingdeadlines" :: Text
|
||||
}
|
||||
-- let features = $(widgetFile "featureList")
|
||||
@ -167,7 +168,7 @@ homeUser uid = do
|
||||
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
|
||||
tickmark
|
||||
]
|
||||
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
|
||||
let validator = def & defaultSorting [SortDescBy "done", SortDescBy "deadline"]
|
||||
sheetTable <- runDB $ dbTableWidget' validator DBTable
|
||||
{ dbtSQLQuery = tableData
|
||||
, dbtColonnade = colonnade
|
||||
@ -201,6 +202,7 @@ homeUser uid = do
|
||||
] -}
|
||||
, dbtFilterUI = mempty
|
||||
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
|
||||
, dbtParams = def
|
||||
, dbtIdent = "upcomingdeadlines" :: Text
|
||||
}
|
||||
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
|
||||
|
||||
@ -262,7 +262,7 @@ mkOwnedCoursesTable =
|
||||
courseCellCL <$> view _dbrOutput
|
||||
]
|
||||
|
||||
validator = def & defaultSorting [ ("term", SortDesc), ("school", SortAsc), ("course", SortAsc) ]
|
||||
validator = def & defaultSorting [ SortDescBy "term", SortAscBy "school", SortAscBy "course" ]
|
||||
dbtSorting = Map.fromList
|
||||
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
|
||||
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
|
||||
@ -274,6 +274,7 @@ mkOwnedCoursesTable =
|
||||
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
||||
]
|
||||
dbtFilterUI = mempty
|
||||
dbtParams = def
|
||||
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)
|
||||
withType = id
|
||||
|
||||
validator = def & defaultSorting [("time",SortDesc)]
|
||||
validator = def & defaultSorting [SortDescBy "time"]
|
||||
|
||||
in \uid -> dbTableWidget' validator
|
||||
DBTable
|
||||
@ -322,6 +323,7 @@ mkEnrolledCoursesTable =
|
||||
]
|
||||
, dbtFilterUI = mempty
|
||||
, dbtStyle = def
|
||||
, dbtParams = def
|
||||
}
|
||||
|
||||
|
||||
@ -385,7 +387,7 @@ mkSubmissionTable =
|
||||
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
|
||||
& restrictSorting (\name _ -> name /= "corrector")
|
||||
& defaultSorting [("edit",SortDesc)]
|
||||
& defaultSorting [SortDescBy "edit"]
|
||||
dbtSorting' uid = Map.fromList
|
||||
[ ( "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 )
|
||||
@ -399,6 +401,7 @@ mkSubmissionTable =
|
||||
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
||||
]
|
||||
dbtFilterUI = mempty
|
||||
dbtParams = def
|
||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
||||
dbtSorting = dbtSorting' uid
|
||||
in dbTableWidget' validator DBTable{..}
|
||||
@ -455,7 +458,7 @@ mkSubmissionGroupTable =
|
||||
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
|
||||
& restrictSorting (\name _ -> name /= "corrector")
|
||||
& defaultSorting [("edit",SortDesc)]
|
||||
& defaultSorting [SortDescBy "edit"]
|
||||
dbtSorting = Map.fromList
|
||||
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
|
||||
, ( "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 )
|
||||
]
|
||||
dbtFilterUI = mempty
|
||||
dbtParams = def
|
||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
||||
in dbTableWidget' validator DBTable{..}
|
||||
|
||||
@ -529,7 +533,7 @@ mkCorrectionsTable =
|
||||
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
|
||||
[ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
|
||||
, ( "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)
|
||||
]
|
||||
dbtFilterUI = mempty
|
||||
dbtParams = def
|
||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
||||
in dbTableWidget' validator DBTable{..}
|
||||
|
||||
|
||||
@ -201,7 +201,7 @@ getSheetListR tid ssh csh = do
|
||||
]
|
||||
|
||||
psValidator = def
|
||||
& defaultSorting [("submission-since", SortAsc)]
|
||||
& defaultSorting [SortAscBy "submission-since"]
|
||||
|
||||
(table,raw_statistics) <- runDB $ liftA2 (,)
|
||||
(dbTableWidget' psValidator DBTable
|
||||
@ -236,6 +236,7 @@ getSheetListR tid ssh csh = do
|
||||
, dbtFilter = mempty
|
||||
, dbtFilterUI = mempty
|
||||
, dbtStyle = def
|
||||
, dbtParams = def
|
||||
, 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
|
||||
]
|
||||
let psValidator = def
|
||||
& defaultSorting [("type", SortAsc), ("path", SortAsc)]
|
||||
& defaultSorting [SortAscBy "type", SortAscBy "path"]
|
||||
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
|
||||
{ dbtSQLQuery = fileData
|
||||
, dbtColonnade = colonnadeFiles
|
||||
@ -319,6 +320,7 @@ getSShowR tid ssh csh shn = do
|
||||
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified
|
||||
)
|
||||
]
|
||||
, dbtParams = def
|
||||
}
|
||||
(hasHints, hasSolution) <- runDB $ do
|
||||
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
|
||||
|
||||
@ -312,6 +312,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
]
|
||||
, dbtFilter = mempty
|
||||
, dbtFilterUI = mempty
|
||||
, dbtParams = def
|
||||
}
|
||||
mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
|
||||
|
||||
|
||||
@ -13,6 +13,8 @@ import Handler.Utils
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
htmlField' :: Field (HandlerT UniWorX IO) Html
|
||||
htmlField' = htmlField
|
||||
@ -154,7 +156,7 @@ postMessageListR = do
|
||||
let
|
||||
dbtSQLQuery = return
|
||||
dbtColonnade = mconcat
|
||||
[ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
|
||||
[ dbSelect _2 id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
|
||||
, dbRow
|
||||
, 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
|
||||
@ -173,28 +175,46 @@ postMessageListR = do
|
||||
{ dbrOutput = (smE, smT)
|
||||
, ..
|
||||
}
|
||||
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
|
||||
tableForm <- runDB $ dbTable psValidator DBTable
|
||||
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
|
||||
(tableRes', tableView) <- runDB $ dbTable psValidator DBTable
|
||||
{ dbtSQLQuery
|
||||
, dbtColonnade
|
||||
, 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
|
||||
, dbtFilterUI = mempty
|
||||
, 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
|
||||
}
|
||||
((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
|
||||
(fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
|
||||
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)
|
||||
$logDebugS "SystemMessage" $ tshow (actionRes, selectionRes)
|
||||
return ((,) <$> actionRes <*> selectionRes, table <> action)
|
||||
|
||||
let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||||
& mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
|
||||
|
||||
case tableRes of
|
||||
FormMissing -> return ()
|
||||
|
||||
@ -128,6 +128,7 @@ getTermShowR = do
|
||||
]
|
||||
, dbtFilterUI = mempty
|
||||
, dbtStyle = def
|
||||
, dbtParams = def
|
||||
, dbtIdent = "terms" :: Text
|
||||
}
|
||||
defaultLayout $ do
|
||||
|
||||
@ -67,7 +67,7 @@ getUsersR = do
|
||||
|]
|
||||
]
|
||||
psValidator = def
|
||||
& defaultSorting [("name", SortAsc),("display-name", SortAsc)]
|
||||
& defaultSorting [SortAscBy "name", SortAscBy "display-name"]
|
||||
|
||||
((), userList) <- runDB $ dbTable psValidator DBTable
|
||||
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||
@ -87,6 +87,7 @@ getUsersR = do
|
||||
, dbtFilter = mempty
|
||||
, dbtFilterUI = mempty
|
||||
, dbtStyle = def
|
||||
, dbtParams = def
|
||||
, dbtIdent = "users" :: Text
|
||||
}
|
||||
|
||||
|
||||
@ -1,15 +1,18 @@
|
||||
module Handler.Utils.Table.Pagination
|
||||
( SortColumn(..), SortDirection(..)
|
||||
( module Handler.Utils.Table.Pagination.Types
|
||||
, SortColumn(..), SortDirection(..)
|
||||
, pattern SortAscBy, pattern SortDescBy
|
||||
, FilterColumn(..), IsFilterColumn
|
||||
, DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
|
||||
, DBStyle(..), DBEmptyStyle(..)
|
||||
, DBTable(..), IsDBTable(..), DBCell(..)
|
||||
, DBParams(..)
|
||||
, cellAttrs, cellContents
|
||||
, PaginationSettings(..), PaginationInput(..), piIsUnset
|
||||
, PSValidator(..)
|
||||
, defaultFilter, defaultSorting
|
||||
, restrictFilter, restrictSorting
|
||||
, ToSortable(..), Sortable(..), sortable
|
||||
, ToSortable(..), Sortable(..)
|
||||
, dbTable
|
||||
, dbTableWidget, dbTableWidget'
|
||||
, widgetColonnade, formColonnade, dbColonnade
|
||||
@ -38,9 +41,6 @@ import qualified Data.Binary.Builder as Builder
|
||||
|
||||
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.Writer hiding ((<>), mapM_)
|
||||
import Control.Monad.Reader (ReaderT(..), mapReaderT)
|
||||
@ -65,18 +65,21 @@ import Data.Aeson (Options(..), defaultOptions, decodeStrict')
|
||||
import Data.Aeson.Text
|
||||
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 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
|
||||
toPathPiece SortAsc = "asc"
|
||||
toPathPiece SortDesc = "desc"
|
||||
fromPathPiece (CI.mk -> t)
|
||||
| t == "asc" = Just SortAsc
|
||||
| t == "desc" = Just SortDesc
|
||||
| otherwise = Nothing
|
||||
fromPathPiece = finiteFromPathPiece
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ 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
|
||||
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
data PaginationSettings = PaginationSettings
|
||||
{ psSorting :: [(CI Text, SortDirection)]
|
||||
, psFilter :: Map (CI Text) [Text]
|
||||
{ psSorting :: [SortingSetting]
|
||||
, psFilter :: Map FilterKey [Text]
|
||||
, psLimit :: Int64
|
||||
, psPage :: Int64
|
||||
}
|
||||
@ -132,8 +158,8 @@ deriveJSON defaultOptions
|
||||
} ''PaginationSettings
|
||||
|
||||
data PaginationInput = PaginationInput
|
||||
{ piSorting :: Maybe [(CI Text, SortDirection)]
|
||||
, piFilter :: Maybe (Map (CI Text) [Text])
|
||||
{ piSorting :: Maybe [SortingSetting]
|
||||
, piFilter :: Maybe (Map FilterKey [Text])
|
||||
, piLimit :: Maybe Int64
|
||||
, piPage :: Maybe Int64
|
||||
} 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 })
|
||||
|
||||
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'
|
||||
where
|
||||
injectDefault x = case x >>= piFilter of
|
||||
Just _ -> id
|
||||
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'
|
||||
where
|
||||
injectDefault x = case x >>= piSorting of
|
||||
Just _ -> id
|
||||
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
|
||||
where
|
||||
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
|
||||
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
|
||||
@ -244,9 +270,6 @@ instance Default DBStyle where
|
||||
, 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.
|
||||
( ToSortable h, Functor h
|
||||
, E.SqlSelect a r
|
||||
@ -260,10 +283,12 @@ data DBTable m x = forall a r r' h i t.
|
||||
, dbtFilter :: Map FilterKey (FilterColumn t)
|
||||
, dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
|
||||
, dbtStyle :: DBStyle
|
||||
, dbtParams :: DBParams m x
|
||||
, 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 :: *
|
||||
|
||||
@ -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
|
||||
-- | 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)
|
||||
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 = dbCell . _1
|
||||
@ -284,6 +309,7 @@ cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
|
||||
cellContents = dbCell . _2
|
||||
|
||||
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' (WidgetT UniWorX IO) () = ()
|
||||
|
||||
@ -299,13 +325,17 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
|
||||
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
||||
dbWidget _ _ = return . snd
|
||||
dbHandler _ _ f = return . over _2 f
|
||||
runDBTable = liftHandlerT
|
||||
runDBTable _ _ = liftHandlerT
|
||||
|
||||
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
|
||||
mempty = WidgetCell mempty $ return mempty
|
||||
(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
|
||||
data DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBParamsDB
|
||||
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
|
||||
|
||||
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
|
||||
dbHandler _ _ f = return . over _2 f
|
||||
-- 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
|
||||
mempty = DBCell mempty $ return mempty
|
||||
(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
|
||||
-- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
|
||||
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
|
||||
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = DBParamsForm
|
||||
{ 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)
|
||||
|
||||
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))
|
||||
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
|
||||
dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi
|
||||
dbHandler dbtable pi f form = return $ fmap (over _2 f) . addPIHiddenField dbtable pi form
|
||||
dbWidget _ _ = return . snd
|
||||
dbHandler _ _ f = return . over _2 f
|
||||
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
|
||||
-- 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 = 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{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet|
|
||||
$newline never
|
||||
<input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
|
||||
|]
|
||||
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
|
||||
let
|
||||
sortingOptions = mkOptionList
|
||||
[ Option t' (t, d) t'
|
||||
[ Option t' (SortingSetting t d) t'
|
||||
| (t, _) <- mapToList dbtSorting
|
||||
, d <- [SortAsc, SortDesc]
|
||||
, let t' = CI.foldedCase t <> "-" <> toPathPiece d
|
||||
, let t' = toPathPiece $ SortingSetting t d
|
||||
]
|
||||
wIdent n
|
||||
| not $ null dbtIdent = dbtIdent <> "-" <> n
|
||||
@ -394,7 +456,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
|
||||
piInput <- lift . runInputGetResult $ PaginationInput
|
||||
<$> 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 "page")
|
||||
|
||||
@ -427,7 +489,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
= pi
|
||||
| otherwise
|
||||
= def
|
||||
psSorting' = map (first (dbtSorting !)) psSorting
|
||||
psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
|
||||
|
||||
mapM_ (addMessageI Warning) errs
|
||||
|
||||
@ -454,7 +516,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
|
||||
filterAction = tblLink
|
||||
$ 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' = do
|
||||
@ -463,7 +525,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
|
||||
widget <- sortableContent ^. cellContents
|
||||
let
|
||||
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
|
||||
directions = [dir | SortingSetting k dir <- psSorting, Just k == sortableKey ]
|
||||
isSortable = isJust sortableKey
|
||||
isSorted = (`elem` directions)
|
||||
attrs = sortableContent ^. cellAttrs
|
||||
@ -485,7 +547,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
|
||||
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
|
||||
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
|
||||
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 initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
|
||||
|
||||
formCell :: forall r i a. Ord i
|
||||
=> (r -> MForm (HandlerT UniWorX IO) i)
|
||||
formCell :: forall res r i a. (Ord i, Monoid res)
|
||||
=> Lens' res (DBFormResult r i a)
|
||||
-> (r -> MForm (HandlerT UniWorX IO) i)
|
||||
-> (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)))
|
||||
formCell genIndex genForm input = FormCell
|
||||
-> (r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
|
||||
formCell resLens genIndex genForm input = FormCell
|
||||
{ formCellAttrs = []
|
||||
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
|
||||
i <- genIndex input
|
||||
(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 = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
|
||||
|
||||
dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
|
||||
=> Setter' a Bool
|
||||
dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res)
|
||||
=> Lens' res (DBFormResult r i a)
|
||||
-> Setter' a Bool
|
||||
-> (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)))
|
||||
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
|
||||
-> Colonnade h r (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
|
||||
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)
|
||||
return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])
|
||||
return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -7,12 +15,23 @@ import Colonnade.Encode
|
||||
|
||||
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
|
||||
{ sortableKey :: Maybe (CI Text)
|
||||
{ sortableKey :: Maybe SortingKey
|
||||
, 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)
|
||||
|
||||
instance Headedness Sortable where
|
||||
|
||||
@ -41,6 +41,7 @@ import Data.Hashable as Import
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..))
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Semigroup)
|
||||
import Data.Monoid as Import (Last(..), First(..))
|
||||
import Data.Monoid.Instances as Import ()
|
||||
|
||||
import Control.Monad.Morph as Import (MFunctor(..))
|
||||
|
||||
@ -1,5 +1,2 @@
|
||||
<div .container>
|
||||
<form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}>
|
||||
^{table}
|
||||
<button type=submit>
|
||||
_{MsgBtnSubmit}
|
||||
^{table}
|
||||
|
||||
@ -1,7 +1,4 @@
|
||||
<section>
|
||||
<form method=POST enctype=#{tableEncoding} action=@{currentRoute}>
|
||||
^{table}
|
||||
<button type=submit>
|
||||
_{MsgBtnSubmit}
|
||||
^{table}
|
||||
<section>
|
||||
^{statistics}
|
||||
^{statistics}
|
||||
|
||||
@ -1,8 +1,5 @@
|
||||
<section>
|
||||
<form method=post action=@{MessageListR} encytpe=#{tableEncoding}>
|
||||
^{tableView}
|
||||
<button type=submit>
|
||||
_{MsgBtnSubmit}
|
||||
^{tableView}
|
||||
|
||||
<section>
|
||||
<form method=post action=@{MessageListR} enctype=#{addEncoding}>
|
||||
|
||||
@ -2,10 +2,10 @@
|
||||
$maybe flag <- sortableKey
|
||||
$case directions
|
||||
$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}
|
||||
$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}
|
||||
$nothing
|
||||
^{widget}
|
||||
|
||||
5
templates/table/form-wrap.hamlet
Normal file
5
templates/table/form-wrap.hamlet
Normal 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}
|
||||
Loading…
Reference in New Issue
Block a user