Make dbtable-forms more robust against pagination & dataset changes
This commit is contained in:
Gregor Kleen
parent
fa9cf21c25
commit
c6918affd5
@ -236,6 +236,7 @@ CorrSetCorrector: Korrektor zuweisen
|
||||
CorrAutoSetCorrector: Korrekturen verteilen
|
||||
NatField name@Text: #{name} muss eine natürliche Zahl sein!
|
||||
JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure}
|
||||
SecretJSONFieldDecryptFailure: Konnte versteckte vertrauliche Daten nicht entschlüsseln
|
||||
|
||||
SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
|
||||
SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
|
||||
|
||||
@ -219,6 +219,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = d
|
||||
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
|
||||
dbTable psValidator DBTable
|
||||
{ dbtSQLQuery
|
||||
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
|
||||
, dbtColonnade
|
||||
, dbtProj
|
||||
, dbtSorting = Map.fromList
|
||||
|
||||
@ -126,6 +126,7 @@ makeCourseTable whereClause colChoices psValidator = do
|
||||
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
|
||||
snd <$> dbTable psValidator DBTable
|
||||
{ dbtSQLQuery
|
||||
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
||||
, dbtColonnade = colChoices
|
||||
, dbtProj
|
||||
, dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
|
||||
|
||||
@ -75,6 +75,7 @@ homeAnonymous = do
|
||||
]
|
||||
courseTable <- runDB $ dbTableWidget' def DBTable
|
||||
{ dbtSQLQuery = tableData
|
||||
, dbtRowKey = (E.^. CourseId)
|
||||
, dbtColonnade = colonnade
|
||||
, dbtProj = return
|
||||
, dbtSorting = Map.fromList
|
||||
@ -171,6 +172,7 @@ homeUser uid = do
|
||||
let validator = def & defaultSorting [SortDescBy "done", SortDescBy "deadline"]
|
||||
sheetTable <- runDB $ dbTableWidget' validator DBTable
|
||||
{ dbtSQLQuery = tableData
|
||||
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||||
, dbtColonnade = colonnade
|
||||
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
|
||||
-> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
|
||||
|
||||
@ -247,6 +247,7 @@ mkOwnedCoursesTable =
|
||||
, course E.^. CourseSchool
|
||||
, course E.^. CourseShorthand
|
||||
)
|
||||
dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId
|
||||
dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))
|
||||
|
||||
dbtColonnade = mconcat
|
||||
@ -295,6 +296,7 @@ mkEnrolledCoursesTable =
|
||||
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
||||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||||
return (course, participant E.^. CourseParticipantRegistration)
|
||||
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
||||
, dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
|
||||
, dbtColonnade = mconcat
|
||||
[ dbRow
|
||||
@ -349,6 +351,7 @@ mkSubmissionTable =
|
||||
)
|
||||
let sht = sheet E.^. SheetName
|
||||
return (crse, sht, submission, lastSubEdit uid submission)
|
||||
dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
|
||||
|
||||
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
|
||||
E.sub_select . E.from $ \subEdit -> do
|
||||
@ -429,6 +432,7 @@ mkSubmissionGroupTable =
|
||||
, course E.^. CourseShorthand
|
||||
)
|
||||
return (crse, sgroup, lastSGEdit sgroup)
|
||||
dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
|
||||
|
||||
lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
|
||||
E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
|
||||
@ -508,6 +512,7 @@ mkCorrectionsTable =
|
||||
, course E.^. CourseShorthand
|
||||
)
|
||||
return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
|
||||
dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId
|
||||
|
||||
dbtProj x = return $ x
|
||||
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
||||
|
||||
@ -208,6 +208,7 @@ getSheetListR tid ssh csh = do
|
||||
{ dbtColonnade = sheetCol
|
||||
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser))
|
||||
-> sheetData dt *> return (sheet, lastSheetEdit sheet, submission)
|
||||
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||||
, dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
|
||||
-> dbr <$ guardM (lift $ sheetFilter sheetName)
|
||||
, dbtSorting = Map.fromList
|
||||
@ -302,6 +303,7 @@ getSShowR tid ssh csh shn = do
|
||||
& defaultSorting [SortAscBy "type", SortAscBy "path"]
|
||||
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
|
||||
{ dbtSQLQuery = fileData
|
||||
, dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId
|
||||
, dbtColonnade = colonnadeFiles
|
||||
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
|
||||
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
|
||||
|
||||
@ -298,6 +298,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
return ((sf1, f1), (sf2, f2))
|
||||
smid2ArchiveTable (smid,cid) = DBTable
|
||||
{ dbtSQLQuery = submissionFiles smid
|
||||
, dbtRowKey = \((_ `E.InnerJoin` f1) `E.FullOuterJoin` (_ `E.InnerJoin` f2)) -> (f1 E.?. FileId, f2 E.?. FileId)
|
||||
, dbtColonnade = colonnadeFiles cid
|
||||
, dbtProj = return . dbrOutput
|
||||
, dbtStyle = def
|
||||
|
||||
@ -178,6 +178,7 @@ postMessageListR = do
|
||||
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
|
||||
(tableRes', tableView) <- runDB $ dbTable psValidator DBTable
|
||||
{ dbtSQLQuery
|
||||
, dbtRowKey = (E.^. SystemMessageId)
|
||||
, dbtColonnade
|
||||
, dbtProj
|
||||
, dbtSorting = Map.fromList
|
||||
|
||||
@ -98,6 +98,7 @@ getTermShowR = do
|
||||
-- ]
|
||||
table <- runDB $ dbTableWidget' def DBTable
|
||||
{ dbtSQLQuery = termData
|
||||
, dbtRowKey = (E.^. TermId)
|
||||
, dbtColonnade = colonnadeTerms
|
||||
, dbtProj = return . dbrOutput
|
||||
, dbtSorting = Map.fromList
|
||||
|
||||
@ -71,6 +71,7 @@ getUsersR = do
|
||||
|
||||
((), userList) <- runDB $ dbTable psValidator DBTable
|
||||
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||
, dbtRowKey = (E.^. UserId)
|
||||
, dbtColonnade
|
||||
, dbtProj = return
|
||||
, dbtSorting = Map.fromList
|
||||
|
||||
@ -37,6 +37,7 @@ import Data.Map (Map, (!))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Control.Monad.Trans.Writer (execWriterT, WriterT)
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import Control.Monad.Writer.Class
|
||||
|
||||
import Data.Scientific (Scientific)
|
||||
@ -471,7 +472,7 @@ jsonField hide = Field{..}
|
||||
inputType
|
||||
| hide = "hidden"
|
||||
| otherwise = "text"
|
||||
fieldParse [v] [] = return . second Just . first (SomeMessage . MsgJSONFieldDecodeFailure) . eitherDecodeStrict' $ encodeUtf8 v
|
||||
fieldParse [v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just . eitherDecodeStrict' $ encodeUtf8 v
|
||||
fieldParse [] [] = return $ Right Nothing
|
||||
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
||||
fieldView theId name attrs val isReq = liftWidgetT [whamlet|
|
||||
@ -479,6 +480,23 @@ jsonField hide = Field{..}
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
secretJsonField :: ( ToJSON a, FromJSON a
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Field m a
|
||||
secretJsonField = Field{..}
|
||||
where
|
||||
fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
|
||||
fieldParse [] [] = return $ Right Nothing
|
||||
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
||||
fieldView theId name attrs val _isReq = do
|
||||
val' <- traverse (encodedSecretBox SecretBoxShort) val
|
||||
[whamlet|
|
||||
<input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
|
||||
funcForm :: forall k v m.
|
||||
( Finite k, Ord k
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Utils.Table.Pagination
|
||||
( module Handler.Utils.Table.Pagination.Types
|
||||
, SortColumn(..), SortDirection(..)
|
||||
@ -67,6 +69,11 @@ import Data.Aeson.TH (deriveJSON)
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Data.Proxy (Proxy(..))
|
||||
|
||||
|
||||
$(sqlInTuples [2..16])
|
||||
|
||||
|
||||
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
|
||||
@ -270,13 +277,14 @@ instance Default DBStyle where
|
||||
, dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default")
|
||||
}
|
||||
|
||||
data DBTable m x = forall a r r' h i t.
|
||||
data DBTable m x = forall a r r' h i t k k'.
|
||||
( ToSortable h, Functor h
|
||||
, E.SqlSelect a r
|
||||
, E.SqlSelect a r, SqlIn k k', ToJSON k', FromJSON k', Eq k'
|
||||
, PathPiece i, Eq i
|
||||
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
|
||||
) => DBTable
|
||||
{ dbtSQLQuery :: t -> E.SqlQuery a
|
||||
, dbtRowKey :: t -> k
|
||||
, dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
|
||||
, dbtColonnade :: Colonnade h r' (DBCell m x)
|
||||
, dbtSorting :: Map SortingKey (SortColumn t)
|
||||
@ -297,10 +305,10 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x), Default (DBParams m x)) =>
|
||||
|
||||
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
||||
-- | Format @DBTable@ when sort-circuiting
|
||||
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget
|
||||
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'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
|
||||
runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
|
||||
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)
|
||||
|
||||
cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
|
||||
cellAttrs = dbCell . _1
|
||||
@ -325,7 +333,7 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
|
||||
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
||||
dbWidget _ _ = return . snd
|
||||
dbHandler _ _ f = return . over _2 f
|
||||
runDBTable _ _ = liftHandlerT
|
||||
runDBTable _ _ _ = liftHandlerT
|
||||
|
||||
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
|
||||
mempty = WidgetCell mempty $ return mempty
|
||||
@ -350,7 +358,7 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
|
||||
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
|
||||
runDBTable _ _ _ = mapReaderT liftHandlerT
|
||||
|
||||
instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
|
||||
mempty = DBCell mempty $ return mempty
|
||||
@ -390,7 +398,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
|
||||
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
|
||||
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
|
||||
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
|
||||
runDBTable dbtable pi = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenField dbtable pi . withFragment
|
||||
runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenFields dbtable pi pKeys . withFragment
|
||||
|
||||
instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
|
||||
def = DBParamsForm
|
||||
@ -413,10 +421,13 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do
|
||||
enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype
|
||||
$(widgetFile "table/form-wrap")
|
||||
|
||||
addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a
|
||||
addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet|
|
||||
addPIHiddenFields :: ToJSON k' => DBTable m x -> PaginationInput -> [k'] -> Form a -> Form a
|
||||
addPIHiddenFields DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi pKeys form fragment = do
|
||||
encrypted <- encodedSecretBox SecretBoxShort pKeys
|
||||
form $ fragment <> [shamlet|
|
||||
$newline never
|
||||
<input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
|
||||
<input type=hidden name=#{wIdent "previous"} value=#{encrypted}>
|
||||
|]
|
||||
where
|
||||
wIdent n
|
||||
@ -453,6 +464,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
}
|
||||
|
||||
piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
|
||||
previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
|
||||
|
||||
piInput <- lift . runInputGetResult $ PaginationInput
|
||||
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
||||
@ -483,7 +495,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
FormFailure errs'
|
||||
-> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
|
||||
_ -> runPSValidator dbtable Nothing
|
||||
paginationInput
|
||||
paginationInput@PaginationInput{..}
|
||||
| FormSuccess pi <- piResult
|
||||
, not $ piIsUnset pi
|
||||
= pi
|
||||
@ -496,24 +508,41 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
rows' <- E.select . E.from $ \t -> do
|
||||
res <- dbtSQLQuery t
|
||||
E.orderBy (map (sqlSortDirection t) psSorting')
|
||||
E.limit psLimit
|
||||
E.offset (psPage * psLimit)
|
||||
case previousKeys of
|
||||
Nothing -> do
|
||||
E.limit psLimit
|
||||
E.offset (psPage * psLimit)
|
||||
Just ps -> E.where_ $ dbtRowKey t `sqlIn` ps
|
||||
Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
|
||||
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), res)
|
||||
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
|
||||
|
||||
let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)
|
||||
let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v)
|
||||
|
||||
rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
|
||||
(currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) $ zip [succ (psPage * psLimit)..] rows'
|
||||
|
||||
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
||||
let
|
||||
tblLink :: (QueryText -> QueryText) -> Text
|
||||
tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ (f . substPi) 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
|
||||
]
|
||||
|
||||
if
|
||||
| Just pKeys <- previousKeys
|
||||
, pKeys /= currentKeys
|
||||
-> redirectWith preconditionFailed412 $ tblLink id
|
||||
| otherwise
|
||||
-> return ()
|
||||
|
||||
let
|
||||
rowCount
|
||||
| (E.Value n, _):_ <- rows' = n
|
||||
| (E.Value n, _, _):_ <- rows' = n
|
||||
| otherwise = 0
|
||||
|
||||
tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ f getParams
|
||||
|
||||
filterAction = tblLink
|
||||
$ setParam (wIdent "page") Nothing
|
||||
. Map.foldrWithKey (\k _ f -> setParam (wIdent $ toPathPiece k) Nothing . f) id dbtFilter
|
||||
@ -547,15 +576,18 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
|
||||
return $(widgetFile "table/layout")
|
||||
|
||||
bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable dbtable paginationInput . fmap swap $ runWriterT table'
|
||||
bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< 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 v qt = maybe id (\v' -> (:) (key, Just v')) v [ i | i@(key', _) <- qt, key' /= key ]
|
||||
setParam key = setParams key . maybeToList
|
||||
|
||||
dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
|
||||
-> DB (DBResult (HandlerT UniWorX IO) x)
|
||||
|
||||
@ -6,6 +6,8 @@ module Handler.Utils.Table.Pagination.Types
|
||||
, sortable
|
||||
, ToSortable(..)
|
||||
, SortableP(..)
|
||||
, SqlIn(..)
|
||||
, sqlInTuples
|
||||
) where
|
||||
|
||||
import Import hiding (singleton)
|
||||
@ -17,6 +19,13 @@ import Data.CaseInsensitive (CI)
|
||||
|
||||
import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
|
||||
|
||||
import Language.Haskell.TH
|
||||
|
||||
import Data.List (foldr1, foldl)
|
||||
|
||||
|
||||
newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
|
||||
deriving (Show, Read)
|
||||
@ -55,3 +64,35 @@ instance ToSortable Headed where
|
||||
|
||||
instance ToSortable Headless where
|
||||
pSortable = Nothing
|
||||
|
||||
|
||||
class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
|
||||
sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
|
||||
|
||||
instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
|
||||
x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
|
||||
|
||||
sqlInTuples :: [Int] -> DecsQ
|
||||
sqlInTuples = mapM sqlInTuple
|
||||
|
||||
sqlInTuple :: Int -> DecQ
|
||||
sqlInTuple arity = do
|
||||
tyVars <- replicateM arity $ newName "t"
|
||||
vVs <- replicateM arity $ newName "v"
|
||||
xVs <- replicateM arity $ newName "x"
|
||||
xsV <- newName "xs"
|
||||
|
||||
let
|
||||
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
|
||||
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
|
||||
|
||||
instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
|
||||
[ funD 'sqlIn
|
||||
[ clause [tupP $ map varP xVs, varP xsV]
|
||||
( guardedB
|
||||
[ normalGE [e|null $(varE xsV)|] [e|E.val False|]
|
||||
, normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|]
|
||||
]
|
||||
) []
|
||||
]
|
||||
]
|
||||
|
||||
@ -77,6 +77,8 @@ import Data.Data (Data)
|
||||
import Model.Types.Wordlist
|
||||
import Data.Text.Metrics (damerauLevenshtein)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
instance PathPiece UUID where
|
||||
fromPathPiece = UUID.fromString . unpack
|
||||
toPathPiece = pack . UUID.toString
|
||||
@ -100,6 +102,12 @@ instance ToHttpApiData (CI Text) where
|
||||
instance FromHttpApiData (CI Text) where
|
||||
parseUrlPiece = fmap CI.mk . parseUrlPiece
|
||||
|
||||
instance ToJSON a => ToJSON (E.Value a) where
|
||||
toJSON = toJSON . E.unValue
|
||||
|
||||
instance FromJSON a => FromJSON (E.Value a) where
|
||||
parseJSON = fmap E.Value . parseJSON
|
||||
|
||||
|
||||
|
||||
type Points = Centi
|
||||
|
||||
@ -371,6 +371,9 @@ instance Ord a => Ord (NTop (Maybe a)) where
|
||||
compare _ (NTop Nothing) = LT
|
||||
compare (NTop (Just x)) (NTop (Just y)) = compare x y
|
||||
|
||||
exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
|
||||
exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT
|
||||
|
||||
|
||||
------------
|
||||
-- Either --
|
||||
|
||||
Loading…
Reference in New Issue
Block a user