diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index d7db622ff..7dc9123e8 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -18,6 +18,8 @@ import qualified Data.Text.Encoding as Text import Language.Haskell.TH.Syntax (Lift(..)) +import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..)) + instance PersistField (CI Text) where 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 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 toMessage = toMessage . CI.original diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index e574aca5a..aa16a97b5 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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)) 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 let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ 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 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 (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf (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))) 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 void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True return i diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 161ebcd1d..03cbe03c5 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -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.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid -makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h ) - => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) +makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) ) + => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget makeCourseTable whereClause colChoices psValidator = do - muid <- maybeAuthId + muid <- lift maybeAuthId let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _ dbtSQLQuery qin@(course `E.InnerJoin` school) = do E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId @@ -122,7 +122,7 @@ makeCourseTable whereClause colChoices psValidator = do return (course, participants, registered, school) dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school) - dbTable psValidator DBTable + fmap snd $ dbTable psValidator DBTable { dbtSQLQuery , dbtColonnade = colChoices , dbtProj @@ -179,7 +179,7 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!! whereClause = const $ E.val True validator = def & defaultSorting [("course", SortAsc), ("term", SortDesc)] - ((), coursesTable) <- makeCourseTable whereClause colonnade validator + coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI MsgCourseListTitle [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO @@ -211,7 +211,7 @@ getTermSchoolCourseListR tid ssh = do E.&&. course E.^. CourseSchool E.==. E.val ssh validator = def & defaultSorting [("cshort", SortAsc)] - ((), coursesTable) <- makeCourseTable whereClause colonnade validator + coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI $ MsgTermSchoolCourseListTitle tid school $(widgetFile "courses") @@ -233,7 +233,7 @@ getTermCourseListR tid = do whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid validator = def & defaultSorting [("cshort", SortAsc)] - ((), coursesTable) <- makeCourseTable whereClause colonnade validator + coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI . MsgTermCourseListTitle $ tid $(widgetFile "courses") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index f6f329951..2a87a09e8 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -72,7 +72,7 @@ homeAnonymous = do , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] - ((), courseTable) <- dbTable def DBTable + courseTable <- runDB $ dbTableWidget' def DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade , dbtProj = return @@ -166,7 +166,7 @@ homeUser uid = do tickmark ] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] - ((), sheetTable) <- dbTable validator DBTable + sheetTable <- runDB $ dbTableWidget' validator DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade , dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 4e1f7abe1..dab2a6b83 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -204,25 +204,25 @@ getProfileDataR = do , studyfeat E.^. StudyFeaturesType , studyfeat E.^. StudyFeaturesSemester) ) - -- Tabelle mit eigenen Kursen - (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid - -- Tabelle mit allen Teilnehmer: Kurs (link), Datum - enrolledCoursesTable <- mkEnrolledCoursesTable uid - -- Tabelle mit allen Klausuren und Noten + ( (hasRows, ownedCoursesTable) + , enrolledCoursesTable + , submissionTable + , submissionGroupTable + , 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.|] - -- 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.|] - -- Tabelle mit allen Tutorials let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] + -- Delete Button (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete) - -- TODO: move this into a Message and/or Widget-File defaultLayout $ do let delWdgt = $(widgetFile "widgets/data-delete") $(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 mkOwnedCoursesTable = 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 mkEnrolledCoursesTable = 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 mkSubmissionTable = 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 mkSubmissionGroupTable = 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 mkCorrectionsTable = let dbtIdent = "corrections" :: Text diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 919dc3f53..18a4c473a 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -194,7 +194,7 @@ getSheetListR tid ssh csh = do ] psValidator = def & defaultSorting [("submission-since", SortAsc)] - ((), table) <- dbTable psValidator $ DBTable + table <- runDB $ dbTableWidget' psValidator DBTable { dbtSQLQuery = sheetData , dbtColonnade = sheetCol , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } @@ -286,7 +286,7 @@ getSShowR tid ssh csh shn = do ] let psValidator = def & defaultSorting [("type", SortAsc), ("path", SortAsc)] - (Any hasFiles, fileTable) <- dbTable psValidator $ DBTable + (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = fileData , dbtColonnade = colonnadeFiles , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 280fc3a48..cc645a929 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -312,7 +312,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do ] , dbtFilter = Map.empty } - mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid + mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid ssh csh shn diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 9ab849b41..0bde9b1c8 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -174,7 +174,7 @@ postMessageListR = do , .. } psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool)) - tableForm <- dbTable psValidator DBTable + tableForm <- runDB $ dbTable psValidator DBTable { dbtSQLQuery , dbtColonnade , dbtProj diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index e5bb7641e..41262bd44 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -96,7 +96,7 @@ getTermShowR = do -- #{termToText termName} -- |] -- ] - ((), table) <- dbTable def DBTable + table <- runDB $ dbTableWidget' def DBTable { dbtSQLQuery = termData , dbtColonnade = colonnadeTerms , dbtProj = return . dbrOutput diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 178957385..ec3924508 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -69,7 +69,7 @@ getUsersR = do psValidator = def & 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)) , dbtColonnade , dbtProj = return diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index df84f44fc..f41a26689 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -25,6 +25,7 @@ module Handler.Utils.Table.Pagination ) where import Handler.Utils.Table.Pagination.Types +import Utils import Utils.Lens.TH import Import hiding (pi) @@ -59,6 +60,10 @@ import Data.Ratio ((%)) 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) } @@ -72,6 +77,10 @@ instance PathPiece SortDirection where | t == "desc" = Just SortDesc | otherwise = Nothing +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''SortDirection + sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t @@ -119,15 +128,32 @@ instance Default PaginationSettings where , psShortcircuit = False } +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''PaginationSettings + data PaginationInput = PaginationInput { piSorting :: Maybe [(CI Text, SortDirection)] , piFilter :: Maybe (Map (CI Text) [Text]) , piLimit :: Maybe Int64 , piPage :: Maybe Int64 , 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 +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , omitNothingFields = True + } ''PaginationInput piIsUnset :: PaginationInput -> Bool 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) -- | 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 - 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) 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) -- dbWidget Proxy Proxy = iso (, ()) $ view _1 - dbWidget _ = return . snd - dbHandler _ f = return . over _2 f + dbWidget _ _ = return . snd + dbHandler _ _ f = return . over _2 f runDBTable = liftHandlerT 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)) (uncurry DBCell) - dbWidget _ = return . snd - dbHandler _ f = return . over _2 f + 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 @@ -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)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) - dbWidget _ = liftHandlerT . fmap (view $ _1 . _2) . runFormPost - dbHandler _ f form = return $ fmap (over _2 f) . form + 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 -- 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 +addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a +addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet| + + |] + 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 mempty = FormCell mempty (return mempty) (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 -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 let sortingOptions = mkOptionList @@ -350,80 +385,89 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), d , fieldEnctype = UrlEncoded } - psResult <- runInputGetResult $ PaginationInput + piResult <- 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) <*> iopt intField (wIdent "pagesize") <*> iopt intField (wIdent "page") <*> ireq checkBoxField (wIdent "table-only") - $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> psResult) - <*> (piFilter <$> psResult) - <*> (piLimit <$> psResult) - <*> (piPage <$> psResult) - <*> (piShortcircuit <$> psResult) + piPrevious <- fmap (fmap (set _piShortcircuit False) . maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination") + + $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> piResult) + <*> (piFilter <$> piResult) + <*> (piLimit <$> piResult) + <*> (piPage <$> piResult) + <*> (piShortcircuit <$> piResult) let - (errs, PaginationSettings{..}) = case psResult of + (errs, PaginationSettings{..}) = case piPrevious <|> piResult of FormSuccess pi - | not (piIsUnset pi) -> runPSValidator dbtable $ Just pi - FormFailure errs' -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing - _ -> runPSValidator dbtable Nothing + | not (piIsUnset pi) + -> runPSValidator dbtable $ Just pi + 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 mapM_ (addMessageI Warning) errs - runDB $ do - rows' <- E.select . E.from $ \t -> do - res <- dbtSQLQuery t - E.orderBy (map (sqlSortDirection t) psSorting') - E.limit psLimit - E.offset (psPage * psLimit) - 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) + rows' <- E.select . E.from $ \t -> do + res <- dbtSQLQuery t + E.orderBy (map (sqlSortDirection t) psSorting') + E.limit psLimit + E.offset (psPage * psLimit) + 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) - let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f) - - rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' + let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f) - let - rowCount - | (E.Value n, _):_ <- rows' = n - | otherwise = 0 + rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' - table' :: WriterT x m Widget - table' = do - getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest + let + rowCount + | (E.Value n, _):_ <- rows' = n + | otherwise = 0 - let - tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams + table' :: WriterT x m Widget + table' = do + getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest - genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do - widget <- sortableContent ^. cellContents - let - directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ] - isSortable = isJust sortableKey - isSorted = (`elem` directions) - attrs = sortableContent ^. cellAttrs - return $(widgetFile "table/cell/header") + let + tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams - columnCount :: Int64 - columnCount = olength64 $ getColonnade dbtColonnade + genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do + widget <- sortableContent ^. cellContents + let + directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ] + isSortable = isJust sortableKey + isSorted = (`elem` directions) + attrs = sortableContent ^. cellAttrs + return $(widgetFile "table/cell/header") - wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable + columnCount :: Int64 + columnCount = olength64 $ getColonnade dbtColonnade - wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do - widget <- cell' ^. cellContents - let attrs = cell' ^. cellAttrs - return $(widgetFile "table/cell/body") - - let table = $(widgetFile "table/colonnade") - pageCount = max 1 . ceiling $ rowCount % psLimit - pageNumbers = [0..pred pageCount] + wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable - return $(widgetFile "table/layout") + wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do + widget <- cell' ^. cellContents + let attrs = cell' ^. cellAttrs + return $(widgetFile "table/cell/body") - bool (dbHandler dbtable $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table' + let table = $(widgetFile "table/colonnade") + pageCount = max 1 . ceiling $ rowCount % psLimit + pageNumbers = [0..pred pageCount] + + return $(widgetFile "table/layout") + + bool (dbHandler dbtable paginationInput $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table' where tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html 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 ] 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' :: 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 widgetColonnade :: (Headedness h, Monoid x)