module Orville.PostgreSQL.Raw.RawSql
( RawSql
, parameter
, fromString
, fromText
, fromBytes
, intercalate
, execute
, executeVoid
, connectionQuoting
, space
, comma
, commaSpace
, leftParen
, rightParen
, dot
, doubleQuote
, doubleColon
, stringLiteral
, identifier
, parenthesized
, intDecLiteral
, int8DecLiteral
, int16DecLiteral
, int32DecLiteral
, int64DecLiteral
, SqlExpression (toRawSql, unsafeFromRawSql)
, unsafeSqlExpression
, toBytesAndParams
, toExampleBytes
, Quoting (Quoting, quoteStringLiteral, quoteIdentifier)
, exampleQuoting
)
where
import Control.Monad (void)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as LBS
import Data.DList (DList)
import qualified Data.DList as DList
import qualified Data.Foldable as Fold
import Data.Functor.Identity (Identity (Identity, runIdentity))
import qualified Data.Int as Int
import qualified Data.List as List
import qualified Data.Text as T
import qualified Data.Text.Encoding as TextEnc
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Orville.PostgreSQL.Raw.Connection as Conn
import Orville.PostgreSQL.Raw.PgTextFormatValue (PgTextFormatValue)
import Orville.PostgreSQL.Raw.SqlValue (SqlValue)
import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue
data RawSql
= SqlSection BSB.Builder
| Parameter SqlValue
| StringLiteral BS.ByteString
| Identifier BS.ByteString
| Append RawSql RawSql
instance Semigroup RawSql where
(SqlSection Builder
builderA) <> :: RawSql -> RawSql -> RawSql
<> (SqlSection Builder
builderB) =
Builder -> RawSql
SqlSection (Builder
builderA Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
builderB)
RawSql
otherA <> RawSql
otherB =
RawSql -> RawSql -> RawSql
Append RawSql
otherA RawSql
otherB
instance Monoid RawSql where
mempty :: RawSql
mempty = Builder -> RawSql
SqlSection Builder
forall a. Monoid a => a
mempty
class SqlExpression a where
toRawSql :: a -> RawSql
unsafeFromRawSql :: RawSql -> a
instance SqlExpression RawSql where
toRawSql :: RawSql -> RawSql
toRawSql = RawSql -> RawSql
forall a. a -> a
id
unsafeFromRawSql :: RawSql -> RawSql
unsafeFromRawSql = RawSql -> RawSql
forall a. a -> a
id
unsafeSqlExpression :: SqlExpression a => String -> a
unsafeSqlExpression :: forall a. SqlExpression a => String -> a
unsafeSqlExpression =
RawSql -> a
forall a. SqlExpression a => RawSql -> a
unsafeFromRawSql (RawSql -> a) -> (String -> RawSql) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> RawSql
fromString
data Quoting m = Quoting
{ forall (m :: * -> *). Quoting m -> ByteString -> m Builder
quoteStringLiteral :: BS.ByteString -> m BSB.Builder
, forall (m :: * -> *). Quoting m -> ByteString -> m Builder
quoteIdentifier :: BS.ByteString -> m BSB.Builder
}
exampleQuoting :: Quoting Identity
exampleQuoting :: Quoting Identity
exampleQuoting =
Quoting
{ quoteStringLiteral :: ByteString -> Identity Builder
quoteStringLiteral = Builder -> Identity Builder
forall a. a -> Identity a
Identity (Builder -> Identity Builder)
-> (ByteString -> Builder) -> ByteString -> Identity Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> Builder
exampleQuoteString Char
'\''
, quoteIdentifier :: ByteString -> Identity Builder
quoteIdentifier = Builder -> Identity Builder
forall a. a -> Identity a
Identity (Builder -> Identity Builder)
-> (ByteString -> Builder) -> ByteString -> Identity Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> Builder
exampleQuoteString Char
'"'
}
exampleQuoteString :: Char -> BS.ByteString -> BSB.Builder
exampleQuoteString :: Char -> ByteString -> Builder
exampleQuoteString Char
quoteChar =
let
quote :: Either (Char, ByteString) ByteString
-> Maybe (Char, Either (Char, ByteString) ByteString)
quote (Right ByteString
bs) =
case ByteString -> Maybe (Char, ByteString)
B8.uncons ByteString
bs of
Maybe (Char, ByteString)
Nothing ->
Maybe (Char, Either (Char, ByteString) ByteString)
forall a. Maybe a
Nothing
Just (Char
char, ByteString
rest) ->
(Char, Either (Char, ByteString) ByteString)
-> Maybe (Char, Either (Char, ByteString) ByteString)
forall a. a -> Maybe a
Just ((Char, Either (Char, ByteString) ByteString)
-> Maybe (Char, Either (Char, ByteString) ByteString))
-> (Char, Either (Char, ByteString) ByteString)
-> Maybe (Char, Either (Char, ByteString) ByteString)
forall a b. (a -> b) -> a -> b
$
if Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
quoteChar
then (Char
char, (Char, ByteString) -> Either (Char, ByteString) ByteString
forall a b. a -> Either a b
Left (Char
char, ByteString
rest))
else (Char
char, ByteString -> Either (Char, ByteString) ByteString
forall a b. b -> Either a b
Right ByteString
rest)
quote (Left (Char
char, ByteString
rest)) =
(Char, Either (Char, ByteString) ByteString)
-> Maybe (Char, Either (Char, ByteString) ByteString)
forall a. a -> Maybe a
Just (Char
char, ByteString -> Either (Char, ByteString) ByteString
forall a b. b -> Either a b
Right ByteString
rest)
quoteBytes :: Builder
quoteBytes =
Char -> Builder
BSB.char8 Char
quoteChar
in
\ByteString
unquoted ->
Builder
quoteBytes
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BSB.byteString ((Either (Char, ByteString) ByteString
-> Maybe (Char, Either (Char, ByteString) ByteString))
-> Either (Char, ByteString) ByteString -> ByteString
forall a. (a -> Maybe (Char, a)) -> a -> ByteString
B8.unfoldr Either (Char, ByteString) ByteString
-> Maybe (Char, Either (Char, ByteString) ByteString)
quote (ByteString -> Either (Char, ByteString) ByteString
forall a b. b -> Either a b
Right ByteString
unquoted))
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
quoteBytes
connectionQuoting :: Conn.Connection -> Quoting IO
connectionQuoting :: Connection -> Quoting IO
connectionQuoting Connection
connection =
Quoting
{ quoteStringLiteral :: ByteString -> IO Builder
quoteStringLiteral = Connection -> ByteString -> IO Builder
Conn.quoteStringLiteral Connection
connection
, quoteIdentifier :: ByteString -> IO Builder
quoteIdentifier = Connection -> ByteString -> IO Builder
Conn.quoteIdentifier Connection
connection
}
toBytesAndParams ::
(SqlExpression sql, Monad m) =>
Quoting m ->
sql ->
m (BS.ByteString, [Maybe PgTextFormatValue])
toBytesAndParams :: forall sql (m :: * -> *).
(SqlExpression sql, Monad m) =>
Quoting m -> sql -> m (ByteString, [Maybe PgTextFormatValue])
toBytesAndParams Quoting m
quoting sql
sql = do
(Builder
byteBuilder, ParamsProgress
finalProgress) <-
Quoting m
-> ParamsProgress -> RawSql -> m (Builder, ParamsProgress)
forall (m :: * -> *).
Monad m =>
Quoting m
-> ParamsProgress -> RawSql -> m (Builder, ParamsProgress)
buildSqlWithProgress Quoting m
quoting ParamsProgress
startingProgress (sql -> RawSql
forall a. SqlExpression a => a -> RawSql
toRawSql sql
sql)
(ByteString, [Maybe PgTextFormatValue])
-> m (ByteString, [Maybe PgTextFormatValue])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( ByteString -> ByteString
LBS.toStrict (Builder -> ByteString
BSB.toLazyByteString Builder
byteBuilder)
, DList (Maybe PgTextFormatValue) -> [Maybe PgTextFormatValue]
forall a. DList a -> [a]
DList.toList (ParamsProgress -> DList (Maybe PgTextFormatValue)
paramValues ParamsProgress
finalProgress)
)
toExampleBytes :: SqlExpression sql => sql -> BS.ByteString
toExampleBytes :: forall sql. SqlExpression sql => sql -> ByteString
toExampleBytes =
(ByteString, [Maybe PgTextFormatValue]) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, [Maybe PgTextFormatValue]) -> ByteString)
-> (sql -> (ByteString, [Maybe PgTextFormatValue]))
-> sql
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (ByteString, [Maybe PgTextFormatValue])
-> (ByteString, [Maybe PgTextFormatValue])
forall a. Identity a -> a
runIdentity (Identity (ByteString, [Maybe PgTextFormatValue])
-> (ByteString, [Maybe PgTextFormatValue]))
-> (sql -> Identity (ByteString, [Maybe PgTextFormatValue]))
-> sql
-> (ByteString, [Maybe PgTextFormatValue])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quoting Identity
-> sql -> Identity (ByteString, [Maybe PgTextFormatValue])
forall sql (m :: * -> *).
(SqlExpression sql, Monad m) =>
Quoting m -> sql -> m (ByteString, [Maybe PgTextFormatValue])
toBytesAndParams Quoting Identity
exampleQuoting
data ParamsProgress = ParamsProgress
{ ParamsProgress -> Int
paramCount :: Int
, ParamsProgress -> DList (Maybe PgTextFormatValue)
paramValues :: DList (Maybe PgTextFormatValue)
}
startingProgress :: ParamsProgress
startingProgress :: ParamsProgress
startingProgress =
ParamsProgress
{ paramCount :: Int
paramCount = Int
0
, paramValues :: DList (Maybe PgTextFormatValue)
paramValues = DList (Maybe PgTextFormatValue)
forall a. DList a
DList.empty
}
snocParam :: ParamsProgress -> Maybe PgTextFormatValue -> ParamsProgress
snocParam :: ParamsProgress -> Maybe PgTextFormatValue -> ParamsProgress
snocParam (ParamsProgress Int
count DList (Maybe PgTextFormatValue)
values) Maybe PgTextFormatValue
newValue =
ParamsProgress
{ paramCount :: Int
paramCount = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
, paramValues :: DList (Maybe PgTextFormatValue)
paramValues = DList (Maybe PgTextFormatValue)
-> Maybe PgTextFormatValue -> DList (Maybe PgTextFormatValue)
forall a. DList a -> a -> DList a
DList.snoc DList (Maybe PgTextFormatValue)
values Maybe PgTextFormatValue
newValue
}
buildSqlWithProgress ::
Monad m =>
Quoting m ->
ParamsProgress ->
RawSql ->
m (BSB.Builder, ParamsProgress)
buildSqlWithProgress :: forall (m :: * -> *).
Monad m =>
Quoting m
-> ParamsProgress -> RawSql -> m (Builder, ParamsProgress)
buildSqlWithProgress Quoting m
quoting ParamsProgress
progress RawSql
rawSql =
case RawSql
rawSql of
SqlSection Builder
builder ->
(Builder, ParamsProgress) -> m (Builder, ParamsProgress)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder
builder, ParamsProgress
progress)
StringLiteral ByteString
unquotedString -> do
Builder
quotedString <- Quoting m -> ByteString -> m Builder
forall (m :: * -> *). Quoting m -> ByteString -> m Builder
quoteStringLiteral Quoting m
quoting ByteString
unquotedString
(Builder, ParamsProgress) -> m (Builder, ParamsProgress)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder
quotedString, ParamsProgress
progress)
Identifier ByteString
unquotedIdentifier -> do
Builder
quotedIdentifier <- Quoting m -> ByteString -> m Builder
forall (m :: * -> *). Quoting m -> ByteString -> m Builder
quoteIdentifier Quoting m
quoting ByteString
unquotedIdentifier
(Builder, ParamsProgress) -> m (Builder, ParamsProgress)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder
quotedIdentifier, ParamsProgress
progress)
Parameter SqlValue
value ->
let
newProgress :: ParamsProgress
newProgress = ParamsProgress -> Maybe PgTextFormatValue -> ParamsProgress
snocParam ParamsProgress
progress (SqlValue -> Maybe PgTextFormatValue
SqlValue.toPgValue SqlValue
value)
placeholder :: Builder
placeholder = String -> Builder
BSB.stringUtf8 String
"$" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
BSB.intDec (ParamsProgress -> Int
paramCount ParamsProgress
newProgress)
in
(Builder, ParamsProgress) -> m (Builder, ParamsProgress)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder
placeholder, ParamsProgress
newProgress)
Append RawSql
first RawSql
second -> do
(Builder
firstBuilder, ParamsProgress
nextProgress) <- Quoting m
-> ParamsProgress -> RawSql -> m (Builder, ParamsProgress)
forall (m :: * -> *).
Monad m =>
Quoting m
-> ParamsProgress -> RawSql -> m (Builder, ParamsProgress)
buildSqlWithProgress Quoting m
quoting ParamsProgress
progress RawSql
first
(Builder
secondBuilder, ParamsProgress
finalProgress) <- Quoting m
-> ParamsProgress -> RawSql -> m (Builder, ParamsProgress)
forall (m :: * -> *).
Monad m =>
Quoting m
-> ParamsProgress -> RawSql -> m (Builder, ParamsProgress)
buildSqlWithProgress Quoting m
quoting ParamsProgress
nextProgress RawSql
second
(Builder, ParamsProgress) -> m (Builder, ParamsProgress)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder
firstBuilder Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
secondBuilder, ParamsProgress
finalProgress)
fromString :: String -> RawSql
fromString :: String -> RawSql
fromString =
Builder -> RawSql
SqlSection (Builder -> RawSql) -> (String -> Builder) -> String -> RawSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
BSB.stringUtf8
fromText :: T.Text -> RawSql
fromText :: Text -> RawSql
fromText =
Builder -> RawSql
SqlSection (Builder -> RawSql) -> (Text -> Builder) -> Text -> RawSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
TextEnc.encodeUtf8Builder
fromBytes :: BS.ByteString -> RawSql
fromBytes :: ByteString -> RawSql
fromBytes =
Builder -> RawSql
SqlSection (Builder -> RawSql)
-> (ByteString -> Builder) -> ByteString -> RawSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
BSB.byteString
parameter :: SqlValue -> RawSql
parameter :: SqlValue -> RawSql
parameter =
SqlValue -> RawSql
Parameter
stringLiteral :: BS.ByteString -> RawSql
stringLiteral :: ByteString -> RawSql
stringLiteral =
ByteString -> RawSql
StringLiteral
identifier :: BS.ByteString -> RawSql
identifier :: ByteString -> RawSql
identifier =
ByteString -> RawSql
Identifier
intercalate :: (SqlExpression sql, Foldable f) => RawSql -> f sql -> RawSql
intercalate :: forall sql (f :: * -> *).
(SqlExpression sql, Foldable f) =>
RawSql -> f sql -> RawSql
intercalate RawSql
separator =
[RawSql] -> RawSql
forall a. Monoid a => [a] -> a
mconcat
([RawSql] -> RawSql) -> (f sql -> [RawSql]) -> f sql -> RawSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSql -> [RawSql] -> [RawSql]
forall a. a -> [a] -> [a]
List.intersperse RawSql
separator
([RawSql] -> [RawSql]) -> (f sql -> [RawSql]) -> f sql -> [RawSql]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (sql -> RawSql) -> [sql] -> [RawSql]
forall a b. (a -> b) -> [a] -> [b]
map sql -> RawSql
forall a. SqlExpression a => a -> RawSql
toRawSql
([sql] -> [RawSql]) -> (f sql -> [sql]) -> f sql -> [RawSql]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f sql -> [sql]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList
execute :: SqlExpression sql => Conn.Connection -> sql -> IO LibPQ.Result
execute :: forall sql. SqlExpression sql => Connection -> sql -> IO Result
execute Connection
connection sql
sql = do
(ByteString
sqlBytes, [Maybe PgTextFormatValue]
params) <- Quoting IO -> sql -> IO (ByteString, [Maybe PgTextFormatValue])
forall sql (m :: * -> *).
(SqlExpression sql, Monad m) =>
Quoting m -> sql -> m (ByteString, [Maybe PgTextFormatValue])
toBytesAndParams (Connection -> Quoting IO
connectionQuoting Connection
connection) sql
sql
Connection -> ByteString -> [Maybe PgTextFormatValue] -> IO Result
Conn.executeRaw Connection
connection ByteString
sqlBytes [Maybe PgTextFormatValue]
params
executeVoid :: SqlExpression sql => Conn.Connection -> sql -> IO ()
executeVoid :: forall sql. SqlExpression sql => Connection -> sql -> IO ()
executeVoid Connection
connection sql
sql = do
IO Result -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Result -> IO ()) -> IO Result -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> sql -> IO Result
forall sql. SqlExpression sql => Connection -> sql -> IO Result
execute Connection
connection sql
sql
space :: RawSql
space :: RawSql
space = String -> RawSql
fromString String
" "
comma :: RawSql
comma :: RawSql
comma = String -> RawSql
fromString String
","
commaSpace :: RawSql
commaSpace :: RawSql
commaSpace = String -> RawSql
fromString String
", "
leftParen :: RawSql
leftParen :: RawSql
leftParen = String -> RawSql
fromString String
"("
rightParen :: RawSql
rightParen :: RawSql
rightParen = String -> RawSql
fromString String
")"
dot :: RawSql
dot :: RawSql
dot = String -> RawSql
fromString String
"."
doubleQuote :: RawSql
doubleQuote :: RawSql
doubleQuote = String -> RawSql
fromString String
"\""
doubleColon :: RawSql
doubleColon :: RawSql
doubleColon = String -> RawSql
fromString String
"::"
int8DecLiteral :: Int.Int8 -> RawSql
int8DecLiteral :: Int8 -> RawSql
int8DecLiteral =
Builder -> RawSql
SqlSection (Builder -> RawSql) -> (Int8 -> Builder) -> Int8 -> RawSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Builder
BSB.int8Dec
int16DecLiteral :: Int.Int16 -> RawSql
int16DecLiteral :: Int16 -> RawSql
int16DecLiteral =
Builder -> RawSql
SqlSection (Builder -> RawSql) -> (Int16 -> Builder) -> Int16 -> RawSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Builder
BSB.int16Dec
int32DecLiteral :: Int.Int32 -> RawSql
int32DecLiteral :: Int32 -> RawSql
int32DecLiteral =
Builder -> RawSql
SqlSection (Builder -> RawSql) -> (Int32 -> Builder) -> Int32 -> RawSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Builder
BSB.int32Dec
int64DecLiteral :: Int.Int64 -> RawSql
int64DecLiteral :: Int64 -> RawSql
int64DecLiteral =
Builder -> RawSql
SqlSection (Builder -> RawSql) -> (Int64 -> Builder) -> Int64 -> RawSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Builder
BSB.int64Dec
intDecLiteral :: Int -> RawSql
intDecLiteral :: Int -> RawSql
intDecLiteral =
Builder -> RawSql
SqlSection (Builder -> RawSql) -> (Int -> Builder) -> Int -> RawSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder
BSB.intDec
parenthesized :: SqlExpression sql => sql -> RawSql
parenthesized :: forall a. SqlExpression a => a -> RawSql
parenthesized sql
expr =
RawSql
leftParen RawSql -> RawSql -> RawSql
forall a. Semigroup a => a -> a -> a
<> sql -> RawSql
forall a. SqlExpression a => a -> RawSql
toRawSql sql
expr RawSql -> RawSql -> RawSql
forall a. Semigroup a => a -> a -> a
<> RawSql
rightParen