Check.hs

{-# LANGUAGE CPP #-}

-- |
-- Module      : Hasql.Check
-- Copyright   : (c) 2022 Kronor.io
--
-- License     : BSD-3-Clause
-- Maintainer  : lorenzo@kronor.io
-- Stability   : experimental
-- Portability : GHC
module Hasql.Check where

import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import PostgresqlSyntax qualified as Ast
import Pqi qualified
import Prelude


-- | Turn the SQL text inside a quasiquote into the SQL the splice actually
-- sends to Postgres, mirroring @Hasql.TH.expPreparableStmtAstParser@ composed
-- with @Hasql.TH.Extraction.Exp.sql@ line for line. Rendering at 'mempty'
-- drops the nullability markers.
renderSql :: Text -> Either String ByteString
renderSql sql = renderStmt <$> parseStmt sql


-- | The statement in a quasiquote, as the splice would render it.
parseStmt :: Text -> Either String Ast.PreparableStmt
parseStmt sql = either (Left . Text.unpack) (Right . lowerAst) (Ast.parse quoterSettings sql)


-- | A statement in plain SQL, as Postgres reads it, whatever syntax this
-- build takes in hasql-th's quotes: for the quoters of
-- "Hasql.Check.Inferred.TH", and the annotated statements that stand for
-- theirs, which hasql-th's nullability markers may annotate.
--
-- Not lowered: Kronor's fork numbers the placeholders afresh as it lowers
-- its parameter fields, which would turn a lone @$2@ into @$1@.
parsePlainStmt :: Bool -> Text -> Either String Ast.PreparableStmt
parsePlainStmt markers sql = either (Left . Text.unpack) Right (Ast.parse (Ast.nullabilityMarkers markers) sql)


renderStmt :: Ast.PreparableStmt -> ByteString
renderStmt = Text.encodeUtf8 . Ast.toText mempty

#ifdef KRONOR_SYNTAX

-- | The settings Kronor's fork of hasql-th parses with: upstream's nullability
-- markers, plus its Haskell targets and Haskell param fields.
quoterSettings :: Ast.Settings
quoterSettings =
    mconcat
        [ Ast.nullabilityMarkers True
        , Ast.haskellTargets True
        , Ast.haskellParamFields True
        ]


-- | 'Ast.lower' numbers the placeholders as they fall in the tree that will
-- actually be rendered - the one with the Haskell targets erased - but hands
-- back the tree that still carries them, because the quasiquoter builds its
-- row decoder by walking those targets. We have no decoder to build, so the
-- erasure the quasiquoter defers to 'Hasql.TH.Extraction.Exp' happens right
-- here.
lowerAst :: Ast.PreparableStmt -> Ast.PreparableStmt
lowerAst ast = Ast.eraseHaskellTargets (fst (Ast.lower ast))

#else

-- | The settings upstream hasql-th parses with.
quoterSettings :: Ast.Settings
quoterSettings = Ast.nullabilityMarkers True


-- | Upstream hasql-th renders the statement as parsed.
lowerAst :: Ast.PreparableStmt -> Ast.PreparableStmt
lowerAst = id

#endif


prepare :: Pqi.Connection -> Text -> Text -> IO (Either String ())
prepare conn stmtName unParsedStmt =
    either (pure . Left) (prepareStmt conn (Text.encodeUtf8 stmtName)) (parseStmt unParsedStmt)


-- | Prepare a statement under a name, returning the server's error if it fails.
prepareStmt :: Pqi.Connection -> ByteString -> Ast.PreparableStmt -> IO (Either String ())
prepareStmt conn stmtName stmt = do
    mr <- conn.prepare stmtName (renderStmt stmt) Nothing
    case mr of
        Nothing -> Left . maybe "Something went wrong" (Text.unpack . Text.decodeUtf8Lenient) <$> conn.errorMessage
        Just r -> do
            rs <- r.resultStatus
            if rs `elem` [Pqi.EmptyQuery, Pqi.BadResponse, Pqi.NonfatalError, Pqi.FatalError]
                then maybe (Left "Something went wrong") (Left . Text.unpack . Text.decodeUtf8Lenient) <$> r.resultErrorMessage
                else pure (Right ())