414 lines
16 KiB
Haskell
414 lines
16 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, ExistentialQuantification
|
|
, RecordWildCards
|
|
, NamedFieldPuns
|
|
, OverloadedStrings
|
|
, TemplateHaskell
|
|
, QuasiQuotes
|
|
, LambdaCase
|
|
, ViewPatterns
|
|
, FlexibleContexts
|
|
, FlexibleInstances
|
|
, MultiParamTypeClasses
|
|
, TypeFamilies
|
|
, ScopedTypeVariables
|
|
, TupleSections
|
|
, RankNTypes
|
|
#-}
|
|
|
|
module Handler.Utils.Table.Pagination
|
|
( SortColumn(..), SortDirection(..)
|
|
, FilterColumn(..), IsFilterColumn
|
|
, DBRow(..), DBOutput
|
|
, DBTable(..), IsDBTable(..)
|
|
, PaginationSettings(..)
|
|
, PSValidator(..)
|
|
, defaultFilter, defaultSorting
|
|
, restrictFilter, restrictSorting
|
|
, ToSortable(..), Sortable(..), sortable
|
|
, dbTable
|
|
, widgetColonnade, formColonnade
|
|
, textCell, stringCell, i18nCell, anchorCell
|
|
, formCell, DBFormResult, getDBFormResult
|
|
, dbRow, dbSelect
|
|
) where
|
|
|
|
import Handler.Utils.Table.Pagination.Types
|
|
|
|
import Import hiding (Proxy(..))
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
|
|
import qualified Database.Esqueleto.Internal.Language as E (From)
|
|
import Text.Blaze (Attribute)
|
|
import qualified Text.Blaze.Html5.Attributes as Html5
|
|
import qualified Text.Blaze.Html5 as Html5
|
|
|
|
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 ((<>), Foldable(..), mapM_, forM_)
|
|
import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
|
|
|
|
import Data.Map (Map, (!))
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.Profunctor (lmap)
|
|
|
|
import Colonnade hiding (bool, fromMaybe, singleton)
|
|
import qualified Colonnade (singleton)
|
|
import Colonnade.Encode
|
|
|
|
import Text.Hamlet (hamletFile)
|
|
|
|
import Data.Ratio ((%))
|
|
|
|
import Control.Lens
|
|
|
|
import Data.Proxy
|
|
|
|
|
|
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)
|
|
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 :: 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
|
|
|
|
|
|
data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a
|
|
|
|
filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
|
|
filterColumn (FilterColumn f) = filterColumn' f
|
|
|
|
class IsFilterColumn t a where
|
|
filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)
|
|
|
|
instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where
|
|
filterColumn' fin _ _ = fin
|
|
|
|
instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
|
|
filterColumn' cont is t = filterColumn' (cont t) is t
|
|
|
|
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
|
|
filterColumn' cont is t = filterColumn' (cont input) is' t
|
|
where
|
|
(input, ($ []) -> is') = go (mempty, id) is
|
|
go acc [] = acc
|
|
go (acc, is') (i:is)
|
|
| Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
|
|
| otherwise = go (acc, is' . (i:)) is
|
|
|
|
|
|
data DBRow r = DBRow
|
|
{ dbrOutput :: r
|
|
, dbrIndex, dbrCount :: Int64
|
|
} deriving (Show, Read, Eq, Ord)
|
|
|
|
class DBOutput r r' where
|
|
dbProj :: r -> r'
|
|
|
|
instance DBOutput (DBRow r) (DBRow r) where
|
|
dbProj = id
|
|
instance DBOutput (DBRow r) r where
|
|
dbProj = dbrOutput
|
|
instance DBOutput (DBRow r) (Int64, r) where
|
|
dbProj = (,) <$> dbrIndex <*> dbrOutput
|
|
|
|
data DBTable m x = forall a r r' h i t.
|
|
( ToSortable h, Functor h
|
|
, E.SqlSelect a r, DBOutput (DBRow r) r'
|
|
, PathPiece i
|
|
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
|
|
) => DBTable
|
|
{ dbtSQLQuery :: t -> E.SqlQuery a
|
|
, dbtColonnade :: Colonnade h r' (DBCell m x)
|
|
, dbtSorting :: Map (CI Text) (SortColumn t)
|
|
, dbtFilter :: Map (CI Text) (FilterColumn t)
|
|
, dbtAttrs :: Attribute -- FIXME: currently unused
|
|
, dbtIdent :: i
|
|
}
|
|
|
|
|
|
data PaginationSettings = PaginationSettings
|
|
{ psSorting :: [(CI Text, SortDirection)]
|
|
, psFilter :: Map (CI Text) [Text]
|
|
, psLimit :: Int64
|
|
, psPage :: Int64
|
|
, psShortcircuit :: Bool
|
|
}
|
|
|
|
instance Default PaginationSettings where
|
|
def = PaginationSettings
|
|
{ psSorting = []
|
|
, psFilter = Map.empty
|
|
, psLimit = 50
|
|
, psPage = 0
|
|
, psShortcircuit = False
|
|
}
|
|
|
|
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
|
|
|
|
instance Default (PSValidator m x) where
|
|
def = PSValidator $ \DBTable{..} -> \case
|
|
Nothing -> def
|
|
Just ps -> swap . (\act -> execRWS act () ps) $ do
|
|
l <- gets psLimit
|
|
when (l <= 0) $ do
|
|
modify $ \ps -> ps { psLimit = psLimit def }
|
|
tell . pure $ SomeMessage MsgPSLimitNonPositive
|
|
|
|
defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
|
|
defaultFilter psFilter (runPSValidator -> f) = PSValidator g
|
|
where
|
|
g dbTable Nothing = over _2 (\s -> s { psFilter }) $ f dbTable Nothing
|
|
g dbTable x = f dbTable x
|
|
|
|
defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
|
|
defaultSorting psSorting (runPSValidator -> f) = PSValidator g
|
|
where
|
|
g dbTable Nothing = over _2 (\s -> s { psSorting }) $ f dbTable Nothing
|
|
g dbTable x = f dbTable x
|
|
|
|
restrictFilter :: (CI Text -> [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 restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
|
|
where
|
|
restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
|
|
|
|
class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where
|
|
type DBResult m x :: *
|
|
-- type DBResult' m x :: *
|
|
|
|
data DBCell m x :: *
|
|
cellAttrs :: Lens' (DBCell m x) [(Text, Text)]
|
|
cellContents :: DBCell m x -> WriterT x m Widget
|
|
|
|
cell :: Widget -> DBCell m x
|
|
|
|
|
|
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
|
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Proxy m -> Proxy x -> DBResult m x -> m' Widget
|
|
runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> m' (DBResult m x)
|
|
|
|
instance IsDBTable (WidgetT UniWorX IO) () where
|
|
type DBResult (WidgetT UniWorX IO) () = Widget
|
|
-- type DBResult' (WidgetT UniWorX IO) () = ()
|
|
|
|
data DBCell (WidgetT UniWorX IO) () = WidgetCell
|
|
{ dbCellAttrs :: [(Text, Text)]
|
|
, dbCellContents :: Widget
|
|
}
|
|
cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
|
|
cellContents = return . dbCellContents
|
|
|
|
cell = WidgetCell []
|
|
|
|
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
|
dbWidget Proxy Proxy = return
|
|
runDBTable = return . join . fmap (view _2)
|
|
|
|
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
|
|
-- 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
|
|
{ formCellAttrs :: [(Text, Text)]
|
|
, formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
|
|
}
|
|
cellAttrs = lens formCellAttrs $ \w as -> w { formCellAttrs = as }
|
|
cellContents = WriterT . fmap swap . formCellContents
|
|
|
|
cell widget = FormCell [] $ return (mempty, widget)
|
|
|
|
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
|
|
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
|
|
dbWidget Proxy Proxy = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
|
|
-- 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
|
|
|
|
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 PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do
|
|
let
|
|
sortingOptions = mkOptionList
|
|
[ Option t' (t, d) t'
|
|
| (t, _) <- mapToList dbtSorting
|
|
, d <- [SortAsc, SortDesc]
|
|
, let t' = CI.foldedCase t <> "-" <> toPathPiece d
|
|
]
|
|
(_, defPS) = runPSValidator dbtable Nothing
|
|
wIdent n
|
|
| not $ null dbtIdent = dbtIdent <> "-" <> n
|
|
| otherwise = n
|
|
dbtAttrs'
|
|
| not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs
|
|
| otherwise = dbtAttrs
|
|
multiTextField = Field
|
|
{ fieldParse = \ts _ -> return . Right $ Just ts
|
|
, fieldView = undefined
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
psResult <- runInputGetResult $ PaginationSettings
|
|
<$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting"))
|
|
<*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
|
|
<*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
|
|
<*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page"))
|
|
<*> ireq checkBoxField (wIdent "table-only")
|
|
|
|
$(logDebug) . tshow $ (,,,,) <$> (length . psSorting <$> psResult)
|
|
<*> (Map.keys . psFilter <$> psResult)
|
|
<*> (psLimit <$> psResult)
|
|
<*> (psPage <$> psResult)
|
|
<*> (psShortcircuit <$> psResult)
|
|
|
|
let
|
|
(errs, PaginationSettings{..}) = case psResult of
|
|
FormSuccess ps -> runPSValidator dbtable $ Just ps
|
|
FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing
|
|
FormMissing -> runPSValidator dbtable Nothing
|
|
psSorting' = map (first (dbtSorting !)) psSorting
|
|
sqlQuery' = E.from $ \t -> 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
|
|
|
|
mapM_ (addMessageI "warning") errs
|
|
|
|
rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "row_number() OVER ()" :: E.SqlExpr (E.Value Int64), E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
|
|
|
|
let
|
|
rowCount
|
|
| ((_, E.Value n), _):_ <- rows' = n
|
|
| otherwise = 0
|
|
rows = map (\((E.Value dbrIndex, E.Value dbrCount), dbrOutput) -> DBRow{..}) rows'
|
|
|
|
table' :: WriterT x m Widget
|
|
table' = do
|
|
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
|
|
|
let
|
|
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
|
|
|
|
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
|
|
widget <- cellContents sortableContent
|
|
let
|
|
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
|
|
isSortable = isJust sortableKey
|
|
isSorted = (`elem` directions)
|
|
attrs = sortableContent ^. cellAttrs
|
|
return $(widgetFile "table/cell/header")
|
|
|
|
columnCount :: Int64
|
|
columnCount = olength64 $ getColonnade dbtColonnade
|
|
|
|
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
|
|
|
|
wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
|
|
widget <- cellContents cell
|
|
let attrs = cell ^. cellAttrs
|
|
return $(widgetFile "table/cell/body")
|
|
|
|
let table = $(widgetFile "table/colonnade")
|
|
pageCount = max 1 . ceiling $ rowCount % psLimit
|
|
pageNumbers = [0..pred pageCount]
|
|
|
|
return $(widgetFile "table/layout")
|
|
|
|
dbWidget' :: DBResult m x -> Handler Widget
|
|
dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
|
|
|
|
bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
|
|
where
|
|
tblLayout :: Widget -> Handler Html
|
|
tblLayout tbl' = do
|
|
tbl <- widgetToPageContent tbl'
|
|
withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")
|
|
|
|
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
|
setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
|
|
|
|
--- DBCell utility functions
|
|
|
|
widgetColonnade :: Headedness h
|
|
=> Colonnade h r (DBCell (WidgetT UniWorX IO) ())
|
|
-> Colonnade h r (DBCell (WidgetT UniWorX IO) ())
|
|
widgetColonnade = id
|
|
|
|
formColonnade :: (Headedness h, Monoid a)
|
|
=> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
|
|
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
|
|
formColonnade = id
|
|
|
|
textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
|
stringCell = textCell
|
|
i18nCell = textCell
|
|
textCell msg = cell [whamlet|_{msg}|]
|
|
|
|
anchorCell :: IsDBTable m a
|
|
=> (r -> Route UniWorX)
|
|
-> (r -> Widget)
|
|
-> (r -> DBCell m a)
|
|
anchorCell mkRoute mkWidget val = cell $(widgetFile "table/cell/link")
|
|
where
|
|
route = mkRoute val
|
|
widget = mkWidget val
|
|
|
|
newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))
|
|
|
|
instance Ord i => Monoid (DBFormResult r i a) where
|
|
mempty = DBFormResult Map.empty
|
|
(DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
|
|
|
|
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)
|
|
-> (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
|
|
{ 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)
|
|
}
|
|
|
|
-- Predefined colonnades
|
|
|
|
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
|
|
dbRow = Colonnade.singleton (headednessPure $ textCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
|
|
|
|
dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
|
|
=> 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 $ textCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
|
|
(selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
|
|
return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])
|