{-# LANGUAGE UndecidableInstances #-}

module Handler.Utils.Table.Pagination
  ( module Handler.Utils.Table.Pagination.Types
  , dbFilterKey
  , SomeExprValue(..)
  , SortColumn(..), SortDirection(..)
  , SortingSetting(..)
  , pattern SortAscBy, pattern SortDescBy
  , FilterColumn(..), IsFilterColumn
  , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
  , DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
  , module Handler.Utils.Table.Pagination.CsvColumnExplanations
  , DBCsvActionMode(..)
  , DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
  , DBTCsvEncode(..), DBTCsvDecode(..)
  , DBTable(..), DBFilterUI, IsDBTable(..), DBCell(..)
  , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM
  , singletonFilter
  , DBParams(..)
  , cellAttrs, cellContents
  , addCellClass
  , PagesizeLimit(..)
  , PaginationSettings(..), PaginationInput(..), piIsUnset
  , PSValidator(..)
  , defaultPagesize
  , defaultFilter, defaultSorting
  , restrictFilter, restrictSorting
  , ToSortable(..), Sortable(..)
  , dbTable
  , dbTableWidget, dbTableWidget'
  , widgetColonnade, formColonnade, dbColonnade
  , cell, textCell, stringCell, i18nCell
  , anchorCell, anchorCell', anchorCellM, anchorCellM'
  , linkEitherCell, linkEitherCellM, linkEitherCellM'
  , cellTooltip
  , listCell
  , formCell, DBFormResult(..), getDBFormResult
  , dbRow, dbSelect
  , (&)
  , module Control.Monad.Trans.Maybe
  , module Colonnade
  , DBSTemplateMode(..)
  ) where

import Handler.Utils.Table.Pagination.Types
import Handler.Utils.Table.Pagination.CsvColumnExplanations
import Handler.Utils.Form
import Handler.Utils.Csv
import Handler.Utils.ContentDisposition
import Handler.Utils.I18n
import Utils
import Utils.Lens

import Import hiding (pi)

import qualified Yesod.Form.Functions as Yesod
  
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
import qualified Database.Esqueleto.Internal.Language as E (From)

import qualified Network.Wai as Wai

import Control.Monad.RWS (RWST(..), execRWS)
import Control.Monad.Writer (WriterT(..))
import Control.Monad.Reader (ReaderT(..), mapReaderT)
import Control.Monad.State (StateT(..), evalStateT)
import Control.Monad.Trans.Maybe
import Control.Monad.State.Class (modify)
import qualified Control.Monad.State.Class as State

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 Data.Csv (NamedRecord)

import Colonnade hiding (bool, fromMaybe, singleton)
import qualified Colonnade (singleton)
import Colonnade.Encode hiding (row)

import Text.Hamlet (hamletFile)

import Data.Ratio ((%))

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

import Data.Semigroup as Sem (Semigroup(..))

import qualified Data.Conduit.List as C

import Handler.Utils.DateTime (formatTimeRangeW)
import qualified Control.Monad.Catch as Catch

import Data.Dynamic

import qualified Data.Csv as Csv


#if MIN_VERSION_base(4,11,0)
type Monoid' = Monoid
#else
type Monoid' x = (Sem.Semigroup x, Monoid x)
#endif


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


dbFilterKey :: PathPiece dbtIdent => dbtIdent -> FilterKey -> Text
dbFilterKey ident = toPathPiece . WithIdent ident


data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }
  
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
                  | SortColumns { getSortColumns :: t -> [SomeExprValue] }

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 ) = pure . E.asc  $ e t
sqlSortDirection t (SortColumn  e , SortDesc) = pure . E.desc $ e t
sqlSortDirection t (SortColumns es, SortAsc ) = es t <&> \(SomeExprValue v) -> E.asc  v
sqlSortDirection t (SortColumns es, SortDesc) = es t <&> \(SomeExprValue v) -> E.desc v


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 is0 = filterColumn' (cont input) is'
    where
      (input, ($ []) -> is') = go (mempty, id) is0
      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
  ]


data DBCsvActionMode = DBCsvActionNew | DBCsvActionExisting | DBCsvActionMissing
  deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, Typeable)
