{-# 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}|])