fradrive/src/Handler/Utils/Table/Pagination.hs

{-# LANGUAGE NoImplicitPrelude
           , ExistentialQuantification
           , RecordWildCards
           , OverloadedStrings
           , TemplateHaskell
           , QuasiQuotes
           , LambdaCase
           , ViewPatterns
           , FlexibleContexts
  #-}

module Handler.Utils.Table.Pagination
  ( SortColumn(..), SortDirection(..)
  , DBTable(..)
  , PaginationSettings(..)
  , PSValidator(..)
  , Sortable(..), sortable
  , dbTable
  ) where

import Handler.Utils.Table.Pagination.Types

import Import
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
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 Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))

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_)

import Data.Map (Map, (!))

import Colonnade hiding (bool, fromMaybe)
import Colonnade.Encode
import Yesod.Colonnade

import Text.Hamlet (hamletFile)

import Data.Ratio ((%))


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 DBTable = forall a r h i t.
  ( ToSortable h
  , E.SqlSelect a r
  , PathPiece i
  , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
  ) => DBTable
  { dbtSQLQuery :: t -> E.SqlQuery a
  , dbtColonnade :: Colonnade h r (Cell UniWorX)
  , dbtSorting :: Map Text (SortColumn t)
  , dbtAttrs :: Attribute
  , dbtIdent :: i
  }

data PaginationSettings = PaginationSettings
  { psSorting      :: [(Text, SortDirection)]
  , psLimit        :: Int64
  , psPage         :: Int64
  , psShortcircuit :: Bool
  }

instance Default PaginationSettings where
  def = PaginationSettings
    { psSorting      = []
    , psLimit        = 50
    , psPage         = 0
    , psShortcircuit = False
    }

newtype PSValidator = PSValidator { runPSValidator :: Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }

instance Default PSValidator where
  def = PSValidator $ \case
    Nothing -> def
    Just ps -> swap . (\act -> execRWS act () ps) $ do
      l <- gets psLimit
      when (l <= 0) $ do
        modify $ \ps -> ps { psLimit = psLimit def }
        tell . pure $ SomeMessage MsgPSLimitNonPositive


dbTable :: PSValidator -> DBTable -> Handler Widget
dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
  let
    sortingOptions = mkOptionList
      [ Option t' (t, d) t'
      | (t, _) <- mapToList dbtSorting
      , d <- [SortAsc, SortDesc]
      , let t' = t <> "-" <> toPathPiece d
      ]
    (_, defPS) = runPSValidator Nothing
    wIdent n
      | not $ null dbtIdent = dbtIdent <> "-" <> n
      | otherwise           = n
    dbtAttrs'
      | not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs
      | otherwise           = dbtAttrs
    
  psResult <- runInputGetResult $ PaginationSettings
    <$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting"))
    <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
    <*> (fromMaybe (psPage  defPS) <$> iopt intField (wIdent "page"))
    <*> ireq checkBoxField (wIdent "table-only")

  $(logDebug) . tshow $ (,,,) <$> (length . psSorting <$> psResult)
                              <*> (psLimit <$> psResult)
                              <*> (psPage <$> psResult)
                              <*> (psShortcircuit <$> psResult)

  let
    (errs, PaginationSettings{..}) = case psResult of
      FormSuccess ps   -> runPSValidator $ Just ps
      FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing
      FormMissing      -> runPSValidator 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)

  mapM_ (addMessageI "warning") errs

  (rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ E.from dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64)))

  bool return (sendResponse <=< tblLayout) psShortcircuit $ do
    getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
    let table = $(widgetFile "table/colonnade")
        pageCount = max 1 . ceiling $ rowCount % psLimit
        tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
        withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell
          { cellContents = $(widgetFile "table/sortable-header")
          , ..
          }
    $(widgetFile "table/layout")
  where
    tblLayout :: Widget -> Handler Html
    tblLayout tbl' = do
      tbl <- widgetToPageContent tbl'
      withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")

    setParam :: Text -> Maybe Text -> QueryText -> QueryText
    setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]

widgetFromCell ::
  (Attribute -> WidgetT site IO () -> WidgetT site IO ())
  -> Cell site
  -> WidgetT site IO ()
widgetFromCell f (Cell attrs contents) =
  f attrs contents
td,th ::
  Attribute -> WidgetT site IO () -> WidgetT site IO ()

td = liftParent Html5.td
th = liftParent Html5.th

liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a
liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do
  (a,gwd) <- f hdata
  let Body bodyFunc = gwdBody gwd
      newBodyFunc render =
        el Html5.! attrs $ (bodyFunc render)
  return (a,gwd { gwdBody = Body newBodyFunc })