sq (empty) → 0.0.1
raw patch · 21 files changed
+4127/−0 lines, 21 filesdep +aesondep +asyncdep +async-pool
Dependencies added: aeson, async, async-pool, attoparsec, base, binary, bytestring, clock, containers, contravariant, criterion, deepseq, df1, di, di-core, di-df1, direct-sqlite, directory, exceptions, filepath, foldl, hedgehog, profunctors, ref-tf, resource-pool, resourcet, resourcet-extra, safe-exceptions, sq, stm, streaming, tasty, tasty-hedgehog, tasty-hunit, template-haskell, text, time, transformers
Files
- CHANGELOG.md +3/−0
- LICENSE +219/−0
- README.md +18/−0
- bench/Main.hs +115/−0
- lib/Sq.hs +380/−0
- lib/Sq/Connection.hs +753/−0
- lib/Sq/Decoders.hs +408/−0
- lib/Sq/Encoders.hs +382/−0
- lib/Sq/Input.hs +163/−0
- lib/Sq/Mode.hs +67/−0
- lib/Sq/Names.hs +104/−0
- lib/Sq/Null.hs +17/−0
- lib/Sq/Output.hs +197/−0
- lib/Sq/Pool.hs +153/−0
- lib/Sq/Statement.hs +153/−0
- lib/Sq/Support.hs +144/−0
- lib/Sq/Transactional.hs +390/−0
- sq.cabal +133/−0
- test/Main.hs +21/−0
- test/Sq/Test.hs +134/−0
- test/Sq/Test/Codec.hs +173/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# Version 0.0.1++* Initial version.
+ LICENSE view
@@ -0,0 +1,219 @@+Copyright 2023, Renzo Carbonara.++Except where otherwise explicitly mentioned, all of contents of the+"sq" project are licensed under the Apache License,+Version 2.0 (the "License"); you may not use this file except in+compliance with the License. You may obtain a copy of the License at the+end of this file or at http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.+++-------------------------------------------------------------------------------+++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ README.md view
@@ -0,0 +1,18 @@+# sq++High-level SQLite client library in Haskell.++* Copyright © Renzo Carbonara, 2023.++* Licensing terms in `LICENSE` file (`Apache-2.0`).++++## Development++1. Clone this repo and run `nix develop` in the top-level folder.++2. Within that environment, you can use `cabal` as usual.++3. If you don't have `nix` installed, then have `nix` installed.+
+ bench/Main.hs view
@@ -0,0 +1,115 @@+module Main (main) where++import Control.Concurrent+import Control.Concurrent.Async qualified as Async+import Control.Exception.Safe qualified as Ex+import Control.Monad+import Control.Monad.Trans.Resource.Extra qualified as R+import Criterion.Main+import Data.Acquire qualified as A+import Data.IORef+import Df1 qualified+import Di qualified+import Di.Core qualified+import Sq qualified++digitChar :: Int -> Char+digitChar i = case show i of+ [c] -> c+ _ -> error "digitChar"++{-+Something more or less like this will be printed. Notice how the inserts (I),+reads (0..9) and deletes (D) are nicely interleaved. This means that work+proceeds as soon as possible.++I1394860527I2743590618I2179540638I0314589267I1204956738I6083247951I8352640917I10+45968732I13290754I601978235468DDDI02136459I87360157482I675038149I9326257081D49I1+374256908DI104963725I0431825769DI1370594826D8I5493728061DI7901654382DDI06172354I+4095891726I1390465738I0257846392D8D1DDI7241506839I1657294038DI15897230I464701698+I35723620985D41I0426189753I5961273480DDDI102435798D6I0617984352I932056481I729386+7154D0I4263091785I7036254198I4806325917DDDI3584976210DDDDDDDI987561203D4I0178953+426I2381674590I302178469D5I8239175406DDI290156347D8I3875210946DI05247638D91I1325+I6270147058963D489DI8019243675I3159642087I7693258140DI6513029847DDI0412789I36503+92715648I9685423071DI483672901I3092875154D6I5179623408DI5106938742I1497608235I02+59413768I3810954267DI5690378142I4052139867I6714820953DDDDI5209364817DI3861945207+DDDDDDDI0284195673I1302794865DI7910456328I1296380754I1306524897DI9103825647I2459+130867I1650432987I2061973854I1389064275DI9516847023I0293857146I0638271594I362987+4510DI0812376459I0345689271I9638417205DI950142786D3DDI2304795816I107263945D8I127+5940638DDI4318926705I782051934DD6DDDI741590I0763541386DD282D9DI0673129548DDDDDI5+841962037DDDI4286109375I1479608253DDI8653204917DDDDI4019735682DDDDDI9163270584DD++-}+run+ :: Sq.Pool Sq.Write+ -> Int+ -- ^ Number of data to be inserted. It will be read back 10 times.+ -> Benchmark+run pool nw = bench (show nw) $ nfIO do+ caps :: Int <- getNumCapabilities+ semForkW :: QSem <- newQSem (2 * caps)+ semForkR :: QSem <- newQSem (10 * caps)+ semDone :: QSemN <- newQSemN 0+ iorOrder :: IORef String <- newIORef ""+ let add :: Char -> IO ()+ add c = atomicModifyIORef' iorOrder \s -> (c : s, ())+ forM_ [1 .. nw] \i -> do+ waitQSem semForkW+ Async.link =<< Async.async do+ o1 <- Sq.commit pool $ Sq.one stInsert i+ add 'I'+ when (o1 /= i) $ Ex.throwString "stInsert: o /= i"+ void $+ waitAll =<< forM [0 .. 9] \(j :: Int) -> do+ waitQSem semForkR+ Async.async do+ o2 <- Sq.read pool $ Sq.one stRead i+ add $ digitChar j+ when (o2 /= i) $ Ex.throwString "stRead: o /= i"+ signalQSem semForkR+ o3 <- Sq.commit pool $ Sq.one stDelete i+ add 'D'+ when (o3 /= i) $ Ex.throwString "stDelete: o /= i"+ signalQSemN semDone 1+ signalQSem semForkW+ waitQSemN semDone nw+ putStrLn =<< fmap reverse (readIORef iorOrder)++waitAll :: [Async.Async a] -> IO [a]+waitAll = go []+ where+ go !acc (aa : rest) = Async.wait aa >>= \a -> go (a : acc) rest+ go !acc [] = pure $ reverse acc++stCreate :: Sq.Statement Sq.Write () ()+stCreate = Sq.writeStatement mempty mempty "CREATE TABLE t (x INTEGER)"++stInsert :: Sq.Statement Sq.Write Int Int+stInsert = Sq.writeStatement "i" "x" "INSERT INTO t (x) VALUES ($i) RETURNING x"++stRead :: Sq.Statement Sq.Read Int Int+stRead = Sq.readStatement "i" "x" "SELECT x FROM t WHERE x=$i"++stDelete :: Sq.Statement Sq.Write Int Int+stDelete = Sq.writeStatement "i" "x" "DELETE FROM t WHERE x=$i RETURNING x"++withTempPool :: Di.Df1 -> (Sq.Pool Sq.Write -> Benchmark) -> Benchmark+withTempPool di k =+ envWithCleanup+ ( do+ (pool, rel) <- R.withRestoreIO $ R.unAcquire $ Sq.tempPool di+ Sq.commit pool $ Sq.zero stCreate ()+ pure (pool, rel)+ )+ (\(_, rel) -> rel A.ReleaseNormal)+ (\ ~(pool, _) -> k pool)++main :: IO ()+main = Di.new \di0 -> do+ let di1 = Di.Core.filter (\l _ _ -> l >= Df1.Info) di0+ defaultMain+ [ bgroup+ "sq"+ [ withTempPool di1 \ ~pool -> run pool 100+ ]+ ]
+ lib/Sq.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoFieldSelectors #-}++-- | High-level SQLite client library+--+-- ⚠️ __This is an early preview release of this library. Use at your own risk.__+--+--+-- @+-- import qualified "Sq"+-- @+--+-- Things currently supported:+--+-- * Type-safe __encoding__ of SQL query parameters and columns ('Encode',+-- 'Input').+--+-- * Type-safe __decoding__ of SQL output rows and columns ('Decode', 'Output').+--+-- * Type-safe __concurrent connections__ with read and write database access+-- ('Pool').+--+-- * Type-safe __'Control.Concurrent.STM'-like transactional__ interactions+-- with the database, including 'Control.Concurrent.STM.retry'-like,+-- 'Control.Concurrent.STM.TVar'-like, and+-- 'Control.Concurrent.STM.catchSTM'-like tools ('Transactional', 'retry',+-- 'Ref').+--+-- * Type-safe __distinction between 'Read'-only and read-'Write'__ things.+--+-- * Type-safe __streaming and interleaving of 'IO'__ with output rows+-- ('streamIO', 'foldIO').+--+-- * Type-safe __resource management__ (via 'A.Acquire', see 'new', 'with',+-- 'uith').+--+-- * 'Savepoint's.+--+-- * A lot of logging.+--+-- Things not supported yet:+--+-- * 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.__+module Sq+ ( -- * Statement+ Statement+ , readStatement+ , writeStatement++ -- ** SQL+ , SQL+ , sql++ -- ** Input+ , Input+ , encode+ , input++ -- *** Encode+ , Encode (..)+ , encodeRefine+ , EncodeDefault (..)+ , encodeMaybe+ , encodeEither+ , encodeSizedIntegral+ , encodeAeson+ , encodeBinary+ , encodeShow++ -- ** Output+ , Output+ , decode+ , output++ -- *** Decode+ , Decode (..)+ , decodeRefine+ , DecodeDefault (..)+ , decodeMaybe+ , decodeEither+ , decodeSizedIntegral+ , decodeAeson+ , decodeBinary+ , decodeRead++ -- ** Name+ , Name+ , name++ -- * Transactional+ , Transactional+ , read+ , commit+ , rollback+ , embed+ , Ref+ , retry+ , orElse++ -- ** Querying+ , one+ , maybe+ , zero+ , some+ , list+ , fold+ , foldM++ -- * Interleaving+ , streamIO+ , foldIO++ -- * Pool+ , Pool+ , readPool+ , writePool+ , tempPool+ , subPool++ -- * Settings+ , Settings (..)+ , settings++ -- * Transaction+ , Transaction+ , readTransaction+ , commitTransaction+ , rollbackTransaction++ -- * Resources+ -- $resources+ , new+ , with+ , uith++ -- * Savepoint+ , Savepoint+ , savepoint+ , savepointRollback+ , savepointRelease++ -- * Miscellaneuos+ , Retry (..)+ , BindingName+ , Mode (..)+ , SubMode+ , Null (..)++ -- * Errors+ , ErrEncode (..)+ , ErrInput (..)+ , ErrDecode (..)+ , ErrOutput (..)+ , ErrStatement (..)+ , ErrRows (..)++ -- * Re-exports+ , S.SQLData (..)+ , S.SQLVFS (..)+ )+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+import Prelude hiding (Read, maybe, read)++import Sq.Connection+import Sq.Decoders+import Sq.Encoders+import Sq.Input+import Sq.Mode+import Sq.Names+import Sq.Null+import Sq.Output+import Sq.Pool+import Sq.Statement+import Sq.Support+import Sq.Transactional++--------------------------------------------------------------------------------++-- $resources+--+-- "Sq" relies heavily on 'A.Acquire' for safe resource management in light of+-- concurrency and dependencies between resources.+--+-- As a user of "Sq", you mostly just have to figure out how to obtain a 'Pool'.+-- For that, you will probably benefit use one of these functions:+--+-- * 'with' for integrating with 'Ex.MonadMask' from the @exceptions@ library.+--+-- * 'new' for integrating with 'R.MonadResource' from the @resourcet@ library.+--+-- * 'uith' for integrating with 'R.MonadUnliftIO' from the @unliftio@ library.+--+-- If you have no idea what I'm talking about, just use 'with'.+-- Here is an example:+--+-- @+-- 'with' 'tempPool' \\(__pool__ :: 'Pool' \''Write') ->+-- /-- Here use __pool__ as necessary./+-- /-- The resources associated with it will be/+-- /-- automatically released after leaving this scope./+-- @+--+-- Now that you have a 'Pool', try to solve your problems within+-- 'Transactional' by means of 'Sq.read', 'Sq.commit' or 'Sq.rollback'.+--+-- However, if you need to interleave 'IO' actions while streaming result rows+-- out of the database, 'Transactional' won't be enough. You will need to use+-- 'foldIO' or 'streamIO'.++-- | 'A.Acquire' through 'R.MonadResource'.+--+-- @+-- 'new' = 'fmap' 'snd' . "Data.Acquire".'A.allocateAcquire'+-- @+new :: (R.MonadResource m) => A.Acquire a -> m a+new = fmap snd . A.allocateAcquire++-- | 'A.Acquire' through 'Ex.MonadMask'.+--+-- @+-- 'with' = "Control.Monad.Trans.Resource.Extra".'R.withAcquire'.+-- @+with :: (Ex.MonadMask m, MonadIO m) => A.Acquire a -> (a -> m b) -> m b+with = R.withAcquire++-- | 'A.Acquire' through 'R.MonadUnliftIO'.+--+-- @+-- 'uith' = "Data.Acquire".'A.with'+-- @+uith :: (R.MonadUnliftIO m) => A.Acquire a -> (a -> m b) -> m b+uith = A.with++--------------------------------------------------------------------------------++-- | Acquire a read-'Write' 'Pool' temporarily persisted in the file-system.+-- It will be deleted once released. This can be useful for testing.+--+-- * Use "Di".'Di.new' to obtain the 'Di.Df1' parameter. Consider using+-- "Di.Core".'Di.Core.filter' to filter-out excessive logging. For example:+--+-- @"Di.Core".'Di.Core.filter' \\l _ _ -> l >= "Df1".'Df1.Info'@+tempPool :: Di.Df1 -> A.Acquire (Pool Write)+tempPool di0 = do+ d <- acquireTmpDir+ pool SWrite (Di.push "sq" di0) $ settings (d </> "db.sqlite")++-- | Acquire a read-'Write' 'Pool' according to the given 'Settings'.+--+-- * Use "Di".'Di.new' to obtain the 'Di.Df1' parameter. Consider using+-- "Di.Core".'Di.Core.filter' to filter-out excessive logging. For example:+--+-- @"Di.Core".'Di.Core.filter' \\l _ _ -> l >= "Df1".'Df1.Info'@+writePool :: Di.Df1 -> Settings -> A.Acquire (Pool Write)+writePool di0 = pool SWrite (Di.push "sq" di0)+{-# INLINE writePool #-}++-- | Acquire a 'Read'-only 'Pool' according to the given 'Settings'.+--+-- * Use "Di".'Di.new' to obtain the 'Di.Df1' parameter. Consider using+-- "Di.Core".'Di.Core.filter' to filter-out excessive logging. For example:+--+-- @"Di.Core".'Di.Core.filter' \\l _ _ -> l >= "Df1".'Df1.Info'@+readPool :: Di.Df1 -> Settings -> A.Acquire (Pool Read)+readPool di0 = pool SRead (Di.push "sq" di0)+{-# INLINE readPool #-}++--------------------------------------------------------------------------------++-- | 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+ :: (MonadIO m, SubMode p 'Read)+ => Pool p+ -> (forall g. Transactional g 'Retry 'Read a)+ -> m a+read p = transactionalRetry $ readTransaction p+{-# INLINE read #-}++-- | Execute a read-'Write' 'Transactional' in a fresh 'Transaction' that will+-- be automatically committed when done.+commit+ :: (MonadIO m)+ => Pool 'Write+ -> (forall g. Transactional g 'Retry 'Write a)+ -> m a+commit p = transactionalRetry $ commitTransaction p+{-# INLINE commit #-}++-- | Execute a read-'Write' 'Transactional' in a fresh 'Transaction' that will+-- be automatically rolled-back when done.+--+-- __This is mostly useful for testing__.+rollback+ :: (MonadIO m)+ => Pool 'Write+ -> (forall g. Transactional g 'Retry 'Write a)+ -> m a+rollback p = transactionalRetry $ rollbackTransaction p+{-# INLINE rollback #-}
+ lib/Sq/Connection.hs view
@@ -0,0 +1,753 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoFieldSelectors #-}++module Sq.Connection+ ( Connection+ , connection+ , Transaction (smode)+ , Settings (..)+ , settings+ , connectionReadTransaction+ , connectionWriteTransaction+ , foldIO+ , streamIO+ , ConnectionId (..)+ , TransactionId (..)+ , SavepointId (..)+ , Savepoint+ , savepoint+ , savepointRollback+ , savepointRelease+ , ErrRows (..)+ , ErrStatement (..)+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.STM+import Control.DeepSeq+import Control.Exception.Safe qualified as Ex+import Control.Foldl qualified as F+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Resource qualified as R hiding (runResourceT)+import Control.Monad.Trans.Resource.Extra qualified as R+import Data.Acquire qualified as A+import Data.Foldable+import Data.Function (fix)+import Data.Functor+import Data.IORef+import Data.Int+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Monoid+import Data.Text qualified as T+import Data.Tuple+import Data.Word+import Database.SQLite3 qualified as S+import Database.SQLite3.Bindings qualified as S (CDatabase, CStatement)+import Database.SQLite3.Direct qualified as S (Database (..), Statement (..))+import Di.Df1 qualified as Di+import Foreign.C.Types (CInt (..))+import Foreign.Marshal.Alloc (free, malloc)+import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr)+import Foreign.Storable+import GHC.IO (unsafeUnmask)+import GHC.Records+import GHC.Show+import Streaming qualified as Z+import Streaming.Prelude qualified as Z+import System.Clock qualified as Clock+import System.Timeout (timeout)+import Prelude hiding (Read, log)++import Sq.Input+import Sq.Mode+import Sq.Names+import Sq.Output+import Sq.Statement+import Sq.Support++--------------------------------------------------------------------------------++modeFlags :: Mode -> [S.SQLOpenFlag]+modeFlags = \case+ Read ->+ [ S.SQLOpenReadOnly+ , S.SQLOpenWAL+ , S.SQLOpenNoMutex+ , S.SQLOpenExResCode+ ]+ Write ->+ [ S.SQLOpenReadWrite+ , S.SQLOpenCreate+ , S.SQLOpenWAL+ , S.SQLOpenNoMutex+ , S.SQLOpenExResCode+ ]++--------------------------------------------------------------------------------++-- | SQLite connection settings.+data Settings = Settings+ { file :: FilePath+ -- ^ Database file path. Not an URI.+ --+ -- Note: To keep things simple, native @:memory:@ SQLite databases are not+ -- supported. Maybe use 'Sq.poolTemp' or @tmpfs@ if you need that?+ , vfs :: S.SQLVFS+ , timeout :: Word32+ -- ^ SQLite busy Timeout in milliseconds.+ }+ deriving stock (Eq, Show)++instance NFData Settings where+ rnf (Settings !_ !_ !_) = ()++-- | Default connection settings.+settings+ :: FilePath+ -- ^ Database file path. Not an URI, not @:memory:@+ -> Settings+settings file =+ Settings+ { file+ , vfs = S.SQLVFSDefault+ , timeout = 120_000 -- 2 minutes+ }++--------------------------------------------------------------------------------++-- | A 'Read' or 'Write' connection handle.+--+-- It is safe to attempt to use this connection concurrently without any+-- locking. The 'Connection' itself mantains an internal locking mechanism so+-- that transactions are always executed serially.+--+-- Note: We don't export 'Connection' directly to the public, because it's+-- easier to export just 'Sq.Pool'.+data Connection (c :: Mode) = Connection+ { _id :: ConnectionId+ , timeout :: Word32+ -- ^ Same @timeout@ as in 'Settings'+ , di :: Di.Df1+ , xconn :: TMVar (Maybe (ExclusiveConnection c))+ -- ^ 'Nothing' if the connection has vanished.+ }++instance HasField "id" (Connection c) ConnectionId where+ getField = (._id)++instance NFData (Connection c) where+ rnf (Connection !_ !_ !_ !_) = ()++instance Show (Connection c) where+ showsPrec _ c = showString "Connection{id = " . shows c.id . showChar '}'++connection :: SMode mode -> Di.Df1 -> Settings -> A.Acquire (Connection c)+connection smode di0 s = do+ (di1, xc) <- exclusiveConnection smode di0 s+ xconn <- R.mkAcquire1 (newTMVarIO (Just xc)) \t ->+ atomically $ tryTakeTMVar t >> putTMVar t Nothing+ pure Connection{xconn, _id = xc.id, di = di1, timeout = s.timeout}++--------------------------------------------------------------------------------++-- | Internal. While a 'Connection' can be used concurrently, an+-- 'ExclusiveConnection' can't. If one has access to an 'ExclusiveConnection',+-- then one can assume that nobody else has access to the underlying+-- 'S.Database' connection handle at the moment.+data ExclusiveConnection (mode :: Mode) = ExclusiveConnection+ { id :: ConnectionId+ , run :: forall x. (S.Database -> IO x) -> IO x+ , statements :: IORef (Map SQL PreparedStatement)+ }++instance Show (ExclusiveConnection m) where+ showsPrec _ x =+ showString "ExclusiveConnection{id = " . shows x.id . showChar '}'++run :: (MonadIO m) => ExclusiveConnection c -> (S.Database -> IO x) -> m x+run ExclusiveConnection{run = r} k = liftIO $ r k++--------------------------------------------------------------------------------++lockConnection :: Connection c -> A.Acquire (ExclusiveConnection c)+lockConnection c =+ R.mkAcquire1+ ( warningOnException (Di.push "lock" c.di) do+ -- We reuse setBusyHandler's timeout because why not.+ y <- timeout (fromIntegral c.timeout * 1000) $ atomically do+ takeTMVar c.xconn >>= \case+ Just x -> pure x+ Nothing ->+ Ex.throwM $+ resourceVanishedWithCallStack+ "lockConnection"+ case y of+ Just xc -> pure xc+ Nothing -> Ex.throwString "Timeout"+ )+ (atomically . void . tryPutTMVar c.xconn . Just)++data DatabaseMessage+ = forall x.+ DatabaseMessage+ (S.Database -> IO x)+ (Either Ex.SomeException x -> IO ())++warningOnException+ :: (MonadIO m, Ex.MonadMask m)+ => Di.Df1+ -> m a+ -> m a+warningOnException di act = Ex.withException act \e ->+ Di.warning di (e :: Ex.SomeException)++exclusiveConnection+ :: SMode mode+ -> Di.Df1+ -> Settings+ -> A.Acquire (Di.Df1, ExclusiveConnection c)+exclusiveConnection smode di0 cs = do+ cId :: ConnectionId <- newConnectionId+ let di1 = Di.attr "connection-mode" smode $ Di.attr "connection" cId di0+ dms :: MVar DatabaseMessage <-+ R.mkAcquire1 newEmptyMVar (fmap (const ()) . tryTakeMVar)+ abackground :: Async.Async () <-+ R.mkAcquire1+ (Async.async (background di1 (takeMVar dms)))+ Async.uninterruptibleCancel+ -- TODO: Async.link should be sufficient. Figure out what I'm doing wrong.+ liftIO $ flip Async.linkOnly abackground \se ->+ Just Async.AsyncCancelled == Ex.fromException se+ statements :: IORef (Map SQL PreparedStatement) <-+ R.mkAcquire1 (newIORef mempty) \r ->+ atomicModifyIORef' r (mempty,) >>= traverse_ \ps ->+ Ex.tryAny (S.finalize ps.handle)+ pure+ ( di1+ , ExclusiveConnection+ { statements+ , id = cId+ , run = \ !act -> do+ mv <- newEmptyMVar+ putMVar dms $! DatabaseMessage act $ putMVar mv+ takeMVar mv >>= either Ex.throwM pure+ }+ )+ where+ background :: forall x. Di.Df1 -> IO DatabaseMessage -> IO x+ background di1 next = R.runResourceT do+ (_, db) <-+ R.allocate+ ( do+ let di2 = Di.push "connect" di1+ db <- warningOnException di2 do+ S.open2 (T.pack cs.file) (modeFlags (fromSMode smode)) cs.vfs+ Di.debug_ di2 "OK"+ pure db+ )+ ( \db -> do+ let di2 = Di.push "disconnect" di1+ warningOnException di1 do+ Ex.finally+ (Ex.uninterruptibleMask_ (S.interrupt db))+ (S.close db)+ Di.debug_ di2 "OK"+ )+ warningOnException (Di.push "set-busy-handler" di1) do+ setBusyHandler db cs.timeout+ liftIO $+ traverse_+ (S.exec db)+ [ "PRAGMA synchronous=NORMAL"+ , "PRAGMA journal_size_limit=67108864" -- 64 MiB+ , "PRAGMA mmap_size=134217728" -- 128 MiB+ , "PRAGMA cache_size=2000" -- 2000 pages+ ]+ liftIO $ forever do+ DatabaseMessage act res <- next+ Ex.try (unsafeUnmask (act db)) >>= res++--------------------------------------------------------------------------------++-- | See <https://www.sqlite.org/c3ref/busy_handler.html>+foreign import ccall unsafe "sqlite3_busy_handler"+ c_sqlite3_busy_handler+ :: Ptr S.CDatabase+ -> FunPtr (Ptr a -> CInt -> IO CInt)+ -> Ptr a+ -> IO CInt++-- | Returns same as input.+foreign import ccall safe "sqlite3_sleep"+ c_sqlite3_sleep+ :: CInt+ -- ^ milliseconds.+ -> IO CInt++foreign import ccall "wrapper"+ createBusyHandlerPtr+ :: (Ptr Clock.TimeSpec -> CInt -> IO CInt)+ -> IO (FunPtr (Ptr Clock.TimeSpec -> CInt -> IO CInt))++setBusyHandler :: (R.MonadResource m) => S.Database -> Word32 -> m ()+setBusyHandler (S.Database pDB) tmaxMS = do+ (_, pHandler) <- R.allocate (createBusyHandlerPtr handler) freeHaskellFunPtr+ (_, pTimeSpec) <- R.allocate malloc free+ liftIO do+ n <- c_sqlite3_busy_handler pDB pHandler pTimeSpec+ when (n /= 0) do+ Ex.throwString $ "sqlite3_busy_handler: return " <> show n+ where+ tmaxNS :: Integer+ !tmaxNS = fromIntegral tmaxMS * 1_000_000+ handler :: Ptr Clock.TimeSpec -> CInt -> IO CInt+ handler pt0 n = do+ t1 <- Clock.getTime Clock.Monotonic+ t0 <-+ if n /= 0+ then peek pt0+ else poke pt0 t1 $> t1+ if Clock.toNanoSecs (Clock.diffTimeSpec t1 t0) < tmaxNS+ then do+ let ms = ceiling $ logBase 2 (fromIntegral (max 1 n) :: Double)+ c_sqlite3_sleep ms $> 1+ else pure 0++--------------------------------------------------------------------------------++-- | A database transaction handle.+--+-- * @t@ indicates whether 'Read'-only or read-'Write' 'Statement's are+-- supported.+--+-- * Prefer to use a 'Read'-only 'Transaction' if you are solely performing+-- 'Read'-only 'Statement's. It will be more efficient in concurrent settings.+--+-- * Obtain with 'Sq.readTransaction' or 'Sq.commitTransaction'. Or, if you+-- are testing, with 'Sq.rollbackTransaction'.+--+-- * If you have access to a 'Transaction' within its intended scope, then you+-- can assume that a database transaction has started, and will eventually be+-- automatically commited or rolled back as requested when it was obtained.+--+-- * It's safe and efficient to use a 'Transaction' concurrently as is.+-- Concurrency is handled internally.++-- While the 'Transaction' is active, an exclusive lock is held on the+-- underlying 'Connection'.+data Transaction (t :: Mode) = forall c.+ (SubMode c t) =>+ Transaction+ { _id :: TransactionId+ , di :: Di.Df1+ , conn :: Connection c+ , commit :: Bool+ , smode :: SMode t+ }++instance Show (Transaction t) where+ showsPrec _ t =+ showString "Transaction{id = "+ . shows t.id+ . showString ", commit = "+ . shows t.commit+ . showChar '}'++instance NFData (Transaction t) where+ rnf (Transaction !_ !_ !_ !_ !_) = ()++instance HasField "id" (Transaction t) TransactionId where+ getField = (._id)++connectionReadTransaction+ :: (SubMode c Read)+ => Connection c+ -> A.Acquire (Transaction 'Read)+connectionReadTransaction c = do+ xc <- lockConnection c+ tId <- newTransactionId+ let di1 = Di.attr "transaction-mode" Read $ Di.attr "transaction" tId c.di+ R.mkAcquireType1+ ( do+ let di2 = Di.push "begin" di1+ warningOnException di2 $ run xc (flip S.exec "BEGIN DEFERRED")+ Di.debug_ di2 "OK"+ )+ ( \_ rt -> do+ let di2 = Di.push "rollback" di1+ for_ (releaseTypeException rt) \e ->+ Di.notice di2 $ "Will rollback due to: " <> show e+ warningOnException di2 $ run xc (flip S.exec "ROLLBACK")+ Di.debug_ di2 "OK"+ )+ xconn <- R.mkAcquire1 (newTMVarIO (Just xc)) \t ->+ atomically $ tryTakeTMVar t >> putTMVar t Nothing+ pure $+ Transaction+ { _id = tId+ , di = di1+ , conn = c{xconn}+ , commit = False+ , smode = SRead+ }++connectionWriteTransaction+ :: Bool+ -- ^ Whether to finally @COMMIT@ the transaction.+ -- Otherwise, it will @ROLLBACK@.+ -> Connection 'Write+ -> A.Acquire (Transaction 'Write)+connectionWriteTransaction commit c = do+ xc <- lockConnection c+ tId <- newTransactionId+ let di1 =+ Di.attr_ "transaction-mode" (if commit then "commit" else "rollback") $+ Di.attr "transaction" tId c.di+ rollback (ye :: Maybe Ex.SomeException) = do+ let di2 = Di.push "rollback" di1+ for_ ye \e -> Di.notice di2 $ "Will rollback due to: " <> show e+ warningOnException di2 $ run xc (flip S.exec "ROLLBACK")+ Di.debug_ di2 "OK"+ R.mkAcquireType1+ ( do+ let di2 = Di.push "begin" di1+ warningOnException di2 $ run xc (flip S.exec "BEGIN IMMEDIATE")+ Di.debug_ di2 "OK"+ )+ ( \_ rt -> case releaseTypeException rt of+ Nothing+ | commit -> do+ let di2 = Di.push "commit" di1+ warningOnException di2 $ run xc (flip S.exec "COMMIT")+ Di.debug_ di2 "OK"+ | otherwise -> rollback Nothing+ Just e -> rollback (Just e)+ )+ xconn <- R.mkAcquire1 (newTMVarIO (Just xc)) \t ->+ atomically $ tryTakeTMVar t >> putTMVar t Nothing+ pure $+ Transaction+ { _id = tId+ , di = di1+ , conn = c{xconn}+ , commit+ , smode = SWrite+ }++--------------------------------------------------------------------------------++-- Note: If you have access to a PreparedStatement, you can assume that+-- you are within a Transaction, and that nobody else has access to this+-- PreparedStatement at the moment.+data PreparedStatement = PreparedStatement+ { handle :: S.Statement+ , columns :: Map BindingName S.ColumnIndex+ , id :: StatementId+ , reprepares :: Int+ -- ^ The @SQLITE_STMTSTATUS_REPREPARE@ when @columns@ was generated.+ }++acquirePreparedStatement+ :: Di.Df1+ -> SQL+ -> ExclusiveConnection c+ -> A.Acquire PreparedStatement+acquirePreparedStatement di0 raw xconn = R.mkAcquire1+ ( do+ yps <- atomicModifyIORef' xconn.statements \m ->+ swap $ Map.updateLookupWithKey (\_ _ -> Nothing) raw m+ case yps of+ Just ps -> do+ reprepares <- getStatementStatusReprepare ps.handle+ if reprepares == ps.reprepares+ then pure ps+ else do+ let di1 = Di.attr "stmt" ps.id di0+ Di.debug_ di1 "Reprepared"+ columns <- getStatementColumnIndexes ps.handle+ Di.debug di1 $ "Columns: " <> show (Map.toAscList columns)+ pure ps{reprepares, columns}+ Nothing -> do+ stId <- newStatementId+ let di1 = Di.attr "stmt" stId di0+ Di.debug di1 $ "Preparing " <> show raw+ handle <- run xconn $ flip S.prepare raw.text+ reprepares <- getStatementStatusReprepare handle+ columns <- getStatementColumnIndexes handle+ Di.debug di1 $ "Columns: " <> show (Map.toAscList columns)+ pure PreparedStatement{id = stId, handle, reprepares, columns}+ )+ \ps -> flip Ex.onException (S.finalize ps.handle) do+ S.reset ps.handle+ atomicModifyIORef' xconn.statements \m ->+ (Map.insert raw ps m, ())++getStatementStatusReprepare :: S.Statement -> IO Int+getStatementStatusReprepare (S.Statement p) = do+ fromIntegral <$> c_sqlite3_stmt_status p c_SQLITE_STMTSTATUS_REPREPARE 0++-- | See <https://www.sqlite.org/c3ref/stmt_status.html>+foreign import ccall unsafe "sqlite3_stmt_status"+ c_sqlite3_stmt_status+ :: Ptr S.CStatement+ -> CInt+ -- ^ op+ -> CInt+ -- ^ resetFlg+ -> IO CInt++-- | See <https://www.sqlite.org/c3ref/c_stmtstatus_counter.html>+c_SQLITE_STMTSTATUS_REPREPARE :: CInt+c_SQLITE_STMTSTATUS_REPREPARE = 5++getStatementColumnIndexes :: S.Statement -> IO (Map BindingName S.ColumnIndex)+getStatementColumnIndexes st = do+ -- Despite the type name, ncols is a length.+ S.ColumnIndex (ncols :: Int) <- S.columnCount st+ Control.Monad.foldM+ ( \ !m i -> do+ -- Pattern never fails because `i` is in range.+ Just t <- S.columnName st i+ case parseOutputBindingName t of+ Right n ->+ Map.alterF+ ( \case+ Nothing -> pure $ Just i+ Just _ -> Ex.throwM $ ErrStatement_DuplicateColumnName n+ )+ n+ m+ Left _ ->+ -- If `t` is not binding name as understood by+ -- `parseOutputBindingName`, we ignore it.+ -- It just won't be available for lookup later on.+ pure m+ )+ Map.empty+ (S.ColumnIndex <$> enumFromTo 0 (ncols - 1))++data ErrStatement+ = -- | A same column name appears twice or more in the raw 'SQL'.+ ErrStatement_DuplicateColumnName BindingName+ deriving stock (Eq, Show)+ deriving anyclass (Ex.Exception)++--------------------------------------------------------------------------------++data ErrRows+ = -- | Fewer rows than requested were available.+ ErrRows_TooFew+ | -- | More rows than requested were available.+ ErrRows_TooMany+ deriving stock (Eq, Show)+ deriving anyclass (Ex.Exception)++-- | __Fold__ the output rows from a 'Statement' in a way that allows+-- interleaving 'IO' actions.+--+-- * This is simpler alternative to 'streamIO' for when all you need to do+-- is fold.+--+-- * If you don't need to interleave 'IO' actions, then consider+-- using 'Sq.fold'.++-- 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)+ => F.FoldM m o z+ -> A.Acquire (Transaction t)+ -- ^ How to acquire the 'Transaction' once the @m@ is executed,+ -- and how to release it when it's not needed anymore.+ --+ -- If you want this 'Statement' to be the only one in the 'Transaction',+ -- then use one of 'Sq.readTransaction', 'Sq.commitTransaction' or+ -- 'Sq.rollbackTransaction'.+ --+ -- Otherwise, if you already obtained a 'Transaction' by other means, then+ -- simply use 'pure' to wrap a 'Transaction' in 'A.Acquire'.+ -> Statement s i o+ -> i+ -> m z+foldIO (F.FoldM fstep finit fext) atx st i = do+ !bs <- hushThrow $ bindStatement st i+ !acc0 <- finit+ R.withAcquire (atx >>= rowPopper bs) \pop ->+ flip fix acc0 \k !acc ->+ liftIO pop >>= maybe (fext acc) (fstep acc >=> k)++-- | __Stream__ the output rows from a 'Statement' in a way that allows+-- interleaving 'IO' actions.+--+-- * An exclusive lock will be held on the 'Transaction' while the 'Z.Stream'+-- is producing rows.+--+-- * The 'Transaction' lock is released automatically if the 'Z.Stream' is+-- consumed until exhaustion.+--+-- * If you won't consume the 'Z.Stream' until exhaustion, then be sure to exit+-- @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)+ => 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.+ --+ -- If you want this 'Statement' to be the only one in the 'Transaction',+ -- then use one of 'Sq.readTransaction', 'Sq.commitTransaction or+ -- 'Sq.rollbackTransaction'.+ --+ -- Otherwise, if you already obtained a 'Transaction' by other means, then+ -- simply use 'pure' to wrap a 'Transaction' in 'A.Acquire'.+ -> Statement s i o+ -> i+ -> Z.Stream (Z.Of o) m ()+ -- ^ A 'Z.Stream' from the @streaming@ library.+ --+ -- We use the @streaming@ library because it is fast and doesn't+ -- add any transitive dependencies to this project.+streamIO atx st i = do+ bs <- liftIO $ hushThrow $ bindStatement st i+ (k, typop) <- lift $ A.allocateAcquire do+ pop <- rowPopper bs =<< atx+ R.mkAcquire1 (newTMVarIO (Just pop)) \tmv -> do+ atomically $ tryTakeTMVar tmv >> putTMVar tmv Nothing+ Z.untilLeft $ liftIO $ Ex.mask \restore ->+ Ex.bracket+ ( atomically do+ takeTMVar typop >>= \case+ Just pop -> pure pop+ Nothing -> Ex.throwM $ resourceVanishedWithCallStack "streamIO"+ )+ (atomically . tryPutTMVar typop . Just)+ ( restore >=> \case+ Just o -> pure $ Right o+ Nothing -> Left <$> R.releaseType k A.ReleaseEarly+ )++-- | Acquires an 'IO' action that will yield the next output row each time it+-- is called, if any. Among other 'IO' exceptions, 'ErrOutput' may be thrown.+rowPopper+ :: (SubMode t s)+ => BoundStatement s o+ -> Transaction t+ -> A.Acquire (IO (Maybe o))+rowPopper !bs Transaction{conn, di = di0} = do+ -- TODO: Could we safely prepare and bind a raw statement before+ -- lockConnection? That would be more efficient.+ xconn <- lockConnection conn+ qId <- newQueryId+ let di1 = Di.attr "query" qId di0+ ps <- acquirePreparedStatement di1 bs.sql xconn+ let di2 = Di.attr "statement" ps.id di1+ !kvs = Map.toAscList $ rawBoundInput bs.input+ R.mkAcquire1 (S.bindNamed ps.handle kvs) \_ -> S.clearBindings ps.handle+ Di.debug di2 $ "Bound " <> show kvs+ pure do+ S.step ps.handle >>= \case+ S.Row -> fmap Just do+ hushThrow =<< flip runOutput bs.output \n ->+ traverse (S.column ps.handle) (Map.lookup n ps.columns)+ S.Done -> pure Nothing++--------------------------------------------------------------------------------++-- | See 'savepoint', 'savepointRollback' and 'savepointRelease'.+--+-- * __WARNING__ safely dealing with 'Savepoint's can be tricky. Consider using+-- 'Ex.catch' on 'Sq.Transactional', which is implemented using 'Savepoint' and+-- does the right thing.+data Savepoint = Savepoint+ { id :: SavepointId+ , rollback :: IO ()+ , release :: IO ()+ }++instance NFData Savepoint where+ rnf (Savepoint !_ !_ !_) = ()++instance Show Savepoint where+ showsPrec _ x = showString "Savepoint{id = " . shows x.id . showChar '}'++-- | Obtain savepoint to which one can later 'savepointRollback' or+-- 'savepointRelease'.+savepoint :: (MonadIO m) => Transaction Write -> m Savepoint+savepoint Transaction{conn} = liftIO do+ spId <- newSavepointId+ let run' raw = R.withAcquire (lockConnection conn) \xc ->+ run xc $ flip S.exec raw+ run' $ "SAVEPOINT s" <> show' spId+ pure $+ Savepoint+ { id = spId+ , rollback = run' $ "ROLLBACK TO s" <> show' spId+ , release = run' $ "RELEASE s" <> show' spId+ }++-- | Disregard all the changes that happened to the 'Transaction'+-- related to this 'Savepoint' since the time it was obtained+-- through 'savepoint'.+--+-- * Trying to 'savepointRollback' a 'Savepoint' that isn't reachable anymore+-- throws an exception.+--+-- * A 'Savepoint' stops being reachable when the relevant 'Transaction' ends,+-- or when a 'savepointRollback' to an earlier 'Savepoint' on the same+-- 'Transaction' is performed, or when it or a later 'Savepoint' is+-- explicitely released through 'savepointRelease'.+savepointRollback :: (MonadIO m) => Savepoint -> m ()+savepointRollback s = liftIO s.rollback++-- | Release a 'Savepoint' so that it, together with any previous 'Savepoint's+-- on the same 'Transaction', become unreachable to future uses of+-- 'savepointRollback' or 'savepointRelease'.+--+-- * Trying to 'savepointRelease' a 'Savepoint' that isn't reachable anymore+-- throws an exception.+--+-- * A 'Savepoint' stops being reachable when the relevant 'Transaction' ends,+-- or when a 'savepointRollback' to an earlier 'Savepoint' on the same+-- 'Transaction' is performed, or when it or a later 'Savepoint' is+-- explicitely released through 'savepointRelease'.+savepointRelease :: (MonadIO m) => Savepoint -> m ()+savepointRelease s = liftIO s.release++--------------------------------------------------------------------------------++newtype SavepointId = SavepointId Word64+ deriving newtype (Eq, Ord, Show, NFData, Di.ToValue)++newSavepointId :: (MonadIO m) => m SavepointId+newSavepointId = SavepointId <$> newUnique++newtype StatementId = StatementId Word64+ deriving newtype (Eq, Ord, Show, NFData, Di.ToValue)++newStatementId :: (MonadIO m) => m StatementId+newStatementId = StatementId <$> newUnique++newtype TransactionId = TransactionId Word64+ deriving newtype (Eq, Ord, Show, NFData, Di.ToValue)++newTransactionId :: (MonadIO m) => m TransactionId+newTransactionId = TransactionId <$> newUnique++newtype ConnectionId = ConnectionId Word64+ deriving newtype (Eq, Ord, Show, NFData, Di.ToValue)++newConnectionId :: (MonadIO m) => m ConnectionId+newConnectionId = ConnectionId <$> newUnique++newtype QueryId = QueryId Word64+ deriving newtype (Eq, Ord, Show, NFData, Di.ToValue)++newQueryId :: (MonadIO m) => m QueryId+newQueryId = QueryId <$> newUnique
+ lib/Sq/Decoders.hs view
@@ -0,0 +1,408 @@+module Sq.Decoders+ ( Decode (..)+ , ErrDecode (..)+ , decodeRefine+ , DecodeDefault (..)+ , decodeMaybe+ , decodeEither+ , decodeSizedIntegral+ , decodeBinary+ , decodeRead+ , decodeAeson+ ) where++import Control.Applicative+import Control.Exception.Safe qualified as Ex+import Control.Monad+import Control.Monad.Catch qualified as Ex (MonadThrow (..))+import Control.Monad.Trans.Reader+import Data.Aeson qualified as Ae+import Data.Aeson.Types qualified as Ae+import Data.Bifunctor+import Data.Binary.Get qualified as Bin+import Data.Bits+import Data.ByteString qualified as B+import Data.ByteString.Builder.Prim.Internal (caseWordSize_32_64)+import Data.ByteString.Lazy qualified as BL+import Data.Int+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Unsafe qualified as T+import Data.Time qualified as Time+import Data.Time.Clock.POSIX qualified as Time+import Data.Time.Format.ISO8601 qualified as Time+import Data.Word+import Database.SQLite3 qualified as S+import GHC.Float (double2Float, float2Double)+import GHC.Stack+import Numeric.Natural+import Text.Read (readEither, readMaybe)++import Sq.Null (Null)++--------------------------------------------------------------------------------++-- | How to decode a single SQLite column value into a Haskell value of type+-- @a@.+newtype Decode a+ = -- | Decode a 'S.SQLData' value into a value of type @a@.+ Decode (S.SQLData -> Either ErrDecode a)+ deriving+ (Functor, Applicative, Monad)+ via ReaderT S.SQLData (Either ErrDecode)++-- | @'mempty' = 'pure' 'mempty'@+instance (Monoid a) => Monoid (Decode a) where+ mempty = pure mempty+ {-# INLINE mempty #-}++-- | @('<>') == 'liftA2' ('<>')@+instance (Semigroup a) => Semigroup (Decode a) where+ (<>) = liftA2 (<>)+ {-# INLINE (<>) #-}++instance Ex.MonadThrow Decode where+ throwM = Decode . const . Left . ErrDecode_Fail . Ex.toException++instance MonadFail Decode where+ fail = Ex.throwString+ {-# INLINE fail #-}++-- | Leftmost result on success, rightmost error on failure.+instance Alternative Decode where+ empty = fail "empty"+ {-# INLINE empty #-}+ (<|>) = mplus+ {-# INLINE (<|>) #-}++-- | Leftmost result on success, rightmost error on failure.+instance MonadPlus Decode where+ mzero = fail "mzero"+ {-# INLINE mzero #-}+ mplus (Decode l) (Decode r) = Decode \s ->+ either (\_ -> r s) pure (l s)+ {-# INLINE mplus #-}++-- | See v'Decode'.+data ErrDecode+ = -- | Received 'S.ColumnType', expected 'S.ColumnType's.+ ErrDecode_Type S.ColumnType [S.ColumnType]+ | ErrDecode_Fail Ex.SomeException+ deriving stock (Show)+ deriving anyclass (Ex.Exception)++--------------------------------------------------------------------------------++sqlDataColumnType :: S.SQLData -> S.ColumnType+sqlDataColumnType = \case+ S.SQLInteger _ -> S.IntegerColumn+ S.SQLFloat _ -> S.FloatColumn+ S.SQLText _ -> S.TextColumn+ S.SQLBlob _ -> S.BlobColumn+ S.SQLNull -> S.NullColumn++--------------------------------------------------------------------------------++-- | A convenience function for refining a 'Decode'r through a function that+-- may fail with a 'String' error message. The 'CallStack' is preserved.+--+-- If you need a more sophisticated refinement, use the 'Decode' constructor.+decodeRefine+ :: (HasCallStack)+ => (a -> Either String b)+ -> Decode a+ -> Decode b+decodeRefine f (Decode g) = Decode \raw -> do+ a <- g raw+ case f a of+ Right b -> Right b+ Left s -> first ErrDecode_Fail (Ex.throwString s)++--------------------------------------------------------------------------------+-- Core decodes++-- | Default way to decode a SQLite value into a Haskell value of type @a@.+--+-- If there there exist also a 'Sq.EncodeDefault' instance for @a@, then it+-- must roundtrip with the 'Sq.DecodeDefault' instance for @a@.+class DecodeDefault a where+ -- | Default way to decode a SQLite value into a Haskell value of type @a@.+ decodeDefault :: Decode a++-- | Literal 'S.SQLData' 'Decode'.+instance DecodeDefault S.SQLData where+ decodeDefault = Decode Right+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn'.+instance DecodeDefault Int64 where+ decodeDefault = Decode \case+ S.SQLInteger x -> Right x+ x -> Left $ ErrDecode_Type (sqlDataColumnType x) [S.IntegerColumn]++-- | 'S.FloatColumn'.+instance DecodeDefault Double where+ decodeDefault = Decode \case+ S.SQLFloat x -> Right x+ x -> Left $ ErrDecode_Type (sqlDataColumnType x) [S.FloatColumn]++-- | 'S.TextColumn'.+instance DecodeDefault T.Text where+ decodeDefault = Decode \case+ S.SQLText x -> Right x+ x -> Left $ ErrDecode_Type (sqlDataColumnType x) [S.TextColumn]++-- | 'S.BlobColumn'.+instance DecodeDefault B.ByteString where+ decodeDefault = Decode \case+ S.SQLBlob x -> Right x+ x -> Left $ ErrDecode_Type (sqlDataColumnType x) [S.BlobColumn]++-- | 'S.NullColumn'.+instance DecodeDefault Null where+ decodeDefault = Decode \case+ S.SQLNull -> Right mempty+ x -> Left $ ErrDecode_Type (sqlDataColumnType x) [S.NullColumn]++--------------------------------------------------------------------------------+-- Extra decodes++-- | 'S.TextColumn'.+instance DecodeDefault TL.Text where+ decodeDefault = TL.fromStrict <$> decodeDefault+ {-# INLINE decodeDefault #-}++-- | 'S.TextColumn'.+instance DecodeDefault Char where+ decodeDefault = flip decodeRefine decodeDefault \t ->+ if T.length t == 1+ then Right (T.unsafeHead t)+ else Left "Expected single character string"++-- | 'S.TextColumn'.+instance DecodeDefault String where+ decodeDefault = T.unpack <$> decodeDefault+ {-# INLINE decodeDefault #-}++-- | 'S.BlobColumn'.+instance DecodeDefault BL.ByteString where+ decodeDefault = BL.fromStrict <$> decodeDefault+ {-# INLINE decodeDefault #-}++-- | See 'decodeMaybe'.+instance (DecodeDefault a) => DecodeDefault (Maybe a) where+ decodeDefault = decodeMaybe decodeDefault+ {-# INLINE decodeDefault #-}++-- | Attempt to decode @a@ first, otherwise attempt decode+-- a 'S.NullColumn' as 'Nothing'.+decodeMaybe :: Decode a -> Decode (Maybe a)+decodeMaybe da = fmap Just da <|> fmap (\_ -> Nothing) (decodeDefault @Null)+{-# INLINE decodeMaybe #-}++-- | See 'decodeEither'.+instance+ (DecodeDefault a, DecodeDefault b)+ => DecodeDefault (Either a b)+ where+ decodeDefault = decodeEither decodeDefault decodeDefault+ {-# INLINE decodeDefault #-}++-- | @+-- 'decodeEither' da db = fmap 'Left' da '<|>' fmap 'Right' db+-- @+decodeEither :: Decode a -> Decode b -> Decode (Either a b)+decodeEither da db = fmap Left da <|> fmap Right db+{-# INLINE decodeEither #-}++-- | 'S.IntegerColumn', 'S.FloatColumn', 'S.TextColumn'+-- depicting a literal integer.+instance DecodeDefault Integer where+ decodeDefault = Decode \case+ S.SQLInteger i -> Right (fromIntegral i)+ S.SQLFloat d+ | not (isNaN d || isInfinite d)+ , (i, 0) <- properFraction d ->+ Right i+ | otherwise -> first ErrDecode_Fail do+ Ex.throwString "Not an integer"+ S.SQLText t+ | Just i <- readMaybe (T.unpack t) -> Right i+ | otherwise -> first ErrDecode_Fail do+ Ex.throwString "Not an integer"+ x -> Left $ ErrDecode_Type (sqlDataColumnType x) do+ [S.IntegerColumn, S.FloatColumn, S.TextColumn]++-- | 'S.IntegerColumn'.+decodeSizedIntegral :: (Integral a, Bits a) => Decode a+decodeSizedIntegral = do+ i <- decodeDefault @Integer+ case toIntegralSized i of+ Just a -> pure a+ Nothing -> fail "Integral overflow or underflow"++-- | 'S.IntegerColumn'.+instance DecodeDefault Int8 where+ decodeDefault = decodeSizedIntegral+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn'.+instance DecodeDefault Word8 where+ decodeDefault = decodeSizedIntegral+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn'.+instance DecodeDefault Int16 where+ decodeDefault = decodeSizedIntegral+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn'.+instance DecodeDefault Word16 where+ decodeDefault = decodeSizedIntegral+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn'.+instance DecodeDefault Int32 where+ decodeDefault = decodeSizedIntegral+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn'.+instance DecodeDefault Word32 where+ decodeDefault = decodeSizedIntegral+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.+instance DecodeDefault Word where+ decodeDefault = decodeSizedIntegral+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.+instance DecodeDefault Word64 where+ decodeDefault = decodeSizedIntegral+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn'.+instance DecodeDefault Int where+ decodeDefault =+ caseWordSize_32_64+ decodeSizedIntegral+ (fromIntegral <$> decodeDefault @Int64)+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.+instance DecodeDefault Natural where+ decodeDefault = decodeSizedIntegral+ {-# INLINE decodeDefault #-}++-- | 'S.IntegerColumn' and 'S.FloatColumn' only.+--+-- @0@ is 'False', every other number is 'True'.+instance DecodeDefault Bool where+ decodeDefault = Decode \case+ S.SQLInteger x -> Right (x /= 0)+ S.SQLFloat x -> Right (x /= 0)+ x ->+ Left $+ ErrDecode_Type+ (sqlDataColumnType x)+ [S.IntegerColumn, S.FloatColumn]++-- | Like for 'Time.ZonedTime'.+instance DecodeDefault Time.UTCTime where+ decodeDefault = Time.zonedTimeToUTC <$> decodeDefault+ {-# INLINE decodeDefault #-}++-- | 'S.TextColumn' ('Time.ISO8601', or seconds since Epoch with optional decimal+-- part of up to picosecond precission), or 'S.Integer' (seconds since Epoch).+--+-- TODO: Currently precission over picoseconds is successfully parsed but+-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.+instance DecodeDefault Time.ZonedTime where+ decodeDefault = Decode \case+ S.SQLText (T.unpack -> s)+ | Just zt <- Time.iso8601ParseM s -> Right zt+ | Just u <- Time.iso8601ParseM s ->+ Right $ Time.utcToZonedTime Time.utc u+ | Just u <- Time.parseTimeM False Time.defaultTimeLocale "%s%Q" s ->+ Right $ Time.utcToZonedTime Time.utc u+ | otherwise -> first ErrDecode_Fail do+ Ex.throwString $ "Invalid timestamp: " <> show s+ S.SQLInteger i ->+ Right $+ Time.utcToZonedTime Time.utc $+ Time.posixSecondsToUTCTime $+ fromIntegral i+ x ->+ Left $+ ErrDecode_Type+ (sqlDataColumnType x)+ [S.IntegerColumn, S.TextColumn]++-- | 'Time.ISO8601' in a @'S.TextColumn'.+instance DecodeDefault Time.LocalTime where+ decodeDefault = decodeDefault >>= Time.iso8601ParseM+ {-# INLINE decodeDefault #-}++-- | 'Time.ISO8601' in a @'S.TextColumn'.+instance DecodeDefault Time.Day where+ decodeDefault = decodeDefault >>= Time.iso8601ParseM+ {-# INLINE decodeDefault #-}++-- | 'Time.ISO8601' in a @'S.TextColumn'.+--+-- TODO: Currently precission over picoseconds is successfully parsed but+-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.+instance DecodeDefault Time.TimeOfDay where+ decodeDefault = decodeDefault >>= Time.iso8601ParseM+ {-# INLINE decodeDefault #-}++-- | 'Time.ISO8601' in a @'S.TextColumn'.+--+-- TODO: Currently precission over picoseconds is successfully parsed but+-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.+instance DecodeDefault Time.CalendarDiffDays where+ decodeDefault = decodeDefault >>= Time.iso8601ParseM+ {-# INLINE decodeDefault #-}++-- | 'Time.ISO8601' in a @'S.TextColumn'.+--+-- TODO: Currently precission over picoseconds is successfully parsed but+-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.+instance DecodeDefault Time.CalendarDiffTime where+ decodeDefault = decodeDefault >>= Time.iso8601ParseM+ {-# INLINE decodeDefault #-}++-- | 'Time.ISO8601' in a @'S.TextColumn'.+instance DecodeDefault Time.TimeZone where+ decodeDefault = decodeDefault >>= Time.iso8601ParseM+ {-# INLINE decodeDefault #-}++-- | 'S.FloatColumn'.+instance DecodeDefault Float where+ decodeDefault = flip decodeRefine decodeDefault \d -> do+ let f = double2Float d+ if float2Double f == d+ then Right f+ else Left "Lossy conversion from Double to Float"++--------------------------------------------------------------------------------++-- | 'S.BlobColumn'.+decodeBinary :: Bin.Get a -> Decode a+decodeBinary ga = flip decodeRefine (decodeDefault @BL.ByteString) \bl ->+ case Bin.runGetOrFail ga bl of+ Right (_, _, a) -> Right a+ Left (_, _, s) -> Left s++-- | 'S.TextColumn'.+decodeRead :: (Prelude.Read a) => Decode a+decodeRead = decodeRefine readEither (decodeDefault @String)+{-# INLINE decodeRead #-}++-- | 'S.TextColumn'.+decodeAeson :: forall a. (Ae.Value -> Ae.Parser a) -> Decode a+decodeAeson p =+ decodeRefine+ (Ae.eitherDecodeStrictText >=> Ae.parseEither p)+ (decodeDefault @T.Text)+{-# INLINE decodeAeson #-}
+ lib/Sq/Encoders.hs view
@@ -0,0 +1,382 @@+module Sq.Encoders+ ( Encode (..)+ , ErrEncode (..)+ , encodeRefine+ , EncodeDefault (..)+ , encodeMaybe+ , encodeEither+ , encodeSizedIntegral+ , encodeBinary+ , encodeShow+ , encodeAeson+ )+where++import Control.Exception.Safe qualified as Ex+import Data.Aeson qualified as Ae+import Data.Aeson.Text qualified as Ae+import Data.Bifunctor+import Data.Binary.Put qualified as Bin+import Data.Bits+import Data.Bool+import Data.ByteString qualified as B+import Data.ByteString.Builder qualified as BB+import Data.ByteString.Lazy qualified as BL+import Data.ByteString.Short qualified as BS+import Data.Coerce+import Data.Functor.Contravariant+import Data.Int+import Data.List qualified as List+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Data.Time qualified as Time+import Data.Time.Format.ISO8601 qualified as Time+import Data.Void+import Data.Word+import Database.SQLite3 qualified as S+import GHC.Float (float2Double)+import GHC.Stack+import Numeric.Natural++import Sq.Null (Null)++--------------------------------------------------------------------------------++-- | How to encode a single Haskell value of type @a@ into a SQLite value.+newtype Encode a+ = -- | Encode a value of type @a@ as 'S.SQLData'.+ --+ -- Ideally, the type @a@ should be small enough that this function always+ -- returns 'Right'. However, that can sometimes be annoying, so we allow+ -- this function to fail with 'ErrEncode' if necessary, in which case an+ -- 'Sq.ErrInput' exception will be eventually thrown while trying to bind the+ -- relevant 'Sq.Input' to a 'Statement'. Why? Because for example, not all+ -- 'String's can be safely encoded as a 'S.SQLText' seeing as some+ -- non-unicode characters will silently be lost in the conversion. So, we+ -- could either not have an 'Encode'r for 'String' at all, which would be+ -- annoying, or we could have 'ErrEncode' as we do here in order to safely+ -- deal with those obscure corner cases.+ Encode (a -> Either ErrEncode S.SQLData)+ deriving (Contravariant) via Op (Either ErrEncode S.SQLData)++unEncode :: Encode a -> a -> Either ErrEncode S.SQLData+unEncode = coerce+{-# INLINE unEncode #-}++-- | See v'Encode'.+newtype ErrEncode = ErrEncode Ex.SomeException+ deriving stock (Show)+ deriving anyclass (Ex.Exception)++--------------------------------------------------------------------------------++-- | Default way to encode a Haskell value of type @a@ into a single+-- SQLite column value.+--+-- If there there exist also a 'Sq.DecodeDefault' instance for @a@, then it+-- must roundtrip with the 'Sq.EncodeDefault' instance for @a@.+class EncodeDefault a where+ -- | Default way to encode a Haskell value of type @a@ into a single+ -- SQLite column value.+ encodeDefault :: (HasCallStack) => Encode a++-- | A convenience function for refining an 'Encode'r through a function that+-- may fail with a 'String' error message. The 'CallStack' is preserved.+--+-- If you need a more sophisticated refinement, use the 'Encode' constructor.+encodeRefine+ :: (HasCallStack)+ => (a -> Either String b)+ -> Encode b+ -> Encode a+encodeRefine f (Encode g) = Encode \a ->+ case f a of+ Right b -> g b+ Left e -> first ErrEncode (Ex.throwString e)++--------------------------------------------------------------------------------+-- Core encodes++-- | Literal 'S.SQLData' 'Encode'.+instance EncodeDefault S.SQLData where+ encodeDefault = Encode Right+ {-# INLINE encodeDefault #-}++-- | 'S.TextColumn'.+instance EncodeDefault T.Text where+ encodeDefault = S.SQLText >$< encodeDefault+ {-# INLINE encodeDefault #-}++{- TODO avoid encoding '\000' ?++ encodeDefault = Encode \t ->+ case T.elem '\000' t of+ False -> Right $ S.SQLText t+ True ->+ first ErrEncode $+ Ex.throwString ("Invalid character " <> show '\000' <> " in " <> show t)+-}++-- | 'S.IntegerColumn'.+instance EncodeDefault Int64 where+ encodeDefault = S.SQLInteger >$< encodeDefault+ {-# INLINE encodeDefault #-}++-- | 'S.FloatColumn'.+instance EncodeDefault Double where+ encodeDefault = S.SQLFloat >$< encodeDefault+ {-# INLINE encodeDefault #-}++-- | 'S.BlobColumn'.+instance EncodeDefault B.ByteString where+ encodeDefault = S.SQLBlob >$< encodeDefault+ {-# INLINE encodeDefault #-}++-- | 'S.NullColumn'.+instance EncodeDefault Null where+ encodeDefault = const S.SQLNull >$< encodeDefault+ {-# INLINE encodeDefault #-}++--------------------------------------------------------------------------------+-- Extra encodes++-- | This is 'absurd'.+instance EncodeDefault Void where+ encodeDefault = Encode absurd++-- | See 'encodeMaybe'.+instance (EncodeDefault a) => EncodeDefault (Maybe a) where+ encodeDefault = encodeMaybe encodeDefault+ {-# INLINE encodeDefault #-}++-- | @a@'s 'S.ColumnType' if 'Just', otherwise 'S.NullColumn'.+encodeMaybe :: Encode a -> Encode (Maybe a)+encodeMaybe (Encode f) = Encode $ maybe (Right S.SQLNull) f+{-# INLINE encodeMaybe #-}++-- | See 'encodeEither'.+instance+ (EncodeDefault a, EncodeDefault b)+ => EncodeDefault (Either a b)+ where+ encodeDefault = encodeEither encodeDefault encodeDefault++-- | @a@'s 'S.ColumnType' if 'Left', otherwise @b@'s 'S.ColumnType'.+encodeEither :: Encode a -> Encode b -> Encode (Either a b)+encodeEither (Encode fa) (Encode fb) = Encode $ either fa fb+{-# INLINE encodeEither #-}++-- | 'S.IntegerColumn'. Encodes 'False' as @0@ and 'True' as @1@.+instance EncodeDefault Bool where+ encodeDefault = bool 0 1 >$< encodeDefault @Int64+ {-# INLINE encodeDefault #-}++-- | 'S.FloatColumn'.+instance EncodeDefault Float where+ encodeDefault = float2Double >$< encodeDefault+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn'.+instance EncodeDefault Int8 where+ encodeDefault = fromIntegral >$< encodeDefault @Int64+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn'.+instance EncodeDefault Word8 where+ encodeDefault = fromIntegral >$< encodeDefault @Int64+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn'.+instance EncodeDefault Int16 where+ encodeDefault = fromIntegral >$< encodeDefault @Int64+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn'.+instance EncodeDefault Word16 where+ encodeDefault = fromIntegral >$< encodeDefault @Int64+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn'.+instance EncodeDefault Int32 where+ encodeDefault = fromIntegral >$< encodeDefault @Int64+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn'.+instance EncodeDefault Word32 where+ encodeDefault = fromIntegral >$< encodeDefault @Int64+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn'.+instance EncodeDefault Int where+ encodeDefault = fromIntegral >$< encodeDefault @Int64+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.+instance EncodeDefault Word where+ encodeDefault = encodeSizedIntegral+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.+instance EncodeDefault Word64 where+ encodeDefault = encodeSizedIntegral+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.+instance EncodeDefault Integer where+ encodeDefault = encodeSizedIntegral+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.+instance EncodeDefault Natural where+ encodeDefault = encodeSizedIntegral+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.+encodeSizedIntegral :: (Integral a, Bits a, HasCallStack) => Encode a+encodeSizedIntegral = Encode \a ->+ case toIntegralSized a of+ Just i -> unEncode (encodeDefault @Int64) i+ Nothing -> unEncode (encodeDefault @String) (show (toInteger a))++-- | 'S.TextColumn'.+instance EncodeDefault TL.Text where+ encodeDefault = TL.toStrict >$< encodeDefault+ {-# INLINE encodeDefault #-}++-- | 'S.TextColumn'.+instance EncodeDefault TB.Builder where+ encodeDefault = TB.toLazyText >$< encodeDefault+ {-# INLINE encodeDefault #-}++-- | 'S.TextColumn'.+instance EncodeDefault Char where+ encodeDefault = pure >$< encodeDefault @String+ {-# INLINE encodeDefault #-}++-- | 'S.TextColumn'.+instance EncodeDefault String where+ encodeDefault = Encode \xc ->+ case List.find invalid xc of+ Nothing -> unEncode encodeDefault (T.pack xc)+ Just c ->+ first ErrEncode $+ Ex.throwString ("Invalid character " <> show c)+ where+ invalid :: Char -> Bool+ invalid = \c -> '\55296' <= c && c <= '\57343'++-- | 'S.BlobColumn'.+instance EncodeDefault BL.ByteString where+ encodeDefault = BL.toStrict >$< encodeDefault+ {-# INLINE encodeDefault #-}++-- | 'S.BlobColumn'.+instance EncodeDefault BS.ShortByteString where+ encodeDefault = BS.fromShort >$< encodeDefault+ {-# INLINE encodeDefault #-}++-- | 'S.BlobColumn'.+instance EncodeDefault BB.Builder where+ encodeDefault = BB.toLazyByteString >$< encodeDefault+ {-# INLINE encodeDefault #-}++-- | 'Time.ISO8601' in a @'S.TextColumn'.+--+-- @yyyy-mm-ddThh:mm:ss/[.ssssssssssss]/+00:00@+--+-- * Sorting these lexicographically in SQL corresponds to sorting them by time.+--+-- * __WARNING__: SQLite date and time functions support resolution only up to+-- milliseconds.+--+-- * __WARNING__: SQLite date and time functions don't support leap seconds.+instance EncodeDefault Time.UTCTime where+ encodeDefault = Time.utcToZonedTime Time.utc >$< encodeDefault++-- | 'Time.ISO8601' in a @'S.TextColumn'.+--+-- @yyyy-mm-ddThh:mm:ss/[.ssssssssssss]/±hh:mm@+--+-- * __WARNING__: Sorting these lexicographically in SQL won't work unless the+-- offset is always the same! Convert to 'Time.UTCTime' first.+--+-- * __WARNING__: SQLite date and time functions support resolution only up to+-- milliseconds.+--+-- * __WARNING__: SQLite date and time functions don't support leap seconds.+instance EncodeDefault Time.ZonedTime where+ encodeDefault = Time.iso8601Show >$< encodeDefault++-- | 'Time.ISO8601' in a @'S.TextColumn'.+--+-- @yyyy-mm-ddThh:mm:ss/[.ssssssssssss]/@+--+-- * Sorting these lexicographically in SQL corresponds to sorting them by time.+--+-- * __WARNING__: SQLite date and time functions support resolution only up to+-- milliseconds.+--+-- * __WARNING__: SQLite date and time functions don't support leap seconds.+instance EncodeDefault Time.LocalTime where+ encodeDefault = Time.iso8601Show >$< encodeDefault++-- | ISO-8601 in a @'S.TextColumn'.+--+-- @yyyy-mm-dd@+--+-- * Sorting these lexicographically in SQL corresponds to sorting them by time.+instance EncodeDefault Time.Day where+ encodeDefault = Time.iso8601Show >$< encodeDefault++-- | 'Time.ISO8601' in a @'S.TextColumn'.+--+-- @hh:mm:ss/[.ssssssssssss]/@+--+-- * Sorting these lexicographically in SQL corresponds to sorting them by time.+--+-- * __WARNING__: SQLite date and time functions support resolution only up to+-- milliseconds.+--+-- * __WARNING__: SQLite date and time functions don't support leap seconds.+instance EncodeDefault Time.TimeOfDay where+ encodeDefault = Time.iso8601Show >$< encodeDefault++-- | 'Time.ISO8601' in a @'S.TextColumn'.+--+-- @PyYmMdD@+instance EncodeDefault Time.CalendarDiffDays where+ encodeDefault = Time.iso8601Show >$< encodeDefault++-- | 'Time.ISO8601' in a @'S.TextColumn'.+--+-- @PyYmMdDThHmMs/[.ssssssssssss]/S@+--+-- * __WARNING__: SQLite date and time functions support resolution only up to+-- milliseconds.+instance EncodeDefault Time.CalendarDiffTime where+ encodeDefault = Time.iso8601Show >$< encodeDefault++-- | 'Time.ISO8601' in a @'S.TextColumn'.+--+-- @±hh:mm@+instance EncodeDefault Time.TimeZone where+ encodeDefault = Time.iso8601Show >$< encodeDefault+++--------------------------------------------------------------------------------++-- | 'S.BlobColumn'.+encodeBinary :: (a -> Bin.Put) -> Encode a+encodeBinary f = contramap (Bin.runPut . f) (encodeDefault @BL.ByteString)+{-# INLINE encodeBinary #-}++-- | 'S.TextColumn'.+encodeShow :: (Show a) => Encode a+encodeShow = show >$< (encodeDefault @String)+{-# INLINE encodeShow #-}++-- | Encodes as 'S.TextColumn'.+encodeAeson :: (a -> Ae.Value) -> Encode a+encodeAeson f = contramap (Ae.encodeToLazyText . f) (encodeDefault @TL.Text)+{-# INLINE encodeAeson #-}
+ lib/Sq/Input.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE StrictData #-}++module Sq.Input+ ( Input+ , runInput+ , encode+ , input+ , BoundInput+ , bindInput+ , ErrInput (..)+ , rawBoundInput+ ) where++import Control.DeepSeq+import Control.Exception.Safe qualified as Ex+import Data.Bifunctor+import Data.Coerce+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible+import Data.Map.Strict qualified as Map+import Data.String+import Data.Text qualified as T+import Database.SQLite3 qualified as S++import Sq.Encoders+import Sq.Names++--------------------------------------------------------------------------------++-- | How to encode all the input to a single 'Sq.Statement'.+--+-- * Construct with 'encode', 'IsString'.+--+-- * Nest with 'input'.+--+-- * Compose with 'Contravariant', 'Divisible', 'Decidable' and 'Monoid' tools.+newtype Input i = Input (i -> Map.Map BindingName (Either ErrEncode S.SQLData))+ deriving newtype+ ( Semigroup+ -- ^ Left-biased in case of overlapping 'BindingName's.+ , Monoid+ , NFData+ )+ deriving+ ( Contravariant+ , Divisible+ -- ^ Left-biased in case of overlapping 'BindingName's.+ , Decidable+ )+ via Op (Map.Map BindingName (Either ErrEncode S.SQLData))++runInput :: Input i -> i -> Map.Map BindingName (Either ErrEncode S.SQLData)+runInput = coerce+{-# INLINE runInput #-}++-- | Encode a single input parameter. The value will be reachable from the 'SQL'+-- query through the specified 'Name', with a @$@ prefix.+--+-- @+-- 'Sq.writeStatement'+-- ('encode' \"foo\" 'encodeDefault')+-- 'mempty'+-- \"INSERT INTO t (a) VALUES ($foo)\"+-- :: ('EncodeDefault' x)+-- => 'Sq.Statement' 'Sq.Write' x ()+-- @+--+-- Note that by design, this library doesn't support positional 'Input'+-- parameters. You must always pick a 'Name'.+--+-- Multiple 'Input's can be composed with 'Contravariant', 'Divisible', 'Decidable'+-- and 'Monoid' tools.+--+-- @+-- 'Sq.writeStatement'+-- ('divided' ('encode' \"foo\" 'encodeDefault')+-- ('encode' \"bar\" 'encodeDefault'))+-- 'mempty'+-- \"INSERT INTO t (a, b) VALUES ($foo, $bar)\"+-- :: ('EncodeDefault' x, 'EncodeDefault' y)+-- => 'Sq.Statement' 'Sq.Write' (x, y) ()+-- @+--+-- Pro-tip: Consider using the 'IsString' instance for 'Input'.+-- For example, @\"foo\"@ means @'encode' \"foo\" 'encodeDefault'@.+-- That is, the last example could be written as follows:+--+-- @+-- 'Sq.writeStatement'+-- ('divided' \"foo\" \"bar\")+-- 'mempty'+-- \"INSERT INTO t (a, b) VALUES ($foo, $bar)\"+-- :: ('EncodeDefault' x, 'EncodeDefault' y)+-- => 'Sq.Statement' 'Sq.Write' (x, y) ()+-- @+encode :: Name -> Encode i -> Input i+encode n (Encode f) = Input (Map.singleton (bindingName n) . f)+{-# INLINE encode #-}++-- | Add a prefix 'Name' to parameters names in the given 'Input',+-- separated by @\__@+--+-- This is useful for making reusable 'Input's. For example,+-- consider the following.+--+-- @+-- data Point = Point { x :: 'Int', y :: 'Int' }+--+-- pointInput :: 'Input' Point+-- pointInput = 'contramap' (\\case Point x _ -> x) \"x\" <>+-- 'contramap' (\\case Point _ y -> y) \"y\"+-- @+--+-- After 'input':+--+-- @+-- 'Sq.writeStatement'+-- ('divided' ('input' \"p1\" pointInput)+-- ('input' \"p2\" pointInput))+-- 'mempty'+-- ['Sq.sql'|+-- INSERT INTO vectors (ax, ay, bx, by)+-- VALUES ($p1\__x, $p1\__y, $p2\__x, $p2\__y) |]+-- :: 'Sq.Statement' 'Sq.Write' (Point, Point) ()+-- @+input :: Name -> Input i -> Input i+input n ba = Input \s ->+ Map.mapKeysMonotonic (bindingName n <>) (runInput ba s)+{-# INLINE input #-}++-- |+-- @+-- 'Sq.writeStatement'+-- \"a\"+-- 'mempty'+-- \"INSERT INTO t (x) VALUES ($a)\"+-- :: ('EncodeDefault' a)+-- => 'Sq.Statement' 'Sq.Write' a ()+-- @+instance (EncodeDefault i) => IsString (Input i) where+ fromString s = encode (fromString s) encodeDefault+ {-# INLINE fromString #-}++--------------------------------------------------------------------------------++newtype BoundInput = BoundInput (Map.Map T.Text S.SQLData)+ deriving newtype (Eq, Show)++bindInput :: Input i -> i -> Either ErrInput BoundInput+bindInput ii i = do+ !m <-+ Map.mapKeysMonotonic renderInputBindingName+ <$> Map.traverseWithKey (first . ErrInput) (runInput ii i)+ pure $ BoundInput m++-- | See v'Encode'.+data ErrInput = ErrInput BindingName ErrEncode+ deriving stock (Show)+ deriving anyclass (Ex.Exception)++rawBoundInput :: BoundInput -> Map.Map T.Text S.SQLData+rawBoundInput = coerce+{-# INLINE rawBoundInput #-}
+ lib/Sq/Mode.hs view
@@ -0,0 +1,67 @@+module Sq.Mode+ ( -- * Mode+ Mode (..)+ , SMode (..)+ , fromSMode++ -- * Constraints+ , SubMode+ ) where++import Di.Df1 qualified as Di+import GHC.TypeLits qualified as GHC+import Prelude hiding (Read)++--------------------------------------------------------------------------------++data Mode+ = -- | * A @'Sq.Statement' \''Read'@ performs a read-only query.+ -- Obtain with 'Sq.readStatement'.+ --+ -- * A @'Sq.Transaction' \''Read'@ can permorm \''Read'+ -- 'Sq.Statement's only. Obtain with 'Sq.readTransaction'.+ --+ -- * A @'Sq.Pool' \''Read'@ can permorm \''Read' 'Sq.Transaction's only.+ -- Obtain with 'Sq.readPool' or 'Sq.subPool'.+ Read+ | -- | * A @'Sq.Statement' \''Write'@ performs a read or write query.+ -- Obtain with 'Sq.writeStatement'.+ --+ -- * A @'Sq.Transaction' \''Write'@ can permorm both \''Read' and+ -- \''Write' 'Sq.Statement's. Obtain with 'Sq.commitTransaction' or+ -- 'Sq.rollbackTransaction'.+ --+ -- * A @'Sq.Pool' \''Write'@ can permorm both \''Read' and \''Write'+ -- 'Sq.Transaction's. Obtain with 'Sq.writePool' or 'Sq.tempPool'.+ Write+ deriving stock (Eq, Ord, Show)++data SMode (mode :: Mode) where+ SRead :: SMode 'Read+ SWrite :: SMode 'Write++fromSMode :: SMode mode -> Mode+fromSMode = \case+ SRead -> Read+ SWrite -> Write+{-# INLINE fromSMode #-}++instance Di.ToValue Mode where+ value = \case+ Read -> "read"+ Write -> "write"+ {-# INLINE value #-}++instance Di.ToValue (SMode mode) where+ value = Di.value . fromSMode+ {-# INLINE value #-}++--------------------------------------------------------------------------------++class SubMode (sup :: Mode) (sub :: Mode)+instance SubMode Read Read+instance SubMode Write Read+instance SubMode Write Write+instance+ (GHC.TypeError (GHC.Text "Write mode is not a subset of Read mode"))+ => SubMode Read Write
+ lib/Sq/Names.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE StrictData #-}++module Sq.Names+ ( Name+ , name+ , BindingName+ , bindingName+ , renderInputBindingName+ , parseInputBindingName+ , renderOutputBindingName+ , parseOutputBindingName+ ) where++import Control.Applicative+import Control.DeepSeq+import Control.Monad+import Data.List.NonEmpty (NonEmpty(..))+import Data.Attoparsec.Text qualified as AT+import Data.Char qualified as Ch+import Data.Coerce+import Data.String+import Data.Text qualified as T+import GHC.Records++--------------------------------------------------------------------------------++-- | Part of a binding name suitable to use with 'Sq.encode', 'Sq.decode',+-- 'Sq.input' and 'Sq.output'.+--+-- Construct with 'name' or 'IsString'.+newtype Name = Name T.Text+ deriving newtype (Eq, Ord, Show, NFData)++instance IsString Name where+ fromString = either error id . name . T.pack++instance HasField "text" Name T.Text where getField = coerce++-- | * First character must be ASCII letter.+--+-- * Last character, if any, must be ASCII letter or ASCII digit.+--+-- * Characters between the first and last, if any, must be ASCII letters,+-- ASCII digits, or underscore.+name :: T.Text -> Either String Name+name = AT.parseOnly (pName <* AT.endOfInput)++pName :: AT.Parser Name+pName = flip (AT.<?>) "pName" do+ c1 <- AT.satisfy pw+ cs <- ptail+ pure $ Name $ T.pack (c1 : cs)+ where+ pw = \c -> Ch.isAsciiLower c || Ch.isAsciiUpper c+ ptail = many do+ AT.satisfy pw+ <|> AT.satisfy Ch.isDigit+ <|> (AT.char '_' <* (AT.peekChar' >>= \c -> guard (c /= '_')))++--------------------------------------------------------------------------------++-- | A non-empty list of 'Name's that can be rendered as 'Sq.Input' or+-- 'Sq.Output' parameters in a 'Sq.Statement'.+--+-- As a user of "Sq", you never construct a 'BindingName' manually. Rather,+-- uses of 'Sq.input' and 'Sq.output' build one for you from its 'Name'+-- constituents. 'BindingName's are only exposed to you through 'Sq.ErrInput',+-- 'Sq.ErrOutput' and 'Sq.ErrStatement'.+newtype BindingName = BindingName (NonEmpty Name)+ deriving newtype (Eq, Ord, Show, NFData, Semigroup)++bindingName :: Name -> BindingName+bindingName = BindingName . pure++--------------------------------------------------------------------------------++-- | @foo__bar3__the_thing@+renderInputBindingName :: BindingName -> T.Text+renderInputBindingName = T.cons '$' . renderOutputBindingName++parseInputBindingName :: T.Text -> Either String BindingName+parseInputBindingName = AT.parseOnly (pInputBindingName <* AT.endOfInput)++pInputBindingName :: AT.Parser BindingName+pInputBindingName = flip (AT.<?>) "pInputBindingName" do+ void $ AT.char '$'+ AT.sepBy' pName "__" >>= \case+ n : ns -> pure $ BindingName (n :| ns)+ [] -> empty++-- | @foo__bar3__the_thing@+renderOutputBindingName :: BindingName -> T.Text+renderOutputBindingName (BindingName (n :| ns)) =+ T.intercalate "__" $ fmap (.text) (n : ns)++-- | @foo__bar3__the_thing@+parseOutputBindingName :: T.Text -> Either String BindingName+parseOutputBindingName = AT.parseOnly (pOutputBindingName <* AT.endOfInput)++pOutputBindingName :: AT.Parser BindingName+pOutputBindingName = flip (AT.<?>) "pOutputBindingName" do+ AT.sepBy' pName "__" >>= \case+ n : ns -> pure $ BindingName (n :| ns)+ [] -> empty
+ lib/Sq/Null.hs view
@@ -0,0 +1,17 @@+module Sq.Null (Null (..)) where++-- | The @NULL@ SQL datatype.+--+-- Mostly useful if you want to encode or decode a literal @NULL@ value+-- through 'Sq.EncodeDefault' and 'Sq.DecodeDefault' instances.+--+-- However, often you can benefit from 'Sq.encodeMaybe' and 'Sq.decodeMaybe'+-- instead.+data Null = Null+ deriving stock (Eq, Ord, Show)++instance Semigroup Null where+ _ <> _ = Null++instance Monoid Null where+ mempty = Null
+ lib/Sq/Output.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE StrictData #-}++module Sq.Output+ ( Output+ , ErrOutput (..)+ , decode+ , runOutput+ , output+ ) where++import Control.Applicative+import Control.Exception.Safe qualified as Ex+import Control.Monad+import Control.Monad.Trans.Resource qualified as R hiding (runResourceT)+import Data.String+import Database.SQLite3 qualified as S++import Sq.Decoders+import Sq.Names++--------------------------------------------------------------------------------++-- | How to decode an output row from a single 'Sq.Statement'.+--+-- * Construct with 'decode', 'IsString'.+--+-- * Nest with 'output'.+--+-- * Compose with 'Monoid', 'Functor', 'Applicative', 'Alternative', 'Monad',+-- 'MonadPlus', 'MonadFail' and 'Ex.MonadThrow' tools.+data Output o+ = Output_Pure o+ | Output_Fail Ex.SomeException+ | Output_Decode BindingName (Decode (Output o))++data ErrOutput+ = -- | Error from v'Decode'.+ ErrOutput_ColumnValue BindingName ErrDecode+ | -- | Missing column name in the raw 'SQL'.+ ErrOutput_ColumnMissing BindingName+ | -- | Error from 'Ex.MonadThrow'.+ ErrOutput_Fail Ex.SomeException+ deriving stock (Show)+ deriving anyclass (Ex.Exception)++-- | Decode the column with the given 'Name'.+--+-- @+-- 'Sq.readStatement'+-- 'mempty'+-- ('decode' \"foo\" 'decodeDefault')+-- \"SELECT foo FROM t\"+-- :: ('DecodeDefault' x)+-- => 'Sq.Statement' 'Sq.Read' () x+-- @+--+-- Note that by design, this library doesn't support positional 'Output'+-- parameters. You must always pick a 'Name'. In the raw SQL, you can use @AS@+-- to rename your output columns as necessary.+--+-- @+-- 'Sq.readStatement'+-- 'mempty'+-- ('decode' \"abc\" 'decodeDefault')+-- \"SELECT foo AS abc FROM t\"+-- :: ('DecodeDefault' x)+-- => 'Sq.Statement' 'Sq.Read' () x+-- @+--+-- Multiple 'Outputs's can be composed with 'Monoid', 'Functor', 'Applicative',+-- 'Alternative', 'Monad', 'MonadPlus', 'MonadFail' and 'Ex.MonadThrow' tools.+--+-- @+-- 'Sq.readStatement'+-- 'mempty'+-- (do foo <- 'decode' \"foo\" 'decodeDefault'+-- 'when' (foo > 10) do+-- 'fail' \"Oh no!"+-- bar <- 'decode' \"bar\" 'decodeDefault'+-- 'pure' (foo, bar))+-- \"SELECT foo, bar FROM t\"+-- :: ('DecodeDefault' y)+-- => 'Sq.Statement' 'Sq.Read' () ('Int', y)+-- @+--+-- Pro-tip: Consider using the 'IsString' instance for 'Output',+-- where for example @\"foo\"@ means @'decode' \"foo\" 'decodeDefault'@:+--+-- @+-- 'Sq.readStatement'+-- ('liftA2' (,) \"foo\" \"bar\")+-- 'mempty'+-- \"SELECT foo, bar FROM t\"+-- :: ('DecodeDefault' x, 'DecodeDefault' y)+-- => 'Sq.Statement' 'Sq.Read' () (x, y)+-- @+decode :: Name -> Decode o -> Output o+decode n vda = Output_Decode (bindingName n) (Output_Pure <$> vda)+{-# INLINE decode #-}++-- | Add a prefix 'Name' to column names in the given 'Output',+-- separated by @\__@+--+-- This is useful for making reusable 'Output's. For example,+-- consider the following.+--+-- @+-- data Point = Point { x :: 'Int', y :: 'Int' }+--+-- pointOutput :: 'Output' Point+-- pointOutput = Point '<$>' \"x\" '<*>' \"y\"+-- @+--+-- After using 'output':+--+-- @+-- 'Sq.readStatement'+-- 'mempty'+-- ('liftA2' ('output' \"p1\" pointInput)+-- ('output' \"p2\" pointInput))+-- ['Sq.sql'|+-- SELECT ax AS p1\__x, ay AS p1\__y,+-- bx AS p2\__x, by AS p2\__y+-- FROM vectors|]+-- :: 'Sq.Statement' 'Sq.Read' () (Point, Point)+-- @+output :: Name -> Output o -> Output o+output n = \case+ Output_Decode bn d ->+ Output_Decode (bindingName n <> bn) (output n <$> d)+ o -> o++-- | TODO cache names after lookup. Important for Alternative.+runOutput+ :: (Monad m)+ => (BindingName -> m (Maybe S.SQLData))+ -> Output o+ -> m (Either ErrOutput o)+runOutput f = \case+ Output_Decode bn (Decode vda) -> do+ f bn >>= \case+ Just s -> case vda s of+ Right d -> runOutput f d+ Left e -> pure $ Left $ ErrOutput_ColumnValue bn e+ Nothing -> pure $ Left $ ErrOutput_ColumnMissing bn+ Output_Pure a -> pure $ Right a+ Output_Fail e -> pure $ Left $ ErrOutput_Fail e++instance Functor Output where+ fmap = liftA+ {-# INLINE fmap #-}++instance Applicative Output where+ pure = Output_Pure+ {-# INLINE pure #-}+ liftA2 = liftM2+ {-# INLINE liftA2 #-}++instance Alternative Output where+ empty = fail "empty"+ {-# INLINE empty #-}+ l <|> r = case l of+ Output_Decode n vda ->+ Output_Decode n (fmap (<|> r) vda)+ Output_Pure _ -> l+ Output_Fail _ -> r++instance MonadPlus Output where+ mzero = fail "mzero"+ {-# INLINE mzero #-}+ mplus = (<|>)+ {-# INLINE mplus #-}++instance Monad Output where+ l >>= k = case l of+ Output_Decode n vda ->+ Output_Decode n (fmap (>>= k) vda)+ Output_Pure a -> k a+ Output_Fail e -> Output_Fail e++instance Ex.MonadThrow Output where+ throwM = Output_Fail . Ex.toException++instance MonadFail Output where+ fail = Ex.throwString++instance (Semigroup o) => Semigroup (Output o) where+ (<>) = liftA2 (<>)+ {-# INLINE (<>) #-}++instance (Monoid o) => Monoid (Output o) where+ mempty = pure mempty+ {-# INLINE mempty #-}++instance (DecodeDefault i) => IsString (Output i) where+ fromString s = decode (fromString s) decodeDefault+ {-# INLINE fromString #-}
+ lib/Sq/Pool.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoFieldSelectors #-}++module Sq.Pool+ ( Pool+ , pool+ , subPool+ , readTransaction+ , commitTransaction+ , rollbackTransaction+ )+where++import Control.Concurrent+import Control.DeepSeq+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.Acquire qualified as A+import Data.Acquire.Internal qualified as A+import Data.Pool qualified as P+import Data.Word+import Di.Df1 qualified as Di+import GHC.Records+import Prelude hiding (Read, log, read)++import Sq.Connection+import Sq.Mode+import Sq.Support++--------------------------------------------------------------------------------++newtype PoolId = PoolId Word64+ deriving newtype (Eq, Ord, Show, NFData, Di.ToValue)++newPoolId :: (MonadIO m) => m PoolId+newPoolId = PoolId <$> newUnique++--------------------------------------------------------------------------------++-- | Pool of connections to a SQLite database.+--+-- * @p@ indicates whether 'Read'-only or read-'Write' 'Statement's are+-- supported by this 'Pool'.+--+-- * Obtain with 'Sq.readPool', 'Sq.writePool' or 'Sq.tempPool'.+--+-- * It's safe and efficient to use a 'Pool' concurrently as is.+-- Concurrency is handled internally.+data Pool (p :: Mode) where+ Pool_Read+ :: PoolId+ -> P.Pool (A.Allocated (Connection Read))+ -> Pool Read+ Pool_Write+ :: PoolId+ -> Connection Write+ -> P.Pool (A.Allocated (Connection Read))+ -> Pool Write++-- | Use 'subPool' to obtain the 'Read'-only subset from a read-'Write' 'Pool'.+--+-- * Useful if you are passing the 'Pool' as an argument to some code,+-- and you want to ensure that it can't performs 'Write' operations on it.+--+-- * The “new” 'Pool' is not new. It shares all the underlying resources with the+-- original one, including their lifetime.+subPool :: Pool 'Write -> Pool 'Read+subPool (Pool_Write i _w r) =+ -- It's alright to "forget" about '_w' here. The original 'Write' pool+ -- is the one that deals with resource management, anyway.+ Pool_Read i r++instance NFData (Pool p) where+ rnf (Pool_Read !_ !_) = ()+ rnf (Pool_Write !_ a !_) = rnf a++instance HasField "id" (Pool p) PoolId where+ getField = \case+ Pool_Read x _ -> x+ Pool_Write x _ _ -> x++pool :: SMode p -> Di.Df1 -> Settings -> A.Acquire (Pool p)+pool smode di0 cs = do+ pId <- newPoolId+ let di1 = Di.attr "pool-mode" smode $ Di.attr "pool" pId di0+ ppcr <- ppoolConnRead di1+ case smode of+ SRead -> pure $ Pool_Read pId ppcr+ SWrite -> do+ cw <- connection SWrite di1 cs+ pure $ Pool_Write pId cw ppcr+ where+ ppoolConnRead+ :: Di.Df1 -> A.Acquire (P.Pool (A.Allocated (Connection Read)))+ ppoolConnRead di1 =+ R.acquire1+ ( \res -> do+ let A.Acquire f = connection SRead di1 cs+ maxResources <- max 8 <$> getNumCapabilities+ P.newPool $+ P.defaultPoolConfig+ (f res)+ (\(A.Allocated _ g) -> g A.ReleaseNormal)+ (60 {- timeout seconds -})+ maxResources+ )+ P.destroyAllResources++-- | Acquire a read-only transaction.+--+-- * You may need this function if you are using one of 'Sq.embed',+-- 'Sq.foldIO' or 'Sq.streamIO'. Otherwise, just use 'Sq.read'.+readTransaction :: Pool mode -> A.Acquire (Transaction 'Read)+readTransaction p = poolConnectionRead p >>= connectionReadTransaction++-- | Acquire a read-write transaction where changes are finally commited to+-- the database unless there is an unhandled exception during the transaction,+-- in which case they are rolled back.+--+-- * You may need this function if you are using one of 'Sq.embed',+-- 'Sq.foldIO' or 'Sq.streamIO'. Otherwise, just use 'Sq.commit'.+commitTransaction :: Pool Write -> A.Acquire (Transaction 'Write)+commitTransaction (Pool_Write _ c _) = connectionWriteTransaction True c++-- | Acquire a read-write transaction where changes are always rolled back.+-- This is mostly useful for testing purposes.+--+-- * You may need this function if you are using one of 'Sq.embed',+-- 'Sq.foldIO' or 'Sq.streamIO'. Otherwise, just use 'Sq.commit'.+--+-- * An equivalent behavior can be achieved by+-- 'Control.Exception.Safe.bracket'ing changes between 'Sq.savepoint' and+-- 'Sq.rollbackTo' in a 'commitTransaction'ting transaction. Or by using+-- 'Ex.throwM' and 'Ex.catch' within 'Transactional'. However, using a+-- 'rollbackTransaction' is much faster than using 'Sq.Savepoint's.+rollbackTransaction :: Pool Write -> A.Acquire (Transaction 'Write)+rollbackTransaction (Pool_Write _ c _) = connectionWriteTransaction False c++poolConnectionRead :: Pool mode -> A.Acquire (Connection Read)+poolConnectionRead p = do+ let ppr = case p of Pool_Write _ _ x -> x; Pool_Read _ x -> x+ tid <- flip R.mkAcquire1 killThread $ forkIO $ forever do+ threadDelay 10_000_000+ putStrLn "Waited 10 seconds to acquire a database connection from the pool"+ fmap (\(A.Allocated c _, _) -> c) do+ R.mkAcquireType1+ (P.takeResource ppr <* killThread tid)+ \(a@(A.Allocated _ rel), lp) t -> case t of+ A.ReleaseExceptionWith _ ->+ rel t `Ex.finally` P.destroyResource ppr lp a+ _ -> P.putResource lp a
+ lib/Sq/Statement.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoFieldSelectors #-}++module Sq.Statement+ ( SQL+ , sql+ , Statement (..)+ , readStatement+ , writeStatement+ , BoundStatement (..)+ , bindStatement+ ) where++import Control.DeepSeq+import Control.Monad+import Data.Coerce+import Data.Functor.Contravariant+import Data.Profunctor+import Data.String+import Data.Text qualified as T+import Di.Df1 qualified as Di+import GHC.Records+import GHC.Show+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Prelude hiding (Read, log)++import Sq.Input+import Sq.Mode+import Sq.Output++--------------------------------------------------------------------------------++-- | Raw SQL string. Completely unchecked.+newtype SQL = SQL T.Text+ deriving newtype+ ( Eq+ , Ord+ , -- | Raw SQL string.+ Show+ , IsString+ , Semigroup+ , NFData+ )++instance Di.ToMessage SQL where+ message = Di.message . show++-- | Raw SQL string as 'T.Text'.+instance HasField "text" SQL T.Text where getField = coerce++-- | A 'QuasiQuoter' for raw SQL strings.+--+-- __WARNING:__ This doesn't check the validity of the SQL. It is offered simply+-- because writing multi-line strings in Haskell is otherwise very annoying.+sql :: QuasiQuoter+sql =+ QuasiQuoter+ { quoteExp = \s -> [|fromString @SQL s|]+ , quotePat = \_ -> fail "sql: No quotePat"+ , quoteType = \_ -> fail "sql: No quoteType"+ , quoteDec = \_ -> fail "sql: No quoteDec"+ }++--------------------------------------------------------------------------------++-- | * A SQL statement taking a value @i@ as input and producing rows of+-- @o@ values as output.+--+-- * @s@ indicates whether the statement is 'Read'-only or read-'Write'.+--+-- * Construct with 'readStatement' or 'writeStatement'.++-- Note: We don't export this constructor because 'readStatement' and+-- 'writeStatement' because it lead to better type inferrence, force users to+-- make a conscious choice about whether they are dealing with a 'Read' or+-- 'Write' statement, and prevent type system from accidentally inferring a+-- 'Write' mode for a 'Read' only statement, which would restrict its+-- usability.+data Statement (s :: Mode) i o = Statement+ { input :: Input i+ , output :: Output o+ , sql :: SQL+ }++instance Show (Statement s i o) where+ showsPrec n s =+ showParen (n >= appPrec1) $+ showString "Statement{sql = "+ . shows s.sql+ . showString ", input = .., output = ..}"++-- | Construct a 'Read'-only 'Statement'.+--+-- __WARNING__: This library doesn't __yet__ provide a safe way to construct+-- 'Statement's. You can potentially write anything in your 'SQL' string.+-- Don't do that.+--+-- * The 'SQL' must be read-only.+--+-- * The 'SQL' must contain a single statement.+--+-- * The 'SQL' must not contain any transaction nor savepoint management+-- statements.+readStatement :: Input i -> Output o -> SQL -> Statement 'Read i o+readStatement = Statement+{-# INLINE readStatement #-}++-- | Construct a 'Statement' that can only be executed as part of a 'Write'+-- 'Transaction'.+--+-- __WARNING__: This library doesn't __yet__ provide a safe way to construct+-- 'Statement's. You can potentially write anything in your 'SQL' string.+-- Don't do that.+--+-- * The 'SQL' must contain a single statement.+--+-- * The 'SQL' must not contain any transaction nor savepoint management+-- statements.+writeStatement :: Input i -> Output o -> SQL -> Statement 'Write i o+writeStatement = Statement+{-# INLINE writeStatement #-}++instance Functor (Statement s i) where+ fmap = rmap+ {-# INLINE fmap #-}++instance Profunctor (Statement s) where+ dimap f g (Statement i o s) = Statement (f >$< i) (g <$> o) s+ {-# INLINE dimap #-}++--------------------------------------------------------------------------------++data BoundStatement (s :: Mode) o = BoundStatement+ { input :: BoundInput+ , output :: Output o+ , sql :: SQL+ }++instance Show (BoundStatement s o) where+ showsPrec n s =+ showParen (n >= appPrec1) $+ showString "Statement{sql = "+ . shows s.sql+ . showString ", input = "+ . shows s.input+ . showString ", output = ..}"++bindStatement :: Statement s i o -> i -> Either ErrInput (BoundStatement s o)+bindStatement st i = do+ bi <- bindInput st.input i+ pure BoundStatement{input = bi, output = st.output, sql = st.sql}+{-# INLINE bindStatement #-}
+ lib/Sq/Support.hs view
@@ -0,0 +1,144 @@+module Sq.Support+ ( resourceVanishedWithCallStack+ , note+ , hushThrow+ , show'+ , newUnique+ , acquireTmpDir+ , releaseTypeException+ , manyTill1+ , foldPostmapM+ , foldList+ , foldNonEmptyM+ , foldMaybeM+ , foldZeroM+ , foldOneM+ ) where++import Control.Applicative+import Control.Exception.Safe qualified as Ex+import Control.Foldl qualified as F+import Control.Monad hiding (void)+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource.Extra qualified as R+import Data.Acquire qualified as A+import Data.Function+import Data.IORef+import Data.Int+import Data.List.NonEmpty qualified as NEL+import Data.String+import Data.Word+import GHC.IO.Exception+import GHC.Stack+import System.Directory+import System.FilePath+import System.IO.Error (isAlreadyExistsError)+import System.IO.Unsafe++--------------------------------------------------------------------------------++resourceVanishedWithCallStack :: (HasCallStack) => String -> IOError+resourceVanishedWithCallStack s =+ (userError s)+ { ioe_location = prettyCallStack (popCallStack callStack)+ , ioe_type = ResourceVanished+ }++note :: a -> Maybe b -> Either a b+note a = maybe (Left a) Right+{-# INLINE note #-}++hushThrow :: (Ex.Exception e, Ex.MonadThrow m) => Either e b -> m b+hushThrow = either Ex.throwM pure+{-# INLINE hushThrow #-}++show' :: forall b a. (IsString b, Show a) => a -> b+show' = fromString . show+{-# INLINE show' #-}++--------------------------------------------------------------------------------++-- | Generate a 'Word64' unique within this OS process.+--+-- If once per nanosecond, it will take 548 years to run out of unique 'Word64'+-- identifiers. Thus, we don't check whether for overflow.+newUnique :: (MonadIO m) => m Word64+newUnique = liftIO $ atomicModifyIORef' _iorefUnique \n -> (n + 1, n)++_iorefUnique :: IORef Word64+_iorefUnique = unsafePerformIO (newIORef 0)+{-# NOINLINE _iorefUnique #-}++--------------------------------------------------------------------------------++acquireTmpDir :: A.Acquire FilePath+acquireTmpDir = flip R.mkAcquire1 removeDirectoryRecursive do+ d0 <- getTemporaryDirectory+ fix $ \k -> do+ u <- newUnique+ let d1 = d0 </> "sq.tmp." <> show u+ Ex.catchJust+ (guard . isAlreadyExistsError)+ (d1 <$ createDirectory d1)+ (const k)++releaseTypeException :: A.ReleaseType -> Maybe Ex.SomeException+releaseTypeException = \case+ A.ReleaseNormal -> Nothing+ A.ReleaseEarly -> Nothing+ A.ReleaseExceptionWith e -> Just e++--------------------------------------------------------------------------------++manyTill1 :: forall f z a. (MonadPlus f) => f z -> f a -> f ([a], z)+manyTill1 fz fa = go id+ where+ go :: ([a] -> [a]) -> f ([a], z)+ go !acc =+ optional fz >>= \case+ Just z | !as <- acc [] -> pure (as, z)+ Nothing -> fa >>= \ !a -> go (acc . (a :))++--------------------------------------------------------------------------------++foldPostmapM :: (Monad m) => (a -> m r) -> F.FoldM m x a -> F.FoldM m x r+foldPostmapM f (F.FoldM step begin done) = F.FoldM step begin (done >=> f)++foldList :: F.Fold o (Int64, [o])+foldList = (,) <$> F.genericLength <*> F.list++foldNonEmptyM+ :: (Ex.MonadThrow m, Ex.Exception e)+ => e+ -- ^ Zero.+ -> F.FoldM m o (Int64, NEL.NonEmpty o)+foldNonEmptyM e = flip foldPostmapM (F.generalize foldList) \case+ (n, os) | Just nos <- NEL.nonEmpty os -> pure (n, nos)+ _ -> Ex.throwM e++foldMaybeM+ :: (Ex.MonadThrow m, Ex.Exception e)+ => e+ -- ^ More than one.+ -> F.FoldM m o (Maybe o)+foldMaybeM e =+ F.FoldM+ (maybe (pure . Just) \_ _ -> Ex.throwM e)+ (pure Nothing)+ pure++foldZeroM+ :: (Ex.MonadThrow m, Ex.Exception e)+ => e+ -- ^ More than zero.+ -> F.FoldM m o ()+foldZeroM e = F.FoldM (\_ _ -> Ex.throwM e) (pure ()) pure++foldOneM+ :: (Ex.MonadThrow m, Ex.Exception e)+ => e+ -- ^ Zero.+ -> e+ -- ^ More than one.+ -> F.FoldM m o o+foldOneM e0 eN = foldPostmapM (maybe (Ex.throwM e0) pure) (foldMaybeM eN)
+ lib/Sq/Transactional.hs view
@@ -0,0 +1,390 @@+module Sq.Transactional+ ( Transactional+ , embed+ , transactionalRetry+ , foldM+ , Ref+ , Retry (..)+ , retry+ , orElse+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM hiding (orElse, retry)+import Control.Exception.Safe qualified as Ex+import Control.Foldl qualified as F+import Control.Monad hiding (foldM)+import Control.Monad.Catch qualified as Cx+import Control.Monad.IO.Class+import Control.Monad.Ref hiding (Ref)+import Control.Monad.Ref qualified+import Control.Monad.Trans.Reader (ReaderT (ReaderT))+import Control.Monad.Trans.Resource qualified as R+import Control.Monad.Trans.Resource.Extra qualified as R hiding (runResourceT)+import Data.Acquire qualified as A+import Data.Coerce+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Kind++import Sq.Connection+import Sq.Mode+import Sq.Statement+import Sq.Support++--------------------------------------------------------------------------------++-- | Used as the @r@ type-parameter in @'Transactional' g r t a@.+--+-- * If the 'Transactional' uses any 'Alternative' or 'MonadPlus' feature, then+-- @r@ must be 'Retry', and the 'Transactional' can only be executed through+-- 'Sq.read', 'Sq.commit' or 'Sq.rollback'.+--+-- * Otherwise, @r@ can be 'NoRetry'. In that case, 'embed' can+-- also be used to execute the 'Transactional'.+data Retry = NoRetry | Retry+ deriving (Eq, Ord, Show)++data Env (g :: k) (r :: Retry) (t :: Mode) = Env+ { unique :: STM Int+ -- ^ Next unique 'Int' within the 'Transactional' to be used as key in 'refs'+ , refs :: TVar (IntMap (SomeRef g))+ -- ^ Currently valid 'Ref's. We keep track of them in order to implement+ -- 'catch'. The 'IntMap' is just for fast diffing purposes.+ , tx :: Transaction t+ -- ^ Current transaction.+ }++acquireEnv :: Transaction t -> A.Acquire (Env g r t)+acquireEnv tx = do+ unique :: STM Int <- liftIO do+ tv <- newTVarIO 0+ pure $ atomicModifyRef' tv \i -> (i + 1, i)+ refs :: TVar (IntMap (SomeRef g)) <-+ R.mkAcquire1 (newTVarIO mempty) \tvsrs ->+ atomically do+ srs <- swapTVar tvsrs mempty+ forM_ srs \(SomeRef (Ref tv)) ->+ writeTVar tv Nothing+ pure Env{..}++-- | @'Transactional' g r t a@ groups together multiple interactions with a same+-- @'Transaction' t@ that finally produce a value of type @a@. Think of+-- 'Transactional' as if it was 'STM'.+--+-- * @g@ is an ephemeral tag for the whole inteaction group that prevents+-- 'Ref's and 'stream's from escaping its intended scope (like 'Data.STRef.ST'+-- does it). Just ignore it, it will always be polymorphic.+--+-- * @r@ says whether the 'Transactional' could potentially be retried from+-- scratch in order to observe a new snapshot of the database (like 'STM' does+-- it). Learn more about this in 'Retry'.+--+-- * @t@ says whether the 'Transactional' could potentially perform 'Write'+-- or 'Read'-only operations.+--+-- * @a@ is the Haskell value finally produced by a successfu execution of+-- the 'Transactional'.+--+-- __To execute a 'Transactional'__ you will normally use one of 'Sq.read' or+-- 'Sq.commit' (or 'Sq.rollback' or 'Sq.embed', but those are less common).+--+-- @+-- /-- We are using 'Sq.commit' to execute the 'Transactional'. This means/+-- /-- that the 'Transactional' will have read and 'Write' capabilities, that/+-- /-- it can 'retry', and that ultimately, unless there are unhandled/+-- /-- exceptions, the changes will be commited to the database./+-- __"Sq".'Sq.commit' pool do__+--+-- /-- We can execute 'Write' 'Statement's:/+-- __userId1 <- "Sq".'Sq.one' /insertUser/ \"haskell\@example.com\"__+--+-- /-- And 'Read' 'Statement's:/+-- __userId2 \<- "Sq".'Sq.one' /getUserIdByEmail/ \"haskell\@example.com\"__+--+-- /-- We have 'MonadFail' too:/+-- __'when' (userId1 /= userId2) do__+-- __'fail' \"Something unexpected happened!\"__+--+-- /-- We also have 'Ref's, which work just like 'TVar's:/+-- __ref \<- 'newRef' (0 :: 'Int')__+--+-- /-- 'Ex.catch' behaves like 'catchSTM', undoing changes to 'Ref's/+-- /-- and to the database itself when the original action fails:/+-- __userId3 \<- 'Ex.catch'__+-- /-- Something will fail .../+-- __(do 'modifyRef' ref (+ 1)__+-- __\_ \<- "Sq".'Sq.one' /insertUser/ \"sqlite\@example.com\"__+-- __'Ex.throwM' FakeException123)__+-- /-- ... but there is a catch!/+-- __(\\FakeException123 -> do__+-- /-- The observable universe has been reset to what it/+-- /-- was before the 'Ex.catch':/+-- __"Sq".'Sq.zero' /getUserIdByEmail/ \"sqlite\@example.com\"__+-- __'modifyRef' ref (+ 10))__+--+-- /-- Only the effects from the exception handling function were preserved:/+-- __"Sq".'Sq.zero' /getUserIdByEmail/ \"sqlite\@example.com\"__+-- __10 <- 'readRef' ref__+--+-- /-- 'retry' and its synonyms 'mzero' and 'empty' not only discard changes as/+-- /-- 'Ex.catch' does, but they also cause the ongoing 'Transaction' to be/+-- /-- discarded, and the entire 'Transactional' to be executed again on a/+-- /-- brand new 'Transaction' observing a new snapshot of the database. For/+-- /-- example, the following code will keep retrying the whole 'Transactional'/+-- /-- until the user with the specified email exists./+-- __userId4 \<- "Sq".'maybe' /getUserIdByEmail/ \"nix@example.com\" >>= \\case__+-- __'Just' x -> 'pure' x__+-- __'Nothing' -> 'retry'__+--+-- /-- Presumably, this example was waiting for a concurrent connection to/+-- /-- insert said user. If we got here, it is because that happened./+--+-- /-- As usual, 'mzero' and 'empty' can be handled by means of '<|>' and 'mplus',/+-- /-- or its synonym 'orElse'./+-- __'False' \<- 'mplus' ('writeRef' ref 8 >> 'mzero' >> 'pure' 'True')__+-- __('pure' 'False')__+--+-- /-- The recent 'writeRef' to 8 on the 'retry'ied 'Transactional' was discarded:/+-- __10 <- 'readRef' ref__+--+-- __'pure' ()__+-- @+newtype Transactional (g :: k) (r :: Retry) (t :: Mode) (a :: Type)+ = Transactional (Env g r t -> R.ResourceT IO a)+ deriving+ ( Functor+ , Applicative+ , Monad+ , Cx.MonadThrow+ , Cx.MonadMask+ , MonadFail+ )+ via (ReaderT (Env g r t) (R.ResourceT IO))++-- | INTERNAL only. This doesn't deal with @g@.+un :: Transactional g r t a -> Env g r t -> R.ResourceT IO a+un = coerce+{-# INLINE un #-}++mk :: (Env g r t -> R.ResourceT IO a) -> Transactional g r t a+mk = coerce+{-# INLINE mk #-}++-- | INTERNAL. Used to implement 'Sq.read', 'Sq.commit' and 'Sq.rollback'.+--+-- Run all the actions in a 'Transactional' as part of a single 'Transaction'.+transactionalRetry+ :: forall m r t a+ . (MonadIO m)+ => A.Acquire (Transaction t)+ -> (forall g. Transactional g r t a)+ -> m a+transactionalRetry atx ta = liftIO (go 0)+ where+ go :: Word -> IO a+ go !n = Ex.catch once \ErrRetry -> do+ -- TODO: Wait with `sqlite3_commit_hook` instead of just retrying.+ let ms = logBase 2 (fromIntegral (max 1 n) :: Double)+ threadDelay $ truncate (1_000 * ms)+ go (n + 1)+ once :: IO a+ once = R.runResourceT do+ (_, env) <- A.allocateAcquire $ acquireEnv =<< atx+ un ta env++-- | Embeds all the actions in a 'Transactional' as part of an ongoing+-- 'Transaction'.+--+-- * __NOTICE__ Contrary to 'Sq.read', 'Sq.commit' or 'Sq.rollback',+-- this 'Transactional' cannot 'retry', as doing so would require+-- cancelling the ongoing 'Transaction'.+embed+ :: forall m t a+ . (MonadIO m)+ => Transaction t+ -- ^ Ongoing transaction.+ -> (forall g. Transactional g 'NoRetry t a)+ -> m a+embed tx ta =+ liftIO $ R.runResourceT do+ (_, env) <- A.allocateAcquire $ acquireEnv tx+ un ta env++-- | __Impurely fold__ the output rows.+--+-- * For a non-'Transactional' version of this function, see 'Sq.foldIO'.+foldM+ :: (SubMode t s)+ => F.FoldM (Transactional g r t) o z+ -> Statement s i o+ -> i+ -> Transactional g r t z+foldM f st i = mk \env ->+ foldIO (F.hoists (flip un env) f) (pure env.tx) st i++-- | 'Ex.catch' behaves like "STM"'s 'catchSTM'.+--+-- In @'Ex.catch' ma f@, if an exception is thrown by @ma@, then any+-- database or 'Ref' changes made by @ma@ will be discarded. Furthermore, if+-- @f@ can handle said exception, then the action resulting from applying @f@+-- will be executed. Otherwise, if @f@ can't handle the exception, it will+-- bubble up.+--+-- Note: This instance's 'Cx.catch' catches async exceptions because that's+-- what 'Cx.MonadCatch' instances normaly do. As a user of this instance, you+-- probably want to use "Control.Exceptions.Safe" to make sure you don't catch+-- async exceptions unless you really want to.+instance Ex.MonadCatch (Transactional g r t) where+ catch act f = mk \env -> do+ refsRollback <- liftIO $ atomically $ saveSomeRefs env.refs+ case env.tx.smode of+ SRead ->+ Ex.catchAsync (un act env) \se -> do+ liftIO $ atomically refsRollback+ case Ex.fromException se of+ Nothing -> Ex.throwM se+ Just e -> un (f e) env+ SWrite -> Ex.mask \restore -> do+ sp <- savepoint env.tx+ Ex.tryAsync (restore (un act env)) >>= \case+ Right a -> do+ -- savepointRelease is not critical.+ void $ Ex.tryAny $ savepointRelease sp+ pure a+ Left se -> do+ liftIO $ atomically refsRollback+ savepointRollback sp+ -- savepointRelease is not critical. Just making sure we+ -- don't accumulate many savepoints in case there is some+ -- recursion going on.+ void $ Ex.tryAny $ savepointRelease sp+ case Ex.fromException se of+ Nothing -> Ex.throwM se+ Just e -> restore $ un (f e) env++--------------------------------------------------------------------------------++-- | INTERNAL.+data ErrRetry = ErrRetry+ deriving stock (Show)+ deriving anyclass (Ex.Exception)++-- | 'retry' behaves like 'STM'\'s 'Control.Concurrent.STM.retry'. It causes+-- the current 'Transaction' to be cancelled so that a new one can take its+-- place and the entire 'Transactional' is executed again. This allows the+-- 'Transactional' to observe a new snapshot of the database.+--+-- * 'retry', 'empty' and 'mzero' all do fundamentally the same thing,+-- however 'retry' leads to better type inferrence because it forces the+-- @r@ type-parameter to be 'Retry'.+--+-- * __NOTICE__ You only need to use 'mzero' if you need access to a newer+-- database snapshot. If all you want to do is undo some 'Ref' transformation+-- effects, or undo database changes, then use 'catch' which doesn't abandon+-- the 'Transaction'.+--+-- * __WARNING__ If we keep 'retry'ing and the database never changes, then+-- we will be stuck in a loop forever. To mitigate this, when executing the+-- 'Transactional' through 'Sq.read', 'Sq.commit' or 'Sq.rollback', you may+-- want to use 'System.Timeout.timeout' to abort at some point in the future.+retry :: Transactional g 'Retry t a+retry = Ex.throwM ErrRetry+{-# INLINE retry #-}++-- | @'orElse' ma mb@ behaves like 'STM'\'s @'Control.Concurrent.STM.orElse' ma+-- mb@. If @ma@ completes without executing 'retry', then that constitutes the+-- entirety of @'orElse' ma mb@. Otherwise, if @ma@ executed 'retry', then all+-- the effects from @ma@ are discared and @mb@ is tried in its place.+--+-- * 'orElse', '<|>' and 'mplus' all do the same thing, but 'orElse' has a more+-- general type because it doesn't force the @r@ type-parameter to be 'Retry'.+orElse+ :: Transactional g r t a+ -> Transactional g r t a+ -> Transactional g r t a+orElse tl tr = Ex.catch tl \ErrRetry -> tr++-- | @+-- 'empty' = 'retry'+-- '(<|>)' = 'orElse'+-- @+instance Alternative (Transactional g 'Retry t) where+ empty = retry+ {-# INLINE empty #-}+ (<|>) = orElse+ {-# INLINE (<|>) #-}++-- | @+-- 'mzero' = 'retry'+-- 'mplus' = 'orElse'+-- @+instance MonadPlus (Transactional g 'Retry t) where+ mzero = retry+ {-# INLINE mzero #-}+ mplus = orElse+ {-# INLINE mplus #-}++--------------------------------------------------------------------------------++data SomeRef g where+ SomeRef :: Ref g a -> SomeRef g++-- | Creates a “savepoint” with the current state of the given 'SomeRef's.+-- The produced 'STM' action can be used to rollback the 'SomeRef's current+-- state in the future.+saveSomeRefs :: TVar (IntMap (SomeRef g)) -> STM (STM ())+saveSomeRefs tvsrs = do+ srs0 <- readTVar tvsrs+ rollbacks <- forM srs0 \(SomeRef (Ref tv)) ->+ writeTVar tv <$> readTVar tv+ pure do+ srs1 <- swapTVar tvsrs srs0+ forM_ (IntMap.difference srs1 srs0) \(SomeRef (Ref tv)) ->+ writeTVar tv Nothing+ sequence_ rollbacks++-- | Like 'TVar', but you can use it inside 'Transactional' through the+-- 'MonadRef' and 'MonadAtomicRef' vocabulary.+newtype Ref g a = Ref (TVar (Maybe a))+ deriving newtype+ ( Eq+ -- ^ Pointer equality+ )++-- | All operations are atomic.+instance MonadRef (Transactional g r t) where+ type Ref (Transactional g r t) = Sq.Transactional.Ref g+ newRef a = mk \env -> liftIO $ atomically do+ i <- env.unique+ tv <- newTVar $! Just a+ let ref = Ref tv+ -- Note: We only explicitly remove things from the IntMap through+ -- saveSomeRefs, or when exiting Transactional. Maybe some day we+ -- optimize this.+ modifyTVar' env.refs $ IntMap.insert i $! SomeRef ref+ pure ref+ readRef (Ref tv) = mk \_ -> liftIO $ atomically do+ readTVar tv >>= \case+ Just a -> pure a+ Nothing -> Ex.throwM $ resourceVanishedWithCallStack "Ref"+ writeRef r a = atomicModifyRef r \_ -> (a, ())+ modifyRef r f = atomicModifyRef r \a -> (f a, ())+ modifyRef' r f = atomicModifyRef' r \a -> (f a, ())++instance MonadAtomicRef (Transactional g r t) where+ atomicModifyRef (Ref tv) f =+ mk \_ -> liftIO $ atomically do+ readTVar tv >>= \case+ Just a0 | (a1, b) <- f a0 -> do+ writeTVar tv $! Just a1+ pure b+ Nothing -> Ex.throwM $ resourceVanishedWithCallStack "Ref"+ atomicModifyRef' (Ref tv) f =+ mk \_ -> liftIO $ atomically do+ readTVar tv >>= \case+ Just a0 | (!a1, !b) <- f a0 -> do+ writeTVar tv $! Just a1+ pure b+ Nothing -> Ex.throwM $ resourceVanishedWithCallStack "Ref"
+ sq.cabal view
@@ -0,0 +1,133 @@+cabal-version: 2.4+name: sq+version: 0.0.1+license: Apache-2.0+license-file: LICENSE+extra-source-files: README.md CHANGELOG.md+author: Renzo Carbonara+maintainer: renλren.zone+copyright: Renzo Carbonara, 2023+category: Databases+build-type: Simple+synopsis: High-level SQLite client.+description: High-level SQLite client.+homepage: https://github.com/k0001/hs-sq+bug-reports: https://github.com/k0001/hs-sq/issues+tested-with: GHC == 9.8.1++common basic+ default-language: GHC2021+ ghc-options: -O2 -Wall+ build-depends:+ base == 4.*,+ default-extensions:+ BlockArguments+ DataKinds+ DeriveAnyClass+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ LambdaCase+ ImplicitParams+ OverloadedRecordDot+ OverloadedStrings+ RecordWildCards+ TypeFamilies+ ViewPatterns++library+ import: basic+ hs-source-dirs: lib+ exposed-modules:+ Sq+ other-modules:+ Sq.Connection+ Sq.Decoders+ Sq.Encoders+ Sq.Input+ Sq.Mode+ Sq.Names+ Sq.Null+ Sq.Output+ Sq.Pool+ Sq.Statement+ Sq.Support+ Sq.Transactional+ build-depends:+ aeson,+ async,+ attoparsec,+ binary,+ bytestring,+ clock,+ containers,+ contravariant,+ deepseq,+ di-df1,+ di-core,+ direct-sqlite,+ directory,+ exceptions,+ filepath,+ foldl,+ profunctors,+ ref-tf,+ resource-pool,+ resourcet,+ resourcet-extra,+ safe-exceptions,+ stm,+ streaming,+ template-haskell,+ text,+ time,+ transformers,++test-suite test+ import: basic+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ ghc-options: -O2 -Wall -threaded -rtsopts -with-rtsopts=-N+ other-modules:+ Sq.Test+ Sq.Test.Codec+ build-depends:+ aeson,+ async,+ binary,+ bytestring,+ di,+ di-core,+ df1,+ hedgehog,+ ref-tf,+ resourcet,+ resourcet-extra,+ safe-exceptions,+ sq,+ tasty,+ tasty-hedgehog,+ tasty-hunit,+ text,+ time,++benchmark bench+ import: basic+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench+ ghc-options: -O2 -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ async,+ async-pool,+ containers,+ criterion,+ df1,+ di,+ di-core,+ resourcet,+ resourcet-extra,+ safe-exceptions,+ sq,+ stm,
+ test/Main.hs view
@@ -0,0 +1,21 @@+module Main (main) where++import Df1 qualified+import Di qualified+import Di.Core qualified+import Sq.Test qualified+import Test.Tasty qualified as Tasty+import Test.Tasty.Hedgehog qualified as Tasty+import Test.Tasty.Runners qualified as Tasty++--------------------------------------------------------------------------------++main :: IO ()+main = Di.new \di0 -> do+ let di1 = Di.Core.filter (\l _ _ -> l >= Df1.Info) di0+ Tasty.defaultMainWithIngredients+ [ Tasty.consoleTestReporter+ , Tasty.listingTests+ ]+ $ Tasty.localOption (Tasty.HedgehogTestLimit (Just 1000))+ $ Sq.Test.tree di1
+ test/Sq/Test.hs view
@@ -0,0 +1,134 @@+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+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Ref+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.Test.Codec qualified++--------------------------------------------------------------------------------++tree :: Di.Df1 -> TestTree+tree di = withAcquire (Sq.tempPool di) \iop ->+ testGroup+ "sq"+ [ {- This code randomly hangs for some reason. It seems to be related+ to HUnit and threading. Not sure.+ testGroup "Name" do+ t0 <- ["a", "ab", "a1b", "a_b", "a1_b", "a_1b"]+ t1 <- [t0, t0 <> "2"]+ pure $ testCase (T.unpack t1) $ fmap (.text) (Sq.name t1) @?= Right t1+ -}+ Sq.Test.Codec.tree iop+ , testProperty "list" $ H.property do+ let stCreate =+ Sq.writeStatement @() @() mempty mempty $+ "CREATE TABLE t (x INTEGER)"+ stInsert =+ Sq.writeStatement @Int @() "x" mempty $+ "INSERT INTO t (x) VALUES ($x)"+ stRead = Sq.readStatement mempty "x" "SELECT x FROM t"+ pool <- liftIO iop+ xs :: [Int] <- H.forAll $ H.list (HR.constant 0 100) H.enumBounded+ (ysLen, ys) <- Sq.rollback pool do+ Sq.zero stCreate ()+ traverse_ (Sq.zero stInsert) xs+ Sq.list stRead ()+ ysLen H.=== fromIntegral (length ys)+ xs H.=== ys+ , testExample1 di+ ]++withAcquire :: A.Acquire a -> (IO a -> TestTree) -> TestTree+withAcquire acq k =+ withResource+ (R.withRestoreIO (R.unAcquire acq))+ (\(_, rel) -> rel A.ReleaseNormal)+ (k . fmap fst)++--------------------------------------------------------------------------------++data FakeException123 = FakeException123+ deriving stock (Show)+ deriving anyclass (Ex.Exception)++example1 :: Sq.Pool Sq.Write -> IO ()+example1 pool = Sq.commit pool do+ userId1 <- Sq.one insertUser "haskell@example.com"+ userId2 <- Sq.one getUserIdByEmail "haskell@example.com"+ when (userId1 /= userId2) do+ fail "Something unexpected happened!"+ ref <- newRef (0 :: Int)+ _userId3 <-+ Ex.catch+ ( do+ modifyRef ref (+ 1)+ _ <- Sq.one insertUser "sqlite@example.com"+ Ex.throwM FakeException123+ )+ ( \FakeException123 -> do+ Sq.zero getUserIdByEmail "sqlite@example.com"+ modifyRef ref (+ 10)+ )+ 10 <- readRef ref+ Sq.zero getUserIdByEmail "sqlite@example.com"+ _userId4 <-+ Sq.maybe getUserIdByEmail "nix@example.com" >>= \case+ Just userId4 -> pure userId4+ Nothing -> mzero+ False <-+ mplus+ (writeRef ref 8 >> mzero >> pure True)+ (pure False)+ 10 <- readRef ref+ pure ()++getUserIdByEmail :: Sq.Statement 'Sq.Read String Int+getUserIdByEmail =+ Sq.readStatement "email" "id" "SELECT id FROM users WHERE email = $email"++insertUser :: Sq.Statement 'Sq.Write String Int+insertUser =+ Sq.writeStatement+ "email"+ "id"+ "INSERT INTO users (email) VALUES ($email) RETURNING id"++createTableUsers :: Sq.Statement 'Sq.Write () ()+createTableUsers =+ Sq.writeStatement+ mempty+ mempty+ "CREATE TABLE users (id INTEGER PRIMARY KEY, email TEXT)"++testExample1 :: Di.Df1 -> TestTree+testExample1 di0 = testCase "example1" do+ Sq.with (Sq.tempPool di0) \pool -> do+ Sq.commit pool $ Sq.zero createTableUsers ()+ Async.withAsync+ ( do+ threadDelay 50_000+ void $ Sq.commit pool $ Sq.one insertUser "nix@example.com"+ )+ \_ ->+ timeout 500_000 (example1 pool) >>= \case+ Just () -> pure ()+ Nothing -> fail "example1: timeout!"
+ test/Sq/Test/Codec.hs view
@@ -0,0 +1,173 @@+module Sq.Test.Codec (tree) where++import Control.Exception.Safe qualified as Ex+import Control.Monad.IO.Class+import Data.Aeson qualified as Ae+import Data.Binary qualified as Bin+import Data.Bits+import Data.ByteString qualified as B+import Data.ByteString.Lazy qualified as BL+import Data.Fixed+import Data.Functor.Contravariant+import Data.Int+import Data.Maybe+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Time qualified as Time+import Data.Time.Clock.POSIX qualified as Time+import Data.Time.Format.ISO8601 qualified as Time+import Data.Typeable+import Data.Word+import Hedgehog qualified as H+import Hedgehog.Gen qualified as H+import Hedgehog.Range qualified as HR+import Numeric.Natural+import Sq qualified+import Test.Tasty (testGroup)+import Test.Tasty.Hedgehog (testProperty)+import Test.Tasty.Runners (TestTree)++--------------------------------------------------------------------------------++tree :: IO (Sq.Pool Sq.Write) -> TestTree+tree iop =+ testGroup+ "decode . encode"+ [ t @Bool $ H.bool+ , t @Int $ H.integral HR.constantBounded+ , t @Int8 $ H.integral HR.constantBounded+ , t @Int16 $ H.integral HR.constantBounded+ , t @Int32 $ H.integral HR.constantBounded+ , t @Int64 $ H.integral HR.constantBounded+ , t @Word $ H.integral HR.constantBounded+ , t @Word8 $ H.integral HR.constantBounded+ , t @Word16 $ H.integral HR.constantBounded+ , t @Word32 $ H.integral HR.constantBounded+ , t @Word64 $ H.integral HR.constantBounded+ , t @Word64 $ H.integral HR.constantBounded+ , t @Natural $ H.integral $ HR.constant 0 maxNatural+ , t @Integer $ H.integral $ HR.constantFrom 0 minInteger maxInteger+ , t @Char H.unicode+ , t @String $ H.string (HR.constant 0 50) H.unicode+ , t @T.Text $ H.text (HR.constant 0 50) H.unicode+ , t @TL.Text $ fmap TL.fromStrict $ H.text (HR.constant 0 50) H.unicode+ , t2 @B.ByteString $ H.bytes (HR.constant 0 50)+ , t2 @BL.ByteString $ fmap BL.fromStrict $ H.bytes (HR.constant 0 50)+ , t2 @Time.UTCTime $ genUTCTime (HR.constantFrom epochUTCTime minUTCTime maxUTCTime)+ , t @Double $ H.double (HR.constantFrom 0 (fromIntegral minInteger) (fromIntegral maxInteger))+ , t @Float $ H.float (HR.constantFrom 0 (fromIntegral minInteger) (fromIntegral maxInteger))+ -- TODO FAIL: , testProperty "Char" $ t @Char (pure '\55296')+ ]+ where+ t+ :: forall a+ . ( Typeable a+ , Eq a+ , Show a+ , Sq.EncodeDefault a+ , Sq.DecodeDefault a+ , Bin.Binary a+ , Ae.ToJSON a+ , Ae.FromJSON a+ )+ => H.Gen a+ -> TestTree+ t ga =+ testGroup+ (tyConName (typeRepTyCon (typeRep ga)))+ [ testGroup "raw" [t2 ga]+ , testGroup "binary" [t2 (WrapBinary <$> ga)]+ , testGroup "aeson" [t2 (WrapAeson <$> ga)]+ ]++ t2+ :: forall a+ . (Typeable a, Eq a, Show a, Sq.EncodeDefault a, Sq.DecodeDefault a)+ => H.Gen a+ -> TestTree+ t2 ga =+ testGroup+ (tyConName (typeRepTyCon (typeRep ga)))+ [ testProperty "pure" $ H.property do+ a0 <- H.forAll ga+ let Sq.Encode g = Sq.encodeDefault+ case g a0 of+ Left e0 -> Ex.throwM e0+ Right raw -> do+ let Sq.Decode f = Sq.decodeDefault+ case f raw of+ Left e -> Ex.throwM e+ Right a1 -> a0 H.=== a1+ , testProperty "db" $ H.property do+ p <- liftIO iop+ a0 <- H.forAll ga+ a1 <- Sq.read p $ Sq.one idStatement a0+ a0 H.=== a1+ ]++newtype WrapBinary a = WrapBinary a+ deriving newtype (Eq, Show)++instance (Bin.Binary a) => Sq.EncodeDefault (WrapBinary a) where+ encodeDefault = contramap (\case WrapBinary a -> a) $ Sq.encodeBinary Bin.put++instance (Bin.Binary a) => Sq.DecodeDefault (WrapBinary a) where+ decodeDefault = WrapBinary <$> Sq.decodeBinary Bin.get++newtype WrapAeson a = WrapAeson a+ deriving newtype (Eq, Show)++instance (Ae.ToJSON a) => Sq.EncodeDefault (WrapAeson a) where+ encodeDefault =+ contramap (\case WrapAeson a -> a) $ Sq.encodeAeson Ae.toJSON++instance (Ae.FromJSON a) => Sq.DecodeDefault (WrapAeson a) where+ decodeDefault = WrapAeson <$> Sq.decodeAeson Ae.parseJSON++idStatement+ :: (Sq.EncodeDefault x, Sq.DecodeDefault x)+ => Sq.Statement Sq.Read x x+idStatement =+ Sq.readStatement+ (Sq.input "a" (Sq.input "b" "c"))+ (Sq.output "x" (Sq.output "y" "z"))+ "SELECT $a__b__c AS x__y__z"++maxNatural :: Natural+maxNatural = 2 ^ (256 :: Int) - 1++maxInteger :: Integer+maxInteger = 2 ^ (255 :: Int) - 1++minInteger :: Integer+minInteger = complement maxInteger++minUTCTime :: Time.UTCTime+minUTCTime = fromJust $ Time.iso8601ParseM "-9999-01-01T00:00:00Z"++maxUTCTime :: Time.UTCTime+maxUTCTime = fromJust $ Time.iso8601ParseM "9999-12-31T24:00:00Z"++epochUTCTime :: Time.UTCTime+epochUTCTime = posixPicoSecondsToUTCTime 0++genUTCTime :: (H.MonadGen m) => H.Range Time.UTCTime -> m Time.UTCTime+genUTCTime =+ fmap posixPicoSecondsToUTCTime+ . H.integral+ . fmap utcTimeToPOSIXPicoSeconds++utcTimeToPOSIXPicoSeconds :: Time.UTCTime -> Integer+utcTimeToPOSIXPicoSeconds t = i+ where+ MkFixed i = Time.nominalDiffTimeToSeconds $ Time.utcTimeToPOSIXSeconds t++posixPicoSecondsToUTCTime :: Integer -> Time.UTCTime+posixPicoSecondsToUTCTime =+ Time.posixSecondsToUTCTime . Time.secondsToNominalDiffTime . MkFixed++-- genRational :: (H.MonadGen m) => m Rational+-- genRational = do+-- n <- genInteger+-- d <- H.integral $ H.linear 1 (10 ^ (10 :: Int))+-- pure (n % d)