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

Send pagination data in dbTable-Forms

Browse Source
This commit is contained in:
Gregor Kleen 2018-11-29 12:30:42 +01:00
parent 6c0f031c4e
commit 997403d6be
11 changed files with 154 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/Data/CaseInsensitive/Instances.hs
View File

@ -18,6 +18,8 @@ import qualified Data.Text.Encoding as Text
import Language.Haskell.TH.Syntax (Lift(..)) import Language.Haskell.TH.Syntax (Lift(..))
import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))
instance PersistField (CI Text) where instance PersistField (CI Text) where
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@ -41,6 +43,14 @@ instance ToJSON a => ToJSON (CI a) where
instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
parseJSON = fmap CI.mk . parseJSON parseJSON = fmap CI.mk . parseJSON
instance (ToJSONKey a, ToJSON a) => ToJSONKey (CI a) where
toJSONKey = case toJSONKey of
ToJSONKeyText toVal toEnc -> ToJSONKeyText (toVal . CI.original) (toEnc . CI.original)
ToJSONKeyValue toVal toEnc -> ToJSONKeyValue (toVal . CI.original) (toEnc . CI.original)
instance (FromJSON a, FromJSONKey a, CI.FoldCase a) => FromJSONKey (CI a) where
fromJSONKey = CI.mk <$> fromJSONKey
instance ToMessage a => ToMessage (CI a) where instance ToMessage a => ToMessage (CI a) where
toMessage = toMessage . CI.original toMessage = toMessage . CI.original

6
src/Handler/Corrections.hs
View File

@ -179,7 +179,7 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x) => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
@ -278,7 +278,7 @@ 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 <- makeCorrectionsTable whereClause displayColumns psValidator return tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator return
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
(fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
(actionRes, action) <- multiAction actions Nothing (actionRes, action) <- multiAction actions Nothing
@ -763,7 +763,7 @@ postCorrectionsGradeR = do
& 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 [("ratingtime", SortDesc)] :: 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)
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
cID <- encrypt subId cID <- encrypt subId
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
return i return i

14
src/Handler/Course.hs
View File

@ -109,10 +109,10 @@ course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \cou
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h ) makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
=> _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
makeCourseTable whereClause colChoices psValidator = do makeCourseTable whereClause colChoices psValidator = do
muid <- maybeAuthId muid <- lift maybeAuthId
let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _ let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
dbtSQLQuery qin@(course `E.InnerJoin` school) = do dbtSQLQuery qin@(course `E.InnerJoin` school) = do
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
@ -122,7 +122,7 @@ makeCourseTable whereClause colChoices psValidator = do
return (course, participants, registered, school) return (course, participants, registered, school)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school) dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
dbTable psValidator DBTable fmap snd $ dbTable psValidator DBTable
{ dbtSQLQuery { dbtSQLQuery
, dbtColonnade = colChoices , dbtColonnade = colChoices
, dbtProj , dbtProj
@ -179,7 +179,7 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
whereClause = const $ E.val True whereClause = const $ E.val True
validator = def validator = def
& defaultSorting [("course", SortAsc), ("term", SortDesc)] & defaultSorting [("course", SortAsc), ("term", SortDesc)]
((), coursesTable) <- makeCourseTable whereClause colonnade validator coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do defaultLayout $ do
setTitleI MsgCourseListTitle setTitleI MsgCourseListTitle
[whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
@ -211,7 +211,7 @@ getTermSchoolCourseListR tid ssh = do
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
validator = def validator = def
& defaultSorting [("cshort", SortAsc)] & defaultSorting [("cshort", SortAsc)]
((), coursesTable) <- makeCourseTable whereClause colonnade validator coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgTermSchoolCourseListTitle tid school setTitleI $ MsgTermSchoolCourseListTitle tid school
$(widgetFile "courses") $(widgetFile "courses")
@ -233,7 +233,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 [("cshort", SortAsc)]
((), coursesTable) <- makeCourseTable whereClause colonnade validator coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do defaultLayout $ do
setTitleI . MsgTermCourseListTitle $ tid setTitleI . MsgTermCourseListTitle $ tid
$(widgetFile "courses") $(widgetFile "courses")

4
src/Handler/Home.hs
View File

@ -72,7 +72,7 @@ homeAnonymous = do
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
] ]
((), courseTable) <- dbTable def DBTable courseTable <- runDB $ dbTableWidget' def DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtColonnade = colonnade , dbtColonnade = colonnade
, dbtProj = return , dbtProj = return
@ -166,7 +166,7 @@ homeUser uid = do
tickmark tickmark
] ]
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
((), sheetTable) <- dbTable validator DBTable sheetTable <- runDB $ dbTableWidget' validator DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtColonnade = colonnade , dbtColonnade = colonnade
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } , dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }

