48113ebee0
removed box-shadow from scrolltable and introduced scrolltable--bordered class; removed course list from home when logged in
1300 lines
54 KiB
Haskell
1300 lines
54 KiB
Haskell
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}|])
|