diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +0.1.0 +--- +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Moritz Kiefer (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Moritz Kiefer nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,31 @@ +# postgresql-named + +[![Travis](https://img.shields.io/travis/cocreature/postgresql-named.svg)]() +[![Hackage](https://img.shields.io/hackage/v/postgresql-named.svg)]() + +Library for deserializing rows in `postgresql-simple` (or any other +library that uses `FromRow`) based on column names instead of the +positions of columns. + +## Example + +```haskell +{-# LANGUAGE DeriveGeneric #-} +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.FromRow.Named +import qualified GHC.Generics as GHC +import Generics.SOP + +data Foobar = Foobar + { foo :: !String + , bar :: !Int + } deriving (Show, Eq, Ord, GHC.Generic) + + +instance Generic Foobar + +instance HasDatatypeInfo Foobar + +instance FromRow Foobar where + fromRow = gFromRow +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/postgresql-named.cabal b/postgresql-named.cabal new file mode 100644 --- /dev/null +++ b/postgresql-named.cabal @@ -0,0 +1,46 @@ +name: postgresql-named +version: 0.1.0 +synopsis: Generic deserialization of PostgreSQL rows based on column names +description: See README.md +homepage: https://github.com/cocreature/postgresql-named#readme +license: BSD3 +license-file: LICENSE +author: Moritz Kiefer +maintainer: moritz.kiefer@purelyfunctional.org +copyright: (C) 2017 Moritz Kiefer +category: Web +build-type: Simple +extra-source-files: README.md + CHANGELOG.md +cabal-version: >=1.10 +tested-with: GHC==8.0.2, GHC==8.2.1 + +library + hs-source-dirs: src + exposed-modules: Database.PostgreSQL.Simple.FromRow.Named + build-depends: base >= 4.9 && < 5 + , bytestring >= 0.10 && < 0.11 + , extra >= 1.5 && < 1.6 + , generics-sop >= 0.3 && < 0.4 + , mtl >= 2.2 && < 2.3 + , postgresql-libpq >= 0.9 && < 0.10 + , postgresql-simple >= 0.5 && < 0.6 + , utf8-string + default-language: Haskell2010 + ghc-options: -Wall + +test-suite postgresql-named-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , generics-sop + , hspec >= 2.4 && < 2.5 + , postgresql-named + , postgresql-simple + ghc-options: -Wall -threaded -rtsopts + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/cocreature/postgresql-named diff --git a/src/Database/PostgreSQL/Simple/FromRow/Named.hs b/src/Database/PostgreSQL/Simple/FromRow/Named.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromRow/Named.hs @@ -0,0 +1,162 @@ +{-| +Module : Database.PostgreSQL.Simple.FromRow.Named +Description : Generic implementation of FromRow based on record field names. +Copyright : (c) Moritz Kiefer, 2017 +License : BSD-3 +Maintainer : moritz.kiefer@purelyfunctional.org + +This module provides the machinery for implementing instances of +'FromRow' that deserialize based on the names of columns instead of +the positions of individual fields. This is particularly convenient +when deserializing to a Haskell record and you want the field names +and column names to match up. In this case 'gFromRow' can be used as +a generic implementation of 'fromRow'. +-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +module Database.PostgreSQL.Simple.FromRow.Named + ( -- * Generic implementation of FromRow + gFromRow + -- * Deserialize individual fields based on their name + , fieldByName + , fieldByNameWith + -- * Exception types + , NoSuchColumn(..) + , TooManyColumns(..) + ) where + +import Control.Exception +import Control.Monad.Extra +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.ByteString (ByteString) +import qualified Data.ByteString.UTF8 as BS +import Data.Typeable +import qualified Database.PostgreSQL.LibPQ as PQ +import Database.PostgreSQL.Simple.FromField hiding (name) +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.Internal +import GHC.TypeLits +import Generics.SOP +import qualified Generics.SOP.Type.Metadata as T + +npLength :: NP f xs -> Word +npLength xs = go 0 xs + where + go :: Word -> NP f xs -> Word + go !i Nil = i + go !i (_ :* xs') = go (i + 1) xs' + +-- | Deserialize a type with a single record constructor by matching +-- the names of columns and record fields. Currently the complexity is /O(n^2)/ where n is the +-- number of record fields. +-- +-- This is intended to be used as the implementation of 'fromRow'. +-- +-- Throws +-- +-- * 'NoSuchColumn' if there is a field for which there is no +-- column with the same name. +-- +-- * 'TooManyColumns' if there more columns (counting both named +-- and unnamed columns) than record fields. +gFromRow :: forall a modName tyName constrName fields xs. + ( Generic a + , HasDatatypeInfo a + , All2 FromField (Code a) + , KnownSymbol modName + , KnownSymbol tyName + , DatatypeInfoOf a ~ 'T.ADT modName tyName '[ 'T.Record constrName fields] + , Code a ~ '[xs] + , T.DemoteFieldInfos fields xs + ) => RowParser a +gFromRow = do + let f :: forall f. FromField f => FieldInfo f -> RowParser f + f (FieldInfo name) = fieldByName (BS.fromString name) + fieldInfos :: NP FieldInfo xs + fieldInfos = T.demoteFieldInfos (Proxy @fields) + guardMatchingColumnNumber (npLength fieldInfos) + res <- + fmap (to . SOP . Z) $ + hsequence + (hcliftA + (Proxy :: Proxy FromField) + f + (T.demoteFieldInfos (Proxy :: Proxy fields))) + setToLastCol + pure res + +guardMatchingColumnNumber :: Word -> RowParser () +guardMatchingColumnNumber numFields = + RP $ do + Row {rowresult} <- ask + PQ.Col (fromIntegral -> numCols) <- liftIO' (PQ.nfields rowresult) + when + (numCols /= numFields) + ((lift . lift . conversionError) (TooManyColumns numFields numCols)) + +liftIO' :: IO a -> ReaderT Row (StateT PQ.Column Conversion) a +liftIO' = lift . lift . liftConversion + +-- | Thrown when there is no column of the given name. +data NoSuchColumn = + NoSuchColumn ByteString + deriving (Show, Eq, Ord, Typeable) + +instance Exception NoSuchColumn + +-- | Thrown by 'gFromRow' when trying to deserialize to a record that +-- has less fields than the current row has columns (counting both +-- named and unnamed columns). +data TooManyColumns = TooManyColumns + { numRecordFields :: !Word -- ^ The expected number of record fields. + , numColumns :: !Word -- ^ The number of columns in the row that should have been deserialized. + } deriving (Show, Eq, Ord, Typeable) + +instance Exception TooManyColumns + + +-- | This is similar to 'fieldWith' but instead of trying to +-- deserialize the field at the current position it goes through all +-- fields in the current row (starting at the beginning not the +-- current position) and tries to deserialize the first field with a +-- matching column name. +fieldByNameWith :: FieldParser a -> ByteString {- ^ column name to look for -} -> RowParser a +fieldByNameWith fieldP name = + RP $ do + Row {rowresult, row} <- ask + ncols <- liftIO' (PQ.nfields rowresult) + matchingCol <- + liftIO' $ + findM + (\col -> (Just name ==) <$> PQ.fname rowresult col) + [PQ.Col 0 .. ncols - 1] + case matchingCol of + Nothing -> (lift . lift . conversionError) (NoSuchColumn name) + Just col -> + (lift . lift) $ do + oid <- liftConversion (PQ.ftype rowresult col) + val <- liftConversion (PQ.getvalue rowresult row col) + fieldP (Field rowresult col oid) val + +-- | This is a wrapper around 'fieldByNameWith' that gets the +-- 'FieldParser' via the typeclass instance. Take a look at the docs +-- for 'fieldByNameWith' for the details of this function. +fieldByName :: FromField a => ByteString {- ^ column name to look for -} -> RowParser a +fieldByName = fieldByNameWith fromField + +setToLastCol :: RowParser () +setToLastCol = + RP $ do + Row {rowresult} <- ask + ncols <- liftIO' (PQ.nfields rowresult) + put ncols diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +import Test.Hspec + +import Control.Exception +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromRow +import qualified GHC.Generics as GHC +import Generics.SOP + +import Database.PostgreSQL.Simple.FromRow.Named + +data Foobar = Foobar + { foo :: !String + , bar :: !Int + } deriving (Show, Eq, Ord, GHC.Generic) + + +instance Generic Foobar + +instance HasDatatypeInfo Foobar + + +instance FromRow Foobar where + fromRow = gFromRow + +withDatabaseConnection :: (Connection -> IO ()) -> IO () +withDatabaseConnection = + bracket + (connectPostgreSQL "host=localhost port=5432 user=postgres dbname=postgres") + close + +main :: IO () +main = + hspec $ do + around withDatabaseConnection $ do + describe "deserialize" $ do + it "deserializes (foo, bar) correctly" $ \conn -> do + query_ conn "select 'abc'::text as foo, 1 as bar" `shouldReturn` + [Foobar "abc" 1] + it "deserializes (bar, foo) correctly" $ \conn -> do + query_ conn "select 1 as bar, 'abc'::text as foo" `shouldReturn` + [Foobar "abc" 1] + it "throws NoSuchColumn" $ \conn -> do + (query_ conn "select 1, 2" :: IO [Foobar]) `shouldThrow` (==NoSuchColumn "foo") + it "throws TooManyColumns" $ \conn -> do + (query_ conn "select 1 bar, 'two'::text as foo, 3 as abc" :: IO [Foobar]) `shouldThrow` (==TooManyColumns 2 3)