diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Version 0.0.1 + +* Initial version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 + ] + ] diff --git a/lib/Sq.hs b/lib/Sq.hs new file mode 100644 --- /dev/null +++ b/lib/Sq.hs @@ -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 +-- . +-- +-- ⚠️ __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 #-} diff --git a/lib/Sq/Connection.hs b/lib/Sq/Connection.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Connection.hs @@ -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 +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 +foreign import ccall unsafe "sqlite3_stmt_status" + c_sqlite3_stmt_status + :: Ptr S.CStatement + -> CInt + -- ^ op + -> CInt + -- ^ resetFlg + -> IO CInt + +-- | See +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 diff --git a/lib/Sq/Decoders.hs b/lib/Sq/Decoders.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Decoders.hs @@ -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 #-} diff --git a/lib/Sq/Encoders.hs b/lib/Sq/Encoders.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Encoders.hs @@ -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 #-} diff --git a/lib/Sq/Input.hs b/lib/Sq/Input.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Input.hs @@ -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 #-} diff --git a/lib/Sq/Mode.hs b/lib/Sq/Mode.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Mode.hs @@ -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 diff --git a/lib/Sq/Names.hs b/lib/Sq/Names.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Names.hs @@ -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 diff --git a/lib/Sq/Null.hs b/lib/Sq/Null.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Null.hs @@ -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 diff --git a/lib/Sq/Output.hs b/lib/Sq/Output.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Output.hs @@ -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 #-} diff --git a/lib/Sq/Pool.hs b/lib/Sq/Pool.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Pool.hs @@ -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 diff --git a/lib/Sq/Statement.hs b/lib/Sq/Statement.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Statement.hs @@ -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 #-} diff --git a/lib/Sq/Support.hs b/lib/Sq/Support.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Support.hs @@ -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) diff --git a/lib/Sq/Transactional.hs b/lib/Sq/Transactional.hs new file mode 100644 --- /dev/null +++ b/lib/Sq/Transactional.hs @@ -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" diff --git a/sq.cabal b/sq.cabal new file mode 100644 --- /dev/null +++ b/sq.cabal @@ -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, diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Sq/Test.hs b/test/Sq/Test.hs new file mode 100644 --- /dev/null +++ b/test/Sq/Test.hs @@ -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!" diff --git a/test/Sq/Test/Codec.hs b/test/Sq/Test/Codec.hs new file mode 100644 --- /dev/null +++ b/test/Sq/Test/Codec.hs @@ -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)