From 335b6188d14d0e58e8a308b800dadd09689093cd Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Sat, 16 Sep 2023 18:39:45 +0200 Subject: [PATCH] Clean up column table code --- lib/Database/PostgreSQL/Opium.hs | 127 +++++++++++---------- lib/Database/PostgreSQL/Opium/Error.hs | 16 ++- lib/Database/PostgreSQL/Opium/FromField.hs | 19 +-- test/Database/PostgreSQL/OpiumSpec.hs | 18 +-- 4 files changed, 91 insertions(+), 89 deletions(-) diff --git a/lib/Database/PostgreSQL/Opium.hs b/lib/Database/PostgreSQL/Opium.hs index 6813f85..8739585 100644 --- a/lib/Database/PostgreSQL/Opium.hs +++ b/lib/Database/PostgreSQL/Opium.hs @@ -11,21 +11,23 @@ module Database.PostgreSQL.Opium ( Error (..) - , FieldError (..) + , ErrorPosition (..) , FromField (..) , FromRow (..) , fetch_ ) where +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT) -import Control.Monad.Trans.State (StateT (..), evalStateT, modify) import Data.ByteString (ByteString) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Data.Proxy (Proxy (..)) import Data.Text (Text) import Database.PostgreSQL.LibPQ ( Column , Connection + , Oid , Result , Row ) @@ -36,43 +38,48 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified Database.PostgreSQL.LibPQ as LibPQ -import Database.PostgreSQL.Opium.Error (Error (..)) -import Database.PostgreSQL.Opium.FromField (FieldError (..), FromField (..), fromField) +import Database.PostgreSQL.Opium.Error (Error (..), ErrorPosition (..)) +import Database.PostgreSQL.Opium.FromField (FromField (..), fromField) -execParams :: Connection -> ByteString -> IO (Either Error Result) +execParams :: Connection -> ByteString -> ExceptT Error IO Result execParams conn query = do - LibPQ.execParams conn query [] LibPQ.Text >>= \case + liftIO (LibPQ.execParams conn query [] LibPQ.Text) >>= \case Nothing -> - pure $ Left ErrorNoResult + except $ Left ErrorNoResult Just result -> do - status <- LibPQ.resultStatus result - mbMessage <- LibPQ.resultErrorMessage result + status <- liftIO $ LibPQ.resultStatus result + mbMessage <- liftIO $ LibPQ.resultErrorMessage result case mbMessage of - Just "" -> pure $ Right result - Just message -> pure $ Left $ ErrorInvalidResult status $ Encoding.decodeUtf8 message - Nothing -> pure $ Right result + Just "" -> pure result + Nothing -> pure result + Just message -> except $ Left $ ErrorInvalidResult status $ Encoding.decodeUtf8 message fetch_ :: forall a. FromRow a => Connection -> ByteString -> IO (Either Error [a]) fetch_ conn query = runExceptT $ do - result <- ExceptT $ execParams conn query + result <- execParams conn query -- TODO: Use unboxed array for columnTable columnTable <- ExceptT $ getColumnTable @a Proxy result - nRows <- ExceptT $ Right <$> LibPQ.ntuples result + nRows <- liftIO $ LibPQ.ntuples result mapM (ExceptT . fromRow result columnTable) [0..nRows - 1] -type ColumnTable = [Column] +type ColumnTable = [(Column, Oid)] + +indexColumnTable :: ColumnTable -> Int -> (Column, Oid) +indexColumnTable = (!!) class FromRow a where - getColumnTable :: Proxy a -> Result -> IO (Either Error [Column]) - default getColumnTable :: (Generic a, GetColumnTable' (Rep a)) => Proxy a -> Result -> IO (Either Error [Column]) + getColumnTable :: Proxy a -> Result -> IO (Either Error ColumnTable) + default getColumnTable :: (Generic a, GetColumnTable' (Rep a)) => Proxy a -> Result -> IO (Either Error ColumnTable) getColumnTable Proxy = runExceptT . getColumnTable' @(Rep a) Proxy fromRow :: Result -> ColumnTable -> Row -> IO (Either Error a) default fromRow :: (Generic a, FromRow' (Rep a)) => Result -> ColumnTable -> Row -> IO (Either Error a) - fromRow result columnTable row = evalStateT (fmap to <$> fromRow' result columnTable row) 0 + fromRow result columnTable row = do + iRef <- newIORef 0 + runExceptT $ to <$> fromRow' (FromRowCtx result columnTable iRef) row class GetColumnTable' f where - getColumnTable' :: Proxy (f p) -> Result -> ExceptT Error IO [Column] + getColumnTable' :: Proxy (f p) -> Result -> ExceptT Error IO ColumnTable instance GetColumnTable' f => GetColumnTable' (M1 D c f) where getColumnTable' Proxy = getColumnTable' @f Proxy @@ -84,12 +91,12 @@ instance (GetColumnTable' f, GetColumnTable' g) => GetColumnTable' (f :*: g) whe getColumnTable' Proxy result = (++) <$> getColumnTable' @f Proxy result <*> getColumnTable' @g Proxy result -checkColumn :: forall a. FromField a => Proxy a -> String -> Result -> ExceptT Error IO [Column] +checkColumn :: forall a. FromField a => Proxy a -> String -> Result -> ExceptT Error IO ColumnTable checkColumn Proxy nameStr result = do column <- ExceptT $ maybe (Left $ ErrorMissingColumn nameText) Right <$> LibPQ.fnumber result name - oid <- ExceptT $ Right <$> LibPQ.ftype result column + oid <- liftIO $ LibPQ.ftype result column if validOid @a Proxy oid then - pure [column] + pure [(column, oid)] else except $ Left $ ErrorInvalidOid nameText oid where @@ -102,62 +109,60 @@ instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => GetColumnTab instance {-# OVERLAPPING #-} (KnownSymbol nameSym, FromField t) => GetColumnTable' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where getColumnTable' Proxy = checkColumn @t Proxy $ symbolVal @nameSym Proxy +data FromRowCtx = FromRowCtx Result ColumnTable (IORef Int) + class FromRow' f where - fromRow' :: Result -> ColumnTable -> Row -> StateT Int IO (Either Error (f p)) + fromRow' :: FromRowCtx -> Row -> ExceptT Error IO (f p) instance FromRow' f => FromRow' (M1 D c f) where - fromRow' result columnTable row = fmap M1 <$> fromRow' result columnTable row + fromRow' ctx row = M1 <$> fromRow' ctx row instance FromRow' f => FromRow' (M1 C c f) where - fromRow' result columnTable row = fmap M1 <$> fromRow' result columnTable row + fromRow' ctx row = M1 <$> fromRow' ctx row instance (FromRow' f, FromRow' g) => FromRow' (f :*: g) where - fromRow' result columnTable row = do - y <- fromRow' result columnTable row - modify (+1) - z <- fromRow' result columnTable row - pure $ (:*:) <$> y <*> z + fromRow' ctx@(FromRowCtx _ _ iRef) row = do + y <- fromRow' ctx row + liftIO $ modifyIORef' iRef (+1) + z <- fromRow' ctx row + pure $ y :*: z decodeField :: FromField t => Text -> (Row -> Maybe t -> Either Error t') - -> Result - -> ColumnTable + -> FromRowCtx -> Row - -> StateT Int IO (Either Error (M1 S m (Rec0 t') p)) -decodeField nameText g result columnTable row = StateT $ \i -> do - v <- runExceptT $ do - let column = columnTable !! i - oid <- ExceptT $ pure <$> LibPQ.ftype result column - mbField <- getFieldText column - mbValue <- getValue oid mbField - value <- except $ g row mbValue - pure $ M1 $ K1 value - - pure (v, i) + -> ExceptT Error IO (M1 S m (Rec0 t') p) +decodeField nameText g (FromRowCtx result columnTable iRef) row = do + i <- liftIO $ readIORef iRef + let (column, oid) = columnTable `indexColumnTable` i + mbField <- liftIO $ getFieldText column + mbValue <- except $ getValue oid mbField + value <- except $ g row mbValue + pure $ M1 $ K1 value where - getFieldText :: Column -> ExceptT Error IO (Maybe Text) + getFieldText :: Column -> IO (Maybe Text) getFieldText column = - ExceptT $ Right . fmap Encoding.decodeUtf8 <$> LibPQ.getvalue result row column + fmap Encoding.decodeUtf8 <$> LibPQ.getvalue result row column - getValue :: FromField u => LibPQ.Oid -> Maybe Text -> ExceptT Error IO (Maybe u) - getValue oid = except . maybe - (Right Nothing) - (fmap Just . mapLeft (ErrorDecode row nameText) . fromField oid) - -instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where - fromRow' = decodeField nameText $ \row -> maybe - (Left $ ErrorUnexpectedNull row nameText) - Right - where - nameText = Text.pack $ symbolVal @nameSym Proxy - -instance {-# OVERLAPPING #-} (KnownSymbol nameSym, FromField t) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where - fromRow' = decodeField nameText $ const Right - where - nameText = Text.pack $ symbolVal @nameSym Proxy + getValue :: FromField u => LibPQ.Oid -> Maybe Text -> Either Error (Maybe u) + getValue oid = maybe (Right Nothing) $ \fieldText -> + mapLeft + (ErrorInvalidField (ErrorPosition row nameText) oid fieldText) + (Just <$> fromField fieldText) mapLeft :: (b -> c) -> Either b a -> Either c a mapLeft f (Left l) = Left $ f l mapLeft _ (Right r) = Right r + +instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where + fromRow' = decodeField nameText $ \row -> + maybe (Left $ ErrorUnexpectedNull $ ErrorPosition row nameText) Right + where + nameText = Text.pack $ symbolVal @nameSym Proxy + +instance {-# OVERLAPPING #-} (KnownSymbol nameSym, FromField t) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where + fromRow' = decodeField nameText $ const pure + where + nameText = Text.pack $ symbolVal @nameSym Proxy diff --git a/lib/Database/PostgreSQL/Opium/Error.hs b/lib/Database/PostgreSQL/Opium/Error.hs index f655031..8486f10 100644 --- a/lib/Database/PostgreSQL/Opium/Error.hs +++ b/lib/Database/PostgreSQL/Opium/Error.hs @@ -1,15 +1,21 @@ -module Database.PostgreSQL.Opium.Error (Error (..)) where +module Database.PostgreSQL.Opium.Error (Error (..), ErrorPosition (..)) where +import Control.Exception (Exception) import Data.Text (Text) import Database.PostgreSQL.LibPQ (ExecStatus, Oid, Row) -import Database.PostgreSQL.Opium.FromField (FieldError) +data ErrorPosition = ErrorPosition + { errorPositionRow :: Row + , errorPositionColumn :: Text + } deriving (Eq, Show) data Error - = ErrorDecode Row Text FieldError - | ErrorNoResult + = ErrorNoResult | ErrorInvalidResult ExecStatus Text | ErrorMissingColumn Text | ErrorInvalidOid Text Oid - | ErrorUnexpectedNull Row Text + | ErrorUnexpectedNull ErrorPosition + | ErrorInvalidField ErrorPosition Oid Text String deriving (Eq, Show) + +instance Exception Error where diff --git a/lib/Database/PostgreSQL/Opium/FromField.hs b/lib/Database/PostgreSQL/Opium/FromField.hs index 6290d3d..d673597 100644 --- a/lib/Database/PostgreSQL/Opium/FromField.hs +++ b/lib/Database/PostgreSQL/Opium/FromField.hs @@ -3,8 +3,7 @@ {-# LANGUAGE TypeApplications #-} module Database.PostgreSQL.Opium.FromField - ( FieldError (..) - , FromField (..) + ( FromField (..) , fromField ) where @@ -25,23 +24,15 @@ import Database.PostgreSQL.LibPQ (Oid) import GHC.Float (double2Float) 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 -data FieldError - = FieldErrorUnexpectedNull - | FieldErrorInvalidField Oid Text String - deriving (Eq, Show) - -mapLeft :: (b -> c) -> Either b a -> Either c a -mapLeft f (Left l) = Left $ f l -mapLeft _ (Right r) = Right r - -fromField :: FromField a => Oid -> Text -> Either FieldError a -fromField oid field = - mapLeft (FieldErrorInvalidField oid field) $ parseOnly parseField field +fromField :: FromField a => Text -> Either String a +fromField = + parseOnly parseField class FromField a where validOid :: Proxy a -> Oid -> Bool diff --git a/test/Database/PostgreSQL/OpiumSpec.hs b/test/Database/PostgreSQL/OpiumSpec.hs index a60e46c..15124e2 100644 --- a/test/Database/PostgreSQL/OpiumSpec.hs +++ b/test/Database/PostgreSQL/OpiumSpec.hs @@ -47,16 +47,16 @@ spec = do it "Gets the column table for a result" $ \conn -> do Just result <- LibPQ.execParams conn "SELECT name, age FROM person" [] LibPQ.Text columnTable <- Opium.getColumnTable @Person Proxy result - columnTable `shouldBe` Right [0, 1] + fmap (map fst) columnTable `shouldBe` Right [0, 1] it "Gets the numbers right for funky configurations" $ \conn -> do Just result0 <- LibPQ.execParams conn "SELECT age, name FROM person" [] LibPQ.Text columnTable0 <- Opium.getColumnTable @Person Proxy result0 - columnTable0 `shouldBe` Right [1, 0] + fmap (map fst) columnTable0 `shouldBe` Right [1, 0] Just result1 <- LibPQ.execParams conn "SELECT 0 AS a, 1 AS b, 2 AS c, age, 4 AS d, name FROM person" [] LibPQ.Text columnTable1 <- Opium.getColumnTable @Person Proxy result1 - columnTable1 `shouldBe` Right [5, 3] + fmap (map fst) columnTable1 `shouldBe` Right [5, 3] it "Fails for missing columns" $ \conn -> do Just result <- LibPQ.execParams conn "SELECT 0 AS a FROM person" [] LibPQ.Text @@ -68,31 +68,31 @@ spec = do Just result <- LibPQ.execParams conn "SELECT * FROM person" [] LibPQ.Text Right columnTable <- Opium.getColumnTable @Person Proxy result - row0 <- Opium.fromRow @Person result columnTable (LibPQ.Row 0) + row0 <- Opium.fromRow @Person result columnTable 0 row0 `shouldBe` Right (Person "paul" 25) - row1 <- Opium.fromRow @Person result columnTable (LibPQ.Row 1) + row1 <- Opium.fromRow @Person result columnTable 1 row1 `shouldBe` Right (Person "albus" 103) it "Decodes NULL into Nothing for Maybes" $ \conn -> do Just result <- LibPQ.execParams conn "SELECT NULL AS a" [] LibPQ.Text Right columnTable <- Opium.getColumnTable @MaybeTest Proxy result - row <- Opium.fromRow result columnTable (LibPQ.Row 0) + row <- Opium.fromRow result columnTable 0 row `shouldBe` Right (MaybeTest Nothing) it "Decodes values into Just for Maybes" $ \conn -> do Just result <- LibPQ.execParams conn "SELECT 'abc' AS a" [] LibPQ.Text Right columnTable <- Opium.getColumnTable @MaybeTest Proxy result - row <- Opium.fromRow result columnTable (LibPQ.Row 0) + row <- Opium.fromRow result columnTable 0 row `shouldBe` Right (MaybeTest $ Just "abc") it "Works for many fields" $ \conn -> do Just result <- LibPQ.execParams conn "SELECT 'abc' AS a, 42 AS b, 1.0::double precision AS c, 'test' AS d, true AS e" [] LibPQ.Text Right columnTable <- Opium.getColumnTable @ManyFields Proxy result - row <- Opium.fromRow result columnTable (LibPQ.Row 0) + row <- Opium.fromRow result columnTable 0 row `shouldBe` Right (ManyFields "abc" 42 1.0 "test" True) describe "fetch_" $ do @@ -106,7 +106,7 @@ spec = do it "Fails for unexpected NULLs" $ \conn -> do rows <- Opium.fetch_ @Person conn "SELECT NULL AS name, 0 AS age" - rows `shouldBe` Left (Opium.ErrorUnexpectedNull (LibPQ.Row 0) "name") + rows `shouldBe` Left (Opium.ErrorUnexpectedNull (Opium.ErrorPosition 0 "name")) it "Fails for the wrong column type" $ \conn -> do rows <- Opium.fetch_ @Person conn "SELECT 'quby' AS name, 'indeterminate' AS age"