38
src/Handler/Profile.hs
View File

@ -204,25 +204,25 @@ getProfileDataR = do
, studyfeat E.^. StudyFeaturesType , studyfeat E.^. StudyFeaturesType
, studyfeat E.^. StudyFeaturesSemester) , studyfeat E.^. StudyFeaturesSemester)
) )
-- Tabelle mit eigenen Kursen ( (hasRows, ownedCoursesTable)
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid , enrolledCoursesTable
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum , submissionTable
enrolledCoursesTable <- mkEnrolledCoursesTable uid , submissionGroupTable
-- Tabelle mit allen Klausuren und Noten , correctionsTable
) <- runDB $ (,,,,)
<$> mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
<*> mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
<*> mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
<*> mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
<*> mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
let examTable = [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|] let examTable = [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
-- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionTable <- mkSubmissionTable uid
-- Tabelle mit allen Abgabegruppen
submissionGroupTable <- mkSubmissionGroupTable uid
-- Tabelle mit allen Korrektor-Aufgaben
correctionsTable <- mkCorrectionsTable uid
-- Tabelle mit allen eigenen Tutorials
let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-- Tabelle mit allen Tutorials
let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-- Delete Button -- Delete Button
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete) (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete)
-- TODO: move this into a Message and/or Widget-File
defaultLayout $ do defaultLayout $ do
let delWdgt = $(widgetFile "widgets/data-delete") let delWdgt = $(widgetFile "widgets/data-delete")
$(widgetFile "profileData") $(widgetFile "profileData")
@ -230,7 +230,7 @@ getProfileDataR = do
mkOwnedCoursesTable :: UserId -> Handler (Bool, Widget) mkOwnedCoursesTable :: UserId -> DB (Bool, Widget)
-- Table listing all courses that the given user is a lecturer for -- Table listing all courses that the given user is a lecturer for
mkOwnedCoursesTable = mkOwnedCoursesTable =
let dbtIdent = "courseOwnership" :: Text let dbtIdent = "courseOwnership" :: Text
@ -277,7 +277,7 @@ mkOwnedCoursesTable =
mkEnrolledCoursesTable :: UserId -> Handler Widget mkEnrolledCoursesTable :: UserId -> DB Widget
-- Table listing all courses that the given user is enrolled in -- Table listing all courses that the given user is enrolled in
mkEnrolledCoursesTable = mkEnrolledCoursesTable =
let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
@ -324,7 +324,7 @@ mkEnrolledCoursesTable =
mkSubmissionTable :: UserId -> Handler Widget mkSubmissionTable :: UserId -> DB Widget
-- Table listing all submissions for the given user -- Table listing all submissions for the given user
mkSubmissionTable = mkSubmissionTable =
let dbtIdent = "submissions" :: Text let dbtIdent = "submissions" :: Text
@ -405,7 +405,7 @@ mkSubmissionTable =
mkSubmissionGroupTable :: UserId -> Handler Widget mkSubmissionGroupTable :: UserId -> DB Widget
-- Table listing all submissions for the given user -- Table listing all submissions for the given user
mkSubmissionGroupTable = mkSubmissionGroupTable =
let dbtIdent = "subGroups" :: Text let dbtIdent = "subGroups" :: Text
@ -470,7 +470,7 @@ mkSubmissionGroupTable =
mkCorrectionsTable :: UserId -> Handler Widget mkCorrectionsTable :: UserId -> DB Widget
-- Table listing sum of corrections made by the given user per sheet -- Table listing sum of corrections made by the given user per sheet
mkCorrectionsTable = mkCorrectionsTable =
let dbtIdent = "corrections" :: Text let dbtIdent = "corrections" :: Text

4
src/Handler/Sheet.hs
View File

@ -194,7 +194,7 @@ getSheetListR tid ssh csh = do
] ]
psValidator = def psValidator = def
& defaultSorting [("submission-since", SortAsc)] & defaultSorting [("submission-since", SortAsc)]
((), table) <- dbTable psValidator $ DBTable table <- runDB $ dbTableWidget' psValidator DBTable
{ dbtSQLQuery = sheetData { dbtSQLQuery = sheetData
, dbtColonnade = sheetCol , dbtColonnade = sheetCol
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
@ -286,7 +286,7 @@ getSShowR tid ssh csh shn = do
] ]
let psValidator = def let psValidator = def
& defaultSorting [("type", SortAsc), ("path", SortAsc)] & defaultSorting [("type", SortAsc), ("path", SortAsc)]
(Any hasFiles, fileTable) <- dbTable psValidator $ DBTable (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery = fileData { dbtSQLQuery = fileData
, dbtColonnade = colonnadeFiles , dbtColonnade = colonnadeFiles
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }

2
src/Handler/Submission.hs
View File

@ -312,7 +312,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
] ]
, dbtFilter = Map.empty , dbtFilter = Map.empty
} }
mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSubmissionEditHead tid ssh csh shn setTitleI $ MsgSubmissionEditHead tid ssh csh shn

