909 lines
36 KiB
Haskell
909 lines
36 KiB
Haskell
{-# OPTIONS -fno-warn-orphans #-}
|
|
|
|
module Handler.Utils.Table.Pagination
|
|
( module Handler.Utils.Table.Pagination.Types
|
|
, SortColumn(..), SortDirection(..)
|
|
, SortingSetting(..)
|
|
, pattern SortAscBy, pattern SortDescBy
|
|
, FilterColumn(..), IsFilterColumn
|
|
, DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
|
|
, DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
|
|
, DBTable(..), IsDBTable(..), DBCell(..)
|
|
, singletonFilter
|
|
, DBParams(..)
|
|
, cellAttrs, cellContents
|
|
, PagesizeLimit(..)
|
|
, PaginationSettings(..), PaginationInput(..), piIsUnset
|
|
, PSValidator(..)
|
|
, defaultFilter, defaultSorting
|
|
, restrictFilter, restrictSorting
|
|
, ToSortable(..), Sortable(..)
|
|
, dbTable
|
|
, dbTableWidget, dbTableWidget'
|
|
, widgetColonnade, formColonnade, dbColonnade
|
|
, cell, textCell, stringCell, i18nCell
|
|
, anchorCell, anchorCell', anchorCellM, anchorCellM'
|
|
, 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 qualified Data.Set as Set
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
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.List (elemIndex)
|
|
|
|
import Data.Aeson (Options(..), SumEncoding(..), defaultOptions)
|
|
import Data.Aeson.Text
|
|
import Data.Aeson.TH (deriveJSON)
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import Data.Proxy (Proxy(..))
|
|
|
|
import qualified Data.Binary as B
|
|
import qualified Data.ByteArray as BA (convert)
|
|
import Crypto.MAC.HMAC (hmac, HMAC)
|
|
import Crypto.Hash.Algorithms (SHAKE256)
|
|
|
|
import qualified Data.ByteString.Base64.URL as Base64 (encode)
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
|
|
|
|
$(sqlInTuples [2..16])
|
|
|
|
|
|
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, Generic)
|
|
|
|
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, Generic)
|
|
|
|
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 PagesizeLimit = PagesizeLimit !Int64 | PagesizeAll
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
instance Bounded PagesizeLimit where
|
|
minBound = PagesizeLimit minBound
|
|
maxBound = PagesizeAll
|
|
|
|
instance Enum PagesizeLimit where
|
|
toEnum i
|
|
| toInteger i >= fromIntegral (minBound :: Int64)
|
|
, toInteger i <= fromIntegral (maxBound :: Int64)
|
|
= PagesizeLimit $ fromIntegral i
|
|
| toInteger i > fromIntegral (maxBound :: Int64)
|
|
= PagesizeAll
|
|
| otherwise
|
|
= error "toEnum PagesizeLimit: out of bounds"
|
|
fromEnum (PagesizeLimit i)
|
|
| toInteger i >= fromIntegral (minBound :: Int)
|
|
, toInteger i <= fromIntegral (maxBound :: Int)
|
|
= fromIntegral i
|
|
| otherwise
|
|
= error "fromEnum PagesizeLimit: out of bounds"
|
|
fromEnum PagesizeAll
|
|
= error "fromEnum PagesizeLimit: infinite"
|
|
|
|
succ (PagesizeLimit i)
|
|
| i == maxBound = PagesizeAll
|
|
| otherwise = PagesizeLimit $ succ i
|
|
succ PagesizeAll = error "succ PagesizeLimit: out of bounds"
|
|
pred (PagesizeLimit i)
|
|
| i == minBound = error "pred PagesizeLimit: out of bounds"
|
|
| otherwise = PagesizeLimit $ pred i
|
|
pred PagesizeAll = PagesizeLimit maxBound
|
|
|
|
instance PathPiece PagesizeLimit where
|
|
toPathPiece PagesizeAll = "all"
|
|
toPathPiece (PagesizeLimit n) = toPathPiece n
|
|
fromPathPiece str
|
|
| CI.mk str == "all" = Just PagesizeAll
|
|
| otherwise = PagesizeLimit <$> fromPathPiece str
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece' 1
|
|
, sumEncoding = UntaggedValue
|
|
} ''PagesizeLimit
|
|
|
|
|
|
data PaginationSettings = PaginationSettings
|
|
{ psSorting :: [SortingSetting]
|
|
, psFilter :: Map FilterKey [Text]
|
|
, psLimit :: PagesizeLimit
|
|
, psPage :: Int64
|
|
}
|
|
|
|
makeLenses_ ''PaginationSettings
|
|
|
|
instance Default PaginationSettings where
|
|
def = PaginationSettings
|
|
{ psSorting = []
|
|
, psFilter = Map.empty
|
|
, psLimit = PagesizeLimit 50
|
|
, psPage = 0
|
|
}
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
} ''PaginationSettings
|
|
|
|
data PaginationInput = PaginationInput
|
|
{ piSorting :: Maybe [SortingSetting]
|
|
, piFilter :: Maybe (Map FilterKey [Text])
|
|
, piLimit :: Maybe PagesizeLimit
|
|
, 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
|
|
]
|
|
|
|
type DBTableKey k' = (ToJSON k', FromJSON k', Ord k', Binary k')
|
|
data DBRow r = forall k'. DBTableKey k' => DBRow
|
|
{ dbrKey :: k'
|
|
, dbrOutput :: r
|
|
, dbrIndex, dbrCount :: Int64
|
|
}
|
|
|
|
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 <$> pure dbrKey <*> 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 (PagesizeLimit l')
|
|
| l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
|
|
| otherwise -> modify $ \ps -> ps { psLimit = PagesizeLimit l' }
|
|
Just PagesizeAll
|
|
-> modify $ \ps -> ps { psLimit = PagesizeAll }
|
|
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)]
|
|
, dbsFilterLayout :: Widget
|
|
-> Enctype
|
|
-> Text
|
|
-> Widget
|
|
-> Widget
|
|
-- ^ Filter UI, Filter Encoding, Filter action, table
|
|
}
|
|
|
|
instance Default DBStyle where
|
|
def = DBStyle
|
|
{ dbsEmptyStyle = def
|
|
, dbsEmptyMessage = MsgNoTableContent
|
|
, dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
|
|
, dbsFilterLayout = \_filterWgdt _filterEnctype _filterAction scrolltable ->
|
|
[whamlet|
|
|
$newline never
|
|
<!-- No Filter UI -->
|
|
^{scrolltable}
|
|
|]
|
|
}
|
|
|
|
defaultDBSFilterLayout :: Widget -- ^ Filter UI
|
|
-> Enctype
|
|
-> Text -- ^ Filter action (target uri)
|
|
-> Widget -- ^ Table
|
|
-> Widget
|
|
defaultDBSFilterLayout filterWgdt filterEnctype filterAction scrolltable = $(widgetFile "table/layout-filter-default")
|
|
|
|
|
|
singletonFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe v)
|
|
-- ^ for use with @prismAForm@
|
|
singletonFilter key = prism' fromInner (fmap Just . fromOuter)
|
|
where
|
|
fromInner = maybe Map.empty $ Map.singleton key . pure
|
|
fromOuter = Map.lookup key >=> listToMaybe
|
|
|
|
|
|
data DBTable m x = forall a r r' h i t k k'.
|
|
( ToSortable h, Functor h
|
|
, E.SqlSelect a r, SqlIn k k', DBTableKey k'
|
|
, PathPiece i, Eq i
|
|
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
|
|
) => DBTable
|
|
{ dbtSQLQuery :: t -> E.SqlQuery a
|
|
, dbtRowKey :: t -> k
|
|
, 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 :: Maybe (Map FilterKey [Text]) -> 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' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> DBResult m x -> m' Widget
|
|
-- | Format @DBTable@ when not short-circuiting
|
|
dbHandler :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
|
|
runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable m x -> PaginationInput -> [k'] -> m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
|
|
|
|
dbInvalidateResult :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBParams m x -> DBTableInvalid -> DBResult m x -> m' (DBResult m x)
|
|
dbInvalidateResult _ _ = return
|
|
|
|
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
|
|
|
|
data DBParamsFormIdent where
|
|
DBParamsFormTableIdent :: DBParamsFormIdent
|
|
DBParamsFormOverrideIdent :: forall t. PathPiece t => t -> DBParamsFormIdent
|
|
DBParamsFormNoIdent :: DBParamsFormIdent
|
|
|
|
instance Default DBParamsFormIdent where
|
|
def = DBParamsFormTableIdent
|
|
|
|
unDBParamsFormIdent :: DBTable m x -> DBParamsFormIdent -> Maybe Text
|
|
unDBParamsFormIdent DBTable{dbtIdent} DBParamsFormTableIdent = Just $ toPathPiece dbtIdent
|
|
unDBParamsFormIdent _ (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
|
|
unDBParamsFormIdent _ DBParamsFormNoIdent = Nothing
|
|
|
|
instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
|
|
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
|
|
{ dbParamsFormMethod :: StdMethod
|
|
, dbParamsFormAction :: Maybe (SomeRoute UniWorX)
|
|
, dbParamsFormAttrs :: [(Text, Text)]
|
|
, dbParamsFormAddSubmit :: Bool
|
|
, dbParamsFormAdditional :: Form a
|
|
, dbParamsFormEvaluate :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
|
|
, dbParamsFormResult :: Lens' x (FormResult a)
|
|
, dbParamsFormIdent :: DBParamsFormIdent
|
|
}
|
|
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, 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)) x = forall a. FormCell
|
|
{ formCellAttrs :: [(Text, Text)]
|
|
, formCellContents :: WriterT x (MForm (HandlerT UniWorX IO)) (FormResult a, Widget)
|
|
, formCellLens :: Lens' x (FormResult a)
|
|
}
|
|
|
|
-- dbCell :: Iso'
|
|
-- (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) x)
|
|
-- ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
|
|
dbCell = iso
|
|
(\FormCell{..} -> (formCellAttrs, formCellContents >>= uncurry ($>) . over _1 (tell . (flip $ set formCellLens) mempty)))
|
|
(\(attrs, mkWidget) -> FormCell attrs ((pure (), ) <$> mkWidget) $ lens (\_ -> pure ()) (\s _ -> s))
|
|
|
|
-- 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 :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
|
|
runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys
|
|
= fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1)
|
|
. dbParamsFormEvaluate
|
|
. fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x)))
|
|
. dbParamsFormWrap dbtParams
|
|
. maybe id (identifyForm' dbParamsFormResult) (unDBParamsFormIdent dbtable dbParamsFormIdent)
|
|
. addPIHiddenField dbtable pi
|
|
. addPreviousHiddenField dbtable pKeys
|
|
. withFragment
|
|
|
|
dbInvalidateResult DBParamsForm{..} reason result = do
|
|
reasonTxt <- getMessageRender <*> pure reason
|
|
let
|
|
adjResult (FormFailure errs) = FormFailure $ reasonTxt : errs
|
|
adjResult _ = FormFailure $ pure reasonTxt
|
|
return $ over (_1 . dbParamsFormResult) adjResult result
|
|
|
|
instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
|
|
def = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Nothing
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormAddSubmit = False
|
|
, dbParamsFormAdditional = \_ -> return (pure (), mempty)
|
|
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
|
, dbParamsFormResult = lens (\_ -> pure ()) (\s _ -> s)
|
|
, dbParamsFormIdent = def
|
|
}
|
|
|
|
dbParamsFormWrap :: Monoid x => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
|
|
dbParamsFormWrap DBParamsForm{..} tableForm frag = do
|
|
let form = mappend <$> tableForm frag <*> (fmap (over _1 $ (flip $ set dbParamsFormResult) mempty) $ dbParamsFormAdditional mempty)
|
|
((res, fWidget), enctype) <- listen form
|
|
return . (res,) $ do
|
|
btnId <- newIdent
|
|
act <- traverse toTextUrl dbParamsFormAction
|
|
let submitField :: Field Handler ButtonSubmit
|
|
submitField = buttonField BtnSubmit
|
|
submitView :: Widget
|
|
submitView = fieldView submitField btnId "" mempty (Right BtnSubmit) False
|
|
enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype
|
|
$(widgetFile "table/form-wrap")
|
|
|
|
data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x }
|
|
|
|
instance PathPiece x => PathPiece (WithIdent x) where
|
|
toPathPiece (WithIdent ident x)
|
|
| not . null $ toPathPiece ident = toPathPiece ident <> "-" <> toPathPiece x
|
|
| otherwise = toPathPiece x
|
|
fromPathPiece txt = do
|
|
let sep = "-"
|
|
(ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt
|
|
WithIdent <$> pure ident <*> fromPathPiece rest
|
|
|
|
addPIHiddenField :: DBTable m' x -> PaginationInput -> (Html -> MForm m a) -> (Html -> MForm m a)
|
|
addPIHiddenField DBTable{ dbtIdent } pi form fragment
|
|
= form $ fragment <> [shamlet|
|
|
$newline never
|
|
<input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
|
|
|]
|
|
where
|
|
wIdent :: Text -> Text
|
|
wIdent = toPathPiece . WithIdent dbtIdent
|
|
|
|
addPreviousHiddenField :: (ToJSON k', MonadHandler m, HandlerSite m ~ UniWorX) => DBTable m' x -> [k'] -> (Html -> MForm m a) -> (Html -> MForm m a)
|
|
addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
|
|
encrypted <- encodedSecretBox SecretBoxShort pKeys
|
|
form $ fragment <> [shamlet|
|
|
$newline never
|
|
<input type=hidden name=#{wIdent "previous"} value=#{encrypted}>
|
|
|]
|
|
where
|
|
wIdent :: Text -> Text
|
|
wIdent = toPathPiece . WithIdent dbtIdent
|
|
|
|
instance Monoid x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
|
|
mempty = FormCell mempty (return mempty) $ lens (\_ -> pure ()) (\s _ -> s)
|
|
(FormCell attrs c l) `mappend` (FormCell attrs' c' l') = FormCell (mappend attrs attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', mappend w w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
|
|
|
|
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 :: Text -> Text
|
|
wIdent = toPathPiece . WithIdent dbtIdent
|
|
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 <- lift . runInputMaybe $ ireq (jsonField True) (wIdent "pagination")
|
|
let piPreviousRes = maybe FormMissing FormSuccess piPrevious
|
|
previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
|
|
|
|
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 pathPieceField (wIdent "pagesize")
|
|
<*> iopt intField (wIdent "page")
|
|
|
|
let prevPi
|
|
| FormSuccess pi <- piPreviousRes <|> piInput
|
|
= pi
|
|
| otherwise
|
|
= def
|
|
|
|
referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
|
|
|
|
(((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
|
|
(filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
|
|
|
|
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
|
|
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
|
|
<* autosubmitButton
|
|
return (filterRes', pagesizeRes')
|
|
|
|
let
|
|
piResult = (\fSettings -> prevPi & _piFilter .~ Just fSettings) <$> filterRes
|
|
<|> (\ps -> prevPi & _piLimit .~ Just ps) <$> pagesizeRes
|
|
<|> piPreviousRes
|
|
<|> piInput
|
|
|
|
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
|
|
|
|
let
|
|
((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
|
|
| FormSuccess pi <- piResult
|
|
, not $ piIsUnset pi
|
|
= (, pi) . runPSValidator dbtable $ Just pi
|
|
| FormFailure errs' <- piResult
|
|
= (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
|
|
| otherwise
|
|
= (, def) $ runPSValidator dbtable Nothing
|
|
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')
|
|
case previousKeys of
|
|
Nothing
|
|
| PagesizeLimit l <- psLimit
|
|
-> do
|
|
E.limit l
|
|
E.offset (psPage * l)
|
|
Just ps -> E.where_ $ dbtRowKey t `sqlIn` ps
|
|
_other -> return ()
|
|
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), dbtRowKey t, res)
|
|
|
|
let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v)
|
|
firstRow :: Int64
|
|
firstRow
|
|
| PagesizeLimit l <- psLimit
|
|
= succ (psPage * l)
|
|
| otherwise
|
|
= 1
|
|
reproduceSorting
|
|
| Just ps <- previousKeys
|
|
= sortOn $ \(_, dbrKey, _) -> elemIndex dbrKey ps
|
|
| otherwise
|
|
= id
|
|
|
|
(currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
|
|
|
|
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
|
let
|
|
tblLink :: (QueryText -> QueryText) -> Text
|
|
tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ (f . substPi . setParam "_hasdata" Nothing) getParams
|
|
substPi = foldr (.) id
|
|
[ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
|
|
, foldr (.) id . map (\k -> setParams (wIdent $ toPathPiece k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
|
|
, setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
|
|
, setParam (wIdent "page") $ fmap toPathPiece piPage
|
|
, setParam (wIdent "pagination") Nothing
|
|
]
|
|
|
|
let
|
|
rowCount
|
|
| (E.Value n, _, _):_ <- rows' = n
|
|
| otherwise = 0
|
|
|
|
rawAction = tblLink
|
|
$ setParam (wIdent "sorting") Nothing
|
|
. setParam (wIdent "pagesize") Nothing
|
|
. setParam (wIdent "page") Nothing
|
|
. setParam (wIdent "pagination") Nothing
|
|
|
|
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")
|
|
|
|
return $(widgetFile "table/colonnade")
|
|
|
|
pageCount
|
|
| PagesizeLimit l <- psLimit
|
|
= max 1 . ceiling $ rowCount % l
|
|
| otherwise
|
|
= 1
|
|
pageNumbers = [0..pred pageCount]
|
|
|
|
uiLayout table = dbsFilterLayout filterWdgt filterEnc rawAction $(widgetFile "table/layout")
|
|
|
|
dbInvalidateResult' = foldr (<=<) return . catMaybes $
|
|
[ do
|
|
pKeys <- previousKeys
|
|
guard $ pKeys /= currentKeys
|
|
return . dbInvalidateResult dbtParams . DBTIRowsMissing $ length previousKeys - length currentKeys
|
|
]
|
|
|
|
dbInvalidateResult' <=< bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout) (sendResponse <=< tblLayout . uiLayout <=< dbWidget (Proxy @m) (Proxy @x)) psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . 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")
|
|
|
|
setParams :: Text -> [Text] -> QueryText -> QueryText
|
|
setParams key vs qt = map ((key, ) . Just) vs ++ [ i | i@(key', _) <- qt, key' /= key ]
|
|
|
|
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
|
setParam key = setParams key . maybeToList
|
|
|
|
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
|
|
|
|
pagesizeOptions :: PagesizeLimit -- ^ Current/previous value
|
|
-> NonNull [PagesizeLimit]
|
|
pagesizeOptions psLim = impureNonNull . Set.toAscList . Set.fromList $ psLim : PagesizeAll : map PagesizeLimit opts
|
|
where
|
|
opts :: [Int64]
|
|
opts = filter (> 0) $ opts' <> map (`div` 2) opts'
|
|
|
|
opts' = [ 10^n | n <- [1..3]]
|
|
|
|
pagesizeField :: PagesizeLimit -> Field Handler PagesizeLimit
|
|
pagesizeField psLim = selectField $ do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let
|
|
optText (PagesizeLimit l) = tshow l
|
|
optText PagesizeAll = mr MsgDBTablePagesizeAll
|
|
|
|
toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o)
|
|
return . toOptionList . toNullable $ pagesizeOptions psLim
|
|
|
|
|
|
---------------------------------------------------------------
|
|
--- DBCell utility functions, more in Handler.Utils.Table.Cells
|
|
|
|
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
|
|
|
|
cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
|
|
cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
|
|
where
|
|
tipWdgt = [whamlet|
|
|
<div .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 i a r = DBFormResult (Map i (r, a -> a))
|
|
|
|
instance Functor (DBFormResult i a) where
|
|
f `fmap` (DBFormResult resMap) = DBFormResult $ fmap (over _1 f) resMap
|
|
|
|
instance Ord i => Monoid (DBFormResult i a r) 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 i a r -> 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 (FormResult (DBFormResult i a (DBRow r)))
|
|
-> (DBRow r -> MForm (HandlerT UniWorX IO) i)
|
|
-> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
|
|
-> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) res)
|
|
formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
|
|
{ formCellAttrs = []
|
|
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
|
|
i <- lift $ genIndex input
|
|
hashKey <- LBS.toStrict . B.encode <$> cryptoIDKey return
|
|
let
|
|
mkUnique :: PathPiece p => p -> Text
|
|
mkUnique (toPathPiece -> name) = name <> "-" <> decodeUtf8 (Base64.encode rowKeyHash)
|
|
where
|
|
rowKeyHash = (BA.convert :: HMAC (SHAKE256 264) -> ByteString) . hmac hashKey . LBS.toStrict $ B.encode dbrKey
|
|
(edit, w) <- lift $ genForm input mkUnique
|
|
return (DBFormResult . Map.singleton i . (input,) <$> edit, w)
|
|
, formCellLens
|
|
}
|
|
|
|
|
|
-- 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 (FormResult (DBFormResult i a (DBRow r)))
|
|
-> Setter' a Bool
|
|
-> (DBRow r -> MForm (HandlerT UniWorX IO) i)
|
|
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) res)
|
|
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
|
|
where
|
|
genForm _ mkUnique = do
|
|
(selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
|
|
return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])
|