507 lines
20 KiB
Haskell
507 lines
20 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, ExistentialQuantification
|
|
, RecordWildCards
|
|
, NamedFieldPuns
|
|
, OverloadedStrings
|
|
, TemplateHaskell
|
|
, QuasiQuotes
|
|
, LambdaCase
|
|
, ViewPatterns
|
|
, FlexibleContexts
|
|
, FlexibleInstances
|
|
, MultiParamTypeClasses
|
|
, TypeFamilies
|
|
, ScopedTypeVariables
|
|
, TupleSections
|
|
, RankNTypes
|
|
, MultiWayIf
|
|
#-}
|
|
|
|
module Handler.Utils.Table.Pagination
|
|
( SortColumn(..), SortDirection(..)
|
|
, FilterColumn(..), IsFilterColumn
|
|
, DBRow(..), DBOutput
|
|
, DBStyle(..), DBEmptyStyle(..)
|
|
, DBTable(..), IsDBTable(..), DBCell(..)
|
|
, PaginationSettings(..), PaginationInput(..), piIsUnset
|
|
, PSValidator(..)
|
|
, defaultFilter, defaultSorting
|
|
, restrictFilter, restrictSorting
|
|
, ToSortable(..), Sortable(..), sortable
|
|
, dbTable
|
|
, widgetColonnade, formColonnade, dbColonnade
|
|
, textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM
|
|
, 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 Control.Monad.Reader (ReaderT(..), mapReaderT)
|
|
|
|
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 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)]
|
|
}
|
|
|
|
instance Default DBStyle where
|
|
def = DBStyle
|
|
{ dbsEmptyStyle = def
|
|
, dbsEmptyMessage = MsgNoTableContent
|
|
, dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
|
|
}
|
|
|
|
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)
|
|
, dbtStyle :: DBStyle
|
|
, 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
|
|
}
|
|
|
|
data PaginationInput = PaginationInput
|
|
{ piSorting :: Maybe [(CI Text, SortDirection)]
|
|
, piFilter :: Maybe (Map (CI Text) [Text])
|
|
, piLimit :: Maybe Int64
|
|
, piPage :: Maybe Int64
|
|
, piShortcircuit :: Bool
|
|
}
|
|
|
|
piIsUnset :: PaginationInput -> Bool
|
|
piIsUnset PaginationInput{..} = and
|
|
[ isNothing piSorting
|
|
, isNothing piFilter
|
|
, isNothing piLimit
|
|
, isNothing piPage
|
|
, not piShortcircuit
|
|
]
|
|
|
|
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 })
|
|
asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s })
|
|
|
|
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, Monoid (DBCell m 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) -> ReaderT SqlBackend 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
|
|
{ wgtCellAttrs :: [(Text, Text)]
|
|
, wgtCellContents :: Widget
|
|
}
|
|
cellAttrs = lens wgtCellAttrs $ \w as -> w { wgtCellAttrs = as }
|
|
cellContents = return . wgtCellContents
|
|
|
|
cell = WidgetCell []
|
|
|
|
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
|
dbWidget Proxy Proxy = return
|
|
runDBTable = return . join . fmap (view _2)
|
|
|
|
instance Monoid (DBCell (WidgetT UniWorX IO) ()) where
|
|
mempty = WidgetCell mempty mempty
|
|
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend c c')
|
|
|
|
instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where
|
|
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) () = Widget
|
|
|
|
data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) () = DBCell
|
|
{ dbCellAttrs :: [(Text, Text)]
|
|
, dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget
|
|
}
|
|
|
|
cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
|
|
cellContents = lift . dbCellContents
|
|
|
|
cell = DBCell [] . return
|
|
|
|
dbWidget Proxy Proxy = return
|
|
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
|
|
runDBTable = fmap snd . mapReaderT liftHandlerT
|
|
|
|
instance Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) where
|
|
mempty = DBCell mempty $ return mempty
|
|
(DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
|
|
|
|
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 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 -> Handler (DBResult m x)
|
|
dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), dbtStyle = DBStyle{..}, .. }) = 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
|
|
dbsAttrs'
|
|
| not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
|
|
| otherwise = dbsAttrs
|
|
multiTextField = Field
|
|
{ fieldParse = \ts _ -> return . Right $ Just ts
|
|
, fieldView = undefined
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
psResult <- runInputGetResult $ PaginationInput
|
|
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
|
<*> ((\m -> m <$ guard (not $ Map.null m)) . Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> 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)
|
|
|
|
let
|
|
(errs, PaginationSettings{..}) = case psResult of
|
|
FormSuccess pi
|
|
| not (piIsUnset pi) -> runPSValidator dbtable $ Just pi
|
|
FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing
|
|
_ -> 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
|
|
|
|
runDB $ do
|
|
rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
|
|
|
|
let
|
|
rowCount
|
|
| (E.Value n, _):_ <- rows' = n
|
|
| otherwise = 0
|
|
rows = 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
|
|
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' :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBResult m x -> m' Widget
|
|
dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
|
|
|
|
bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . 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-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
|
|
|
|
dbColonnade :: Headedness h
|
|
=> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
|
|
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
|
|
dbColonnade = 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 => Route UniWorX -> Widget -> DBCell m a
|
|
anchorCell = anchorCellM . return
|
|
|
|
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 = cell $ do
|
|
route <- routeM
|
|
authResult <- liftHandlerT $ isAuthorized route False
|
|
|
|
if
|
|
| Authorized <- authResult -> $(widgetFile "table/cell/link")
|
|
| otherwise -> widget
|
|
|
|
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}|])
|