packages feed

sq 0.0.1 → 0.0.2

raw patch · 8 files changed

+377/−75 lines, 8 files

Files

CHANGELOG.md view
@@ -1,3 +1,12 @@+# Version 0.0.2++* Added `FromJSON`, `ToJSON` instances for `Name`.++* Improved type-parameter order in `zero`, `one`, `foldM` and similar.++* Added manual transactional migrations suport.++ # Version 0.0.1  * Initial version.
lib/Sq.hs view
@@ -3,9 +3,6 @@  -- | High-level SQLite client library ----- ⚠️  __This is an early preview release of this library. Use at your own risk.__------ -- @ -- import qualified "Sq" -- @@@ -34,6 +31,8 @@ -- * Type-safe __resource management__ (via 'A.Acquire', see 'new', 'with', -- 'uith'). --+-- * Manual __transactional migrations__ ('migrate').+-- -- * 'Savepoint's. -- -- * A lot of logging.@@ -42,14 +41,13 @@ -- -- * Type-safe 'SQL'. ----- * Manual and automatic migrations solution. -- -- * Probably other things. -- -- If you have questions or suggestions, just say so at -- <https://github.com/k0001/hs-sq/issues>. ----- ⚠️  __This is an early preview release of this library. Use at your own risk.__+-- Note: This library is young and needs more testing. module Sq    ( -- * Statement     Statement@@ -148,6 +146,14 @@    , savepointRollback    , savepointRelease +    -- * Migrations+    -- $migrations+   , migrate+   , migration+   , Migration+   , MigrationId+   , MigrationsTable+     -- * Miscellaneuos    , Retry (..)    , BindingName@@ -170,15 +176,12 @@ where  import Control.Exception.Safe qualified as Ex-import Control.Foldl qualified as F import Control.Monad hiding (foldM) import Control.Monad.IO.Class import Control.Monad.Trans.Resource qualified as R import Control.Monad.Trans.Resource.Extra qualified as R import Data.Acquire qualified as A import Data.Function-import Data.Int-import Data.List.NonEmpty (NonEmpty) import Database.SQLite3 qualified as S import Di.Df1 qualified as Di import System.FilePath@@ -188,6 +191,7 @@ import Sq.Decoders import Sq.Encoders import Sq.Input+import Sq.Migrations import Sq.Mode import Sq.Names import Sq.Null@@ -290,63 +294,6 @@  -------------------------------------------------------------------------------- --- | Executes a 'Statement' expected to return __zero or one__ rows.------ * Throws 'ErrRows_TooMany' if more than one row.-maybe :: (SubMode t s) => Statement s i o -> i -> Transactional g r t (Maybe o)-maybe = foldM $ foldMaybeM ErrRows_TooMany-{-# INLINE maybe #-}---- | Executes a 'Statement' expected to return exactly __one__ row.------ * Throws 'ErrRows_TooFew' if zero rows, 'ErrRows_TooMany' if more than one row.-one :: (SubMode t s) => Statement s i o -> i -> Transactional g r t o-one = foldM $ foldOneM ErrRows_TooFew ErrRows_TooMany-{-# INLINE one #-}---- | Executes a 'Statement' expected to return exactly __zero__ rows.------ * Throws 'ErrRows_TooMany' if more than zero rows.-zero :: (SubMode t s) => Statement s i o -> i -> Transactional g r t ()-zero = foldM $ foldZeroM ErrRows_TooMany-{-# INLINE zero #-}---- | Executes a 'Statement' expected to return __one or more__ rows.------ * Returns the length of the 'NonEmpty' list, too.------ * Throws 'ErrRows_TooFew' if zero rows.-some-   :: (SubMode t s)-   => Statement s i o-   -> i-   -> Transactional g r t (Int64, NonEmpty o)-some = foldM $ foldNonEmptyM ErrRows_TooFew-{-# INLINE some #-}---- | Executes a 'Statement' expected to return __zero or more__ rows.------ * Returns the length of the list, too.-list-   :: (SubMode t s)-   => Statement s i o-   -> i-   -> Transactional g r t (Int64, [o])-list = fold foldList-{-# INLINE list #-}---- | __Purely fold__ all the output rows.-fold-   :: (SubMode t s)-   => F.Fold o z-   -> Statement s i o-   -> i-   -> Transactional g r t z-fold = foldM . F.generalize-{-# INLINE fold #-}----------------------------------------------------------------------------------- -- | Execute a 'Read'-only 'Transactional' in a fresh 'Transaction' that will -- be automatically released when done. read@@ -378,3 +325,41 @@    -> m a rollback p = transactionalRetry $ rollbackTransaction p {-# INLINE rollback #-}++--------------------------------------------------------------------------------++-- $migrations+--+-- 1. List all the 'Migration's in chronological order.+--    Each 'Migration' is a 'Transactional' action on the database, identified+--    by a unique 'MigrationId'. Construct with 'migration'.+--+--     @+--     __migrations__ :: ["Sq".'Migration']+--     __migrations__ =+--        [ "Sq".'migration' /\"create users table\"/ createUsersTable+--        , "Sq".'migration' /\"add email column to users\"/ addUserEmailColumn+--        , "Sq".'migration' /\"create articles table\"/ createArticlesTable+--        , / ... more migrations ... /+--        ]+--     @+--+-- 2. Run any 'Migration's that haven't been run yet, if necessary, by performing+--    'migrate' once as soon as you obtain your 'Write' connection 'Pool'.+--    'migrate' will enforce that the 'MigrationId's, be unique, and will+--    make sure that any migration history in the 'MigrationsTable' is+--    compatible with the specified 'Migration's.+--+--     @+--     "Sq".'migrate' pool /\"migrations\"/ __migrations__ \\case+--        []   -> /... No migrations will run. .../+--        mIds -> /... Some migrations will run. Maybe backup things here? .../+--     @+--+-- 3. __Don't change your 'MigrationId's over time__. If you do, then the+--    history in 'MigrationsTable' will become unrecognizable by 'migrate'.+--    Also, avoid having the 'Transactional' code in each 'Migration' use your+--    domain types and functions, as doing so may force you to alter past+--    'Transactional' if your domain types and functions change. Ideally,+--    you should write each 'Migration' in such a way that you never /have/+--    to modify them in the future.
lib/Sq/Connection.hs view
@@ -561,7 +561,8 @@ -- Note: This could be defined in terms of 'streamIO', but this implementation -- is faster because we avoid per-row resource management. foldIO-   :: (MonadIO m, Ex.MonadMask m, SubMode t s)+   :: forall o z i t s m+    . (MonadIO m, Ex.MonadMask m, SubMode t s)    => F.FoldM m o z    -> A.Acquire (Transaction t)    -- ^ How to acquire the 'Transaction' once the @m@ is executed,@@ -596,7 +597,8 @@ -- @m@ by means of 'R.runResourceT' or similar as soon as possible in order to -- release the 'Transaction' lock. streamIO-   :: (R.MonadResource m, SubMode t s)+   :: forall o i t s m+    . (R.MonadResource m, SubMode t s)    => A.Acquire (Transaction t)    -- ^ How to acquire the 'Transaction' once the 'Z.Stream' starts    -- being consumed, and how to release it when it's not needed anymore.
+ lib/Sq/Migrations.hs view
@@ -0,0 +1,175 @@+module Sq.Migrations {--}+   ( migrate+   , migration+   , Migration+   , MigrationId+   , MigrationsTable+   ) -- }+where++import Control.Exception.Safe qualified as Ex+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource.Extra qualified as R+import Data.Aeson qualified as Ae+import Data.List qualified as List+import Data.Set (Set)+import Data.Set qualified as Set+import Data.String+import Data.Text qualified as T+import Data.Time qualified as Time+import GHC.Records++import Sq.Connection+import Sq.Decoders+import Sq.Encoders+import Sq.Mode+import Sq.Names+import Sq.Pool+import Sq.Statement+import Sq.Transactional++-- | Name of the database table keeping a registry of executed 'Migration's, by+-- their 'MigrationId'.+--+-- * Same syntax rules as 'Name'.+--+-- * This table will be created and updated by 'migrate' as necessary.+newtype MigrationsTable = MigrationsTable Name+   deriving newtype (Eq, Ord, Show, IsString, Ae.FromJSON, Ae.ToJSON)++instance HasField "text" MigrationsTable T.Text where+   getField (MigrationsTable x) = x.text++-- | A single 'Migration' consisting of a 'Transactional' action uniquely+-- identified by a 'MigrationId'.+--+-- * Construct with 'migration'.+--+-- * Run through 'migrate'.+data Migration = Migration MigrationId (Transaction 'Write -> IO ())++instance HasField "id" Migration MigrationId where+   getField (Migration x _) = x++-- | 'Just' if at least one 'MigrationId' is duplicate.+duplicateMigrationId :: [Migration] -> Maybe MigrationId+duplicateMigrationId = go mempty+  where+   go :: Set MigrationId -> [Migration] -> Maybe MigrationId+   go !mIds = \case+      Migration mId _ : ms+         | Set.member mId mIds -> Just mId+         | otherwise -> go (Set.insert mId mIds) ms+      [] -> Nothing++-- | Define a single 'Migration' that, when executed, will perform+-- the given 'Transactional'.+--+-- * See 'Migration'.+migration+   :: MigrationId+   -> (forall g. Transactional g 'NoRetry 'Write ())+   -- ^ Notice the 'NoRetry'. In other words, this 'Transactional'+   -- can't perform 'retry' nor any 'Control.Applicative.Alternative'+   -- nor 'MonadPlus' features.+   -> Migration+migration mId ta = Migration mId \tx -> embed tx ta++-- | Unique identifier for a 'Migration' within a 'MigrationsTable'.+--+-- * You are supposed to type these statically, so construct a 'MigrationId'+-- by typing down the literal string.+newtype MigrationId = MigrationId T.Text+   deriving newtype (Eq, Ord, IsString, Show, EncodeDefault, DecodeDefault)++instance HasField "text" MigrationId T.Text where+   getField (MigrationId x) = x++--------------------------------------------------------------------------------++createMigrationsTable :: MigrationsTable -> Statement 'Write () ()+createMigrationsTable tbl =+   -- We are storing the timestamp in case we need it in the future.+   -- We aren't really using it now.+   writeStatement mempty mempty $+      fromString $+         "CREATE TABLE IF NOT EXISTS "+            <> show tbl+            <> " (ord INTEGER PRIMARY KEY NOT NULL CHECK (ord >= 0)"+            <> ", id TEXT UNIQUE NOT NULL"+            <> ", time TEXT NOT NULL)"++getMigrations+   :: MigrationsTable -> Statement 'Read () (Time.UTCTime, MigrationId)+getMigrations tbl =+   readStatement mempty (liftA2 (,) "time" "id") $+      fromString $+         "SELECT time, id FROM " <> show tbl <> " ORDER BY ord ASC"++pushMigration :: MigrationsTable -> Statement 'Write MigrationId Time.UTCTime+pushMigration tbl =+   writeStatement "id" "time" $+      fromString $+         "INSERT INTO "+            <> show tbl+            <> " (ord, time, id)"+            <> " SELECT t.ord"+            <> ", strftime('%Y-%m-%dT%H:%M:%f+00:00', 'now', 'subsecond')"+            <> ", $id"+            <> " FROM (SELECT coalesce(max(ord) + 1, 0) AS ord FROM "+            <> show tbl+            <> ") AS t"+            <> " RETURNING time"++--------------------------------------------------------------------------------++-- | Run all the migrations in 'Migration's that haven't been run yet.+--+-- * If the 'MigrationId's are not compatible with the current migration+-- history as reported by 'MigrationsTable', there will be an exception.+--+-- * If 'MigrationsTable' doesn't exist, it will be created.+--+-- * All the changes are run in a single 'Transaction', including those to+-- 'MigrationsTable'.+migrate+   :: forall a m+    . (MonadIO m, Ex.MonadMask m)+   => Pool 'Write+   -- ^ Connection 'Pool' to the database to migrate.+   -> MigrationsTable+   -- ^ Name of the table where the registry of ran 'Migration's is kept.+   -> [Migration]+   -- ^ 'Migration's to apply to the database, if necessary, in chronological+   -- order.+   -> ([MigrationId] -> m a)+   -- ^ This will be performed __while the write transaction is active__,+   -- letting you know which 'MigrationId's are to be performed, and in which+   -- order.+   --+   -- This can be a good place to perform a backup of the database if+   -- necessary. Presumably, 'migrate' is being run during the initialization+   -- of your program, suggesting that nobody else is trying to write to the+   -- database at this time, so it's OK if this code takes a while to run.+   --+   -- Don't try to acquire a 'Write' transaction here, it will deadlock.+   -- It's OK to interact with the 'Pool' through 'Read'-only means.+   -> m a+migrate p tbl want k+   | Just mId <- duplicateMigrationId want =+      Ex.throwString $ "Duplicate migration id: " <> show mId+   | otherwise = R.withAcquire (commitTransaction p) \tx -> do+      pending <- embed tx do+         zero (createMigrationsTable tbl) ()+         (nran, ran) <- list (getMigrations tbl) ()+         case List.stripPrefix (fmap snd ran) (fmap (.id) want) of+            Just _ -> pure $ List.drop (fromIntegral nran) want+            Nothing ->+               Ex.throwString $+                  "Incompatible migration history: " <> show (fmap snd ran)+      a <- k $ fmap (.id) pending+      forM_ pending \(Migration mId f) -> do+         liftIO $ f tx+         void $ embed tx $ one (pushMigration tbl) mId+      pure a
lib/Sq/Names.hs view
@@ -14,10 +14,11 @@ import Control.Applicative import Control.DeepSeq import Control.Monad-import Data.List.NonEmpty (NonEmpty(..))+import Data.Aeson qualified as Ae import Data.Attoparsec.Text qualified as AT import Data.Char qualified as Ch import Data.Coerce+import Data.List.NonEmpty (NonEmpty (..)) import Data.String import Data.Text qualified as T import GHC.Records@@ -29,10 +30,13 @@ -- -- Construct with 'name' or 'IsString'. newtype Name = Name T.Text-   deriving newtype (Eq, Ord, Show, NFData)+   deriving newtype (Eq, Ord, Show, NFData, Ae.ToJSON)  instance IsString Name where    fromString = either error id . name . T.pack++instance Ae.FromJSON Name where+   parseJSON = Ae.withText "Name" (either fail pure . name)  instance HasField "text" Name T.Text where getField = coerce
lib/Sq/Transactional.hs view
@@ -2,6 +2,12 @@    ( Transactional    , embed    , transactionalRetry+   , one+   , maybe+   , zero+   , some+   , list+   , fold    , foldM    , Ref    , Retry (..)@@ -9,7 +15,7 @@    , orElse    ) where -import Control.Applicative+import Control.Applicative hiding (some) import Control.Concurrent import Control.Concurrent.STM hiding (orElse, retry) import Control.Exception.Safe qualified as Ex@@ -24,9 +30,12 @@ import Control.Monad.Trans.Resource.Extra qualified as R hiding (runResourceT) import Data.Acquire qualified as A import Data.Coerce+import Data.Int import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IntMap import Data.Kind+import Data.List.NonEmpty (NonEmpty)+import Prelude hiding (Read, maybe, read)  import Sq.Connection import Sq.Mode@@ -216,7 +225,8 @@ -- -- * For a non-'Transactional' version of this function, see 'Sq.foldIO'. foldM-   :: (SubMode t s)+   :: forall o z i t s g r+    . (SubMode t s)    => F.FoldM (Transactional g r t) o z    -> Statement s i o    -> i@@ -388,3 +398,78 @@                writeTVar tv $! Just a1                pure b             Nothing -> Ex.throwM $ resourceVanishedWithCallStack "Ref"++--------------------------------------------------------------------------------++-- | Executes a 'Statement' expected to return __zero or one__ rows.+--+-- * Throws 'ErrRows_TooMany' if more than one row.+maybe+   :: forall o i t s g r+    . (SubMode t s)+   => Statement s i o+   -> i+   -> Transactional g r t (Maybe o)+maybe = foldM $ foldMaybeM ErrRows_TooMany+{-# INLINE maybe #-}++-- | Executes a 'Statement' expected to return exactly __one__ row.+--+-- * Throws 'ErrRows_TooFew' if zero rows, 'ErrRows_TooMany' if more than one row.+one+   :: forall o i t s g r+    . (SubMode t s)+   => Statement s i o+   -> i+   -> Transactional g r t o+one = foldM $ foldOneM ErrRows_TooFew ErrRows_TooMany+{-# INLINE one #-}++-- | Executes a 'Statement' expected to return exactly __zero__ rows.+--+-- * Throws 'ErrRows_TooMany' if more than zero rows.+zero+   :: forall o i t s g r+    . (SubMode t s)+   => Statement s i o+   -> i+   -> Transactional g r t ()+zero = foldM $ foldZeroM ErrRows_TooMany+{-# INLINE zero #-}++-- | Executes a 'Statement' expected to return __one or more__ rows.+--+-- * Returns the length of the 'NonEmpty' list, too.+--+-- * Throws 'ErrRows_TooFew' if zero rows.+some+   :: forall o i t s g r+    . (SubMode t s)+   => Statement s i o+   -> i+   -> Transactional g r t (Int64, NonEmpty o)+some = foldM $ foldNonEmptyM ErrRows_TooFew+{-# INLINE some #-}++-- | Executes a 'Statement' expected to return __zero or more__ rows.+--+-- * Returns the length of the list, too.+list+   :: forall o i t s g r+    . (SubMode t s)+   => Statement s i o+   -> i+   -> Transactional g r t (Int64, [o])+list = fold foldList+{-# INLINE list #-}++-- | __Purely fold__ all the output rows.+fold+   :: forall o z i t s g r+    . (SubMode t s)+   => F.Fold o z+   -> Statement s i o+   -> i+   -> Transactional g r t z+fold = foldM . F.generalize+{-# INLINE fold #-}
sq.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: sq-version: 0.0.1+version: 0.0.2 license: Apache-2.0 license-file: LICENSE extra-source-files: README.md CHANGELOG.md@@ -45,6 +45,7 @@     Sq.Decoders     Sq.Encoders     Sq.Input+    Sq.Migrations     Sq.Mode     Sq.Names     Sq.Null
test/Sq/Test.hs view
@@ -1,6 +1,5 @@ module Sq.Test (tree) where -import Control.Applicative import Control.Concurrent import Control.Concurrent.Async qualified as Async import Control.Exception.Safe qualified as Ex@@ -10,18 +9,17 @@ import Control.Monad.Trans.Resource.Extra qualified as R import Data.Acquire.Internal qualified as A import Data.Foldable-import Data.Text qualified as T import Di qualified import Hedgehog qualified as H import Hedgehog.Gen qualified as H import Hedgehog.Range qualified as HR-import Sq qualified import System.Timeout import Test.Tasty (testGroup, withResource) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.Runners (TestTree) +import Sq qualified import Sq.Test.Codec qualified  --------------------------------------------------------------------------------@@ -55,6 +53,7 @@          ysLen H.=== fromIntegral (length ys)          xs H.=== ys       , testExample1 di+      , testMigs di       ]  withAcquire :: A.Acquire a -> (IO a -> TestTree) -> TestTree@@ -132,3 +131,45 @@             timeout 500_000 (example1 pool) >>= \case                Just () -> pure ()                Nothing -> fail "example1: timeout!"++--------------------------------------------------------------------------------++testMigs :: Di.Df1 -> TestTree+testMigs di0 = testCase "migs" do+   Sq.with (Sq.tempPool di0) \pool -> do+      Sq.migrate pool "migs" migsAB \ids -> ids @?= ["A", "B"]+      Sq.migrate pool "migs" migsAB \ids -> ids @?= []+      for_ [migsCD, []] \migs ->+         Ex.catchJust+            ( \case+               Ex.StringException m _ ->+                  guard $ m == "Incompatible migration history: [\"A\",\"B\"]"+            )+            (Sq.migrate pool "migs" migs mempty)+            pure+      Sq.migrate pool "migs" migsAB \ids -> ids @?= []+      Sq.migrate pool "migs" (migsAB <> migsCD) \ids -> ids @?= ["C", "D"]+      Sq.migrate pool "migs" (migsAB <> migsCD) \ids -> ids @?= []+      Sq.read pool do+         (2, [7, 8 :: Int]) <-+            Sq.list+               (Sq.readStatement mempty "x" "SELECT x FROM t ORDER BY x ASC")+               ()+         pure ()+  where+   migsAB :: [Sq.Migration]+   migsAB =+      [ Sq.migration "A" (pure ())+      , Sq.migration "B" (pure ())+      ]+   migsCD :: [Sq.Migration]+   migsCD =+      [ Sq.migration "C" do+         Sq.zero @()+            (Sq.writeStatement mempty mempty "CREATE TABLE t (x INTEGER)")+            ()+      , Sq.migration "D" do+         Sq.zero @()+            (Sq.writeStatement mempty mempty "INSERT INTO t (x) VALUES (7), (8)")+            ()+      ]