From c6918affd5d518b51e03902afed6554af2001e59 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 13 Dec 2018 23:05:52 +0100 Subject: [PATCH] Make dbtable-forms more robust against pagination & dataset changes --- messages/uniworx/de.msg | 1 + src/Handler/Corrections.hs | 1 + src/Handler/Course.hs | 1 + src/Handler/Home.hs | 2 + src/Handler/Profile.hs | 5 ++ src/Handler/Sheet.hs | 2 + src/Handler/Submission.hs | 1 + src/Handler/SystemMessage.hs | 1 + src/Handler/Term.hs | 1 + src/Handler/Users.hs | 1 + src/Handler/Utils/Form.hs | 20 +++++- src/Handler/Utils/Table/Pagination.hs | 74 +++++++++++++++------ src/Handler/Utils/Table/Pagination/Types.hs | 41 ++++++++++++ src/Model/Types.hs | 8 +++ src/Utils.hs | 3 + 15 files changed, 140 insertions(+), 22 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2ee21fdf2..2e6525f8a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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): diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index e89ff4b8c..946ad1ae9 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index cd62c1333..116a54487 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index abde50485..8a259bb02 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -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) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index cb487fcc8..4f421ec3c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -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)) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index ccacabe32..090fefcd5 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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) diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 447e0c593..d3641e34c 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -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 diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 96fe43cf7..07c0e919c 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 358d31ef8..0c778343b 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -98,6 +98,7 @@ getTermShowR = do -- ] table <- runDB $ dbTableWidget' def DBTable { dbtSQLQuery = termData + , dbtRowKey = (E.^. TermId) , dbtColonnade = colonnadeTerms , dbtProj = return . dbrOutput , dbtSorting = Map.fromList diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index e2f0fbbdd..5104abf15 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 86455f0c5..bbb8d157c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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| + + |] + fieldEnctype = UrlEncoded + funcForm :: forall k v m. ( Finite k, Ord k diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c3e4e8ca4..b3c2f8cb7 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 + |] 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) diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index 58884b3da..f83c27e4d 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -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)|] + ] + ) [] + ] + ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 222b84a22..c0c60a023 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index fed726e6f..4bc4c1c9f 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 --