mirror of
https://github.com/nikita-volkov/hasql.git
synced 2024-11-30 00:55:22 +03:00
Clean up
This commit is contained in:
Nikita Volkov
parent
5fb0fe331f
commit
d7fb2ce0b9
@ -39,13 +39,8 @@ library
|
||||
library
|
||||
other-modules:
|
||||
HighSQL.Prelude
|
||||
HighSQL.CompositionT
|
||||
HighSQL.QQ
|
||||
HighSQL.QQ.Parser
|
||||
HighSQL.API
|
||||
HighSQL.Conversion
|
||||
exposed-modules:
|
||||
HighSQL
|
||||
HighSQL.Backend
|
||||
build-depends:
|
||||
-- template-haskell:
|
||||
|
||||
@ -1,26 +0,0 @@
|
||||
module HighSQL
|
||||
(
|
||||
-- * Pool
|
||||
Pool,
|
||||
Settings(..),
|
||||
withPool,
|
||||
-- * Error
|
||||
Error(..),
|
||||
-- * Transaction
|
||||
T,
|
||||
-- ** Execution
|
||||
-- |
|
||||
-- Functions for execution of transactions.
|
||||
-- They determine the transactional locking strategy of the database.
|
||||
read,
|
||||
write,
|
||||
admin,
|
||||
-- ** Statement Quasi-Quote
|
||||
q,
|
||||
-- * Results Stream
|
||||
ResultsStream,
|
||||
)
|
||||
where
|
||||
|
||||
import HighSQL.API as API
|
||||
import HighSQL.QQ as QQ
|
||||
@ -1,279 +0,0 @@
|
||||
module HighSQL.API where
|
||||
|
||||
import HighSQL.Prelude hiding (read, Read, write, Write, Error)
|
||||
import qualified Data.Pool as Pool
|
||||
import qualified HighSQL.CompositionT as CompositionT
|
||||
import qualified HighSQL.Backend as Backend
|
||||
import qualified HighSQL.Conversion as Conversion
|
||||
import qualified ListT
|
||||
|
||||
|
||||
-- * Pool
|
||||
-------------------------
|
||||
|
||||
-- |
|
||||
-- A pool of connections to the database.
|
||||
newtype Pool =
|
||||
Pool (Pool.Pool Backend.Connection)
|
||||
|
||||
-- |
|
||||
-- Pool initization settings.
|
||||
data Settings =
|
||||
Settings {
|
||||
-- |
|
||||
-- The number of stripes (distinct sub-pools) to maintain.
|
||||
-- The smallest acceptable value is 1.
|
||||
striping1 :: Word32,
|
||||
-- |
|
||||
-- The maximum number of connections to keep open per a pool stripe.
|
||||
-- The smallest acceptable value is 1.
|
||||
-- Requests for connections will block if this limit is reached
|
||||
-- on a single stripe,
|
||||
-- even if other stripes have idle connections available.
|
||||
striping2 :: Word32,
|
||||
-- |
|
||||
-- The amount of time for which an unused connection is kept open.
|
||||
-- The smallest acceptable value is 0.5 seconds.
|
||||
connectionTimeout :: NominalDiffTime
|
||||
}
|
||||
|
||||
-- |
|
||||
-- Initialize a pool given a backend and settings
|
||||
-- and run an IO computation with it,
|
||||
-- while automating the resource management.
|
||||
withPool :: Backend.Backend -> Settings -> (Pool -> IO a) -> IO a
|
||||
withPool b s =
|
||||
bracket acquire release
|
||||
where
|
||||
acquire =
|
||||
do
|
||||
pool <-
|
||||
Pool.createPool
|
||||
(Backend.connect b) (Backend.disconnect) (striping1 s)
|
||||
(connectionTimeout s) (striping2 s)
|
||||
return (Pool pool)
|
||||
release (Pool pool) =
|
||||
Pool.purgePool pool
|
||||
|
||||
|
||||
-- * Error
|
||||
-------------------------
|
||||
|
||||
-- |
|
||||
-- The only exception type that this API can raise.
|
||||
data Error =
|
||||
-- |
|
||||
-- Cannot connect to a server
|
||||
-- or the connection got interrupted.
|
||||
ConnectionError Text |
|
||||
-- |
|
||||
-- Attempt to parse a statement execution result into an incompatible type.
|
||||
-- Indicates either a mismatching schema or an incorrect query.
|
||||
ResultParsingError [Backend.Value] TypeRep |
|
||||
-- |
|
||||
-- A free-form backend-specific exception.
|
||||
BackendError SomeException
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance Exception Error
|
||||
|
||||
|
||||
-- * Transaction
|
||||
-------------------------
|
||||
|
||||
-- |
|
||||
-- A transaction with a level @l@,
|
||||
-- running on an anonymous state-thread @s@
|
||||
-- and gaining a result @r@.
|
||||
newtype T l s r =
|
||||
T (CompositionT.T (ReaderT Backend.Connection IO) r)
|
||||
deriving (Functor, Applicative, Monad)
|
||||
|
||||
-- |
|
||||
-- Execute a transaction in a write mode (if 'True') using a connections pool.
|
||||
--
|
||||
-- * Automatically determines,
|
||||
-- whether it's actually a transaction or just a single action
|
||||
-- and executes accordingly.
|
||||
--
|
||||
-- * Automatically retries the transaction in case of a
|
||||
-- 'Backend.TransactionError' exception.
|
||||
--
|
||||
-- * Rethrows all the other exceptions after wrapping them in 'Error'.
|
||||
transaction :: Bool -> Pool -> (forall s. T l s r) -> IO r
|
||||
transaction w (Pool p) (T t) =
|
||||
do
|
||||
e <-
|
||||
try $ Pool.withResource p $
|
||||
\c ->
|
||||
case CompositionT.run t of
|
||||
(False, r) ->
|
||||
runReaderT r c
|
||||
(True, r) ->
|
||||
retry
|
||||
where
|
||||
retry =
|
||||
do
|
||||
Backend.beginTransaction c w
|
||||
e <- try $ runReaderT r c
|
||||
case e of
|
||||
Left (Backend.TransactionError) ->
|
||||
do
|
||||
Backend.finishTransaction c False
|
||||
retry
|
||||
Left e ->
|
||||
do
|
||||
Backend.finishTransaction c False
|
||||
throwIO e
|
||||
Right r ->
|
||||
do
|
||||
Backend.finishTransaction c True
|
||||
return r
|
||||
case e of
|
||||
Left (Backend.ConnectionError t) ->
|
||||
throwIO (ConnectionError t)
|
||||
Left (Backend.BackendError e) ->
|
||||
throwIO (BackendError e)
|
||||
Left (Backend.TransactionError) ->
|
||||
$bug "Unexpected TransactionError"
|
||||
Right r ->
|
||||
return r
|
||||
|
||||
|
||||
-- ** Levels
|
||||
-------------------------
|
||||
|
||||
data Read
|
||||
|
||||
-- |
|
||||
-- Execute a transaction on a connections pool.
|
||||
--
|
||||
-- Requires minimal locking from the database,
|
||||
-- however you can only execute the \"SELECT\" statements in it.
|
||||
-- The API ensures of that on the type-level.
|
||||
read :: Pool -> (forall s. T Read s r) -> IO r
|
||||
read = transaction False
|
||||
|
||||
|
||||
data Write
|
||||
|
||||
-- |
|
||||
-- Execute a transaction on a connections pool.
|
||||
--
|
||||
-- Allows to execute the \"SELECT\", \"UPDATE\", \"INSERT\"
|
||||
-- and \"DELETE\" statements.
|
||||
-- However, compared to 'read', this transaction requires the database to choose
|
||||
-- a more resource-demanding locking strategy.
|
||||
write :: Pool -> (forall s. T Write s r) -> IO r
|
||||
write = transaction True
|
||||
|
||||
|
||||
data Admin
|
||||
|
||||
-- |
|
||||
-- Execute a transaction on a connections pool.
|
||||
--
|
||||
-- Same as 'write', but allows you to perform any kind of statements,
|
||||
-- including \"CREATE\", \"DROP\" and \"ALTER\".
|
||||
admin :: Pool -> (forall s. T Admin s r) -> IO r
|
||||
admin = transaction True
|
||||
|
||||
|
||||
-- ** Privileges
|
||||
-------------------------
|
||||
|
||||
-- |
|
||||
-- \"SELECT\"
|
||||
class SelectPrivilege l where
|
||||
-- |
|
||||
-- Produce a results stream from a statement.
|
||||
select ::
|
||||
forall s r.
|
||||
(Conversion.Row r, Typeable r) => Statement -> ResultsStream s (T l s) r
|
||||
select (Statement bs vl) =
|
||||
do
|
||||
(w, s) <-
|
||||
lift $ T $ lift $ do
|
||||
Backend.Connection {..} <- ask
|
||||
liftIO $ do
|
||||
ps <- prepare bs
|
||||
executeStreaming ps vl Nothing
|
||||
l <- ResultsStream $ hoist (T . liftIO) $ replicateM w s
|
||||
maybe (throwParsingError l (typeOf (undefined :: r))) return $ Conversion.fromRow l
|
||||
where
|
||||
throwParsingError vl t =
|
||||
ResultsStream $ lift $ T $ liftIO $ throwIO $ ResultParsingError vl t
|
||||
|
||||
instance SelectPrivilege Read
|
||||
instance SelectPrivilege Write
|
||||
instance SelectPrivilege Admin
|
||||
|
||||
|
||||
-- |
|
||||
-- \"UPDATE\", \"INSERT\", \"DELETE\"
|
||||
class UpdatePrivilege l where
|
||||
-- |
|
||||
-- Execute and count the amount of affected rows.
|
||||
update :: Statement -> T l s Integer
|
||||
update (Statement bs vl) =
|
||||
T $ do
|
||||
Backend.Connection {..} <- lift $ ask
|
||||
liftIO $ do
|
||||
ps <- prepare bs
|
||||
executeCountingEffects ps vl
|
||||
-- |
|
||||
-- Execute and return the possibly auto-incremented number.
|
||||
insert :: Statement -> T l s (Maybe Integer)
|
||||
insert (Statement bs vl) =
|
||||
T $ do
|
||||
Backend.Connection {..} <- lift $ ask
|
||||
liftIO $ do
|
||||
ps <- prepare bs
|
||||
executeIncrementing ps vl
|
||||
|
||||
instance UpdatePrivilege Write
|
||||
instance UpdatePrivilege Admin
|
||||
|
||||
|
||||
-- |
|
||||
-- \"CREATE\", \"ALTER\", \"DROP\", \"TRUNCATE\"
|
||||
class CreatePrivilege l where
|
||||
create :: Statement -> T l s ()
|
||||
create (Statement bs vl) =
|
||||
T $ do
|
||||
Backend.Connection {..} <- lift $ ask
|
||||
liftIO $ do
|
||||
ps <- prepare bs
|
||||
execute ps vl
|
||||
|
||||
instance CreatePrivilege Admin
|
||||
|
||||
|
||||
-- * Statement
|
||||
-------------------------
|
||||
|
||||
data Statement =
|
||||
Statement !ByteString ![Backend.Value]
|
||||
deriving (Show)
|
||||
|
||||
|
||||
-- * Results Stream
|
||||
-------------------------
|
||||
|
||||
-- |
|
||||
-- A stream of results,
|
||||
-- which fetches only those that you reach.
|
||||
--
|
||||
-- It is implemented as a wrapper around 'ListT.ListT',
|
||||
-- hence all the utility functions of the list transformer API
|
||||
-- are applicable to this type.
|
||||
--
|
||||
-- It uses the same trick as 'ST' to become impossible to be run outside of
|
||||
-- its transaction.
|
||||
-- Hence you can only access it while remaining in a transaction,
|
||||
-- and when the transaction finishes it safely gets automatically released.
|
||||
newtype ResultsStream s m r =
|
||||
ResultsStream (ListT.ListT m r)
|
||||
deriving (Functor, Applicative, Alternative, Monad, MonadTrans, MonadPlus,
|
||||
Monoid, ListT.ListMonad, ListT.ListTrans)
|
||||
|
||||
@ -1,40 +0,0 @@
|
||||
module HighSQL.CompositionT where
|
||||
|
||||
import HighSQL.Prelude
|
||||
|
||||
|
||||
-- |
|
||||
-- A monad transformer,
|
||||
-- which serves a purpose of detecting composition of the inner monad.
|
||||
data T m r =
|
||||
T Bool (m r)
|
||||
|
||||
-- |
|
||||
-- Unwrap into a boolean signifying whether the base monad is a composition and
|
||||
-- the base monad itself.
|
||||
run :: T m r -> (Bool, m r)
|
||||
run (T c m) = (c, m)
|
||||
|
||||
instance Monad m => Monad (T m) where
|
||||
return a =
|
||||
T False (return a)
|
||||
(>>=) (T _ m) k =
|
||||
T True (m >>= \a -> case k a of T _ m' -> m')
|
||||
|
||||
instance Functor f => Functor (T f) where
|
||||
fmap f (T c m) = T c (fmap f m)
|
||||
|
||||
instance Applicative f => Applicative (T f) where
|
||||
pure a =
|
||||
T False (pure a)
|
||||
(<*>) (T _ a) (T _ b) =
|
||||
T True (a <*> b)
|
||||
|
||||
instance MonadTrans T where
|
||||
lift m =
|
||||
T False m
|
||||
|
||||
instance MonadIO m => MonadIO (T m) where
|
||||
liftIO io =
|
||||
T False (liftIO io)
|
||||
|
||||
@ -1,139 +0,0 @@
|
||||
-- |
|
||||
-- An open API for implementation of specific backend drivers.
|
||||
module HighSQL.Conversion where
|
||||
|
||||
import HighSQL.Prelude
|
||||
import Language.Haskell.TH
|
||||
import qualified Data.Text as Text
|
||||
import qualified HighSQL.Backend as Backend
|
||||
|
||||
|
||||
-- * Value
|
||||
-------------------------
|
||||
|
||||
class Value a where
|
||||
toValue :: a -> Backend.Value
|
||||
fromValue :: Backend.Value -> Maybe a
|
||||
|
||||
-- Generate standard instances using Template Haskell:
|
||||
let
|
||||
inst :: Name -> Dec
|
||||
inst t =
|
||||
InstanceD [] (AppT (ConT ''Value) (ConT t)) [d1, d2]
|
||||
where
|
||||
c =
|
||||
mkName $ "Backend." ++ nameBase t
|
||||
d1 =
|
||||
FunD 'toValue [Clause [] (NormalB (ConE c)) []]
|
||||
d2 =
|
||||
FunD 'fromValue [c1, c2]
|
||||
where
|
||||
c1 =
|
||||
Clause [p] (NormalB e) []
|
||||
where
|
||||
p = ConP c [VarP v]
|
||||
v = mkName "a"
|
||||
e = AppE (ConE 'Just) (VarE v)
|
||||
c2 =
|
||||
Clause [WildP] (NormalB (ConE 'Nothing)) []
|
||||
in
|
||||
mapM (return . inst)
|
||||
[''NominalDiffTime, ''UTCTime, ''ZonedTime, ''TimeOfDay, ''LocalTime,
|
||||
''Day, ''Rational, ''Double, ''Bool, ''Char, ''Integer, ''Int64, ''Int32,
|
||||
''Word64, ''Word32, ''ByteString, ''Text]
|
||||
|
||||
instance Value String where
|
||||
toValue = Backend.Text . Text.pack
|
||||
fromValue = \case Backend.Text a -> Just (Text.unpack a); _ -> Nothing
|
||||
|
||||
instance Value Word where
|
||||
toValue = Backend.Word64 . fromIntegral
|
||||
fromValue = \case Backend.Word64 a -> Just (fromIntegral a); _ -> Nothing
|
||||
|
||||
instance Value Int where
|
||||
toValue = Backend.Int64 . fromIntegral
|
||||
fromValue = \case Backend.Int64 a -> Just (fromIntegral a); _ -> Nothing
|
||||
|
||||
instance Value a => Value (Maybe a) where
|
||||
toValue = Backend.Maybe . fmap toValue
|
||||
fromValue = \case Backend.Maybe a -> traverse fromValue a; _ -> Nothing
|
||||
|
||||
|
||||
-- * Row
|
||||
-------------------------
|
||||
|
||||
class Row r where
|
||||
fromRow :: [Backend.Value] -> Maybe r
|
||||
|
||||
-- Generate tuple instaces using Template Haskell:
|
||||
let
|
||||
inst :: Int -> Dec
|
||||
inst arity =
|
||||
InstanceD constraints head [fromRowDec]
|
||||
where
|
||||
varNames =
|
||||
[1 .. arity] >>= \i -> return (mkName ('_' : show i))
|
||||
varTypes =
|
||||
map VarT varNames
|
||||
constraints =
|
||||
map (ClassP ''Value . pure) varTypes
|
||||
head =
|
||||
AppT (ConT ''Row) (foldl AppT (TupleT arity) varTypes)
|
||||
fromRowDec =
|
||||
FunD 'fromRow [c1, c2]
|
||||
where
|
||||
c1 =
|
||||
Clause [ListP (map VarP varNames)] (NormalB e) []
|
||||
where
|
||||
e =
|
||||
foldQueue queue
|
||||
where
|
||||
con = ConE (tupleDataName arity)
|
||||
queue =
|
||||
(con :) $
|
||||
(VarE '(<$>) :) $
|
||||
intersperse (VarE '(<*>)) $
|
||||
map (AppE (VarE 'fromValue) . VarE) varNames
|
||||
foldQueue =
|
||||
\case
|
||||
e : o : t -> UInfixE e o (foldQueue t)
|
||||
e : [] -> e
|
||||
_ -> $bug "Unexpected queue size"
|
||||
c2 =
|
||||
Clause [WildP] (NormalB (ConE 'Nothing)) []
|
||||
in
|
||||
mapM (return . inst) [2 .. 24]
|
||||
|
||||
-- Generate single-type instaces using Template Haskell:
|
||||
let
|
||||
inst :: Name -> Dec
|
||||
inst n =
|
||||
InstanceD [] (AppT (ConT ''Row) (ConT n)) [fromRowDec]
|
||||
where
|
||||
fromRowDec =
|
||||
FunD 'fromRow [c1, c2]
|
||||
where
|
||||
c1 =
|
||||
Clause [ListP [VarP v]] (NormalB e) []
|
||||
where
|
||||
v = mkName "a"
|
||||
e = AppE (VarE 'fromValue) (VarE v)
|
||||
c2 =
|
||||
Clause [WildP] (NormalB (ConE 'Nothing)) []
|
||||
in
|
||||
mapM (return . inst)
|
||||
[''NominalDiffTime, ''UTCTime, ''ZonedTime, ''TimeOfDay, ''LocalTime,
|
||||
''Day, ''Rational, ''Double, ''Bool, ''Char, ''Integer, ''Int64,
|
||||
''Int32, ''Word64, ''Word32, ''ByteString, ''Text]
|
||||
|
||||
instance Row () where
|
||||
fromRow = \case [] -> Just (); _ -> Nothing
|
||||
|
||||
instance Row String where
|
||||
fromRow = fmap Text.unpack . fromRow
|
||||
|
||||
instance Row Word where
|
||||
fromRow = fmap (fromIntegral :: Word64 -> Word) . fromRow
|
||||
|
||||
instance Row Int where
|
||||
fromRow = fmap (fromIntegral :: Int64 -> Int) . fromRow
|
||||
@ -1,104 +0,0 @@
|
||||
module HighSQL.QQ where
|
||||
|
||||
import HighSQL.Prelude
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import qualified HighSQL.QQ.Parser as Parser
|
||||
import qualified HighSQL.API as API
|
||||
import qualified HighSQL.Backend as Backend
|
||||
import qualified HighSQL.Conversion as Conversion
|
||||
|
||||
|
||||
-- |
|
||||
-- Produces a lambda-expression,
|
||||
-- which takes as many parameters as there are placeholders in the statement
|
||||
-- and, depending on the statement kind, results in one of the following types:
|
||||
--
|
||||
-- [@SELECT@]
|
||||
--
|
||||
-- A stream of results, with 'API.T' as the inner monad:
|
||||
--
|
||||
-- @'API.ResultsStream' s ('API.T' l s) r@
|
||||
--
|
||||
-- [@INSERT@]
|
||||
--
|
||||
-- A transaction,
|
||||
-- which returns the possibly auto-incremented value
|
||||
-- (of the @id@ column typically):
|
||||
--
|
||||
-- @'API.T' l s (Maybe Integer)@
|
||||
--
|
||||
-- [@UPDATE, DELETE@]
|
||||
--
|
||||
-- A transaction,
|
||||
-- which returns the amount of affected rows:
|
||||
--
|
||||
-- @'API.T' l s Integer@
|
||||
--
|
||||
-- [@CREATE, ALTER, DROP, TRUNCATE@]
|
||||
--
|
||||
-- A unit transaction:
|
||||
--
|
||||
-- @'API.T' l s ()@
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- >write session $ do
|
||||
-- > artistIDMaybe <- ListT.head $ [q| SELECT id FROM artists WHERE name = ? |] "Metallica"
|
||||
-- > userIDMaybe <- ListT.head $ [q| SELECT id FROM users WHERE name = ? |] "Nikita Volkov"
|
||||
-- > forM_ ((,) <$> artistIDMaybe <*> userIDMaybe) $ \(artistID, userID) ->
|
||||
-- > [q| INSERT INTO artists_fans (artist_id, user_id) VALUES (?, ?) |] artistID userID
|
||||
--
|
||||
-- Of course, the same thing can be implemented a bit smarter:
|
||||
--
|
||||
-- >write session $ sequence_ $ ListT.head $ do
|
||||
-- > artistID <- [q| SELECT id FROM artists WHERE name = ? |] "Metallica"
|
||||
-- > userID <- [q| SELECT id FROM users WHERE name = ? |] "Nikita Volkov"
|
||||
-- > return $ [q| INSERT INTO artists_fans (artist_id, user_id) VALUES (?, ?) |] artistID userID
|
||||
--
|
||||
-- In both examples above we execute a 'write' transaction,
|
||||
-- in which we query two tables and insert a row into a third one.
|
||||
q :: QuasiQuoter
|
||||
q =
|
||||
QuasiQuoter
|
||||
parseExp
|
||||
(const $ fail "Pattern context is not supported")
|
||||
(const $ fail "Type context is not supported")
|
||||
(const $ fail "Declaration context is not supported")
|
||||
|
||||
|
||||
parseExp :: String -> Q Exp
|
||||
parseExp s =
|
||||
do
|
||||
(k, n) <-
|
||||
either (fail . (showString "Parsing failure: ")) return (Parser.parse (fromString s))
|
||||
return $ fmapLamE (AppE (VarE (conName k))) (statementF s n)
|
||||
where
|
||||
conName =
|
||||
\case
|
||||
Parser.Select -> 'API.select
|
||||
Parser.Update -> 'API.update
|
||||
Parser.Insert -> 'API.insert
|
||||
Parser.Delete -> 'API.update
|
||||
Parser.Create -> 'API.create
|
||||
Parser.Alter -> 'API.create
|
||||
Parser.Drop -> 'API.create
|
||||
Parser.Truncate -> 'API.create
|
||||
|
||||
-- |
|
||||
-- An expression of an arbitrary arg-length function,
|
||||
-- which produces a "API.Statement".
|
||||
statementF :: String -> Int -> Exp
|
||||
statementF s n =
|
||||
LamE pats exp
|
||||
where
|
||||
vars = map (mkName . ('_' :) . show) [1 .. n]
|
||||
pats = map VarP vars
|
||||
exp = AppE (AppE (ConE 'API.Statement) (LitE (StringL s))) (ListE exps)
|
||||
where
|
||||
exps = map (AppE (VarE 'Conversion.toValue) . VarE) vars
|
||||
|
||||
fmapLamE :: (Exp -> Exp) -> Exp -> Exp
|
||||
fmapLamE f =
|
||||
\case
|
||||
LamE pats exp -> LamE pats (f exp)
|
||||
Loading…
Reference in New Issue
Block a user