instance Universe DBCsvActionMode
instance Finite DBCsvActionMode

nullaryPathPiece ''DBCsvActionMode $ camelToPathPiece' 3
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 3
  } ''DBCsvActionMode


data ButtonCsvMode = BtnCsvExport | BtnCsvImport | BtnCsvImportConfirm
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCsvMode
instance Finite ButtonCsvMode

embedRenderMessage ''UniWorX ''ButtonCsvMode id

nullaryPathPiece ''ButtonCsvMode $ camelToPathPiece' 1

instance Button UniWorX ButtonCsvMode where
  btnLabel BtnCsvExport
    = [whamlet|
        $newline never
        #{iconFileCSV}
        \ _{BtnCsvExport}
      |]
  btnLabel x = [whamlet|_{x}|]


data DBCsvMode
  = DBCsvNormal
  | DBCsvExport
    { dbCsvExportData :: Dynamic
    }
  | DBCsvImport
    { dbCsvFiles :: [FileInfo]
    }

data DBCsvDiff r' csv k'
  = DBCsvDiffNew
    { dbCsvNewKey :: Maybe k'
    , dbCsvNew :: csv
    }
  | DBCsvDiffExisting
    { dbCsvOldKey :: k'
    , dbCsvOld :: r'
    , dbCsvNew :: csv
    }
  | DBCsvDiffMissing
    { dbCsvOldKey :: k'
    , dbCsvOld :: r'
    }

makeLenses_ ''DBCsvDiff
makePrisms ''DBCsvDiff

data DBCsvException k'
  = DBCsvDuplicateKey
    { dbCsvDuplicateKey :: k'
    , dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB :: NamedRecord
    }
  | DBCsvException
    { dbCsvExceptionRow :: NamedRecord
    , dbCsvException :: Text
    }
  deriving (Show, Typeable)

makeLenses_ ''DBCsvException

instance (Typeable k', Show k') => Exception (DBCsvException k')


type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeable 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

defaultPagesize :: PagesizeLimit -> PSValidator m x -> PSValidator m x
defaultPagesize psLimit (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
  where
    injectDefault x = case x >>= piLimit of
      Just _  -> id
      Nothing -> set (_2._psLimit) psLimit

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 r = DBStyle
  { dbsEmptyStyle :: DBEmptyStyle
  , dbsEmptyMessage :: UniWorXMessage
  , dbsAttrs :: [(Text, Text)]
  , dbsFilterLayout :: Widget
                    -> Enctype
                    -> SomeRoute UniWorX
                    -> Widget
                    -> Widget
    -- ^ Filter UI, Filter Encoding, Filter action, table
  , dbsTemplate :: DBSTemplateMode r
  }

data DBSTemplateMode r = DBSTDefault
                       | DBSTCourse (Lens' r (Entity Course)) (Lens' r [Entity User]) (Lens' r Bool) (Lens' r (Entity School)) (Traversal' r (Entity Allocation))

instance Default (DBStyle r) 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}
        |]
    , dbsTemplate = DBSTDefault
    }

defaultDBSFilterLayout :: Widget -- ^ Filter UI
                       -> Enctype
                       -> SomeRoute UniWorX -- ^ Filter action (target uri)
                       -> Widget -- ^ Table
                       -> Widget