2
src/Handler/SystemMessage.hs
View File

@ -174,7 +174,7 @@ postMessageListR = do
, .. , ..
} }
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool)) psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
tableForm <- dbTable psValidator DBTable tableForm <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery { dbtSQLQuery
, dbtColonnade , dbtColonnade
, dbtProj , dbtProj

2
src/Handler/Term.hs
View File

@ -96,7 +96,7 @@ getTermShowR = do
-- #{termToText termName} -- #{termToText termName}
-- |] -- |]
-- ] -- ]
((), table) <- dbTable def DBTable table <- runDB $ dbTableWidget' def DBTable
{ dbtSQLQuery = termData { dbtSQLQuery = termData
, dbtColonnade = colonnadeTerms , dbtColonnade = colonnadeTerms
, dbtProj = return . dbrOutput , dbtProj = return . dbrOutput

2
src/Handler/Users.hs
View File

@ -69,7 +69,7 @@ getUsersR = do
psValidator = def psValidator = def
& defaultSorting [("name", SortAsc),("display-name", SortAsc)] & defaultSorting [("name", SortAsc),("display-name", SortAsc)]
((), userList) <- 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))
, dbtColonnade , dbtColonnade
, dbtProj = return , dbtProj = return

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

@ -25,6 +25,7 @@ module Handler.Utils.Table.Pagination
) where ) where
import Handler.Utils.Table.Pagination.Types import Handler.Utils.Table.Pagination.Types
import Utils
import Utils.Lens.TH import Utils.Lens.TH
import Import hiding (pi) import Import hiding (pi)
@ -59,6 +60,10 @@ import Data.Ratio ((%))
import Control.Lens import Control.Lens
import Data.Aeson (Options(..), defaultOptions, decodeStrict')
import Data.Aeson.Text
import Data.Aeson.TH (deriveJSON)
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) }
@ -72,6 +77,10 @@ instance PathPiece SortDirection where
| t == "desc" = Just SortDesc | t == "desc" = Just SortDesc
| otherwise = Nothing | otherwise = Nothing
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
} ''SortDirection
sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t 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
@ -119,15 +128,32 @@ instance Default PaginationSettings where
, psShortcircuit = False , psShortcircuit = False
} }
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
} ''PaginationSettings
data PaginationInput = PaginationInput data PaginationInput = PaginationInput
{ piSorting :: Maybe [(CI Text, SortDirection)] { piSorting :: Maybe [(CI Text, SortDirection)]
, piFilter :: Maybe (Map (CI Text) [Text]) , piFilter :: Maybe (Map (CI Text) [Text])
, piLimit :: Maybe Int64 , piLimit :: Maybe Int64
, piPage :: Maybe Int64 , piPage :: Maybe Int64
, piShortcircuit :: Bool , piShortcircuit :: Bool
} } deriving (Eq, Ord, Show, Read, Generic)
instance Default PaginationInput where
def = PaginationInput
{ piSorting = Nothing
, piFilter = Nothing
, piLimit = Nothing
, piPage = Nothing
, piShortcircuit = False
}
makeLenses_ ''PaginationInput makeLenses_ ''PaginationInput
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
, omitNothingFields = True
} ''PaginationInput
piIsUnset :: PaginationInput -> Bool piIsUnset :: PaginationInput -> Bool
piIsUnset PaginationInput{..} = and piIsUnset PaginationInput{..} = and
@ -241,9 +267,9 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x) -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
-- | Format @DBTable@ when sort-circuiting -- | Format @DBTable@ when sort-circuiting
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> 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 -> (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) => 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)]
@ -266,8 +292,8 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
(uncurry WidgetCell) (uncurry WidgetCell)
-- 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
@ -286,8 +312,8 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
(\DBCell{..} -> (dbCellAttrs, dbCellContents)) (\DBCell{..} -> (dbCellAttrs, dbCellContents))
(uncurry DBCell) (uncurry DBCell)
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
@ -314,13 +340,22 @@ 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 _ = liftHandlerT . fmap (view $ _1 . _2) . runFormPost dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi
dbHandler _ f form = return $ fmap (over _2 f) . form dbHandler dbtable pi f form = return $ fmap (over _2 f) . addPIHiddenField dbtable pi form
-- 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 = return . withFragment
addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a
addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet|
<input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
|]
where
wIdent n
| not $ null dbtIdent = dbtIdent <> "-" <> n
| otherwise = n
instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
mempty = FormCell mempty (return mempty) mempty = FormCell mempty (return mempty)
(FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c') (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')
@ -329,7 +364,7 @@ instance IsDBTable m a => IsString (DBCell m a) where
fromString = cell . fromString fromString = cell . fromString
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x) dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
let let
sortingOptions = mkOptionList sortingOptions = mkOptionList
@ -350,80 +385,89 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), d
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
psResult <- runInputGetResult $ PaginationInput piResult <- 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 $ CI.foldedCase k) dbtFilter)
<*> iopt intField (wIdent "pagesize") <*> iopt intField (wIdent "pagesize")
<*> iopt intField (wIdent "page") <*> iopt intField (wIdent "page")
<*> ireq checkBoxField (wIdent "table-only") <*> ireq checkBoxField (wIdent "table-only")
$(logDebug) . tshow $ (,,,,) <$> (piSorting <$> psResult) piPrevious <- fmap (fmap (set _piShortcircuit False) . maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
<*> (piFilter <$> psResult)
<*> (piLimit <$> psResult) $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> piResult)
<*> (piPage <$> psResult) <*> (piFilter <$> piResult)
<*> (piShortcircuit <$> psResult) <*> (piLimit <$> piResult)
<*> (piPage <$> piResult)
<*> (piShortcircuit <$> piResult)
let let
(errs, PaginationSettings{..}) = case psResult of (errs, PaginationSettings{..}) = case piPrevious <|> piResult of
FormSuccess pi FormSuccess pi
| not (piIsUnset pi) -> runPSValidator dbtable $ Just pi | not (piIsUnset pi)
FormFailure errs' -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing -> runPSValidator dbtable $ Just pi
_ -> runPSValidator dbtable Nothing FormFailure errs'
-> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
_ -> runPSValidator dbtable Nothing
paginationInput
| FormSuccess pi <- piPrevious <|> piResult
, not $ piIsUnset pi
= pi
| otherwise
= def
psSorting' = map (first (dbtSorting !)) psSorting psSorting' = map (first (dbtSorting !)) psSorting
mapM_ (addMessageI Warning) errs mapM_ (addMessageI Warning) errs
runDB $ do rows' <- E.select . E.from $ \t -> do
rows' <- E.select . E.from $ \t -> do res <- dbtSQLQuery t
res <- dbtSQLQuery t E.orderBy (map (sqlSortDirection t) psSorting')
E.orderBy (map (sqlSortDirection t) psSorting') E.limit psLimit
E.limit psLimit E.offset (psPage * psLimit)
E.offset (psPage * psLimit) Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), res)
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), res)
let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f) let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)
rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
let let
rowCount rowCount
| (E.Value n, _):_ <- rows' = n | (E.Value n, _):_ <- rows' = n
| otherwise = 0 | otherwise = 0
table' :: WriterT x m Widget table' :: WriterT x m Widget
table' = do table' = do
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
let let
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
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 | (k, dir) <- psSorting, Just k == sortableKey ]
isSortable = isJust sortableKey isSortable = isJust sortableKey
isSorted = (`elem` directions) isSorted = (`elem` directions)
attrs = sortableContent ^. cellAttrs attrs = sortableContent ^. cellAttrs
return $(widgetFile "table/cell/header") return $(widgetFile "table/cell/header")
columnCount :: Int64 columnCount :: Int64
columnCount = olength64 $ getColonnade dbtColonnade columnCount = olength64 $ getColonnade dbtColonnade
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
widget <- cell' ^. cellContents widget <- cell' ^. cellContents
let attrs = cell' ^. cellAttrs let attrs = cell' ^. cellAttrs
return $(widgetFile "table/cell/body") return $(widgetFile "table/cell/body")
let table = $(widgetFile "table/colonnade") let table = $(widgetFile "table/colonnade")
pageCount = max 1 . ceiling $ rowCount % psLimit pageCount = max 1 . ceiling $ rowCount % psLimit
pageNumbers = [0..pred pageCount] pageNumbers = [0..pred pageCount]
return $(widgetFile "table/layout") return $(widgetFile "table/layout")
bool (dbHandler dbtable $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table' bool (dbHandler dbtable paginationInput $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . 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
@ -434,10 +478,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), d
setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ] setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
-> Handler (DBResult (HandlerT UniWorX IO) x) -> DB (DBResult (HandlerT UniWorX IO) x)
dbTableWidget = dbTable dbTableWidget = dbTable
dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> Handler Widget dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> DB Widget
dbTableWidget' = fmap (fmap snd) . dbTable dbTableWidget' = fmap (fmap snd) . dbTable
widgetColonnade :: (Headedness h, Monoid x) widgetColonnade :: (Headedness h, Monoid x)