{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeApplications      #-}

module Database.PostgreSQL.PureSpec (spec) where

import           Database.PostgreSQL.Pure
import qualified Database.PostgreSQL.Pure.Oid     as Oid

import           Test.Hspec                       hiding (beforeAllWith)
import           Test.Hspec.Core.Hooks.Extra

import           Control.Monad                    (void)
import qualified Data.Attoparsec.ByteString       as AP
import qualified Data.Attoparsec.ByteString.Char8 as AP
import qualified Data.ByteString                  as BS
import qualified Data.ByteString.Char8            as BSC
import qualified Data.ByteString.UTF8             as BSU
import           Data.Default.Class               (Default (def))
import           Data.Int                         (Int32)
import           Data.Maybe                       (fromMaybe)
import qualified Data.Tuple.Homotuple             as T
import           Data.Tuple.Homotuple.Only        ()
import           Data.Tuple.Only                  (Only (Only))
import qualified Network.Socket                   as NS
import           System.Environment               (lookupEnv)
import           Text.Read                        (readMaybe)

{-# ANN module ("HLint: ignore Redundant do" :: String) #-}

data Env =
  Env
    { hostString :: String
    , portString :: String
    , host       :: Maybe NS.HostAddress
    , port       :: Maybe NS.PortNumber
    , user       :: String
    , password   :: String
    , database   :: String
    }

spec :: Spec
spec = do
  beforeAll
    ( do
        hostString <- getEnvDef "PURE_HOST" "127.0.0.1"
        portString <- getEnvDef "PURE_PORT" "5432"
        let
          host = fromEitherToMaybe $ parseHostIPv4 $ BSC.pack hostString
          port = readMaybe portString :: Maybe NS.PortNumber
        user <- getEnvDef "PURE_USER" "postgres"
        password <- getEnvDef "PURE_PASSWORD" ""
        database <- getEnvDef "PURE_DATABASE" "postgres"
        pure Env { hostString, portString, host, port, user, password, database }
    )
    $ do
        describe "connection" $ do
          describe "connect/disconnect" $ do
            it "resolved address" $ \Env { host, port, user, password, database } -> do
              case (host, port) of
                (Just host, Just port) -> do
                  let
                    config =
                      def
                        { address = AddressResolved $ NS.SockAddrInet port host
                        , user
                        , password
                        , database
                        }
                  conn <- connect config
                  disconnect conn
                _ -> pendingWith "the given host and port are not resolved"

            it "not-resolved address" $ \Env { hostString, portString, user, password, database } -> do
              let
                config =
                  def
                    { address = AddressNotResolved hostString portString
                    , user
                    , password
                    , database
                    }
              conn <- connect config
              disconnect conn

          it "withConnection" $ \Env { hostString, portString, user, password, database } -> do
            let
              config =
                def
                  { address = AddressNotResolved hostString portString
                  , user
                  , password
                  , database
                  }
            withConnection config (const $ pure ())

        beforeAllWith
          ( \Env { hostString, portString, user, password, database } -> do
              let
                config =
                  def
                    { address = AddressNotResolved hostString portString
                    , user
                    , password
                    , database
                    }
              connect config
          )
          $ afterAll
              disconnect
              $ do
                  describe "CREATE TABLE/DROP TABLE" $ do
                    it "hints, hints" $ \conn -> do
                      let
                        e0 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "CREATE TABLE test (value INT NOT NULL)" (Just (T.Empty, T.Empty))
                        e1 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DROP TABLE IF EXISTS test" (Just (T.Empty, T.Empty))
                      (((_, _, e0, _), (_, _, e1, _)), ts) <- sync conn (e0, e1)
                      ts `shouldBe` Idle
                      result e0 `shouldBe` ExecuteComplete CreateTableTag
                      records e0 `shouldBe` ([] :: [()])
                      result e1 `shouldBe` ExecuteComplete DropTableTag
                      records e1 `shouldBe` ([] :: [()])

                    it "no hints, no hints" $ \conn -> do
                      let
                        e0 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "CREATE TABLE test (value INT NOT NULL)" Nothing
                        e1 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DROP TABLE IF EXISTS test" Nothing
                      (((_, _, e0, _), (_, _, e1, _)), ts) <- sync conn (e0, e1)
                      ts `shouldBe` Idle
                      result e0 `shouldBe` ExecuteComplete CreateTableTag
                      records e0 `shouldBe` ([] :: [()])
                      result e1 `shouldBe` ExecuteComplete DropTableTag
                      records e1 `shouldBe` ([] :: [()])

                  beforeWith
                    ( \conn -> do
                         let
                           e0 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "CREATE TABLE test (value INT NOT NULL)" (Just (T.Empty, T.Empty))
                           e1 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "INSERT INTO test (value) VALUES (0), (1), (2)" (Just (T.Empty, T.Empty))
                         (((_, _, e0, _), (_, _, e1, _)), ts) <- sync conn (e0, e1)
                         ts `shouldBe` Idle
                         result e0 `shouldBe` ExecuteComplete CreateTableTag
                         records e0 `shouldBe` ([] :: [()])
                         result e1 `shouldSatisfy` \(ExecuteComplete (InsertTag _ 3)) -> True
                         records e1 `shouldBe` ([] :: [()])
                         pure conn
                    )
                    $ after
                        ( \conn -> do
                            let
                              e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DROP TABLE IF EXISTS test" (Just (T.Empty, T.Empty))
                            ((_, _, e, _), ts) <- sync conn e
                            ts `shouldBe` Idle
                            result e `shouldBe` ExecuteComplete DropTableTag
                            records e `shouldBe` ([] :: [()])
                        )
                        $ do
                            describe "table: test (value INT NOT NULL)" $ do
                              it "DELETE FROM test WHERE value = 0" $ \conn -> do
                                let
                                  e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DELETE FROM test WHERE value = 0" (Just (T.Empty, T.Empty))
                                ((_, _, e, _), ts) <- sync conn e
                                ts `shouldBe` Idle
                                result e `shouldBe` ExecuteComplete (DeleteTag 1)
                                records e `shouldBe` ([] :: [()])

                              it "UPDATE test SET value = 10 WHERE value = 1" $ \conn -> do
                                let
                                  e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "UPDATE test SET value = 10 WHERE value = 1" (Just (T.Empty, T.Empty))
                                ((_, _, e, _), ts) <- sync conn e
                                ts `shouldBe` Idle
                                result e `shouldBe` ExecuteComplete (UpdateTag 1)
                                records e `shouldBe` ([] :: [()])

                              it "SELECT value FROM test ORDER BY value (get all)" $ \conn -> do
                                let
                                  e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value" (Just (T.Empty, Only Oid.int4))
                                ((_, _, e, _), ts) <- sync conn e
                                ts `shouldBe` Idle
                                result e `shouldBe` ExecuteComplete (SelectTag 3)
                                records e `shouldBe` ([Only 0, Only 1, Only 2] :: [Only Int])

                              it "SELECT value FROM test ORDER BY value (get a part)" $ \conn -> do
                                let
                                  e = execute 1 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value" (Just (T.Empty, Only Oid.int4))
                                ((_, _, e, _), ts) <- sync conn e
                                ts `shouldBe` Idle
                                result e `shouldBe` ExecuteSuspended
                                records e `shouldBe` ([Only 0] :: [Only Int])

                              it "SELECT value FROM test ORDER BY value (reuse portal)" $ \conn -> do
                                let
                                  p = forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value" (Just (T.Empty, Only Oid.int4))
                                  e = execute 2 (pure . BSU.toString) p
                                (_, p, e, _) <- flush conn e
                                result e `shouldBe` ExecuteSuspended
                                records e `shouldBe` ([Only 0, Only 1] :: [Only Int])
                                let
                                  e = execute 1 (pure . BSU.toString) p
                                (_, _, e, _) <- flush conn e
                                result e `shouldBe` ExecuteSuspended
                                records e `shouldBe` ([Only 2] :: [Only Int])
                                let
                                  e = execute 1 (pure . BSU.toString) p
                                ((_, _, e, _), ts) <- sync conn e
                                ts `shouldBe` Idle
                                result e `shouldBe` ExecuteComplete (SelectTag 0)
                                records e `shouldBe` ([] :: [Only Int])

                              it "SELECT value FROM test WHERE value = $1 (reuse prepared statement)" $ \conn -> do
                                let
                                  ps = parse "" "SELECT value FROM test WHERE value = $1" (Just (Only Oid.int4, Only Oid.int4))
                                  e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) (Only (0 :: Int32)) ps
                                ((ps, _, e, _), ts) <- sync conn e
                                ts `shouldBe` Idle
                                result e `shouldBe` ExecuteComplete (SelectTag 1)
                                records e `shouldBe` [Only (0 :: Int)]
                                let
                                  e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) (Only (2 :: Int32)) ps
                                ((_, _, e, _), ts) <- sync conn e
                                ts `shouldBe` Idle
                                result e `shouldBe` ExecuteComplete (SelectTag 1)
                                records e `shouldBe` [Only (2 :: Int)]

                              it "BEGIN/ROLLBACK" $ \conn -> do
                                ((_, _, e, _), ts) <- sync conn begin
                                ts `shouldBe` Block
                                result e `shouldBe` ExecuteComplete BeginTag
                                records e `shouldBe` []
                                ((_, _, e, _), ts) <- sync conn rollback
                                ts `shouldBe` Idle
                                result e `shouldBe` ExecuteComplete RollbackTag
                                records e `shouldBe` []

                              it "BEGIN/COMMIT" $ \conn -> do
                                ((_, _, e, _), ts) <- sync conn begin
                                ts `shouldBe` Block
                                result e `shouldBe` ExecuteComplete BeginTag
                                records e `shouldBe` []
                                ((_, _, e, _), ts) <- sync conn commit
                                ts `shouldBe` Idle
                                result e `shouldBe` ExecuteComplete CommitTag
                                records e `shouldBe` []

                            describe "invalid SQL" $ do
                              it "parse sync" $ \conn -> do
                                let
                                  ps = parse "" "INVALID SQL" (Just (T.Empty, T.Empty))
                                sync conn ps `shouldThrow` (\ErrorResponse {} -> True)

                              it "parse flush" $ \conn -> do
                                let
                                  ps = parse "" "INVALID SQL" (Just (T.Empty, T.Empty))
                                flush conn ps `shouldThrow` (\ErrorResponse {} -> True)

                            describe "invalid parameter type" $ do
                              it "parse sync" $ \conn -> do
                                let
                                  ps = parse "" "SELECT value FROM test WHERE value = $1" (Just (Only Oid.varchar, Only Oid.int4))
                                void $ sync conn ps `shouldThrow` (\ErrorResponse {} -> True)

                              it "parse flush" $ \conn -> do
                                let
                                  ps = parse "" "SELECT value FROM test WHERE value = $1" (Just (Only Oid.varchar, Only Oid.int4))
                                void $ flush conn ps `shouldThrow` (\ErrorResponse {} -> True)

                            describe "invalid result type" $ do
                              it "parse/bind sync" $ \conn -> do
                                let
                                  p = forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Just (T.Empty, Only Oid.varchar))
                                ((_, _), ts) <- sync conn p
                                ts `shouldBe` Idle

                              it "parse/bind flush" $ \conn -> do
                                let
                                  p = forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Just (T.Empty, Only Oid.varchar))
                                void $ flush conn p

                              it "parse/bind/execute sync" $ \conn -> do
                                let
                                  e = execute @_ @_ @(Only Int) 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Just (T.Empty, Only Oid.varchar))
                                sync conn e `shouldThrow` (\ResponseParsingFailed {} -> True)

                              it "parse/bind/execute flush" $ \conn -> do
                                let
                                  e = execute @_ @_ @(Only Int) 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Just (T.Empty, Only Oid.varchar))
                                flush conn e `shouldThrow` (\ResponseParsingFailed {} -> True)

getEnvDef :: String -> String -> IO String
getEnvDef name value = fromMaybe value <$> lookupEnv name

parseHostIPv4 :: BS.ByteString -> Either String NS.HostAddress
parseHostIPv4 =
  AP.parseOnly ipv4Parser
  where
    ipv4Parser = do
      p1 <- AP.decimal
      void $ AP.char '.'
      p2 <- AP.decimal
      void $ AP.char '.'
      p3 <- AP.decimal
      void $ AP.char '.'
      p4 <- AP.decimal
      pure $ NS.tupleToHostAddress (p1, p2, p3, p4)

fromEitherToMaybe :: Either a b -> Maybe b
fromEitherToMaybe (Left _)  = Nothing
fromEitherToMaybe (Right b) = Just b

forceRight :: Either String a -> a
forceRight (Right a) = a
forceRight (Left e)  = error $ "forceRight: " <> e