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

Cleanup

Browse Source
This commit is contained in:
Gregor Kleen 2018-03-19 12:29:55 +01:00
parent 170442cff0
commit 28d9c5c95b
1 changed files with 27 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -8,7 +8,13 @@
, ViewPatterns , ViewPatterns
#-} #-}
module Handler.Utils.Table.Pagination where module Handler.Utils.Table.Pagination
( SortColumn(..), SortDirection(..)
, DBTable(..)
, PaginationSettings(..)
, PSValidator(..)
, dbTable
) where
import Import import Import
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
@ -16,9 +22,12 @@ import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
import Text.Blaze (Attribute) import Text.Blaze (Attribute)
import qualified Text.Blaze.Html5.Attributes as Html5 import qualified Text.Blaze.Html5.Attributes as Html5
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_) import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_)
import Data.Map (Map) import Data.Map (Map, (!))
import Colonnade hiding (bool, fromMaybe) import Colonnade hiding (bool, fromMaybe)
import Yesod.Colonnade import Yesod.Colonnade
@ -29,8 +38,16 @@ import Data.Ratio ((%))
data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) } data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) }
data SortDirection = SortAsc | SortDesc data SortDirection = SortAsc | SortDesc
deriving (Eq, Ord, Enum, Show, Read) deriving (Eq, Ord, Enum, Show, Read)
instance PathPiece SortDirection where
toPathPiece SortAsc = "asc"
toPathPiece SortDesc = "desc"
fromPathPiece (CI.mk -> t)
| t == "asc" = Just SortAsc
| t == "desc" = Just SortDesc
| otherwise = Nothing
sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy
sqlSortDirection (SortColumn e, SortAsc ) = E.asc e sqlSortDirection (SortColumn e, SortAsc ) = E.asc e
@ -49,7 +66,7 @@ data DBTable = forall a r h i.
} }
data PaginationSettings = PaginationSettings data PaginationSettings = PaginationSettings
{ psSorting :: [(SortColumn, SortDirection)] { psSorting :: [(Text, SortDirection)]
, psLimit :: Int64 , psLimit :: Int64
, psPage :: Int64 , psPage :: Int64
, psShortcircuit :: Bool , psShortcircuit :: Bool
@ -78,16 +95,11 @@ dbTable :: PSValidator -> DBTable -> Handler Widget
dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
let let
sortingOptions = mkOptionList sortingOptions = mkOptionList
[ Option t' (c, d) t' [ Option t' (t, d) t'
| (t, c) <- mapToList dbtSorting | (t, _) <- mapToList dbtSorting
, d <- [SortAsc, SortDesc] , d <- [SortAsc, SortDesc]
, let t' = t <> "-" <> tshow d , let t' = t <> "-" <> toPathPiece d
] ]
sortingField = Field parse (\_ _ _ _ _ -> return ()) UrlEncoded
where
parse optlist _ = case mapM (olReadExternal sortingOptions) optlist of
Nothing -> return $ Left "Error parsing values"
Just res -> return $ Right $ Just res
(_, defPS) = runPSValidator Nothing (_, defPS) = runPSValidator Nothing
wIdent n wIdent n
| not $ null dbtIdent = dbtIdent <> "-" <> n | not $ null dbtIdent = dbtIdent <> "-" <> n
@ -97,7 +109,7 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
| otherwise = dbtAttrs | otherwise = dbtAttrs
psResult <- runInputGetResult $ PaginationSettings psResult <- runInputGetResult $ PaginationSettings
<$> ireq sortingField (wIdent "sorting") <$> ireq (multiSelectField $ return sortingOptions) (wIdent "sorting")
<*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize")) <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
<*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page")) <*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page"))
<*> ireq checkBoxField (wIdent "table-only") <*> ireq checkBoxField (wIdent "table-only")
@ -112,13 +124,14 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
FormSuccess ps -> runPSValidator $ Just ps FormSuccess ps -> runPSValidator $ Just ps
FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing
FormMissing -> runPSValidator Nothing FormMissing -> runPSValidator Nothing
psSorting' = map (first (dbtSorting !)) psSorting
sqlQuery' = dbtSQLQuery sqlQuery' = dbtSQLQuery
<* E.orderBy (map sqlSortDirection psSorting) <* E.orderBy (map sqlSortDirection psSorting')
<* E.limit psLimit <* E.limit psLimit
<* E.offset (psPage * psLimit) <* E.offset (psPage * psLimit)
mapM_ (addMessageI "warning") errs mapM_ (addMessageI "warning") errs
(rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64))) (rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64)))
bool return (sendResponse <=< tblLayout) psShortcircuit $ do bool return (sendResponse <=< tblLayout) psShortcircuit $ do