defaultDBSFilterLayout filterWdgt filterEnctype filterAction scrolltable
  = $(widgetFile "table/layout-filter-default")
  where
    filterForm = wrapForm filterWdgt FormSettings
      { formMethod   = GET
      , formAction   = Just filterAction
      , formEncoding = filterEnctype
      , formAttrs    = [("class", "table-filter-form")]
      , formSubmit   = FormAutoSubmit
      , formAnchor   = Nothing :: Maybe Text
      }


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 DBTCsvEncode r' k' csv = forall exportData.
  ( ToNamedRecord csv, CsvColumnsExplained csv
  , DBTableKey k'
  , Typeable exportData
  ) => DBTCsvEncode
  { dbtCsvExportForm   :: AForm (YesodDB UniWorX) exportData
  , dbtCsvHeader       :: Maybe exportData -> YesodDB UniWorX Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error
  , dbtCsvDoEncode     :: exportData -> ConduitT (k', r') csv (YesodDB UniWorX) ()
  , dbtCsvName         :: FilePath
  , dbtCsvNoExportData :: Maybe (AnIso' exportData ())
  }
data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
  ( FromNamedRecord csv, ToNamedRecord csv
  , DBTableKey k'
  , RedirectUrl UniWorX route
  , Typeable csv
  , Ord csvAction, FromJSON csvAction, ToJSON csvAction
  , Ord csvActionClass
  , Exception csvException
  ) => DBTCsvDecode
  { dbtCsvRowKey :: csv -> MaybeT (YesodDB UniWorX) k'
  , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction (YesodDB UniWorX) ()
  , dbtCsvClassifyAction :: csvAction -> csvActionClass
  , dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
  , dbtCsvExecuteActions :: ConduitT csvAction Void (YesodDB UniWorX) route
  , dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
  , dbtCsvRenderActionClass :: csvActionClass -> Widget
  , dbtCsvRenderException :: csvException -> YesodDB UniWorX Text
  }

data DBTable m x = forall a r r' h i t k k' csv.
  ( ToSortable h, Functor h
  , E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
  , PathPiece i, Eq i
  , E.From t
  ) => DBTable
  { dbtSQLQuery :: t -> E.SqlQuery a
  , dbtRowKey :: t -> k                 -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
  , dbtProj :: DBRow r -> MaybeT (YesodDB UniWorX) r'
  , dbtColonnade :: Colonnade h r' (DBCell m x)
  , dbtSorting :: Map SortingKey (SortColumn t)
  , dbtFilter :: Map FilterKey (FilterColumn t)
  , dbtFilterUI :: DBFilterUI
  , dbtStyle :: DBStyle r'
  , dbtParams :: DBParams m x
  , dbtCsvEncode :: Maybe (DBTCsvEncode r' k' csv)
  , dbtCsvDecode :: Maybe (DBTCsvDecode r' k' csv)
  , dbtIdent :: i
  }

type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])

noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
noCsvEncode = Nothing

simpleCsvEncode :: forall fp r' k' csv.
                   ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
                   , DBTableKey k'
                   , Textual fp
                   )
                => fp -> (r' -> csv) -> Maybe (DBTCsvEncode r' k' csv)
simpleCsvEncode fName f = Just DBTCsvEncode
  { dbtCsvExportForm   = pure ()
  , dbtCsvDoEncode     = \() -> C.map (f . view _2)
  , dbtCsvName         = unpack fName
  , dbtCsvNoExportData = Just id
  , dbtCsvHeader       = const . return $ headerOrder (error "headerOrder" :: csv)
  }

simpleCsvEncodeM :: forall fp r' k' csv.
                    ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
                    , DBTableKey k'
                    , Textual fp
                    )
                 => fp -> ReaderT r' (YesodDB UniWorX) csv -> Maybe (DBTCsvEncode r' k' csv)
simpleCsvEncodeM fName f = Just DBTCsvEncode
  { dbtCsvExportForm   = pure ()
  , dbtCsvDoEncode     = \() -> C.mapM (runReaderT f . view _2)
  , dbtCsvName         = unpack fName
  , dbtCsvNoExportData = Just id
  , dbtCsvHeader       = const . return $ headerOrder (error "headerOrder" :: csv)
  }


