678 lines
27 KiB
Haskell
678 lines
27 KiB
Haskell
module Handler.Utils.Table.Pagination
|
|
( 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(..)
|
|
, dbTable
|
|
, dbTableWidget, dbTableWidget'
|
|
, widgetColonnade, formColonnade, dbColonnade
|
|
, cell, textCell, stringCell, i18nCell
|
|
, anchorCell, anchorCell', anchorCellM, anchorCellM'
|
|
, tickmarkCell, cellTooltip
|
|
, listCell
|
|
, formCell, DBFormResult, getDBFormResult
|
|
, dbRow, dbSelect
|
|
, (&)
|
|
, module Control.Monad.Trans.Maybe
|
|
, module Colonnade
|
|
) where
|
|
|
|
import Handler.Utils.Table.Pagination.Types
|
|
import Handler.Utils.Form
|
|
import Utils
|
|
import Utils.Lens.TH
|
|
|
|
import Import hiding (pi)
|
|
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 qualified Data.Binary.Builder as Builder
|
|
|
|
import qualified Network.Wai as Wai
|
|
|
|
import Control.Monad.RWS hiding ((<>), mapM_)
|
|
import Control.Monad.Writer hiding ((<>), mapM_)
|
|
import Control.Monad.Reader (ReaderT(..), mapReaderT)
|
|
import Control.Monad.Trans.Maybe
|
|
|
|
import Data.Foldable (Foldable(foldMap))
|
|
|
|
import Data.Map (Map, (!))
|
|
import qualified Data.Map as Map
|
|
|
|
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.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, Bounded, Show, Read)
|
|
|
|
instance Universe SortDirection
|
|
instance Finite SortDirection
|
|
|
|
instance PathPiece SortDirection where
|
|
toPathPiece SortAsc = "asc"
|
|
toPathPiece SortDesc = "desc"
|
|
fromPathPiece = finiteFromPathPiece
|
|
|
|
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
|
|
|
|
|
|
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)
|
|
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 = filterColumn' (cont input) is'
|
|
where
|
|
(input, ($ []) -> is') = go (mempty, id) is
|
|
go acc [] = acc
|
|
go (acc, is3) (i:is2)
|
|
| Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2
|
|
| otherwise = go (acc, is3 . (i:)) is2
|
|
|
|
data PaginationSettings = PaginationSettings
|
|
{ psSorting :: [SortingSetting]
|
|
, psFilter :: Map FilterKey [Text]
|
|
, psLimit :: Int64
|
|
, psPage :: Int64
|
|
}
|
|
|
|
makeLenses_ ''PaginationSettings
|
|
|
|
instance Default PaginationSettings where
|
|
def = PaginationSettings
|
|
{ psSorting = []
|
|
, psFilter = Map.empty
|
|
, psLimit = 50
|
|
, psPage = 0
|
|
}
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
} ''PaginationSettings
|
|
|
|
data PaginationInput = PaginationInput
|
|
{ piSorting :: Maybe [SortingSetting]
|
|
, piFilter :: Maybe (Map FilterKey [Text])
|
|
, piLimit :: Maybe Int64
|
|
, piPage :: Maybe Int64
|
|
} deriving (Eq, Ord, Show, Read, Generic)
|
|
|
|
instance Default PaginationInput where
|
|
def = PaginationInput
|
|
{ piSorting = Nothing
|
|
, piFilter = Nothing
|
|
, piLimit = Nothing
|
|
, piPage = Nothing
|
|
}
|
|
|
|
makeLenses_ ''PaginationInput
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
, omitNothingFields = True
|
|
} ''PaginationInput
|
|
|
|
piIsUnset :: PaginationInput -> Bool
|
|
piIsUnset PaginationInput{..} = and
|
|
[ isNothing piSorting
|
|
, isNothing piFilter
|
|
, isNothing piLimit
|
|
, isNothing piPage
|
|
]
|
|
|
|
data DBRow r = DBRow
|
|
{ dbrOutput :: r
|
|
, dbrIndex, dbrCount :: Int64
|
|
} deriving (Show, Read, Eq, Ord)
|
|
|
|
makeLenses_ ''DBRow
|
|
|
|
instance Functor DBRow where
|
|
fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }
|
|
|
|
instance Foldable DBRow where
|
|
foldMap f DBRow{..} = f dbrOutput
|
|
|
|
instance Traversable DBRow where
|
|
traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount
|
|
|
|
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
|
|
|
|
instance Default (PSValidator m x) where
|
|
def = PSValidator $ \DBTable{..} -> \case
|
|
Nothing -> def
|
|
Just pi -> swap . (\act -> execRWS act pi def) $ do
|
|
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
|
|
asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
|
|
|
|
l <- asks piLimit
|
|
case l of
|
|
Just l'
|
|
| l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
|
|
| otherwise -> modify $ \ps -> ps { psLimit = l' }
|
|
Nothing -> return ()
|
|
|
|
asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
|
|
|
|
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 :: [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 :: (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 :: (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 (\SortingSetting{..} -> restrict sortKey sortDir) $ psSorting p }
|
|
|
|
|
|
data DBEmptyStyle = DBESNoHeading | DBESHeading
|
|
deriving (Enum, Bounded, Ord, Eq, Show, Read)
|
|
|
|
instance Default DBEmptyStyle where
|
|
def = DBESHeading
|
|
|
|
data DBStyle = DBStyle
|
|
{ dbsEmptyStyle :: DBEmptyStyle
|
|
, dbsEmptyMessage :: UniWorXMessage
|
|
, dbsAttrs :: [(Text, Text)]
|
|
, dbsLayoutFilter :: Widget -- ^ Filter UI
|
|
-> Enctype
|
|
-> Text -- ^ Filter action (target uri)
|
|
-> Widget -- ^ Table
|
|
-> Widget
|
|
}
|
|
|
|
instance Default DBStyle where
|
|
def = DBStyle
|
|
{ dbsEmptyStyle = def
|
|
, dbsEmptyMessage = MsgNoTableContent
|
|
, dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
|
|
, dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default")
|
|
}
|
|
|
|
data DBTable m x = forall a r r' h i t.
|
|
( ToSortable h, Functor h
|
|
, E.SqlSelect a r
|
|
, PathPiece i, Eq i
|
|
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
|
|
) => DBTable
|
|
{ dbtSQLQuery :: t -> E.SqlQuery a
|
|
, dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
|
|
, dbtColonnade :: Colonnade h r' (DBCell m x)
|
|
, dbtSorting :: Map SortingKey (SortColumn 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), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
|
|
data DBParams m x :: *
|
|
type DBResult m x :: *
|
|
-- type DBResult' m x :: *
|
|
|
|
data DBCell m x :: *
|
|
dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
|
|
|
|
-- 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 -> 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) => 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
|
|
|
|
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) () = ()
|
|
|
|
data DBCell (HandlerT UniWorX IO) x = WidgetCell
|
|
{ wgtCellAttrs :: [(Text, Text)]
|
|
, wgtCellContents :: WriterT x (HandlerT UniWorX IO) Widget
|
|
}
|
|
|
|
dbCell = iso
|
|
(\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
|
|
(uncurry WidgetCell)
|
|
|
|
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
|
dbWidget _ _ = return . snd
|
|
dbHandler _ _ f = return . over _2 f
|
|
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
|
|
{ dbCellAttrs :: [(Text, Text)]
|
|
, dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerT UniWorX IO)) Widget
|
|
}
|
|
|
|
dbCell = iso
|
|
(\DBCell{..} -> (dbCellAttrs, dbCellContents))
|
|
(uncurry DBCell)
|
|
|
|
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
|
|
|
|
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
|
|
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
|
|
{ formCellAttrs :: [(Text, Text)]
|
|
, formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
|
|
}
|
|
|
|
-- dbCell :: Iso'
|
|
-- (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) (FormResult a))
|
|
-- ([(Text, Text)], WriterT (FormResult a) (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
|
|
dbCell = iso
|
|
(\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents))
|
|
(\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget)
|
|
|
|
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
|
|
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
|
|
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 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
|
|
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')
|
|
|
|
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 -> DB (DBResult m x)
|
|
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
|
|
let
|
|
sortingOptions = mkOptionList
|
|
[ Option t' (SortingSetting t d) t'
|
|
| (t, _) <- mapToList dbtSorting
|
|
, d <- [SortAsc, SortDesc]
|
|
, let t' = toPathPiece $ SortingSetting t d
|
|
]
|
|
wIdent n
|
|
| not $ null dbtIdent = dbtIdent <> "-" <> n
|
|
| otherwise = n
|
|
dbsAttrs'
|
|
| not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
|
|
| otherwise = dbsAttrs
|
|
multiTextField = Field
|
|
{ fieldParse = \ts _ -> return . Right $ Just ts
|
|
, fieldView = error "multiTextField: should not be rendered"
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
|
|
|
|
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 $ toPathPiece k) dbtFilter)
|
|
<*> iopt intField (wIdent "pagesize")
|
|
<*> iopt intField (wIdent "page")
|
|
|
|
let filterPi
|
|
| FormSuccess PaginationInput{..} <- piPrevious <|> piInput
|
|
= def{ piSorting, piLimit }
|
|
| otherwise
|
|
= def
|
|
|
|
((filterRes, filterWdgt), filterEnc) <- runFormGet . renderAForm FormDBTableFilter $ (,)
|
|
<$> areq (jsonField True) "" (Just filterPi)
|
|
<*> dbtFilterUI
|
|
|
|
let
|
|
piResult = piPrevious <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes <|> piInput
|
|
|
|
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
|
|
|
|
let
|
|
(errs, PaginationSettings{..}) = case piResult of
|
|
FormSuccess pi
|
|
| not (piIsUnset pi)
|
|
-> runPSValidator dbtable $ Just pi
|
|
FormFailure errs'
|
|
-> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
|
|
_ -> runPSValidator dbtable Nothing
|
|
paginationInput
|
|
| FormSuccess pi <- piResult
|
|
, not $ piIsUnset pi
|
|
= pi
|
|
| otherwise
|
|
= def
|
|
psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
|
|
|
|
mapM_ (addMessageI Warning) errs
|
|
|
|
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'
|
|
|
|
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
|
|
|
let
|
|
rowCount
|
|
| (E.Value n, _):_ <- rows' = n
|
|
| otherwise = 0
|
|
|
|
tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ f getParams
|
|
|
|
filterAction = tblLink
|
|
$ setParam (wIdent "page") Nothing
|
|
. Map.foldrWithKey (\k _ f -> setParam (wIdent $ toPathPiece k) Nothing . f) id dbtFilter
|
|
|
|
table' :: WriterT x m Widget
|
|
table' = do
|
|
|
|
let
|
|
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
|
|
widget <- sortableContent ^. cellContents
|
|
let
|
|
directions = [dir | SortingSetting 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 <- 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]
|
|
|
|
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 dbtable paginationInput . fmap swap $ runWriterT table'
|
|
where
|
|
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
|
|
tblLayout tbl' = do
|
|
tbl <- liftHandlerT $ widgetToPageContent tbl'
|
|
withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
|
|
|
|
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
|
setParam key v qt = maybe id (\v' -> (:) (key, Just v')) v [ i | i@(key', _) <- qt, key' /= key ]
|
|
|
|
dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
|
|
-> DB (DBResult (HandlerT UniWorX IO) x)
|
|
dbTableWidget = dbTable
|
|
|
|
dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> DB Widget
|
|
dbTableWidget' = fmap (fmap snd) . dbTable
|
|
|
|
widgetColonnade :: (Headedness h, Monoid x)
|
|
=> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
|
|
-> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
|
|
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
|
|
|
|
dbColonnade :: (Headedness h, Monoid x)
|
|
=> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
|
|
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
|
|
dbColonnade = id
|
|
|
|
|
|
--- DBCell utility functions
|
|
|
|
cell :: IsDBTable m a => Widget -> DBCell m a
|
|
cell wgt = dbCell # ([], return wgt)
|
|
|
|
textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
|
|
textCell = cell . toWidget . (pack :: String -> Text) . otoList
|
|
stringCell = textCell
|
|
|
|
i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
|
i18nCell msg = cell $ do
|
|
mr <- getMessageRender
|
|
toWidget $ mr msg
|
|
|
|
tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
|
|
tickmarkCell True = textCell (tickmark :: Text)
|
|
tickmarkCell False = mempty
|
|
|
|
cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
|
|
cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
|
|
where
|
|
tipWdgt = [whamlet|
|
|
<div .js-tooltip>
|
|
<div .tooltip__handle>
|
|
<div .tooltip__content>_{msg}
|
|
|]
|
|
|
|
|
|
anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
|
|
anchorCell = anchorCellM . return
|
|
|
|
{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-}
|
|
anchorCell' :: IsDBTable m a
|
|
=> (r -> Route UniWorX)
|
|
-> (r -> Widget)
|
|
-> (r -> DBCell m a)
|
|
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
|
|
|
|
anchorCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> Widget -> DBCell m a
|
|
anchorCellM routeM widget = anchorCellM' routeM id (const widget)
|
|
|
|
anchorCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
|
|
anchorCellM' xM x2route x2widget = cell $ do
|
|
x <- xM
|
|
let route = x2route x
|
|
widget = x2widget x
|
|
authResult <- liftHandlerT $ isAuthorized route False
|
|
case authResult of
|
|
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
|
|
_otherwise -> widget -- don't show prohibited link
|
|
|
|
|
|
listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
|
|
listCell xs mkCell = review dbCell . ([], ) $ do
|
|
cells <- forM xs $
|
|
\(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
|
|
return $(widgetFile "table/cell/list")
|
|
|
|
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 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 (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 (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w)
|
|
}
|
|
|
|
|
|
-- Predefined colonnades
|
|
|
|
--Number column?
|
|
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 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 (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 selLens <$> selResult, [whamlet|^{fvInput selWidget}|])
|