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(..)
  , module Handler.Utils.Table.Pagination.CsvColumnExplanations
  , DBCsvActionMode(..)
  , DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
  , DBTCsvEncode, DBTCsvDecode(..)
  , DBTable(..), noCsvEncode, IsDBTable(..), DBCell(..)
  , singletonFilter
  , DBParams(..)
  , cellAttrs, cellContents
  , 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 Utils
import Utils.Lens

import Import hiding (pi)
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 Control.Lens.Extras (is)

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 (formatTimeW)
import qualified Control.Monad.Catch as Catch


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


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 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
        #{iconCSV}
        \ _{BtnCsvExport}
      |]
  btnLabel x = [whamlet|_{x}|]


data DBCsvMode
  = DBCsvNormal
  | DBCsvExport
  | 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))

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

type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv) (Conduit r' (YesodDB UniWorX) csv)
data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
  ( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered 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' -> Source (YesodDB UniWorX) csvAction
  , dbtCsvClassifyAction :: csvAction -> csvActionClass
  , dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
  , dbtCsvExecuteActions :: Sink csvAction (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 E.SqlQuery E.SqlExpr E.SqlBackend 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 :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
  , dbtStyle :: DBStyle r'
  , dbtParams :: DBParams m x
  , dbtCsvEncode :: DBTCsvEncode r' csv
  , dbtCsvDecode :: Maybe (DBTCsvDecode r' k' csv)
  , dbtIdent :: i
  }

noCsvEncode :: DictMaybe (ToNamedRecord Void, DefaultOrdered Void, CsvColumnsExplained Void) (Conduit r' (YesodDB UniWorX) Void)
noCsvEncode = Nothing

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

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 => Sem.Semigroup (DBCell (HandlerT UniWorX IO) x) where
  (WidgetCell a c) <> (WidgetCell a' c') = WidgetCell (a <> a') ((<>) <$> c <*> c')

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

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 => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
  (DBCell a c) <> (DBCell a' c') = DBCell (a <> a') ((<>) <$> c <*> c')

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

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)]
    , dbParamsFormSubmit     :: FormSubmitType
    , 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 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 Monoid' x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
  def = DBParamsForm
    { dbParamsFormMethod     = POST
    , dbParamsFormAction     = Nothing
    , dbParamsFormAttrs      = []
    , dbParamsFormSubmit     = FormSubmit
    , dbParamsFormAdditional = \_ -> return (pure (), mempty)
    , dbParamsFormEvaluate   = liftHandlerT . runFormPost
    , dbParamsFormResult     = lens (\_ -> pure ()) (\s _ -> s)
    , dbParamsFormIdent      = def
    }

dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerT UniWorX IO)) x -> DBParams (MForm (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (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 (HandlerT UniWorX IO)) 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 (HandlerT UniWorX IO)) 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 . 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 & addName (wIdent "pagesize") & addClass "select--pagesize") (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

  Just currentRoute <- getCurrentRoute -- `dbTable` should never be called from a 404-handler
  getParams <- liftHandlerT $ 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 (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
      ]
    tblLink' :: (QueryText -> QueryText) -> Widget
    tblLink' = toWidget <=< toTextUrl . tblLink

  ((csvExportRes, csvExportWdgt), csvExportEnctype) <- lift . runFormGet . identifyForm FIDDBTableCsvExport . set (mapped . mapped . _1 . mapped) DBCsvExport $ buttonForm' [BtnCsvExport]
  ((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 csvExportWdgt FormSettings
      { formMethod = GET
      , formAction = Just $ tblLink id
      , formEncoding = csvExportEnctype
      , formAttrs = [("target", "_blank"), ("class", "form--inline")]
      , formSubmit = FormNoSubmit
      , formAnchor = Nothing :: Maybe Text
      }
    csvImportWdgt' = wrapForm' BtnCsvImport csvImportWdgt FormSettings
      { formMethod = POST
      , formAction = Just $ tblLink id
      , formEncoding = csvImportEnctype
      , formAttrs = []
      , formSubmit = FormSubmit
      , formAnchor = Nothing :: Maybe Text
      }
    csvColExplanations = case dbtCsvEncode of
      (Just (Dict, _) :: DBTCsvEncode _ 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 (map (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 (Dict, dbtCsvEncode') <- dbtCsvEncode -> do
        setContentDisposition' . Just $ unpack dbtIdent <.> unpack extensionCsv
        sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList rows .| dbtCsvEncode'
    DBCsvImport{..}
      | Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
                          , ..
                          } :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do
        let existing = Map.fromList $ zip currentKeys rows
            sourceDiff :: Source (StateT (Map k' csv) (YesodDB UniWorX)) (DBCsvDiff r' csv k')
            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' :: Sink (DBCsvDiff r' csv k') (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 yieldM . doHandle . runConduit $ dbtCsvComputeActions x .| C.fold accActionMap Map.empty
                  innerAct .| C.foldMap id
              actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift dbtCsvComputeActions'

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

              liftHandlerT . (>>= 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 (HandlerT UniWorX IO) 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) <- liftHandlerT . 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")

        let defaultHeaderOrder = headerOrder (error "not to be forced" :: csv)
        catches importCsv
          [ Catch.Handler $ \case
              (DBCsvDuplicateKey{..} :: DBCsvException k')
                -> liftHandlerT $ sendResponseStatus badRequest400 =<< do
                     mr <- getMessageRender

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

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

                     let offendingCsv = CsvRendered defaultHeaderOrder [ 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' :: HandlerSite m ~ UniWorX => WriterT x m Widget
    table' = let
        columnCount :: Int64
        columnCount = olength64 $ getColonnade dbtColonnade
      in case dbsTemplate of
      DBSTCourse c l r s -> do
        wRows <- forM (zip [0..length rows] rows) $ \(cid, 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
          courseId         = tshow cid
          in return $(widgetFile "table/course/course-teaser")

        return $(widgetFile "table/course/colonnade")
      DBSTDefault -> 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
              piSorting' = [ sSet | sSet <- fromMaybe [] piSorting, Just (sortKey sSet) /= sortableKey ]
            return $(widgetFile "table/cell/header")

        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]

    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 <- 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}
      |]

-- | 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, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> wgt -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget)

anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO 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, HandlerSite m ~ UniWorX) => url -> (wgt, wgt') -> DBCell m a
linkEitherCell = linkEitherCellM . return

linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO 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
                    , HandlerSite m ~ UniWorX
                    )
                 => WidgetT UniWorX IO 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 :: WidgetT UniWorX IO ()
      widget       = toWidget $ x2widgetAuth   x
      widgetUnauth = toWidget $ x2widgetUnauth x
  authResult <- liftHandlerT $ 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. 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 x r i a. (Ord i, 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 (HandlerT UniWorX IO) i)          -- ^ generate row identfifiers for use in form result
         -> (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)) x)
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

-- | 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, Ord i, PathPiece i, Monoid' x)
         => Lens' x (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)) 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}|])