class (MonadHandler m, HandlerSite m ~ UniWorX, 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

addCellClass :: (IsDBTable m x, PathPiece t) => t -> DBCell m x -> DBCell m x
addCellClass = over cellAttrs . Yesod.addClass . toPathPiece

instance Monoid' x => IsDBTable (HandlerFor UniWorX) x where
  data DBParams (HandlerFor UniWorX) x = DBParamsWidget
  type DBResult (HandlerFor UniWorX) x = (x, Widget)
  -- type DBResult' (WidgetFor UniWorX) () = ()

  data DBCell (HandlerFor UniWorX) x = WidgetCell
    { wgtCellAttrs :: [(Text, Text)]
    , wgtCellContents :: WriterT x (HandlerFor UniWorX) Widget
    }

  dbCell = iso
    (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
    (uncurry WidgetCell)

  -- dbWidget Proxy Proxy = iso (, ()) $ view _1
  dbWidget _ _ = return . snd
  dbHandler _ _ f = return . over _2 f
  runDBTable _ _ _ = liftHandler

instance Monoid' x => Sem.Semigroup (DBCell (HandlerFor UniWorX) x) where
  (WidgetCell a c) <> (WidgetCell a' c') = WidgetCell (a <> a') ((<>) <$> c <*> c')

instance Monoid' x => Monoid (DBCell (HandlerFor UniWorX) x) where
  mempty = WidgetCell mempty $ return mempty
  mappend = (<>)

instance Default (DBParams (HandlerFor UniWorX) x) where
  def = DBParamsWidget

instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerFor UniWorX)) x where
  data DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBParamsDB
  type DBResult (ReaderT SqlBackend (HandlerFor UniWorX)) x = (x, Widget)

  data DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBCell
    { dbCellAttrs :: [(Text, Text)]
    , dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerFor UniWorX)) 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 (HandlerFor UniWorX) ((), Widget) -> m (Widget)
  runDBTable _ _ _ = mapReaderT liftHandler

instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
  (DBCell a c) <> (DBCell a' c') = DBCell (a <> a') ((<>) <$> c <*> c')

instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
  mempty = DBCell mempty $ return mempty
  mappend = (<>)

instance Default (DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) 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 (HandlerFor UniWorX)) x where
  data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = forall a. DBParamsForm
    { dbParamsFormMethod     :: StdMethod
    , dbParamsFormAction     :: Maybe (SomeRoute UniWorX)
    , dbParamsFormAttrs      :: [(Text, Text)]
    , dbParamsFormSubmit     :: FormSubmitType
    , dbParamsFormAdditional :: Form a
    , dbParamsFormEvaluate   :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerFor UniWorX) (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 (HandlerFor UniWorX)) x = (x, Widget)
  -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a) = (FormResult a, Enctype)

  data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = forall a. FormCell
    { formCellAttrs :: [(Text, Text)]
    , formCellContents :: WriterT x (MForm (HandlerFor UniWorX)) (FormResult a, Widget)
    , formCellLens :: Lens' x (FormResult a)
    }

  -- dbCell :: Iso'
  --             (DBCell (RWST ... ... ... (HandlerFor UniWorX)) x)
  --             ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerFor UniWorX)) 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 (HandlerFor UniWorX)) x -> PaginationInput -> [k'] -> (MForm (HandlerFor UniWorX)) (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 dbtable 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 Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
  def = DBParamsForm
    { dbParamsFormMethod     = POST
    , dbParamsFormAction     = Nothing
    , dbParamsFormAttrs      = []
    , dbParamsFormSubmit     = FormSubmit
    , dbParamsFormAdditional = \_ -> return (pure (), mempty)
    , dbParamsFormEvaluate   = liftHandler . runFormPost
    , dbParamsFormResult     = lens (\_ -> pure ()) (\s _ -> s)
    , dbParamsFormIdent      = def
    }

dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerFor UniWorX)) x -> DBParams (MForm (HandlerFor UniWorX)) x -> (Html -> MForm (HandlerFor UniWorX) (x, Widget)) -> (Html -> MForm (HandlerFor UniWorX) (x, Widget))
dbParamsFormWrap DBTable{ dbtIdent } 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,) $ wrapForm fWidget FormSettings
    { formMethod   = dbParamsFormMethod
    , formAction   = dbParamsFormAction
    , formEncoding = enctype
    , formAttrs    = dbParamsFormAttrs
    , formSubmit   = dbParamsFormSubmit
    , formAnchor   = Just $ WithIdent dbtIdent ("form" :: Text)
    }


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 => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
  (FormCell attrs c l) <> (FormCell attrs' c' l') = FormCell (attrs <> attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', w <> w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))

instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
  mempty = FormCell mempty (return mempty) $ lens (\_ -> pure ()) (\s _ -> s)
  mappend = (<>)

instance IsDBTable m a => IsString (DBCell m a) where
  fromString = cell . fromString


