postgresql-named (empty) → 0.1.0

raw patch · 7 files changed

+321/−0 lines, 7 filesdep +basedep +bytestringdep +extrasetup-changed

Dependencies added: base, bytestring, extra, generics-sop, hspec, mtl, postgresql-libpq, postgresql-named, postgresql-simple, utf8-string

Files

CHANGELOG.md +3/−0
LICENSE +30/−0
README.md +31/−0
Setup.hs +2/−0
postgresql-named.cabal +46/−0
src/Database/PostgreSQL/Simple/FromRow/Named.hs +162/−0
test/Spec.hs +47/−0

+ CHANGELOG.md view

@@ -0,0 +1,3 @@+0.1.0+---+* Initial release.

+ LICENSE view

@@ -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.

+ README.md view

@@ -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+```

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ postgresql-named.cabal view

@@ -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

+ src/Database/PostgreSQL/Simple/FromRow/Named.hs view

@@ -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

+ test/Spec.hs view

@@ -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)