{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
module PgNamed
(
NamedParam (..)
, Name (..)
, (=?)
, PgNamedError (..)
, WithNamedError
, extractNames
, namesToRow
, queryNamed
, queryWithNamed
, executeNamed
, executeNamed_
, withNamedArgs
) where
import Control.Monad (void)
import Control.Monad.Except (MonadError (throwError))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import Data.Char (isAlphaNum)
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty (..), toList)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import GHC.Exts (IsString)
import qualified Data.ByteString.Char8 as BS
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.FromRow as PG
import qualified Database.PostgreSQL.Simple.Internal as PG
import qualified Database.PostgreSQL.Simple.ToField as PG
import qualified Database.PostgreSQL.Simple.Types as PG
newtype Name = Name
{ Name -> Text
unName :: Text
} deriving newtype (Int -> Name -> ShowS
[Name] -> ShowS
Name -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Name] -> ShowS
$cshowList :: [Name] -> ShowS
show :: Name -> String
$cshow :: Name -> String
showsPrec :: Int -> Name -> ShowS
$cshowsPrec :: Int -> Name -> ShowS
Show, Name -> Name -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Eq Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c< :: Name -> Name -> Bool
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
Ord, String -> Name
forall a. (String -> a) -> IsString a
fromString :: String -> Name
$cfromString :: String -> Name
IsString)
data NamedParam = NamedParam
{ NamedParam -> Name
namedParamName :: !Name
, NamedParam -> Action
namedParamParam :: !PG.Action
} deriving stock (Int -> NamedParam -> ShowS
[NamedParam] -> ShowS
NamedParam -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NamedParam] -> ShowS
$cshowList :: [NamedParam] -> ShowS
show :: NamedParam -> String
$cshow :: NamedParam -> String
showsPrec :: Int -> NamedParam -> ShowS
$cshowsPrec :: Int -> NamedParam -> ShowS
Show)
data PgNamedError
= PgNamedParam Name
| PgNoNames PG.Query
| PgEmptyName PG.Query
deriving stock (PgNamedError -> PgNamedError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PgNamedError -> PgNamedError -> Bool
$c/= :: PgNamedError -> PgNamedError -> Bool
== :: PgNamedError -> PgNamedError -> Bool
$c== :: PgNamedError -> PgNamedError -> Bool
Eq)
type WithNamedError = MonadError PgNamedError
instance Show PgNamedError where
show :: PgNamedError -> String
show PgNamedError
e = String
"PostgreSQL named parameter error: " forall a. [a] -> [a] -> [a]
++ case PgNamedError
e of
PgNamedParam Name
n -> String
"Named parameter '" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
"' is not specified"
PgNoNames (PG.Query ByteString
q) ->
String
"Query has no names but was called with named functions: " forall a. [a] -> [a] -> [a]
++ ByteString -> String
BS.unpack ByteString
q
PgEmptyName (PG.Query ByteString
q) ->
String
"Query contains an empty name: " forall a. [a] -> [a] -> [a]
++ ByteString -> String
BS.unpack ByteString
q
lookupName :: Name -> [NamedParam] -> Maybe PG.Action
lookupName :: Name -> [NamedParam] -> Maybe Action
lookupName Name
n = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\NamedParam{Action
Name
namedParamParam :: Action
namedParamName :: Name
namedParamParam :: NamedParam -> Action
namedParamName :: NamedParam -> Name
..} -> (Name
namedParamName, Action
namedParamParam))
extractNames
:: PG.Query
-> Either PgNamedError (PG.Query, NonEmpty Name)
Query
qr = ByteString -> Either PgNamedError (ByteString, [Name])
go (Query -> ByteString
PG.fromQuery Query
qr) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(ByteString
_, []) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Query -> PgNamedError
PgNoNames Query
qr
(ByteString
q, Name
name:[Name]
names) -> forall a b. b -> Either a b
Right (ByteString -> Query
PG.Query ByteString
q, Name
name forall a. a -> [a] -> NonEmpty a
:| [Name]
names)
where
go :: ByteString -> Either PgNamedError (ByteString, [Name])
go :: ByteString -> Either PgNamedError (ByteString, [Name])
go ByteString
str
| ByteString -> Bool
BS.null ByteString
str = forall a b. b -> Either a b
Right (ByteString
"", [])
| Bool
otherwise = let (ByteString
before, ByteString
after) = ByteString -> (ByteString, ByteString)
PG.breakOnSingleQuestionMark ByteString
str in
case ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
after of
Maybe (Char, ByteString)
Nothing -> forall a b. b -> Either a b
Right (ByteString
before, [])
Just (Char
'?', ByteString
nameStart) ->
let (ByteString
name, ByteString
remainingQuery) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span Char -> Bool
isNameChar ByteString
nameStart
in if ByteString -> Bool
BS.null ByteString
name
then forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Query -> PgNamedError
PgEmptyName Query
qr
else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((ByteString
before forall a. Semigroup a => a -> a -> a
<> ByteString
"?") forall a. Semigroup a => a -> a -> a
<>) (Text -> Name
Name (ByteString -> Text
decodeUtf8 ByteString
name) forall a. a -> [a] -> [a]
:))
(ByteString -> Either PgNamedError (ByteString, [Name])
go ByteString
remainingQuery)
Just (Char, ByteString)
_ -> forall a. HasCallStack => String -> a
error String
"'break (== '?')' doesn't return string started with the question mark"
isNameChar :: Char -> Bool
isNameChar :: Char -> Bool
isNameChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'
namesToRow
:: forall m . WithNamedError m
=> NonEmpty Name
-> [NamedParam]
-> m (NonEmpty PG.Action)
namesToRow :: forall (m :: * -> *).
WithNamedError m =>
NonEmpty Name -> [NamedParam] -> m (NonEmpty Action)
namesToRow NonEmpty Name
names [NamedParam]
params = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> m Action
magicLookup NonEmpty Name
names
where
magicLookup :: Name -> m PG.Action
magicLookup :: Name -> m Action
magicLookup Name
n = case Name -> [NamedParam] -> Maybe Action
lookupName Name
n [NamedParam]
params of
Just Action
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Action
x
Maybe Action
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Name -> PgNamedError
PgNamedParam Name
n
infix 1 =?
(=?) :: (PG.ToField a) => Name -> a -> NamedParam
Name
n =? :: forall a. ToField a => Name -> a -> NamedParam
=? a
a = Name -> Action -> NamedParam
NamedParam Name
n forall a b. (a -> b) -> a -> b
$ forall a. ToField a => a -> Action
PG.toField a
a
{-# INLINE (=?) #-}
queryNamed
:: (MonadIO m, WithNamedError m, PG.FromRow res)
=> PG.Connection
-> PG.Query
-> [NamedParam]
-> m [res]
queryNamed :: forall (m :: * -> *) res.
(MonadIO m, WithNamedError m, FromRow res) =>
Connection -> Query -> [NamedParam] -> m [res]
queryNamed Connection
conn Query
qNamed [NamedParam]
params =
forall (m :: * -> *).
WithNamedError m =>
Query -> [NamedParam] -> m (Query, NonEmpty Action)
withNamedArgs Query
qNamed [NamedParam]
params forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Query
q, NonEmpty Action
actions) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
conn Query
q (forall a. NonEmpty a -> [a]
toList NonEmpty Action
actions)
queryWithNamed
:: (MonadIO m, WithNamedError m)
=> PG.RowParser res
-> PG.Connection
-> PG.Query
-> [NamedParam]
-> m [res]
queryWithNamed :: forall (m :: * -> *) res.
(MonadIO m, WithNamedError m) =>
RowParser res -> Connection -> Query -> [NamedParam] -> m [res]
queryWithNamed RowParser res
rowParser Connection
conn Query
qNamed [NamedParam]
params =
forall (m :: * -> *).
WithNamedError m =>
Query -> [NamedParam] -> m (Query, NonEmpty Action)
withNamedArgs Query
qNamed [NamedParam]
params forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Query
q, NonEmpty Action
actions) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall q r.
ToRow q =>
RowParser r -> Connection -> Query -> q -> IO [r]
PG.queryWith RowParser res
rowParser Connection
conn Query
q (forall a. NonEmpty a -> [a]
toList NonEmpty Action
actions)
executeNamed
:: (MonadIO m, WithNamedError m)
=> PG.Connection
-> PG.Query
-> [NamedParam]
-> m Int64
executeNamed :: forall (m :: * -> *).
(MonadIO m, WithNamedError m) =>
Connection -> Query -> [NamedParam] -> m Int64
executeNamed Connection
conn Query
qNamed [NamedParam]
params =
forall (m :: * -> *).
WithNamedError m =>
Query -> [NamedParam] -> m (Query, NonEmpty Action)
withNamedArgs Query
qNamed [NamedParam]
params forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Query
q, NonEmpty Action
actions) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall q. ToRow q => Connection -> Query -> q -> IO Int64
PG.execute Connection
conn Query
q (forall a. NonEmpty a -> [a]
toList NonEmpty Action
actions)
executeNamed_
:: (MonadIO m, WithNamedError m)
=> PG.Connection
-> PG.Query
-> [NamedParam]
-> m ()
executeNamed_ :: forall (m :: * -> *).
(MonadIO m, WithNamedError m) =>
Connection -> Query -> [NamedParam] -> m ()
executeNamed_ Connection
conn Query
qNamed = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadIO m, WithNamedError m) =>
Connection -> Query -> [NamedParam] -> m Int64
executeNamed Connection
conn Query
qNamed
{-# INLINE executeNamed_ #-}
withNamedArgs
:: WithNamedError m
=> PG.Query
-> [NamedParam]
-> m (PG.Query, NonEmpty PG.Action)
withNamedArgs :: forall (m :: * -> *).
WithNamedError m =>
Query -> [NamedParam] -> m (Query, NonEmpty Action)
withNamedArgs Query
qNamed [NamedParam]
namedArgs = do
(Query
q, NonEmpty Name
names) <- case Query -> Either PgNamedError (Query, NonEmpty Name)
extractNames Query
qNamed of
Left PgNamedError
errType -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PgNamedError
errType
Right (Query, NonEmpty Name)
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Query, NonEmpty Name)
r
NonEmpty Action
args <- forall (m :: * -> *).
WithNamedError m =>
NonEmpty Name -> [NamedParam] -> m (NonEmpty Action)
namesToRow NonEmpty Name
names [NamedParam]
namedArgs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Query
q, NonEmpty Action
args)