-- | DB-backed tables with pagination, may short-circuit a handler if the frontend only asks for the table content, i.e. handler actions after calls to dbTable may not happen at all.
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
      }

  piPreviousPost <- lift . runInputPost $ iopt (jsonField True) (wIdent "pagination")
  piPreviousGet  <- lift . runInputGet  $ iopt (jsonField True) (wIdent "pagination")
  let
    piPreviousRes = maybe FormMissing FormSuccess $ piPreviousPost <|> piPreviousGet
  $logDebugS "dbTable" [st|#{wIdent "pagination"}: #{tshow piPreviousRes}|]

  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 $ dbFilterKey dbtIdent' 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 & addName (wIdent "pagesize") & addClass ("select--pagesize" :: Text)) (Just referencePagesize)
    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{..} -> (Map.findWithDefault (error $ "Invalid sorting key: " <> show sortKey) sortKey dbtSorting, sortDir)) psSorting

  mapM_ (addMessageI Warning) errs

  currentRoute <- fromMaybe (error "dbTable called from 404-handler") <$> getCurrentRoute
  getParams <- liftHandler $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
  let
    tblLink :: (QueryText -> QueryText) -> SomeRoute UniWorX
    tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
    substPi = foldr (.) id
      [ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
      , foldr (.) id . map (\k -> setParams (dbFilterKey dbtIdent' 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
      ]
    tblLink' :: (QueryText -> QueryText) -> Widget
    tblLink' = toWidget <=< toTextUrl . tblLink

  let noExportData
        | Just DBTCsvEncode{..} <- dbtCsvEncode
        = is _Just dbtCsvNoExportData
        | otherwise
        = True

  ((csvExportRes, csvExportWdgt), csvExportEnctype) <- bool runFormPost runFormGet noExportData . identifyForm FIDDBTableCsvExport . renderAForm FormDBTableCsvExport . fmap DBCsvExport $ case dbtCsvEncode of
    Just DBTCsvEncode{..}
      | Just (cloneIso -> noExportData') <- dbtCsvNoExportData
        -> toDyn . view (noExportData' . from noExportData') <$> dbtCsvExportForm
      | otherwise
        -> toDyn <$> dbtCsvExportForm
    Nothing
        -> pure $ toDyn ()
  ((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . identifyForm FIDDBTableCsvImport . renderAForm FormDBTableCsvImport $ DBCsvImport
    <$> areq fileFieldMultiple (fslI MsgCsvFile) Nothing

  let
    csvMode = asum
      [ csvExportRes <* guard (is _Just dbtCsvEncode)
      , csvImportRes <* guard (is _Just dbtCsvDecode)
      , FormSuccess DBCsvNormal
      ]
    csvExportWdgt' = wrapForm' BtnCsvExport csvExportWdgt FormSettings
      { formMethod = bool POST GET noExportData
      , formAction = Just $ tblLink id
      , formEncoding = csvExportEnctype
      , formAttrs = []
      , formSubmit = FormSubmit
      , formAnchor = Just $ wIdent "csv-export"
      }
    csvImportWdgt' = wrapForm' BtnCsvImport csvImportWdgt FormSettings
      { formMethod = POST
      , formAction = Just $ tblLink id
      , formEncoding = csvImportEnctype
      , formAttrs = []
      , formSubmit = FormSubmit
      , formAnchor = Just $ wIdent "csv-import"
      }
    csvImportExplanation = modal [whamlet|_{MsgCsvImportExplanationLabel}|] $ Right $(i18nWidgetFile "table/csv-import-explanation")
    csvColExplanations = case dbtCsvEncode of
      Just (DBTCsvEncode{} :: DBTCsvEncode r' k' csv) -> assertM' (not . null) . Map.toList . csvColumnsExplanations $ Proxy @csv
      Nothing -> Nothing
    csvColExplanations' = case csvColExplanations of
      Just csvColExplanations'' -> modal [whamlet|_{MsgCsvColumnsExplanationsLabel}|] $ Right $(widgetFile "table/csv-column-explanations")
      Nothing -> mempty


  rows' <- E.select . E.from $ \t -> do
    res <- dbtSQLQuery t
    E.orderBy $ concatMap (sqlSortDirection t) psSorting'
    case csvMode of
      FormSuccess DBCsvExport{} -> return ()
      FormSuccess DBCsvImport{} -> return ()
      _other -> do
        case previousKeys of
          Nothing
            | PagesizeLimit l <- psLimit
              -> do
                E.limit l
                E.offset (psPage * l)
          Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
          _other  -> return ()
        Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) 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'


  formResult csvMode $ \case
    DBCsvExport{..}
      | Just DBTCsvEncode{..} <- dbtCsvEncode
      , Just exportData <- fromDynamic dbCsvExportData -> do
        hdr <- dbtCsvHeader $ Just exportData
        let ensureExtension ext fName = bool (addExtension ext) id (ext `isExtensionOf` fName) fName
        setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName
        sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
    DBCsvImport{..}
      | Just DBTCsvEncode{..} <- dbtCsvEncode
      , Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
                          , ..
                          } :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do
        let existing = Map.fromList $ zip currentKeys rows
            sourceDiff :: ConduitT () (DBCsvDiff r' csv k') (StateT (Map k' csv) (YesodDB UniWorX)) ()
            sourceDiff = do
              let
                toDiff :: csv -> StateT (Map k' csv) (YesodDB UniWorX) (DBCsvDiff r' csv k')
                toDiff row = do
                  rowKey <- lift $
                    handle (throwM . (DBCsvException (toNamedRecord row) :: Text -> DBCsvException k') <=< dbtCsvRenderException) . runMaybeT $ dbtCsvRowKey row
                  seenKeys <- State.get
                  (<* modify (maybe id (flip Map.insert row) rowKey)) $ if
                    | Just rowKey' <- rowKey
                    , Just oldRow <- Map.lookup rowKey' seenKeys
                      -> throwM $ DBCsvDuplicateKey rowKey' (toNamedRecord oldRow) (toNamedRecord row)
                    | Just rowKey' <- rowKey
                    , Just oldRow <- Map.lookup rowKey' existing
                      -> return $ DBCsvDiffExisting rowKey' oldRow row
                    | otherwise
                      -> return $ DBCsvDiffNew rowKey row
              mapM_ fileSourceCsv dbCsvFiles .| C.mapM toDiff

              seen <- State.get
              forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if
                | Map.member rowKey seen -> return ()
                | otherwise -> yield $ DBCsvDiffMissing rowKey oldRow

            accActionMap :: Map csvActionClass (Set csvAction) -> csvAction -> Map csvActionClass (Set csvAction)
            accActionMap acc csvAct = Map.insertWith Set.union (dbtCsvClassifyAction csvAct) (Set.singleton csvAct) acc

            importCsv = do
              let
                dbtCsvComputeActions' :: ConduitT (DBCsvDiff r' csv k') Void (YesodDB UniWorX) (Map csvActionClass (Set csvAction))
                dbtCsvComputeActions' = do
                  let innerAct = awaitForever $ \x
                        -> let doHandle
                                 | Just inpCsv <- x ^? _dbCsvNew
                                 = handle $ throwM . (DBCsvException (toNamedRecord inpCsv) :: Text -> DBCsvException k') <=< dbtCsvRenderException
                                 | otherwise
                                 = id
                            in C.sourceList <=< lift . doHandle . runConduit $ dbtCsvComputeActions x .| C.foldMap pure
                  innerAct .| C.fold accActionMap Map.empty
              actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift dbtCsvComputeActions'

              when (Map.null actionMap) $ do
                addMessageI Info MsgCsvImportUnnecessary
                redirect $ tblLink id

              liftHandler . (>>= sendResponse) $
                siteLayoutMsg MsgCsvImportConfirmationHeading $ do
                  setTitleI MsgCsvImportConfirmationHeading

                  let
                    precomputeIdents :: forall f m'. (Eq (Element f), MonoFoldable f, MonadHandler m') => f -> m' (Element f -> Text)
                    precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed")
                  actionClassIdent <- precomputeIdents $ Map.keys actionMap
                  actionIdent <- precomputeIdents . Set.unions $ Map.elems actionMap

                  let defaultChecked actClass = case dbtCsvCoarsenActionClass actClass of
                        DBCsvActionMissing -> False
                        _other             -> True
                      csvActionCheckBox :: [(Text, Text)] -> csvAction -> Widget
                      csvActionCheckBox vAttrs act = do
                        let
                          sJsonField :: Field (HandlerFor UniWorX) csvAction
                          sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
                            [whamlet|
                              $newline never
                              <input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} :defaultChecked (dbtCsvClassifyAction act):checked>
                            |]
                        fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False
                  (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
                  let csvImportConfirmForm = wrapForm' BtnCsvImportConfirm csvImportConfirmForm' FormSettings
                        { formMethod = POST
                        , formAction = Just $ tblLink id
                        , formEncoding = csvImportConfirmEnctype
                        , formAttrs = []
                        , formSubmit = FormSubmit
                        , formAnchor = Nothing :: Maybe Text
                        }

                  $(widgetFile "csv-import-confirmation-wrapper")

        hdr <- dbtCsvHeader Nothing
        catches importCsv
          [ Catch.Handler $ \case
              (DBCsvDuplicateKey{..} :: DBCsvException k')
                -> liftHandler $ sendResponseStatus badRequest400 =<< do
                     mr <- getMessageRender

                     let offendingCsv = CsvRendered hdr [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
                         heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvDuplicateKey]

                     siteLayoutMsg heading $ do
                       setTitleI heading
                       [whamlet|
                         <p>_{MsgDBCsvDuplicateKey}
                         <p>_{MsgDBCsvDuplicateKeyTip}
                         ^{offendingCsv}
                       |]
              (DBCsvException{..} :: DBCsvException k')
                -> liftHandler $ sendResponseStatus badRequest400 =<< do
                     mr <- getMessageRender

                     let offendingCsv = CsvRendered hdr [ dbCsvExceptionRow ]
                         heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvException]

                     siteLayoutMsg heading $ do
                       setTitleI heading
                       [whamlet|
                         <p>_{MsgDBCsvException}
                         $if not (Text.null dbCsvException)
                           <p>#{dbCsvException}
                         ^{ offendingCsv}
                       |]
          ]
    _other      -> return ()

  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' = let
        columnCount :: Int64
        columnCount = olength64 $ getColonnade dbtColonnade

        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 dir = fromMaybe False $ (==) <$> (SortingSetting <$> sortableKey <*> pure dir) <*> listToMaybe psSorting
            attrs = sortableContent ^. cellAttrs
            piSorting' = [ sSet | sSet <- fromMaybe [] piSorting, Just (sortKey sSet) /= sortableKey ]
          case dbsTemplate of
            DBSTCourse{} -> return $(widgetFile "table/course/header")
            DBSTDefault  -> return $(widgetFile "table/cell/header")
      in do
        wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
        case dbsTemplate of
          DBSTCourse c l r s a -> do
            wRows <- forM rows $ \row' -> let
              Course{..}       = row' ^. c . _entityVal
              lecturerUsers    = row' ^. l
              courseLecturers  = userSurname . entityVal <$> lecturerUsers
              isRegistered     = row' ^. r
              courseSchoolName = schoolName $ row' ^. s . _entityVal
              courseSemester   = (termToText . unTermKey) courseTerm
              courseAllocation = row' ^? a
              in return $(widgetFile "table/course/course-teaser")
            return $(widgetFile "table/course/colonnade")
          DBSTDefault -> do
            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]

    pagesizeWdgt' = wrapForm pagesizeWdgt FormSettings
      { formMethod = GET
      , formAction = Just . SomeRoute $ rawAction :#: wIdent "table-wrapper"
      , formEncoding = pagesizeEnc
      , formAttrs = [("class", "pagesize")]
      , formSubmit = FormAutoSubmit
      , formAnchor = Just $ wIdent "pagesize-form"
      }

    csvWdgt = $(widgetFile "table/csv-transcode")

    uiLayout table = csvWdgt <> dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout")

    dbInvalidateResult' = foldr (<=<) return . catMaybes $
      [ do
          pKeys <- previousKeys
          guard $ pKeys /= currentKeys
          return . dbInvalidateResult dbtParams . DBTIRowsMissing $ length previousKeys - length currentKeys
      ]

  ((csvImportConfirmRes, ()), _enctype) <- case dbtCsvDecode of
    Just (DBTCsvDecode{dbtCsvExecuteActions} :: DBTCsvDecode r' k' csv) -> do
      lift . runFormPost . identifyForm FIDDBTableCsvImportConfirm $ \_csrf -> do
        acts <- globalPostParamFields PostDBCsvImportAction secretJsonField
        return . (, ()) $ if
          | null acts -> FormSuccess $ do
              addMessageI Info MsgCsvImportAborted
              redirect $ tblLink id
          | otherwise -> FormSuccess $ do
              finalDest <- runConduit $ C.sourceList acts .| dbtCsvExecuteActions
              addMessageI Success . MsgCsvImportSuccessful $ length acts
              E.transactionSave
              redirect finalDest
    _other -> return ((FormMissing, ()), mempty)
  formResult csvImportConfirmRes id

  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 <- liftHandler $ 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 (HandlerFor UniWorX) x
              -> DBTable (HandlerFor UniWorX) x
              -> DB (DBResult (HandlerFor UniWorX) x)
dbTableWidget = dbTable

dbTableWidget' :: PSValidator (HandlerFor UniWorX) ()
               -> DBTable (HandlerFor UniWorX) ()
               -> DB Widget
dbTableWidget' = fmap (fmap snd) . dbTable

widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
                -> Colonnade h r (DBCell (HandlerFor UniWorX) x)
widgetColonnade = id

formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
              -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
formColonnade = id

dbColonnade :: Colonnade h r (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x)
            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) 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}
      |]

-- | Always display widget; maybe a link if user is Authorized.
--   Also see variant `linkEmptyCell`
anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a
anchorCell = anchorCellM . return

anchorCell' :: ( IsDBTable m a
               , ToWidget UniWorX wgt
               , HasRoute UniWorX url
               )
           => (r -> url)
           -> (r -> wgt)
           -> (r -> DBCell m a)
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)

anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX url -> wgt -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget)

anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)

-- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user
linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => url -> (wgt, wgt') -> DBCell m a
linkEitherCell = linkEitherCellM . return

linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => WidgetFor UniWorX url -> (wgt, wgt') -> DBCell m a
linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth)

linkEitherCellM' :: forall m url wgt wgt' a x.
                    ( HasRoute UniWorX url
                    , ToWidget UniWorX wgt
                    , ToWidget UniWorX wgt'
                    , IsDBTable m a
                    )
                 => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
  x <- xM
  let route        = x2route        x
      widget, widgetUnauth :: Widget
      widget       = toWidget $ x2widgetAuth   x
      widgetUnauth = toWidget $ x2widgetUnauth x
  authResult <- liftHandler $ isAuthorized (urlRoute route) False
  linkUrl <- toTextUrl route
  case authResult of
    Authorized -> $(widgetFile "table/cell/link") -- show allowed link
    _otherwise -> widgetUnauth                    -- show alternative widget



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 => Sem.Semigroup (DBFormResult i a r) where
  (DBFormResult m1) <> (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2

instance Ord i => Monoid (DBFormResult i a r) where
  mempty = DBFormResult Map.empty
  mappend = (<>)

getDBFormResult :: forall r i a. (r -> a) -> DBFormResult i a r -> Map i a
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m

formCell :: forall x r i a. Monoid x
         => Lens' x (FormResult (DBFormResult i a (DBRow r)))   -- ^ lens focussing on the form result within the larger DBResult; @id@ iff the form delivers the only result of the table
         -> (DBRow r -> MForm (HandlerFor UniWorX) i)          -- ^ generate row identfifiers for use in form result
         -> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerFor UniWorX) (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 (HandlerFor UniWorX)) x)
formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
  { formCellAttrs    = []
  , formCellContents = do -- MForm (HandlerFor UniWorX) (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

-- | Simple number column, also see Handler.Utils.Table.Columns.dbRowIndicator
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 x h r i a. (Headedness h, Monoid' x)
         => Lens' x (FormResult (DBFormResult i a (DBRow r)))
         -> Setter' a Bool
         -> (DBRow r -> MForm (HandlerFor UniWorX) i)
         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
-- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty) $ formCell resLens genIndex genForm
  where
    genForm _ mkUnique = do
      (selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
      return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])