From 8c8740e4b8a970376deb186343213c521ebc3728 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Sun, 3 Sep 2023 04:02:07 +0200 Subject: [PATCH] Add unit tests and reimplement FromField --- README.md | 11 +++ flake.nix | 3 + lib/Database/PostgreSQL/Opium.hs | 42 +++++++---- lib/Database/PostgreSQL/Opium/FromField.hs | 52 ++++++++++++++ lib/Database/PostgreSQL/Opium/Oid.hs | 31 ++++++++ opium.cabal | 19 ++++- .../PostgreSQL/Opium/FromFieldSpec.hs | 70 +++++++++++++++++++ test/Database/PostgreSQL/OpiumSpec.hs | 37 ++++++++++ test/Main.hs | 19 +---- test/SpecHook.hs | 43 ++++++++++++ 10 files changed, 293 insertions(+), 34 deletions(-) create mode 100644 README.md create mode 100644 lib/Database/PostgreSQL/Opium/FromField.hs create mode 100644 lib/Database/PostgreSQL/Opium/Oid.hs create mode 100644 test/Database/PostgreSQL/Opium/FromFieldSpec.hs create mode 100644 test/Database/PostgreSQL/OpiumSpec.hs create mode 100644 test/SpecHook.hs diff --git a/README.md b/README.md new file mode 100644 index 0000000..bd65508 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# opium + +> An opionated Haskell Postgres library. + +## TO DO + +- [x] Implement `String` and `Text` decoding +- [x] Implement `Int` decoding +- [ ] Implement error reporting i.e. use `Either OpiumError` instead of `Maybe` +- [ ] Implement `Float` and `Double` decoding +- [ ] Implement `UTCTime` and zoned time decoding diff --git a/flake.nix b/flake.nix index 806eaa2..805e2ec 100644 --- a/flake.nix +++ b/flake.nix @@ -14,10 +14,13 @@ pkgs.cabal-install pkgs.haskellPackages.implicit-hie (pkgs.ghc.withPackages (hp: with hp; [ + attoparsec containers bytestring + hspec postgresql-libpq text + transformers ])) pkgs.haskell-language-server diff --git a/lib/Database/PostgreSQL/Opium.hs b/lib/Database/PostgreSQL/Opium.hs index 373f9bf..c77c514 100644 --- a/lib/Database/PostgreSQL/Opium.hs +++ b/lib/Database/PostgreSQL/Opium.hs @@ -5,12 +5,19 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -module Database.PostgreSQL.Opium where +module Database.PostgreSQL.Opium + ( FromField (..) + , FromRow (..) + , fetch_ + ) + where +import Control.Monad.Trans.Maybe (MaybeT (..)) import Data.ByteString (ByteString) import Data.Proxy (Proxy (Proxy)) import Database.PostgreSQL.LibPQ - (Result + ( Connection + , Result , Row ) import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..)) @@ -21,6 +28,18 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified Database.PostgreSQL.LibPQ as LibPQ +import Database.PostgreSQL.Opium.FromField (FromField (..)) + +fetch_ :: FromRow a => Connection -> ByteString -> IO (Maybe [a]) +fetch_ conn query = runMaybeT $ do + result <- MaybeT $ LibPQ.execParams conn query [] LibPQ.Text + MaybeT $ fetchResult result + +fetchResult :: FromRow a => Result -> IO (Maybe [a]) +fetchResult result = do + nRows <- LibPQ.ntuples result + runMaybeT $ mapM (MaybeT . flip fromRow result) [0..nRows - 1] + class FromRow a where fromRow :: Row -> Result -> IO (Maybe a) default fromRow :: (Generic a, FromRow' (Rep a)) => Row -> Result -> IO (Maybe a) @@ -48,16 +67,13 @@ instance (KnownSymbol nameSym, FromField t) => FromRow' (M1 S ('MetaSel ('Just n Nothing -> pure Nothing Just column -> do mbField <- LibPQ.getvalue result row column - printf "%s: %s" (show name) (show mbField) - pure $ M1 . K1 <$> fromField mbField + ty <- LibPQ.ftype result column + case fromField ty . Encoding.decodeUtf8 =<< mbField of + Nothing -> do + format <- LibPQ.fformat result column + printf "field %s: %s (oid: %s, format: %s)\n" (show name) (show mbField) (show ty) (show format) + pure Nothing + Just value -> + pure $ Just $ M1 $ K1 value where name = Encoding.encodeUtf8 $ Text.pack $ symbolVal (Proxy :: Proxy nameSym) - -class FromField a where - fromField :: Maybe ByteString -> Maybe a - -instance FromField String where - fromField = fmap (Text.unpack . Encoding.decodeUtf8) - -instance FromField Int where - fromField = fmap (read . Text.unpack . Encoding.decodeUtf8) diff --git a/lib/Database/PostgreSQL/Opium/FromField.hs b/lib/Database/PostgreSQL/Opium/FromField.hs new file mode 100644 index 0000000..9dd61e4 --- /dev/null +++ b/lib/Database/PostgreSQL/Opium/FromField.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} + +module Database.PostgreSQL.Opium.FromField (FromField (..)) where + +import Data.Attoparsec.Text + ( Parser + , decimal + , parseOnly + , signed + ) +import Data.Text (Text) +import Database.PostgreSQL.LibPQ (Oid) + +import qualified Data.Text as Text +import qualified Database.PostgreSQL.Opium.Oid as Oid + +(\/) :: (a -> Bool) -> (a -> Bool) -> a -> Bool +p \/ q = \x -> p x || q x + +eitherToMaybe :: Either b a -> Maybe a +eitherToMaybe = \case + Left _ -> Nothing + Right x -> Just x + +fromParser + :: (Oid -> Bool) + -> Parser a + -> Oid + -> Text + -> Maybe a +fromParser validOid parser oid value + | validOid oid = eitherToMaybe $ parseOnly parser value + | otherwise = Nothing + +class FromField a where + fromField :: Oid -> Text -> Maybe a + +instance FromField Int where + fromField = fromParser + (Oid.smallint \/ Oid.integer \/ Oid.bigint) + (signed decimal) + +instance FromField Text where + fromField oid text = + if Oid.text oid || Oid.character oid || Oid.characterVarying oid then + Just text + else + Nothing + +instance FromField String where + fromField oid text = Text.unpack <$> fromField oid text diff --git a/lib/Database/PostgreSQL/Opium/Oid.hs b/lib/Database/PostgreSQL/Opium/Oid.hs new file mode 100644 index 0000000..f16b78d --- /dev/null +++ b/lib/Database/PostgreSQL/Opium/Oid.hs @@ -0,0 +1,31 @@ +module Database.PostgreSQL.Opium.Oid where + +import Database.PostgreSQL.LibPQ (Oid (..)) + +eq :: Eq a => a -> a -> Bool +eq = (==) + +-- integer types + +-- | 16-bit integer +smallint :: Oid -> Bool +smallint = eq $ Oid 21 + +-- | 32-bit integer +integer :: Oid -> Bool +integer = eq $ Oid 23 + +-- | 64-bit integer +bigint :: Oid -> Bool +bigint = eq $ Oid 20 + +-- string types + +text :: Oid -> Bool +text = eq $ Oid 25 + +character :: Oid -> Bool +character = eq $ Oid 1042 + +characterVarying :: Oid -> Bool +characterVarying = eq $ Oid 1043 diff --git a/opium.cabal b/opium.cabal index e9a4150..dda2388 100644 --- a/opium.cabal +++ b/opium.cabal @@ -63,7 +63,9 @@ library Database.PostgreSQL.Opium -- Modules included in this library but not exported. - -- other-modules: + other-modules: + Database.PostgreSQL.Opium.FromField, + Database.PostgreSQL.Opium.Oid -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -71,10 +73,12 @@ library -- Other library packages from which modules are imported. build-depends: base, + attoparsec, bytestring, containers, postgresql-libpq, - text + text, + transformers -- Directories containing source files. hs-source-dirs: lib @@ -104,7 +108,16 @@ test-suite opium-test -- The entrypoint to the test suite. main-is: Main.hs + other-modules: + SpecHook, + Database.PostgreSQL.OpiumSpec, + Database.PostgreSQL.Opium.FromFieldSpec + -- Test dependencies. build-depends: base, - opium + opium, + bytestring, + hspec, + postgresql-libpq, + text diff --git a/test/Database/PostgreSQL/Opium/FromFieldSpec.hs b/test/Database/PostgreSQL/Opium/FromFieldSpec.hs new file mode 100644 index 0000000..7a31547 --- /dev/null +++ b/test/Database/PostgreSQL/Opium/FromFieldSpec.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Database.PostgreSQL.Opium.FromFieldSpec (spec) where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Database.PostgreSQL.LibPQ (Connection) +import Database.PostgreSQL.Opium (FromRow) +import GHC.Generics (Generic) +import Test.Hspec (SpecWith, describe, it, shouldBe) + +import qualified Database.PostgreSQL.Opium as Opium + +newtype SingleInt = SingleInt + { int :: Int + } deriving (Eq, Generic, Show) + +instance FromRow SingleInt where + +newtype SingleText = SingleText + { text :: Text + } deriving (Eq, Generic, Show) + +instance FromRow SingleText where + +newtype SingleString = SingleString + { string :: String + } deriving (Eq, Generic, Show) + +instance FromRow SingleString where + +shouldFetch :: (Eq a, FromRow a, Show a) => Connection -> ByteString -> [a] -> IO () +shouldFetch conn query expectedRows = do + Just actualRows <- Opium.fetch_ conn query + actualRows `shouldBe` expectedRows + +spec :: SpecWith Connection +spec = do + describe "FromField Int" $ do + it "Decodes smallint" $ \conn -> do + shouldFetch conn "SELECT 42::SMALLINT AS int" [SingleInt 42] + + it "Decodes integer" $ \conn -> do + shouldFetch conn "SELECT 42::INTEGER AS int" [SingleInt 42] + + it "Decodes bigint" $ \conn -> do + shouldFetch conn "SELECT 42::BIGINT AS int" [SingleInt 42] + + describe "FromField Text" $ do + it "Decodes text" $ \conn -> do + shouldFetch conn "SELECT 'Hello, World!'::TEXT AS text" [SingleText "Hello, World!"] + + it "Decodes character" $ \conn -> do + shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(10) AS text" [SingleText "Hello, Wor"] + shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(20) AS text" [SingleText "Hello, World! "] + + it "Decodes character varying" $ \conn -> do + shouldFetch conn "SELECT 'Hello, World!'::CHARACTER VARYING (20) AS text" [SingleText "Hello, World!"] + + describe "FromField String" $ do + it "Decodes text" $ \conn -> do + shouldFetch conn "SELECT 'Hello, World!'::TEXT AS string" [SingleString "Hello, World!"] + + it "Decodes character" $ \conn -> do + shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(10) AS string" [SingleString "Hello, Wor"] + shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(20) AS string" [SingleString "Hello, World! "] + + it "Decodes character varying" $ \conn -> do + shouldFetch conn "SELECT 'Hello, World!'::CHARACTER VARYING (20) AS string" [SingleString "Hello, World!"] diff --git a/test/Database/PostgreSQL/OpiumSpec.hs b/test/Database/PostgreSQL/OpiumSpec.hs new file mode 100644 index 0000000..4f779b7 --- /dev/null +++ b/test/Database/PostgreSQL/OpiumSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Database.PostgreSQL.OpiumSpec (spec) where + +import Data.Text (Text) +import Database.PostgreSQL.LibPQ (Connection) +import GHC.Generics (Generic) +import Test.Hspec (SpecWith, describe, it, shouldBe) + +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Database.PostgreSQL.Opium as Opium + +data Person = Person + { name :: Text + , age :: Int + } deriving (Eq, Generic, Show) + +instance Opium.FromRow Person where + +spec :: SpecWith Connection +spec = do + describe "fromRow" $ do + it "decodes rows in a Result" $ \conn -> do + Just result <- LibPQ.execParams conn "SELECT * FROM person" [] LibPQ.Text + + row0 <- Opium.fromRow @Person (LibPQ.Row 0) result + row0 `shouldBe` Just (Person "paul" 25) + + row1 <- Opium.fromRow @Person (LibPQ.Row 1) result + row1 `shouldBe` Just (Person "albus" 103) + + describe "fetch_" $ do + it "retrieves a list of rows" $ \conn -> do + rows <- Opium.fetch_ conn "SELECT * FROM person" + rows `shouldBe` Just [Person "paul" 25, Person "albus" 103] diff --git a/test/Main.hs b/test/Main.hs index d4c1af3..a824f8c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,18 +1 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Main (main) where - -import GHC.Generics (Generic) - -import Database.PostgreSQL.Opium (FromRow) - -data Person = Person - { name :: String - , age :: Int --- , lovesCats :: Bool - } deriving (Generic) - -instance FromRow Person where - -main :: IO () -main = putStrLn "TBD" +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/SpecHook.hs b/test/SpecHook.hs new file mode 100644 index 0000000..d02b716 --- /dev/null +++ b/test/SpecHook.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SpecHook (hook) where + +import Control.Exception (bracket) +import Database.PostgreSQL.LibPQ (Connection) +import System.Environment (lookupEnv) +import Test.Hspec (Spec, SpecWith, around) +import Text.Printf (printf) + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Encoding +import qualified Database.PostgreSQL.LibPQ as LibPQ + +setupConnection :: IO Connection +setupConnection = do + Just dbUser <- lookupEnv "DB_USER" + Just dbPass <- lookupEnv "DB_PASS" + Just dbName <- lookupEnv "DB_NAME" + Just dbPort <- lookupEnv "DB_PORT" + + let dsn = printf "host=localhost user=%s password=%s dbname=%s port=%s" dbUser dbPass dbName dbPort + conn <- LibPQ.connectdb $ Encoding.encodeUtf8 $ Text.pack dsn + _ <- LibPQ.setClientEncoding conn "UTF8" + + _ <- LibPQ.exec conn "CREATE TABLE person (name TEXT NOT NULL, age INT NOT NULL)" + _ <- LibPQ.exec conn "INSERT INTO person VALUES ('paul', 25), ('albus', 103)" + + pure conn + +teardownConnection :: Connection -> IO () +teardownConnection conn = do + _ <- LibPQ.exec conn "DROP TABLE person" + LibPQ.finish conn + +class SpecInput a where + hook :: SpecWith a -> Spec + +instance SpecInput Connection where + hook = around $ bracket setupConnection teardownConnection + +instance SpecInput () where + hook = id