diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ # Changelog for persistent-pagination -## Unreleased changes +## 0.1.1.0 + +- Add `Database.Esqueleto.Pagination` module for streaming from an `Esqueleto` query. +- Add `Database.Persist.Pagination.Types` module to share common types. + +## 0.1.0.0 + +- Initial Release diff --git a/persistent-pagination.cabal b/persistent-pagination.cabal --- a/persistent-pagination.cabal +++ b/persistent-pagination.cabal @@ -1,8 +1,8 @@ cabal-version: 1.12 name: persistent-pagination -version: 0.1.0.0 -synopsis: Efficient and correct pagination for persistent queries. +version: 0.1.1.0 +synopsis: Efficient and correct pagination for persistent or esqueleto queries. description: Please see the README on GitHub at homepage: https://github.com/parsonsmatt/persistent-pagination#readme bug-reports: https://github.com/parsonsmatt/persistent-pagination/issues @@ -24,17 +24,20 @@ library exposed-modules: Database.Persist.Pagination + Database.Esqueleto.Pagination + Database.Persist.Pagination.Types other-modules: Paths_persistent_pagination hs-source-dirs: src build-depends: base >= 4.11 && < 5 - , persistent >= 2 && < 3.0 , conduit >= 1.2.8 && < 1.4 - , mtl < 3 + , esqueleto , foldl < 1.5.0 , microlens < 0.5 + , mtl < 3 + , persistent >= 2 && < 3.0 default-language: Haskell2010 ghc-options: -Wall @@ -45,20 +48,22 @@ other-modules: Paths_persistent_pagination Database.Persist.PaginationSpec + Database.Esqueleto.PaginationSpec hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 - , persistent-pagination + , conduit + , containers + , esqueleto + , hspec + , hspec-discover + , mtl , persistent + , persistent-pagination , persistent-sqlite , persistent-template - , hspec - , time - , hspec-discover , QuickCheck - , conduit - , containers - , mtl + , time default-language: Haskell2010 diff --git a/src/Database/Esqueleto/Pagination.hs b/src/Database/Esqueleto/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Database/Esqueleto/Pagination.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides efficient pagination over your database queries. +-- No @OFFSET@ here - we use ranges to do this right! +-- +-- The ideal "range" column for a datatype has a few properties: +-- +-- 1. It should have an index. An index on the column will dramatically +-- improve performance on pagination. +-- 2. It should be monotonic - that is, we shouldn't be able to insert new +-- data into the middle of a range. An example would be a @created_at@ +-- timestamp field, or a auto-incrementing primary key. +-- +-- This module offers two ways to page through a database. You can use the +-- 'streamingEntities' to get a 'ConduitT' of @'Entity' record@ values +-- streaming out. Or, if you'd like finer control, you can use 'getPage' +-- to get the first page of data, and then 'nextPage' to get the next +-- possible page of data. +module Database.Esqueleto.Pagination + ( module Database.Esqueleto.Pagination + , module Types + ) where + +import Conduit +import Control.Applicative +import qualified Control.Foldl as Foldl +import Control.Monad.Reader (ReaderT) +import Data.Foldable (for_, toList) +import Data.Maybe +import Data.Semigroup +import Database.Persist.Class +import Database.Persist.Sql +import Lens.Micro + +import Database.Esqueleto (SqlExpr, SqlQuery, Value, + asc, desc, from, limit, + orderBy, select, val, + where_) +import qualified Database.Esqueleto as E + +import Database.Persist.Pagination.Types as Types + +-- | Stream entities out of the database, only pulling a limited amount +-- into memory at a time. +-- +-- You should use this instead of 'selectSource' because 'selectSource' +-- doesn't really work. It doesn't work at all in MySQL, and it's somewhat +-- sketchy with PostgreSQL and SQLite. This function is guaranteed to use +-- only as much memory as a single page, and if you tune the page size +-- right, you'll get efficient queries from the database. +-- +-- There's an open issue for 'selectSource' not working: +-- . +-- +-- @since 0.1.1.0 +streamEntities + :: forall record backend typ m a. + ( PersistRecordBackend record backend + , PersistQueryRead backend + , PersistUniqueRead backend + , BackendCompatible SqlBackend backend + , BackendCompatible SqlBackend (BaseBackend backend) + , Ord typ + , PersistField typ + , MonadIO m + ) + => (SqlExpr (Entity record) -> SqlExpr (Value Bool)) + -- ^ The filters to apply. + -> EntityField record typ + -- ^ The field to sort on. This field should have an index on it, and + -- ideally, the field should be monotonic - that is, you can only + -- insert values at either extreme end of the range. A @created_at@ + -- timestamp or autoincremented ID work great for this. Non-monotonic + -- keys can work too, but you may miss records that are inserted during + -- a traversal. + -> PageSize + -- ^ How many records in a page + -> SortOrder + -- ^ Ascending or descending + -> DesiredRange typ + -- ^ The desired range. Provide @'Range' Nothing Nothing@ if you want + -- everything in the database. + -> ConduitT a (Entity record) (ReaderT backend m) () +streamEntities filters field pageSize sortOrder range = do + mpage <- lift (getPage filters field pageSize sortOrder range) + for_ mpage loop + where + loop page = do + yieldMany (pageRecords page) + mpage <- lift (nextPage page) + for_ mpage loop + +-- | Convert a @'DesiredRange' typ@ into a 'SqlQuery' that operates on the +-- range. The 'DesiredRange' is treated as an exclusive range. +-- +-- @since 0.1.1.0 +rangeToFilters + :: (PersistField typ, PersistEntity record) + => Range (Maybe typ) + -> EntityField record typ + -> SqlExpr (Entity record) + -> SqlQuery () +rangeToFilters range field sqlRec = do + for_ (rangeMin range) $ \m -> + where_ $ sqlRec E.^. field E.>. val m + for_ (rangeMax range) $ \m -> + where_ $ sqlRec E.^. field E.<. val m + +-- | Get the first 'Page' according to the given criteria. This returns +-- a @'Maybe' 'Page'@, because there may not actually be any records that +-- correspond to the query you issue. You can call 'pageRecords' on the +-- result object to get the row of records for this page, and you can call +-- 'nextPage' with the 'Page' object to get the next page, if one exists. +-- +-- This function gives you lower level control over pagination than the +-- 'streamEntities' function. +-- +-- @since 0.1.1.0 +getPage + :: forall record backend typ m. + ( PersistRecordBackend record backend + , PersistQueryRead backend + , PersistUniqueRead backend + , BackendCompatible SqlBackend backend + , BackendCompatible SqlBackend (BaseBackend backend) + , Ord typ + , PersistField typ + , MonadIO m + ) + => (SqlExpr (Entity record) -> SqlExpr (Value Bool)) + -- ^ The filters to apply. + -> EntityField record typ + -- ^ The field to sort on. This field should have an index on it, and + -- ideally, the field should be monotonic - that is, you can only + -- insert values at either extreme end of the range. A @created_at@ + -- timestamp or autogenerated ID work great for this. Non-monotonic + -- keys can work too, but you may miss records that are inserted during + -- a traversal. + -> PageSize + -- ^ How many records in a page + -> SortOrder + -- ^ Ascending or descending + -> DesiredRange typ + -- ^ The desired range. Provide @'Range' Nothing Nothing@ if you want + -- everything in the database. + -> ReaderT backend m (Maybe (Page record typ)) +getPage filts field pageSize sortOrder desiredRange = do + erecs <- + select $ + from $ \e -> do + where_ $ filts e + rangeToFilters desiredRange field e + limit (fromIntegral (unPageSize pageSize)) + orderBy . pure $ case sortOrder of + Ascend -> asc $ e E.^.field + Descend -> desc $ e E.^. field + pure e + case erecs of + [] -> + pure Nothing + rec:recs -> + pure (Just (mkPage rec recs)) + where + mkPage rec recs = flip Foldl.fold (rec:recs) $ do + let recs' = rec : recs + rangeDefault = initRange rec + maxRange <- Foldl.premap (Just . Max . (^. fieldLens field)) Foldl.mconcat + minRange <- Foldl.premap (Just . Min . (^. fieldLens field)) Foldl.mconcat + len <- Foldl.length + pure Page + { pageRecords = recs' + , pageRange = fromMaybe rangeDefault $ + Range <$> fmap getMin minRange <*> fmap getMax maxRange + , pageDesiredRange = desiredRange + , pageField = field + , pageFilters = filts + , pageSize = pageSize + , pageRecordCount = len + , pageSortOrder = sortOrder + } + initRange :: Entity record -> Range typ + initRange rec = + Range + { rangeMin = rec ^. fieldLens field + , rangeMax = rec ^. fieldLens field + } + +-- | Retrieve the next 'Page' of data, if possible. +-- +-- @since 0.1.1.0 +nextPage + :: + ( PersistRecordBackend record backend + , PersistQueryRead backend + , PersistUniqueRead backend + , BackendCompatible SqlBackend backend + , BackendCompatible SqlBackend (BaseBackend backend) + , Ord typ + , PersistField typ + , MonadIO m + ) + => Page record typ -> ReaderT backend m (Maybe (Page record typ)) +nextPage Page{..} + | pageRecordCount < unPageSize pageSize = + pure Nothing + | otherwise = + getPage + pageFilters + pageField + pageSize + pageSortOrder + (bumpPageRange pageSortOrder pageDesiredRange pageRange) + +-- | A @'Page' record typ@ describes a list of records and enough +-- information necessary to acquire the next page of records, if possible. +-- +-- This is a distinct type from the 'Page' in "Database.Persist.Pagination" +-- because the 'pageFilters' field needs a different type. As a result, +-- some of this stuff is duplicated. It's possible that this can be fixed +-- and more code could be shared. +-- +-- @since 0.1.1.0 +data Page record typ + = Page + { pageRecords :: [Entity record] + -- ^ The collection of records. + -- + -- @since 0.1.1.0 + , pageRecordCount :: Int + -- ^ The count of records in the collection. If this number is less + -- than the 'pageSize' field, then a call to 'nextPage' will result in + -- 'Nothing'. + -- + -- @since 0.1.1.0 + , pageRange :: Range typ + -- ^ The minimum and maximum value of @typ@ in the list. + -- + -- @since 0.1.1.0 + , pageDesiredRange :: DesiredRange typ + -- ^ The desired range in the next page of values. When the + -- 'pageSortOrder' is 'Ascending', then the 'rangeMin' value will + -- increase with each page until the set of data is complete. Likewise, + -- when the 'pageSortOrder' is 'Descending', then the 'rangeMax' will + -- decrease until the final page is reached. + -- + -- @since 0.1.1.0 + , pageField :: EntityField record typ + -- ^ The field to sort on. This field should have an index on it, and + -- ideally, the field should be monotonic - that is, you can only + -- insert values at either extreme end of the range. A @created_at@ + -- timestamp or autogenerated ID work great for this. Non-monotonic + -- keys can work too, but you may miss records that are inserted during + -- a traversal. + -- + -- @since 0.1.1.0 + , pageFilters :: SqlExpr (Entity record) -> SqlExpr (Value Bool) + -- ^ The extra filters that are placed on the query. + -- + -- @since 0.1.1.0 + , pageSize :: PageSize + -- ^ The desired size of the 'Page' for successive results. + , pageSortOrder :: SortOrder + -- ^ Whether to sort on the 'pageField' in 'Ascending' or 'Descending' + -- order. The choice you make here determines how the + -- 'pageDesiredRange' changes with each page. + -- + -- @since 0.1.1.0 + } + +-- | An empty query value to pass to the functions when you don't have any +-- filters to run. +-- +-- @since 0.1.1.0 +emptyQuery :: SqlExpr (Entity record) -> SqlExpr (Value Bool) +emptyQuery _ = val True diff --git a/src/Database/Persist/Pagination.hs b/src/Database/Persist/Pagination.hs --- a/src/Database/Persist/Pagination.hs +++ b/src/Database/Persist/Pagination.hs @@ -24,19 +24,23 @@ -- streaming out. Or, if you'd like finer control, you can use 'getPage' -- to get the first page of data, and then 'nextPage' to get the next -- possible page of data. -module Database.Persist.Pagination where +module Database.Persist.Pagination + ( module Database.Persist.Pagination + , module Types + ) where import Conduit -import Control.Applicative -import qualified Control.Foldl as Foldl -import Control.Monad.Reader (ReaderT) -import Data.Foldable (toList, forM_) +import qualified Control.Foldl as Foldl +import Control.Monad.Reader (ReaderT) +import Data.Foldable (for_, toList) import Data.Maybe import Data.Semigroup import Database.Persist.Class import Database.Persist.Sql import Lens.Micro +import Database.Persist.Pagination.Types as Types + -- | Stream entities out of the database, only pulling a limited amount -- into memory at a time. -- @@ -77,95 +81,12 @@ -> ConduitT a (Entity record) (ReaderT backend m) () streamEntities filters field pageSize sortOrder range = do mpage <- lift (getPage filters field pageSize sortOrder range) - forM_ mpage loop + for_ mpage loop where loop page = do yieldMany (pageRecords page) mpage <- lift (nextPage page) - forM_ mpage loop - --- | The amount of records in a 'Page' of results. --- --- @since 0.1.0.0 -newtype PageSize = PageSize { unPageSize :: Int } - deriving (Eq, Show) - --- | Whether to sort by @ASC@ or @DESC@ when you're paging over results. --- --- @since 0.1.0.0 -data SortOrder = Ascend | Descend - deriving (Eq, Show) - --- | A datatype describing the min and max value of the relevant field that --- you are ranging over in a non-empty sequence of records. --- --- @since 0.1.0.0 -data Range t = Range { rangeMin :: t, rangeMax :: t } - deriving (Eq, Show, Functor, Foldable, Traversable) - -instance Ord t => Semigroup (Range t) where - Range l h <> Range l' h' = Range (min l l') (max h h') - -instance (Bounded t, Ord t) => Monoid (Range t) where - mempty = Range minBound maxBound - mappend = (<>) - --- | Users aren't required to put a value in for the range - a value of --- 'Nothing' is equivalent to saying "unbounded from below." --- --- @since 0.1.0.0 -type DesiredRange t = Range (Maybe t) - --- | A @'Page' record typ@ describes a list of records and enough --- information necessary to acquire the next page of records, if possible. --- --- @since 0.1.0.0 -data Page record typ - = Page - { pageRecords :: [Entity record] - -- ^ The collection of records. - -- - -- @since 0.1.0.0 - , pageRecordCount :: Int - -- ^ The count of records in the collection. If this number is less - -- than the 'pageSize' field, then a call to 'nextPage' will result in - -- 'Nothing'. - -- - -- @since 0.1.0.0 - , pageRange :: Range typ - -- ^ The minimum and maximum value of @typ@ in the list. - -- - -- @since 0.1.0.0 - , pageDesiredRange :: DesiredRange typ - -- ^ The desired range in the next page of values. When the - -- 'pageSortOrder' is 'Ascending', then the 'rangeMin' value will - -- increase with each page until the set of data is complete. Likewise, - -- when the 'pageSortOrder' is 'Descending', then the 'rangeMax' will - -- decrease until the final page is reached. - -- - -- @since 0.1.0.0 - , pageField :: EntityField record typ - -- ^ The field to sort on. This field should have an index on it, and - -- ideally, the field should be monotonic - that is, you can only - -- insert values at either extreme end of the range. A @created_at@ - -- timestamp or autogenerated ID work great for this. Non-monotonic - -- keys can work too, but you may miss records that are inserted during - -- a traversal. - -- - -- @since 0.1.0.0 - , pageFilters :: [Filter record] - -- ^ The extra filters that are placed on the query. - -- - -- @since 0.1.0.0 - , pageSize :: PageSize - -- ^ The desired size of the 'Page' for successive results. - , pageSortOrder :: SortOrder - -- ^ Whether to sort on the 'pageField' in 'Ascending' or 'Descending' - -- order. The choice you make here determines how the - -- 'pageDesiredRange' changes with each page. - -- - -- @since 0.1.0.0 - } + for_ mpage loop -- | Convert a @'DesiredRange' typ@ into a list of 'Filter's for the query. -- The 'DesiredRange' is treated as an exclusive range. @@ -277,19 +198,54 @@ pageSortOrder (bumpPageRange pageSortOrder pageDesiredRange pageRange) --- | Modify the 'DesiredRange' according to the 'Range' that was provided --- by the query and the 'SortOrder'. +-- | A @'Page' record typ@ describes a list of records and enough +-- information necessary to acquire the next page of records, if possible. -- -- @since 0.1.0.0 -bumpPageRange - :: Ord typ - => SortOrder - -> DesiredRange typ - -> Range typ - -> DesiredRange typ -bumpPageRange sortOrder (Range mmin mmax) (Range min' max') = - case sortOrder of - Ascend -> - Range (mmin `max` Just max') mmax - Descend -> - Range mmin (Just min' <|> (Just min' `min` mmax)) +data Page record typ + = Page + { pageRecords :: [Entity record] + -- ^ The collection of records. + -- + -- @since 0.1.0.0 + , pageRecordCount :: Int + -- ^ The count of records in the collection. If this number is less + -- than the 'pageSize' field, then a call to 'nextPage' will result in + -- 'Nothing'. + -- + -- @since 0.1.0.0 + , pageRange :: Range typ + -- ^ The minimum and maximum value of @typ@ in the list. + -- + -- @since 0.1.0.0 + , pageDesiredRange :: DesiredRange typ + -- ^ The desired range in the next page of values. When the + -- 'pageSortOrder' is 'Ascending', then the 'rangeMin' value will + -- increase with each page until the set of data is complete. Likewise, + -- when the 'pageSortOrder' is 'Descending', then the 'rangeMax' will + -- decrease until the final page is reached. + -- + -- @since 0.1.0.0 + , pageField :: EntityField record typ + -- ^ The field to sort on. This field should have an index on it, and + -- ideally, the field should be monotonic - that is, you can only + -- insert values at either extreme end of the range. A @created_at@ + -- timestamp or autogenerated ID work great for this. Non-monotonic + -- keys can work too, but you may miss records that are inserted during + -- a traversal. + -- + -- @since 0.1.0.0 + , pageFilters :: [Filter record] + -- ^ The extra filters that are placed on the query. + -- + -- @since 0.1.0.0 + , pageSize :: PageSize + -- ^ The desired size of the 'Page' for successive results. + , pageSortOrder :: SortOrder + -- ^ Whether to sort on the 'pageField' in 'Ascending' or 'Descending' + -- order. The choice you make here determines how the + -- 'pageDesiredRange' changes with each page. + -- + -- @since 0.1.0.0 + } + diff --git a/src/Database/Persist/Pagination/Types.hs b/src/Database/Persist/Pagination/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Pagination/Types.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} + +module Database.Persist.Pagination.Types where + +import Control.Applicative (Alternative(..)) +import Database.Persist.Sql (Entity) + +-- | The amount of records in a 'Page' of results. +-- +-- @since 0.1.0.0 +newtype PageSize = PageSize { unPageSize :: Int } + deriving (Eq, Show) + +-- | Whether to sort by @ASC@ or @DESC@ when you're paging over results. +-- +-- @since 0.1.0.0 +data SortOrder = Ascend | Descend + deriving (Eq, Show) + +-- | A datatype describing the min and max value of the relevant field that +-- you are ranging over in a non-empty sequence of records. +-- +-- @since 0.1.0.0 +data Range t = Range { rangeMin :: t, rangeMax :: t } + deriving (Eq, Show, Functor, Foldable, Traversable) + +instance Ord t => Semigroup (Range t) where + Range l h <> Range l' h' = Range (min l l') (max h h') + +instance (Bounded t, Ord t) => Monoid (Range t) where + mempty = Range minBound maxBound + mappend = (<>) + +-- | Users aren't required to put a value in for the range - a value of +-- 'Nothing' is equivalent to saying "unbounded from below." +-- +-- @since 0.1.0.0 +type DesiredRange t = Range (Maybe t) + +-- | Modify the 'DesiredRange' according to the 'Range' that was provided +-- by the query and the 'SortOrder'. +-- +-- @since 0.1.0.0 +bumpPageRange + :: Ord typ + => SortOrder + -> DesiredRange typ + -> Range typ + -> DesiredRange typ +bumpPageRange sortOrder (Range mmin mmax) (Range min' max') = + case sortOrder of + Ascend -> + Range (mmin `max` Just max') mmax + Descend -> + Range mmin (Just min' <|> (Just min' `min` mmax)) diff --git a/test/Database/Esqueleto/PaginationSpec.hs b/test/Database/Esqueleto/PaginationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Esqueleto/PaginationSpec.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Database.Esqueleto.PaginationSpec where + +import Conduit +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import Data.Time +import Database.Persist.Sqlite hiding ((==.)) +import Database.Persist.TH +import Test.Hspec +import Test.QuickCheck + +import Database.Esqueleto.Pagination +import Database.Esqueleto (val, (==.), (^.)) + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| + +User + name String + age Int + createdAt UTCTime + + deriving Eq Ord Show +|] + +spec :: Spec +spec = do + it "streamEntities descend" $ do + xs <- runDb $ do + runConduit + $ streamEntities + emptyQuery + UserCreatedAt + (PageSize 10) + Descend + (Range Nothing Nothing) + .| sinkList + let sortedKeys = List.sort (map entityKey xs) + + map length (List.group sortedKeys) + `shouldBe` + map length (map (:[]) sortedKeys) + + it "streamEntities ascend" $ do + xs <- runDb $ do + runConduit + $ streamEntities + emptyQuery + UserCreatedAt + (PageSize 10) + Ascend + (Range Nothing Nothing) + .| sinkList + length xs `shouldBe` entityCount + Set.toList (Set.fromList (map entityKey xs)) + `shouldBe` + List.sort (map entityKey xs) + + it "getPage" $ do + let pgSize = 10 + Just page <- runDb $ do + getPage emptyQuery UserCreatedAt (PageSize pgSize) Ascend (Range Nothing Nothing :: DesiredRange UTCTime) + let records1 = pageRecords page + length records1 + `shouldBe` + pgSize + pageRecordCount page + `shouldBe` + pgSize + let mmin = rangeMin (pageRange page) + + mpage2 <- runDb $ do + nextPage page + + void mpage2 `shouldSatisfy` isJust + + let Just page2 = mpage2 + records2 = pageRecords page2 + + length records2 + `shouldBe` + pageRecordCount page2 + + + (Set.fromList records1 `Set.intersection` Set.fromList records2) + `shouldBe` Set.empty + + (Set.fromList (map entityKey records1) `Set.intersection` Set.fromList (map entityKey records2)) + `shouldBe` Set.empty + + it "works for all pages" $ do + pages <- runDb $ do + Just page <- + getPage emptyQuery UserCreatedAt (PageSize 10) Ascend (Range Nothing Nothing :: DesiredRange UTCTime) + whileJust page nextPage + let sortedKeys = + List.sort (concatMap (map entityKey . pageRecords) pages) + + List.group sortedKeys `shouldBe` map pure sortedKeys + + it "works for id" $ do + (records0, records1) <- + runDb $ + (,) <$> do + runConduit + $ streamEntities + emptyQuery + UserId + (PageSize 10) + Ascend + (Range Nothing Nothing) + .| sinkList + <*> do + selectList [] [] + length (Set.fromList records0) + `shouldBe` + entityCount + let mkMap = Map.fromList . map (\e -> (entityKey e, entityVal e)) + r0map = mkMap records0 + r1map = mkMap records1 + + Map.keys r0map + `shouldBe` + Map.keys r1map + + void $ flip Map.traverseWithKey r0map $ \k a -> + Map.lookup k r1map + `shouldBe` + Just a + + void $ flip Map.traverseWithKey r1map $ \k a -> + Map.lookup k r0map + `shouldBe` + Just a + + it "works with a filter" $ do + let searchAge = 1234 + usersWithSearchAge <- + traverse + (\k -> fmap k getCurrentTime) + [User "foo" searchAge, User "bar" searchAge, User "baz" searchAge] + irrelevantUsers <- + traverse + (\k -> fmap k getCurrentTime) + [User "foo" 0, User "bar" 0, User "baz" 0, User "quux" 0] + (returnedEntities, properUserIds) <- + runDb $ do + userIdsWithSearchAge <- insertMany usersWithSearchAge + _ <- insertMany irrelevantUsers + records <- runConduit + $ streamEntities + (\e -> e ^. UserAge ==. val searchAge) + UserCreatedAt + (PageSize 1) + Descend + (Range Nothing Nothing) + .| sinkList + pure (records, userIdsWithSearchAge) + + length returnedEntities + `shouldBe` + length usersWithSearchAge + + forM_ returnedEntities $ \entity -> + entity + `shouldSatisfy` + ((searchAge ==) . userAge . entityVal) + + Set.fromList (map entityVal returnedEntities) + `shouldBe` + Set.fromList usersWithSearchAge + + Set.fromList (map entityKey returnedEntities) + `shouldBe` + Set.fromList properUserIds + +whileJust :: Monad m => a -> (a -> m (Maybe a)) -> m [a] +whileJust a k = (a :) <$> do + ma <- k a + case ma of + Nothing -> pure [] + Just a' -> whileJust a' k + + +runDb :: SqlPersistM a -> IO a +runDb action = do + runSqlite ":memory:" $ do + runMigration migrateAll + seedDatabase + action + +entityCount :: Int +entityCount = 63 + +seedDatabase :: SqlPersistM () +seedDatabase = do + let now = UTCTime (fromGregorian 1990 1 1) 0 + forM_ [1..entityCount] $ \n -> do + str <- liftIO $ generate $ do + i <- choose (5, 20) + vectorOf i arbitrary + insert $ User str n ((50 * fromIntegral n) `addUTCTime` now) + +typeChecksWithSqlReadT + :: MonadIO m + => ConduitT Void (Entity User) (ReaderT SqlReadBackend m) () +typeChecksWithSqlReadT = + streamEntities + emptyQuery + UserCreatedAt + (PageSize 10) + Descend + (Range Nothing Nothing) + +typeChecksWithSqlWriteT + :: MonadIO m + => ConduitT Void (Entity User) (ReaderT SqlWriteBackend m) () +typeChecksWithSqlWriteT = + streamEntities + emptyQuery + UserCreatedAt + (PageSize 10) + Descend + (Range Nothing Nothing)