{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Postgres.Query
( sql,
Query (..),
Error (..),
format,
details,
)
where
import Control.Monad (void)
import Data.String (String)
import qualified Data.Text.Encoding
import Database.PostgreSQL.Typed (PGConnection, pgSQL, useTPGDatabase)
import Database.PostgreSQL.Typed.Array ()
import Database.PostgreSQL.Typed.Query (getQueryString, pgQuery)
import qualified Database.PostgreSQL.Typed.Types as PGTypes
import qualified Environment
import Language.Haskell.TH (ExpQ)
import Language.Haskell.TH.Quote
( QuasiQuoter (QuasiQuoter, quoteDec, quoteExp, quotePat, quoteType),
)
import Language.Haskell.TH.Syntax (runIO)
import qualified List
import qualified Log
import qualified Log.SqlQuery as SqlQuery
import Postgres.Error (Error (..))
import qualified Postgres.QueryParser as Parser
import qualified Postgres.Settings
import qualified Text
import Prelude (IO)
import qualified Prelude
data Query row = Query
{
Query row -> PGConnection -> IO [row]
runQuery :: PGConnection -> IO [row],
Query row -> Text
sqlString :: Text,
Query row -> Text
quasiQuotedString :: Text,
Query row -> Text
sqlOperation :: Text,
Query row -> Text
queriedRelation :: Text
}
qqSQL :: String -> ExpQ
qqSQL :: String -> ExpQ
qqSQL String
query = do
let db :: IO PGDatabase
db =
Decoder Settings -> IO Settings
forall a. Decoder a -> IO a
Environment.decode Decoder Settings
Postgres.Settings.decoder
IO Settings -> (IO Settings -> IO PGDatabase) -> IO PGDatabase
forall a b. a -> (a -> b) -> b
|> (Settings -> PGDatabase) -> IO Settings -> IO PGDatabase
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map Settings -> PGDatabase
Postgres.Settings.toPGDatabase
PGDatabase
db' <- IO PGDatabase -> Q PGDatabase
forall a. IO a -> Q a
runIO IO PGDatabase
db
Q [Dec] -> Q ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PGDatabase -> Q [Dec]
useTPGDatabase PGDatabase
db')
let meta :: QueryMeta
meta = Text -> QueryMeta
Parser.parse (String -> Text
Text.fromList String
query)
let op :: String
op = Text -> String
Text.toList (QueryMeta -> Text
Parser.sqlOperation QueryMeta
meta)
let rel :: String
rel = Text -> String
Text.toList (QueryMeta -> Text
Parser.queriedRelation QueryMeta
meta)
[e|
let q = $(quoteExp pgSQL query)
in Query
{ runQuery = \c -> pgQuery c q,
sqlString = Data.Text.Encoding.decodeUtf8 (getQueryString PGTypes.unknownPGTypeEnv q),
quasiQuotedString = Text.fromList query,
sqlOperation = op,
queriedRelation = rel
}
|]
sql :: QuasiQuoter
sql :: QuasiQuoter
sql =
QuasiQuoter :: (String -> ExpQ)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> ExpQ
quoteExp = String -> ExpQ
qqSQL,
quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
Prelude.error String
"sql not supported in types",
quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
Prelude.error String
"sql not supported in patterns",
quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
Prelude.error String
"sql not supported in declarations"
}
format :: Query row -> Text.Text
format :: Query row -> Text
format Query row
query =
let fixBang :: Text -> Text
fixBang Text
query_ =
case Text -> Maybe (Char, Text)
Text.uncons Text
query_ of
Just (Char
'!', Text
rest) -> Text
"! " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> Text
Text.trim Text
rest
Just (Char, Text)
_ -> Text
query_
Maybe (Char, Text)
Nothing -> Text
query_
indent :: appendable -> appendable
indent appendable
string =
appendable
" " appendable -> appendable -> appendable
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ appendable
string
in Query row -> Text
forall row. Query row -> Text
quasiQuotedString Query row
query
Text -> (Text -> List Text) -> List Text
forall a b. a -> (a -> b) -> b
|> Text -> Text -> List Text
Text.split Text
"\n"
List Text -> (List Text -> List Text) -> List Text
forall a b. a -> (a -> b) -> b
|> (Text -> Text) -> List Text -> List Text
forall a b. (a -> b) -> List a -> List b
List.map Text -> Text
Text.trim
List Text -> (List Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> List Text -> Text
Text.join Text
"\n "
Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> Text
fixBang
Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> Text
forall appendable.
(Semigroup appendable, IsString appendable) =>
appendable -> appendable
indent
details :: Query row -> SqlQuery.Details -> SqlQuery.Details
details :: Query row -> Details -> Details
details Query row
query Details
connectionDetails =
Details
connectionDetails
{ query :: Maybe (Secret Text)
SqlQuery.query = Secret Text -> Maybe (Secret Text)
forall a. a -> Maybe a
Just (Text -> Secret Text
forall a. a -> Secret a
Log.mkSecret (Query row -> Text
forall row. Query row -> Text
sqlString Query row
query)),
queryTemplate :: Maybe Text
SqlQuery.queryTemplate = Text -> Maybe Text
forall a. a -> Maybe a
Just (Query row -> Text
forall row. Query row -> Text
quasiQuotedString Query row
query),
sqlOperation :: Maybe Text
SqlQuery.sqlOperation = Text -> Maybe Text
forall a. a -> Maybe a
Just (Query row -> Text
forall row. Query row -> Text
sqlOperation Query row
query),
queriedRelation :: Maybe Text
SqlQuery.queriedRelation = Text -> Maybe Text
forall a. a -> Maybe a
Just (Query row -> Text
forall row. Query row -> Text
queriedRelation Query row
query)
}