1685 lines
72 KiB
Haskell
1685 lines
72 KiB
Haskell
{-# 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, _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
|
|
, forceFilter
|
|
, ToSortable(..), Sortable(..)
|
|
, dbTable
|
|
, dbTableWidget, dbTableWidget'
|
|
, dbTableDB, dbTableDB'
|
|
, widgetColonnade, formColonnade, dbColonnade
|
|
, cell, textCell, stringCell, i18nCell
|
|
, anchorCell, anchorCell', anchorCellM, anchorCellM'
|
|
, linkEitherCell, linkEitherCellM, linkEitherCellM'
|
|
, maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
|
|
, anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
|
|
, cellTooltip
|
|
, listCell, listCell'
|
|
, formCell, DBFormResult(..), getDBFormResult
|
|
, dbSelect
|
|
, (&)
|
|
, cap'
|
|
, 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 Handler.Utils.Widgets
|
|
import Utils
|
|
import Utils.Lens
|
|
|
|
import Import hiding (pi)
|
|
|
|
import qualified Data.Foldable as Foldable
|
|
|
|
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 Network.Wai as Wai
|
|
|
|
import Control.Monad.RWS (RWST(..), execRWS)
|
|
import Control.Monad.State (evalStateT, execStateT)
|
|
import Control.Monad.Trans.Maybe
|
|
import Control.Monad.State.Class (modify)
|
|
import qualified Control.Monad.State.Class as State
|
|
import Control.Monad.Trans.Writer.Lazy (censor)
|
|
|
|
import Data.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.List (inits)
|
|
|
|
import Data.Maybe (fromJust)
|
|
|
|
import Data.Aeson.Text
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
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 (sourceList)
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import Handler.Utils.DateTime (formatTimeRangeW)
|
|
import qualified Control.Monad.Catch as Catch
|
|
|
|
import Data.Dynamic
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
import Jobs.Queue
|
|
|
|
|
|
#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 :: Text
|
|
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 r' = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
|
| SortColumns { getSortColumns :: t -> [SomeExprValue] }
|
|
| SortProjected { sortProjected :: r' -> r' -> Ordering }
|
|
|
|
data SortDirection = SortAsc | SortDesc
|
|
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
|
|
|
instance Universe SortDirection
|
|
instance Finite SortDirection
|
|
|
|
nullaryPathPiece ''SortDirection $ camelToPathPiece' 1
|
|
pathPieceJSON ''SortDirection
|
|
|
|
sqlSortDirection :: SortColumn t r' -> Maybe (SortDirection -> t -> [E.SqlExpr E.OrderBy])
|
|
sqlSortDirection (SortColumn e ) = Just $ \case
|
|
SortAsc -> pure . E.asc . e
|
|
SortDesc -> pure . E.desc . e
|
|
sqlSortDirection (SortColumns es) = Just $ \case
|
|
SortAsc -> fmap (\(SomeExprValue v) -> E.asc v) . es
|
|
SortDesc -> fmap (\(SomeExprValue v) -> E.desc v) . es
|
|
sqlSortDirection _ = Nothing
|
|
|
|
sortDirectionProjected :: SortColumn t r' -> r' -> r' -> Ordering
|
|
sortDirectionProjected SortProjected{..} = sortProjected
|
|
sortDirectionProjected _ = \_ _ -> EQ
|
|
|
|
|
|
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 :: Text
|
|
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 r' = forall a. IsFilterColumn t a => FilterColumn a
|
|
| forall a. IsFilterProjected r' a => FilterProjected a
|
|
|
|
filterColumn :: FilterColumn t r' -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
|
|
filterColumn (FilterColumn f) = Just $ filterColumn' f
|
|
filterColumn _ = Nothing
|
|
|
|
filterProjected :: FilterColumn t r' -> r' -> [Text] -> DB Bool
|
|
filterProjected (FilterProjected f) = flip $ filterProjected' f
|
|
filterProjected _ = \_ _ -> return True
|
|
|
|
class IsFilterColumn t a where
|
|
filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)
|
|
|
|
instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where
|
|
filterColumn' fin _ _ = fin
|
|
|
|
instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
|
|
filterColumn' cont is' t = filterColumn' (cont t) is' t
|
|
|
|
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
|
|
filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
|
|
|
|
class IsFilterProjected r' a where
|
|
filterProjected' :: a -> [Text] -> r' -> DB Bool
|
|
|
|
instance IsFilterProjected r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where
|
|
filterProjected' fin _ _ = fin
|
|
|
|
instance IsFilterProjected r' Bool where
|
|
filterProjected' fin _ _ = return fin
|
|
|
|
instance IsFilterProjected r' cont => IsFilterProjected r' (r' -> cont) where
|
|
filterProjected' cont is' r = filterProjected' (cont r) is' r
|
|
|
|
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected r' cont, MonoPointed l, Monoid l) => IsFilterProjected r' (l -> cont) where
|
|
filterProjected' cont is' = filterProjected' (cont $ is' ^. mono' _PathPiece) is'
|
|
|
|
|
|
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
|
|
]
|
|
|
|
psToPi :: PaginationSettings -> PaginationInput
|
|
psToPi PaginationSettings{..} = PaginationInput
|
|
{ piSorting = Just psSorting
|
|
, piFilter = Just psFilter
|
|
, piLimit = Just psLimit
|
|
, piPage = Just psPage
|
|
}
|
|
|
|
|
|
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 | BtnCsvImportAbort
|
|
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}|]
|
|
|
|
btnClasses BtnCsvImportAbort = [BCIsButton, BCDanger]
|
|
btnClasses BtnCsvImportConfirm = [BCIsButton, BCPrimary]
|
|
btnClasses _ = [BCIsButton]
|
|
|
|
btnValidate _ BtnCsvImportAbort = False
|
|
btnValidate _ _ = True
|
|
|
|
|
|
data DBCsvMode
|
|
= DBCsvNormal
|
|
| DBCsvExport
|
|
{ dbCsvExportData :: Dynamic
|
|
}
|
|
| DBCsvImport
|
|
{ dbCsvFiles :: FileUploads
|
|
}
|
|
| DBCsvExportExample
|
|
| DBCsvAbort
|
|
|
|
makePrisms ''DBCsvMode
|
|
|
|
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
|
|
, 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 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 prev -> _2 . _psSorting <>~ filter (\ss -> none (((==) `on` sortKey) ss) prev) psSorting
|
|
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 }
|
|
|
|
forceFilter :: ( MonoFoldable mono
|
|
, MonoPointed mono
|
|
, Monoid mono
|
|
, PathPiece (Element mono)
|
|
)
|
|
=> FilterKey -> mono -> PSValidator m x -> PSValidator m x
|
|
forceFilter key args (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 inject $ f dbTable' ps
|
|
where
|
|
inject p = p { psFilter = psFilter p <> Map.singleton key (review monoPathPieces args) }
|
|
|
|
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 { dbstmNumber :: Int64 -> Bool, dbstmShowNumber :: Int64 -> Bool }
|
|
| DBSTCourse
|
|
(Lens' r (Entity Course)) -- course
|
|
(Lens' r [Entity User]) -- lecturers
|
|
(Lens' r Bool) -- isRegistered
|
|
(Lens' r (Entity School)) -- school
|
|
(Traversal' r (Entity Allocation)) -- allocation
|
|
(Lens' r Bool) -- mayEditCourse
|
|
|
|
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 (>= 10) (\n -> n `mod` 5 == 0)
|
|
}
|
|
|
|
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"), ("autocomplete", "off")]
|
|
, 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 DB exportData
|
|
, dbtCsvHeader :: Maybe exportData -> DB Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error or exporting example data
|
|
, dbtCsvExampleData :: Maybe [csv]
|
|
, dbtCsvDoEncode :: exportData -> ConduitT (k', r') csv DB ()
|
|
, 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 DB k'
|
|
, dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction DB ()
|
|
, dbtCsvClassifyAction :: csvAction -> csvActionClass
|
|
, dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
|
|
, dbtCsvExecuteActions :: ConduitT csvAction Void (YesodJobDB UniWorX) route
|
|
, dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
|
|
, dbtCsvRenderActionClass :: csvActionClass -> Widget
|
|
, dbtCsvRenderException :: csvException -> DB Text
|
|
}
|
|
|
|
data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar).
|
|
( ToSortable h, Functor h
|
|
, E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
|
|
, PathPiece i, Eq i
|
|
, E.From t
|
|
, AsCornice h p r' (DBCell m x) colonnade
|
|
) => 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 -> DB r'
|
|
, dbtColonnade :: colonnade
|
|
, dbtSorting :: Map SortingKey (SortColumn t r')
|
|
, dbtFilter :: Map FilterKey (FilterColumn t r')
|
|
, 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 DB (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)
|
|
, dbtCsvExampleData = Nothing
|
|
}
|
|
|
|
simpleCsvEncodeM :: forall fp r' k' csv.
|
|
( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
|
|
, DBTableKey k'
|
|
, Textual fp
|
|
)
|
|
=> fp -> ReaderT r' DB 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)
|
|
, dbtCsvExampleData = 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
|
|
|
|
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)))
|
|
. maybe id (identifyForm' dbParamsFormResult) (unDBParamsFormIdent dbtable dbParamsFormIdent)
|
|
. dbParamsFormWrap dbtable dbtParams
|
|
. 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 :: forall m'. Applicative m' => Field m' [Text]
|
|
multiTextField = Field
|
|
{ fieldParse = \ts _ -> pure . 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
|
|
= views _2 psToPi . runPSValidator dbtable . formResultToMaybe $ piPreviousRes <|> piInput
|
|
|
|
referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
|
|
|
|
(((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
|
|
(filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm (FIDDBTableFilter dbtIdent) . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
|
|
|
|
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm (FIDDBTablePagesize dbtIdent) . 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 = (prevPi &) . (_piFilter ?~) <$> filterRes
|
|
<|> (prevPi &) . (_piLimit ?~) <$> 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
|
|
|
|
forM_ errs $ \err -> do
|
|
mr <- getMessageRender
|
|
$logDebugS "dbTable paginationSettings" $ mr err
|
|
addMessageI Warning err
|
|
|
|
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 . setParam (toPathPiece PostFormIdentifier) 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 . addPIHiddenField dbtable paginationInput . identifyForm (FIDDBTableCsvExport dbtIdent) . 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 ()
|
|
let importButtons prevRes = do
|
|
isReImport <- hasGlobalPostParamForm PostDBCsvReImport
|
|
if | is _FormSuccess prevRes || isReImport
|
|
-> return [BtnCsvImport, BtnCsvImportAbort]
|
|
| otherwise
|
|
-> return [BtnCsvImport]
|
|
handleBtnAbort _ (FormSuccess BtnCsvImportAbort) = pure DBCsvAbort
|
|
handleBtnAbort x btn = x <* btn
|
|
((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . withGlobalPostParam PostDBCsvReImport () . withButtonFormCombM' handleBtnAbort importButtons . identifyForm (FIDDBTableCsvImport dbtIdent) . renderAForm FormDBTableCsvImport $ DBCsvImport
|
|
<$> areq fileFieldMultiple (fslI MsgCsvFile) Nothing
|
|
exportExampleRes <- guardOn <$> hasGlobalGetParam GetCsvExampleData <*> pure DBCsvExportExample
|
|
|
|
let
|
|
csvMode = asum
|
|
[ maybe FormMissing FormSuccess exportExampleRes
|
|
, 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 csvImportWdgt FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just $ tblLink id
|
|
, formEncoding = csvImportEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormNoSubmit
|
|
, formAnchor = Just $ wIdent "csv-import"
|
|
}
|
|
csvImportExplanation :: Widget
|
|
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
|
|
|
|
psFilter' = imap (\key args -> (, args) $ Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) psFilter
|
|
|
|
primarySortSql = flip has psSorting' $ _head . _1 . to sqlSortDirection . _Just
|
|
|
|
sortSql :: _ -> [E.SqlExpr E.OrderBy]
|
|
sortSql t = concatMap (\(f, d) -> f d t) $ mapMaybe (\(c, d) -> (, d) <$> sqlSortDirection c) psSorting'
|
|
|
|
filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool)))
|
|
filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter'
|
|
|
|
selectPagesize = primarySortSql
|
|
&& all (is _Just) filterSql
|
|
|
|
psLimit' = bool PagesizeAll psLimit selectPagesize
|
|
|
|
|
|
rows' <- E.select . E.from $ \t -> do
|
|
res <- dbtSQLQuery t
|
|
E.orderBy $ sortSql t
|
|
case csvMode of
|
|
-- FormSuccess DBCsvExport{} -> return ()
|
|
FormSuccess DBCsvImport{} -> return () -- don't apply filter and sorting for csv _import_; we expect all rows to be available for matching with provided csv
|
|
_other -> do
|
|
case previousKeys of
|
|
Nothing
|
|
| PagesizeLimit l <- psLimit'
|
|
, selectPagesize
|
|
-> do
|
|
unless (has (_FormSuccess . _DBCsvExport) csvMode) $
|
|
E.limit l
|
|
E.offset (psPage * l)
|
|
Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
|
|
_other -> return ()
|
|
Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql
|
|
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
|
|
|
|
let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> 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
|
|
|
|
allFilterProjected r' = lift $ getAll <$> foldMapM (\(f, args) -> All <$> filterProjected f r' args) psFilter'
|
|
|
|
sortProjected
|
|
| is _Just previousKeys
|
|
= id
|
|
| primarySortSql
|
|
= id
|
|
| otherwise
|
|
= sortBy $ concatMap (\(c, d) (_, r) (_, r') -> adjustOrder d $ sortDirectionProjected c r r') psSorting'
|
|
where
|
|
adjustOrder SortAsc x = x
|
|
adjustOrder SortDesc LT = GT
|
|
adjustOrder SortDesc EQ = EQ
|
|
adjustOrder SortDesc GT = LT
|
|
|
|
(currentKeys, rows) <- fmap (unzip . sortProjected) . mapMaybeM' (assertMM allFilterProjected . lift . dbtProj) . map (\(E.Value dbrCount, dbrKey, dbrOutput) -> (dbrKey, DBRow{..})) $ reproduceSorting rows'
|
|
|
|
csvExample <- runMaybeT $ do
|
|
DBTCsvEncode{..} <- hoistMaybe dbtCsvEncode
|
|
exData <- hoistMaybe dbtCsvExampleData
|
|
hdr <- lift $ dbtCsvHeader Nothing
|
|
exportUrl <- toTextUrl (currentRoute, [(toPathPiece GetCsvExampleData, "")])
|
|
return $(widgetFile "table/csv-example")
|
|
|
|
formResult csvMode $ \case
|
|
DBCsvAbort{} -> do
|
|
addMessageI Info MsgCsvImportAborted
|
|
redirect $ tblLink id
|
|
DBCsvExportExample{}
|
|
| Just DBTCsvEncode{..} <- dbtCsvEncode
|
|
, Just exData <- dbtCsvExampleData -> do
|
|
hdr <- dbtCsvHeader Nothing
|
|
sendResponse <=< liftHandler . respondCsv hdr $ C.sourceList exData
|
|
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
|
|
dbtCsvName' <- timestampCsv <*> pure dbtCsvName
|
|
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) DB) ()
|
|
sourceDiff = do
|
|
let
|
|
toDiff :: csv -> StateT (Map k' csv) DB (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
|
|
transPipe liftHandler dbCsvFiles .| fileSourceCsv .| 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 DB (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.foldl accActionMap Map.empty
|
|
actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift dbtCsvComputeActions'
|
|
|
|
when (Map.null actionMap) $ do
|
|
addMessageI Info MsgCsvImportUnnecessary
|
|
redirect $ tblLink id
|
|
|
|
E.transactionSave -- If dbtCsvComputeActions has side-effects, commit those
|
|
|
|
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 . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
|
|
let csvImportConfirmForm = wrapForm csvImportConfirmForm' FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just $ tblLink id
|
|
, formEncoding = csvImportConfirmEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormNoSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
|
|
$(widgetFile "csv-import-confirmation-wrapper")
|
|
|
|
csvReImport = $(widgetFile "table/csv-reimport")
|
|
|
|
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|
|
|
$newline never
|
|
<section>
|
|
<p>_{MsgDBCsvDuplicateKey}
|
|
<p>_{MsgDBCsvDuplicateKeyTip}
|
|
^{offendingCsv}
|
|
<section>
|
|
^{csvReImport}
|
|
|]
|
|
(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|
|
|
$newline never
|
|
<section>
|
|
<p>_{MsgDBCsvException}
|
|
$if not (Text.null dbCsvException)
|
|
<p>#{dbCsvException}
|
|
^{offendingCsv}
|
|
<section>
|
|
^{csvReImport}
|
|
|]
|
|
, Catch.Handler $ \(csvParseError :: CsvParseError)
|
|
-> liftHandler $ sendResponseStatus badRequest400 =<< do
|
|
mr <- getMessageRender
|
|
|
|
let heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvParseError]
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
[whamlet|
|
|
$newline never
|
|
<section>
|
|
<p>_{MsgDBCsvParseErrorTip}
|
|
<pre .csv-parse-error>
|
|
$case csvParseError
|
|
$of CsvParseError _ errMsg
|
|
#{errMsg}
|
|
$of IncrementalError errMsg
|
|
#{errMsg}
|
|
<section>
|
|
^{csvReImport}
|
|
|]
|
|
]
|
|
_other -> return ()
|
|
|
|
let
|
|
rowCount
|
|
| selectPagesize = fromMaybe 0 $ rows' ^? _head . _1 . _Value
|
|
| otherwise = olength64 rows
|
|
|
|
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 . discard $ dbtColonnade ^. _Cornice
|
|
|
|
numberColumn = case dbsTemplate of
|
|
DBSTDefault{..} -> dbstmNumber rowCount
|
|
_other -> False
|
|
|
|
genHeaders :: forall h. Cornice h _ _ (DBCell m x) -> SortableP h -> WriterT x m Widget
|
|
genHeaders cornice SortableP{..} = execWriterT . go mempty $ annotate cornice
|
|
where
|
|
go :: forall (p' :: Pillar) r'.
|
|
[(Int, Int, Int)]
|
|
-> AnnotatedCornice (Maybe Int) h p' r' (DBCell m x)
|
|
-> WriterT Widget (WriterT x m) ()
|
|
go rowspanAcc (AnnotatedCorniceBase _ (Colonnade (toList -> v))) = censor wrap . forM_ (zip (inits v) v) $ \(before, OneColonnade Sized{..} _) -> do
|
|
let (_, cellSize') = compCellSize rowspanAcc (map oneColonnadeHead before) Sized{..}
|
|
whenIsJust cellSize' $ \cellSize -> tellM $ fromContent Sized { sizedSize = cellSize, sizedContent }
|
|
go rowspanAcc (AnnotatedCorniceCap _ v@(toList -> oneCornices)) = do
|
|
rowspanAcc' <- (execStateT ?? rowspanAcc) . hoist (censor wrap) . forM_ (zip (inits oneCornices) oneCornices) $ \(before, OneCornice h (size -> sz')) -> do
|
|
let sz = Sized sz' h
|
|
let (beforeSize, cellSize') = compCellSize rowspanAcc (concatMap (map oneColonnadeHead . toList . getColonnade . uncapAnnotated . oneCorniceBody) before) sz
|
|
whenIsJust cellSize' $ \cellSize -> do
|
|
let Sized{..} = sz
|
|
lift . tellM $ fromContent Sized { sizedSize = cellSize, sizedContent }
|
|
if | [n] <- mapMaybe (\(key, val) -> guardOnM (is _Rowspan key) $ readMay val) (toSortable sizedContent ^. _sortableContent . cellAttrs)
|
|
-> State.modify $ (:) (n, beforeSize, cellSize)
|
|
| otherwise -> return ()
|
|
let rowspanAcc'' = rowspanAcc'
|
|
& traverse . _1 %~ pred
|
|
whenIsJust (flattenAnnotated v) $ go rowspanAcc''
|
|
|
|
compCellSize :: forall h' c. [(Int, Int, Int)] -> [Sized (Maybe Int) h' c] -> Sized (Maybe Int) h' c -> (Int, Maybe Int)
|
|
compCellSize rowspanAcc before Sized{..} = (beforeSize,) . assertM' (> 0) $ fromMaybe 1 sizedSize - shadowed
|
|
where Sum beforeSize = foldMap (\(Sized sz _) -> Sum $ fromMaybe 1 sz) before
|
|
Sum shadowed = flip foldMap rowspanAcc $ \(rowsRem, firstCol, sz) -> fromMaybe mempty $ do
|
|
guard $ rowsRem > 0
|
|
guard $ firstCol <= beforeSize
|
|
guard $ beforeSize < firstCol + sz
|
|
return . Sum $ sz - (beforeSize - firstCol)
|
|
|
|
wrap :: Widget -> Widget
|
|
wrap row = case dbsTemplate of
|
|
DBSTCourse{} -> row
|
|
DBSTDefault{} -> $(widgetFile "table/header")
|
|
fromContent :: Sized Int h (DBCell m x) -> WriterT x m Widget
|
|
fromContent Sized{ sizedSize = cellSize, sizedContent = toSortable -> 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 (dbtColonnade ^. _Cornice)) pSortable
|
|
now <- liftIO getCurrentTime
|
|
case dbsTemplate of
|
|
DBSTCourse c l r s a e -> do
|
|
wRows <- forM rows $ \row' -> let
|
|
Course{..} = row' ^. c . _entityVal
|
|
lecturerUsers = row' ^. l
|
|
courseLecturers = userSurname . entityVal <$> lecturerUsers
|
|
isRegistered = row' ^. r
|
|
mayEdit = row' ^. e
|
|
nmnow = NTop $ Just now
|
|
courseIsVisible = NTop courseVisibleFrom <= nmnow && nmnow <= NTop courseVisibleTo
|
|
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
|
|
let colonnade = discard $ dbtColonnade ^. _Cornice
|
|
wRows' <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade colonnade) $ \(($ row') -> cell') -> do
|
|
widget <- cell' ^. cellContents
|
|
let attrs = cell' ^. cellAttrs
|
|
return $(widgetFile "table/cell/body")
|
|
let wRows = zip [firstRow..] wRows'
|
|
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"), ("autocomplete", "off")]
|
|
, formSubmit = FormAutoSubmit
|
|
, formAnchor = Just $ wIdent "pagesize-form"
|
|
}
|
|
showPagesizeWdgt = toEnum (fromIntegral rowCount) > minimum (pagesizeOptions referencePagesize)
|
|
&& selectPagesize
|
|
|
|
csvWdgt = $(widgetFile "table/csv-transcode")
|
|
|
|
uiLayout :: Widget -> Widget
|
|
uiLayout table = 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, _confirmView), _enctype) <- case dbtCsvDecode of
|
|
Just (DBTCsvDecode{dbtCsvExecuteActions} :: DBTCsvDecode r' k' csv) -> do
|
|
lift . runFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \_csrf -> do
|
|
acts <- globalPostParamFields PostDBCsvImportAction secretJsonField
|
|
return . (, mempty) $ if
|
|
| null acts -> FormSuccess $ do
|
|
addMessageI Info MsgCsvImportAborted
|
|
redirect $ tblLink id
|
|
| otherwise -> FormSuccess $ do
|
|
finalDest <- runDBJobs' . runConduit $ C.sourceList acts .| dbtCsvExecuteActions
|
|
addMessageI Success . MsgCsvImportSuccessful $ length acts
|
|
E.transactionSave
|
|
redirect finalDest
|
|
_other -> return ((FormMissing, mempty), mempty)
|
|
formResult csvImportConfirmRes $ \case
|
|
(_, BtnCsvImportAbort) -> do
|
|
addMessageI Info MsgCsvImportAborted
|
|
redirect $ tblLink id
|
|
(act, _) -> act
|
|
|
|
let
|
|
wrapLayout :: DBResult m x -> DB (DBResult m x)
|
|
wrapLayout = dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout
|
|
shortcircuit :: forall void. DBResult m x -> DB void
|
|
shortcircuit res = do
|
|
addCustomHeader HeaderDBTableCanonicalURL =<< toTextUrl (tblLink substPi)
|
|
sendResponse =<< tblLayout . uiLayout =<< dbWidget (Proxy @m) (Proxy @x) res
|
|
dbInvalidateResult' <=< bool wrapLayout shortcircuit 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
|
|
|
|
dbTableDB :: Monoid x
|
|
=> PSValidator DB x
|
|
-> DBTable DB x
|
|
-> DB (DBResult DB x)
|
|
dbTableDB = dbTable
|
|
|
|
dbTableDB' :: PSValidator DB ()
|
|
-> DBTable DB ()
|
|
-> DB Widget
|
|
dbTableDB' = 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 DB x)
|
|
-> Colonnade h r (DBCell DB 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' :: [Int64]
|
|
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
|
|
|
|
anchorCellC :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> url -> wgt -> DBCell m a
|
|
anchorCellC cache = anchorCellCM cache . 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)
|
|
|
|
anchorCellCM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX url -> wgt -> DBCell m a
|
|
anchorCellCM cache routeM widget = anchorCellCM' cache 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)
|
|
|
|
anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
|
|
anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget)
|
|
|
|
maybeAnchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) url -> wgt -> DBCell m a
|
|
maybeAnchorCellM routeM widget = maybeAnchorCellM' routeM id (const widget)
|
|
|
|
maybeAnchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (Maybe x -> wgt) -> DBCell m a
|
|
maybeAnchorCellM' xM x2route x2widget = maybeLinkEitherCellM' xM x2route (x2widget . Just, 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) = maybeLinkEitherCellM' (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust)
|
|
|
|
linkEitherCellCM' :: forall m url wgt wgt' a x cache.
|
|
( HasRoute UniWorX url
|
|
, ToWidget UniWorX wgt
|
|
, ToWidget UniWorX wgt'
|
|
, IsDBTable m a
|
|
, Binary cache
|
|
)
|
|
=> cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
|
|
linkEitherCellCM' cache xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellCM' (Just . toStrict $ B.encode cache) (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust)
|
|
|
|
maybeLinkEitherCellM' :: forall m url wgt wgt' a x.
|
|
( HasRoute UniWorX url
|
|
, ToWidget UniWorX wgt
|
|
, ToWidget UniWorX wgt'
|
|
, IsDBTable m a
|
|
)
|
|
=> MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a
|
|
maybeLinkEitherCellM' = maybeLinkEitherCellCM' Nothing
|
|
|
|
maybeLinkEitherCellCM' :: forall m url wgt wgt' a x.
|
|
( HasRoute UniWorX url
|
|
, ToWidget UniWorX wgt
|
|
, ToWidget UniWorX wgt'
|
|
, IsDBTable m a
|
|
)
|
|
=> Maybe ByteString -> MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a
|
|
maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
|
|
x' <- runMaybeT xM
|
|
case x' of
|
|
Just x -> do
|
|
let route = x2route x
|
|
widget, widgetUnauth :: Widget
|
|
widget = toWidget $ x2widgetAuth x
|
|
widgetUnauth = toWidget . x2widgetUnauth $ Just x
|
|
authResult <- liftHandler . maybe id $cachedHereBinary mCache . hasReadAccessTo $ urlRoute route
|
|
linkUrl <- toTextUrl route
|
|
if
|
|
| authResult -> $(widgetFile "table/cell/link") -- show allowed link
|
|
| otherwise -> widgetUnauth
|
|
_otherwise -> do
|
|
toWidget $ x2widgetUnauth Nothing
|
|
|
|
|
|
listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
|
|
listCell = listCell' . return
|
|
|
|
listCell' :: (IsDBTable m a, Traversable f) => WriterT a m (f r') -> (r' -> DBCell m a) -> DBCell m a
|
|
listCell' mkXS mkCell = review dbCell . ([], ) $ do
|
|
xs <- mkXS
|
|
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
|
|
|
|
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 & cellAttrs <>~ pure ("uw-hide-columns--no-hide","")) $ formCell resLens genIndex genForm
|
|
where
|
|
genForm _ mkUnique = do
|
|
(selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
|
|
return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
|
|
|
|
|
|
cap' :: ( AsCornice Sortable p r' (DBCell m x) colonnade
|
|
, IsDBTable m x
|
|
)
|
|
=> colonnade
|
|
-> Cornice Sortable ('Cap p) r' (DBCell m x)
|
|
cap' (view _Cornice -> cornice) = case cornice of
|
|
CorniceBase Colonnade{..}
|
|
| [OneColonnade{..}] <- toList getColonnade
|
|
-> recap (oneColonnadeHead & _sortableContent . cellAttrs %~ incRowspan) cornice
|
|
CorniceCap cornices
|
|
-> CorniceCap $ fmap (\OneCornice{..} -> OneCornice { oneCorniceHead = oneCorniceHead & _sortableContent . cellAttrs %~ incRowspan, oneCorniceBody = cap' oneCorniceBody }) cornices
|
|
other
|
|
-> recap (fromSortable . Sortable Nothing $ cell mempty) other
|
|
where
|
|
incRowspan :: [(Text, Text)] -> [(Text, Text)]
|
|
incRowspan attrs
|
|
| [n] <- mapMaybe (\(key, val) -> guardOnM (is _Rowspan key) $ readMay val) attrs
|
|
= (_Rowspan # (), tshow (succ n :: Natural)) : filter (hasn't $ _1 . _Rowspan) attrs
|
|
| otherwise = (_Rowspan # (), "2") : filter (hasn't $ _1 . _Rowspan) attrs
|
|
|
|
_Rowspan :: Prism' Text ()
|
|
_Rowspan = prism' (\() -> "rowspan") $ flip guardOn () . ((==) `on` CI.mk) "rowspan"
|