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

Introduce DBCell-Constructor and dbColonnade

Browse Source
This commit is contained in:
Gregor Kleen 2018-07-08 14:51:05 +02:00
parent d0fcf2e9e3
commit 96eea52344
1 changed files with 70 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -29,7 +29,7 @@ module Handler.Utils.Table.Pagination
, restrictFilter, restrictSorting , restrictFilter, restrictSorting
, ToSortable(..), Sortable(..), sortable , ToSortable(..), Sortable(..), sortable
, dbTable , dbTable
, widgetColonnade, formColonnade , widgetColonnade, formColonnade, dbColonnade
, textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM , textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM
, formCell, DBFormResult, getDBFormResult , formCell, DBFormResult, getDBFormResult
, dbRow, dbSelect , dbRow, dbSelect
@ -54,6 +54,7 @@ import qualified Data.CaseInsensitive as CI
import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_) import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_) import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
import Control.Monad.Reader (ReaderT(..), mapReaderT)
import Data.Map (Map, (!)) import Data.Map (Map, (!))
import qualified Data.Map as Map import qualified Data.Map as Map
@ -251,18 +252,18 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' 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 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) runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
instance IsDBTable (WidgetT UniWorX IO) () where instance IsDBTable (WidgetT UniWorX IO) () where
type DBResult (WidgetT UniWorX IO) () = Widget type DBResult (WidgetT UniWorX IO) () = Widget
-- type DBResult' (WidgetT UniWorX IO) () = () -- type DBResult' (WidgetT UniWorX IO) () = ()
data DBCell (WidgetT UniWorX IO) () = WidgetCell data DBCell (WidgetT UniWorX IO) () = WidgetCell
{ dbCellAttrs :: [(Text, Text)] { wgtCellAttrs :: [(Text, Text)]
, dbCellContents :: Widget , wgtCellContents :: Widget
} }
cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as } cellAttrs = lens wgtCellAttrs $ \w as -> w { wgtCellAttrs = as }
cellContents = return . dbCellContents cellContents = return . wgtCellContents
cell = WidgetCell [] cell = WidgetCell []
@ -274,6 +275,27 @@ instance Monoid (DBCell (WidgetT UniWorX IO) ()) where
mempty = WidgetCell mempty mempty mempty = WidgetCell mempty mempty
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend c c') (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 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) = ((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) = Form a
@ -354,54 +376,55 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
mapM_ (addMessageI "warning") errs mapM_ (addMessageI "warning") errs
rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery' runDB $ do
rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
let let
rowCount rowCount
| (E.Value n, _):_ <- rows' = n | (E.Value n, _):_ <- rows' = n
| otherwise = 0 | otherwise = 0
rows = map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' rows = map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
table' :: WriterT x m Widget table' :: WriterT x m Widget
table' = do table' = do
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
let let
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
widget <- cellContents sortableContent widget <- cellContents sortableContent
let let
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ] directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
isSortable = isJust sortableKey isSortable = isJust sortableKey
isSorted = (`elem` directions) isSorted = (`elem` directions)
attrs = sortableContent ^. cellAttrs attrs = sortableContent ^. cellAttrs
return $(widgetFile "table/cell/header") return $(widgetFile "table/cell/header")
columnCount :: Int64 columnCount :: Int64
columnCount = olength64 $ getColonnade dbtColonnade columnCount = olength64 $ getColonnade dbtColonnade
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
widget <- cellContents cell widget <- cellContents cell
let attrs = cell ^. cellAttrs let attrs = cell ^. cellAttrs
return $(widgetFile "table/cell/body") return $(widgetFile "table/cell/body")
let table = $(widgetFile "table/colonnade") let table = $(widgetFile "table/colonnade")
pageCount = max 1 . ceiling $ rowCount % psLimit pageCount = max 1 . ceiling $ rowCount % psLimit
pageNumbers = [0..pred pageCount] pageNumbers = [0..pred pageCount]
return $(widgetFile "table/layout") 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)
dbWidget' :: DBResult m x -> Handler Widget bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
where where
tblLayout :: Widget -> Handler Html tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
tblLayout tbl' = do tblLayout tbl' = do
tbl <- widgetToPageContent tbl' tbl <- liftHandlerT $ widgetToPageContent tbl'
withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet") withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")
setParam :: Text -> Maybe Text -> QueryText -> QueryText setParam :: Text -> Maybe Text -> QueryText -> QueryText
@ -419,6 +442,11 @@ 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 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 textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
stringCell = textCell stringCell = textCell
i18nCell = textCell i18nCell = textCell