├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── postgresql-named.cabal ├── src └── Database │ └── PostgreSQL │ └── Simple │ └── FromRow │ └── Named.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | dist-newstyle/ 3 | dist/ 4 | *~ 5 | cabal.project.local 6 | .ghc.environment.* 7 | cabal.sandbox.config 8 | .dir-locals.el 9 | .cabal-sandbox/ 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # make_travis_yml_2.hs 'postgresql-named.cabal' 4 | # 5 | # For more information, see https://github.com/hvr/multi-ghc-travis 6 | # 7 | language: c 8 | sudo: false 9 | dist: trusty 10 | 11 | services: 12 | - postgresql 13 | 14 | addons: 15 | posgtresql: "9.6" 16 | 17 | git: 18 | submodules: false # whether to recursively clone submodules 19 | 20 | cache: 21 | directories: 22 | - $HOME/.cabal/packages 23 | - $HOME/.cabal/store 24 | 25 | before_cache: 26 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 27 | # remove files that are regenerated by 'cabal update' 28 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 29 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 30 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 31 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 32 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 33 | 34 | matrix: 35 | include: 36 | - compiler: "ghc-8.0.2" 37 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 38 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}} 39 | - compiler: "ghc-8.2.1" 40 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 41 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}} 42 | 43 | before_install: 44 | - HC=${CC} 45 | - unset CC 46 | - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH 47 | - PKGNAME='postgresql-named' 48 | 49 | install: 50 | - cabal --version 51 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 52 | - BENCH=${BENCH---enable-benchmarks} 53 | - TEST=${TEST---enable-tests} 54 | - travis_retry cabal update -v 55 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 56 | - rm -fv cabal.project.local 57 | - "echo 'packages: .' > cabal.project" 58 | - rm -f cabal.project.freeze 59 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all 60 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all 61 | 62 | # Here starts the actual work to be performed for the package under test; 63 | # any command which exits with a non-zero exit code causes the build to fail. 64 | script: 65 | - if [ -f configure.ac ]; then autoreconf -i; fi 66 | - rm -rf .ghc.environment.* dist/ 67 | - cabal sdist # test that a source-distribution can be generated 68 | - cd dist/ 69 | - SRCTAR=(${PKGNAME}-*.tar.gz) 70 | - SRC_BASENAME="${SRCTAR/%.tar.gz}" 71 | - tar -xvf "./$SRC_BASENAME.tar.gz" 72 | - cd "$SRC_BASENAME/" 73 | ## from here on, CWD is inside the extracted source-tarball 74 | - rm -fv cabal.project.local 75 | - "echo 'packages: .' > cabal.project" 76 | # this builds all libraries and executables (without tests/benchmarks) 77 | - rm -f cabal.project.freeze 78 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all 79 | # this builds all libraries and executables (including tests/benchmarks) 80 | # - rm -rf ./dist-newstyle 81 | 82 | # build & run tests 83 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 84 | - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi 85 | 86 | # EOF 87 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 0.1.0 2 | --- 3 | * Initial release. 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Moritz Kiefer (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Moritz Kiefer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # postgresql-named 2 | 3 | [![Travis](https://img.shields.io/travis/cocreature/postgresql-named.svg)](https://travis-ci.org/cocreature/postgresql-named) 4 | [![Hackage](https://img.shields.io/hackage/v/postgresql-named.svg)](https://hackage.haskell.org/package/postgresql-named) 5 | 6 | Library for deserializing rows in `postgresql-simple` (or any other 7 | library that uses `FromRow`) based on column names instead of the 8 | positions of columns. 9 | 10 | ## Example 11 | 12 | ```haskell 13 | {-# LANGUAGE DeriveGeneric #-} 14 | import Database.PostgreSQL.Simple.FromRow 15 | import Database.PostgreSQL.Simple.FromRow.Named 16 | import qualified GHC.Generics as GHC 17 | import Generics.SOP 18 | 19 | data Foobar = Foobar 20 | { foo :: !String 21 | , bar :: !Int 22 | } deriving (Show, Eq, Ord, GHC.Generic) 23 | 24 | 25 | instance Generic Foobar 26 | 27 | instance HasDatatypeInfo Foobar 28 | 29 | instance FromRow Foobar where 30 | fromRow = gFromRow 31 | ``` 32 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /postgresql-named.cabal: -------------------------------------------------------------------------------- 1 | name: postgresql-named 2 | version: 0.1.0 3 | synopsis: Generic deserialization of PostgreSQL rows based on column names 4 | description: See README.md 5 | homepage: https://github.com/cocreature/postgresql-named#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Moritz Kiefer 9 | maintainer: moritz.kiefer@purelyfunctional.org 10 | copyright: (C) 2017 Moritz Kiefer 11 | category: Web 12 | build-type: Simple 13 | extra-source-files: README.md 14 | CHANGELOG.md 15 | cabal-version: >=1.10 16 | tested-with: GHC==8.0.2, GHC==8.2.1 17 | 18 | library 19 | hs-source-dirs: src 20 | exposed-modules: Database.PostgreSQL.Simple.FromRow.Named 21 | build-depends: base >= 4.9 && < 5 22 | , bytestring >= 0.10 && < 0.11 23 | , extra >= 1.5 && < 1.6 24 | , generics-sop >= 0.3 && < 0.4 25 | , mtl >= 2.2 && < 2.3 26 | , postgresql-libpq >= 0.9 && < 0.10 27 | , postgresql-simple >= 0.5 && < 0.6 28 | , utf8-string 29 | default-language: Haskell2010 30 | ghc-options: -Wall 31 | 32 | test-suite postgresql-named-test 33 | type: exitcode-stdio-1.0 34 | hs-source-dirs: test 35 | main-is: Spec.hs 36 | build-depends: base 37 | , generics-sop 38 | , hspec >= 2.4 && < 2.5 39 | , postgresql-named 40 | , postgresql-simple 41 | ghc-options: -Wall -threaded -rtsopts 42 | default-language: Haskell2010 43 | 44 | source-repository head 45 | type: git 46 | location: https://github.com/cocreature/postgresql-named 47 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/FromRow/Named.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Database.PostgreSQL.Simple.FromRow.Named 3 | Description : Generic implementation of FromRow based on record field names. 4 | Copyright : (c) Moritz Kiefer, 2017 5 | License : BSD-3 6 | Maintainer : moritz.kiefer@purelyfunctional.org 7 | 8 | This module provides the machinery for implementing instances of 9 | 'FromRow' that deserialize based on the names of columns instead of 10 | the positions of individual fields. This is particularly convenient 11 | when deserializing to a Haskell record and you want the field names 12 | and column names to match up. In this case 'gFromRow' can be used as 13 | a generic implementation of 'fromRow'. 14 | -} 15 | {-# LANGUAGE BangPatterns #-} 16 | {-# LANGUAGE DataKinds #-} 17 | {-# LANGUAGE DeriveAnyClass #-} 18 | {-# LANGUAGE DeriveDataTypeable #-} 19 | {-# LANGUAGE FlexibleContexts #-} 20 | {-# LANGUAGE GADTs #-} 21 | {-# LANGUAGE NamedFieldPuns #-} 22 | {-# LANGUAGE ScopedTypeVariables #-} 23 | {-# LANGUAGE TypeApplications #-} 24 | {-# LANGUAGE TypeOperators #-} 25 | {-# LANGUAGE ViewPatterns #-} 26 | module Database.PostgreSQL.Simple.FromRow.Named 27 | ( -- * Generic implementation of FromRow 28 | gFromRow 29 | -- * Deserialize individual fields based on their name 30 | , fieldByName 31 | , fieldByNameWith 32 | -- * Exception types 33 | , NoSuchColumn(..) 34 | , TooManyColumns(..) 35 | ) where 36 | 37 | import Control.Exception 38 | import Control.Monad.Extra 39 | import Control.Monad.Reader 40 | import Control.Monad.State.Strict 41 | import Data.ByteString (ByteString) 42 | import qualified Data.ByteString.UTF8 as BS 43 | import Data.Typeable 44 | import qualified Database.PostgreSQL.LibPQ as PQ 45 | import Database.PostgreSQL.Simple.FromField hiding (name) 46 | import Database.PostgreSQL.Simple.FromRow 47 | import Database.PostgreSQL.Simple.Internal 48 | import GHC.TypeLits 49 | import Generics.SOP 50 | import qualified Generics.SOP.Type.Metadata as T 51 | 52 | npLength :: NP f xs -> Word 53 | npLength xs = go 0 xs 54 | where 55 | go :: Word -> NP f xs -> Word 56 | go !i Nil = i 57 | go !i (_ :* xs') = go (i + 1) xs' 58 | 59 | -- | Deserialize a type with a single record constructor by matching 60 | -- the names of columns and record fields. Currently the complexity is /O(n^2)/ where n is the 61 | -- number of record fields. 62 | -- 63 | -- This is intended to be used as the implementation of 'fromRow'. 64 | -- 65 | -- Throws 66 | -- 67 | -- * 'NoSuchColumn' if there is a field for which there is no 68 | -- column with the same name. 69 | -- 70 | -- * 'TooManyColumns' if there more columns (counting both named 71 | -- and unnamed columns) than record fields. 72 | gFromRow :: forall a modName tyName constrName fields xs. 73 | ( Generic a 74 | , HasDatatypeInfo a 75 | , All2 FromField (Code a) 76 | , KnownSymbol modName 77 | , KnownSymbol tyName 78 | , DatatypeInfoOf a ~ 'T.ADT modName tyName '[ 'T.Record constrName fields] 79 | , Code a ~ '[xs] 80 | , T.DemoteFieldInfos fields xs 81 | ) => RowParser a 82 | gFromRow = do 83 | let f :: forall f. FromField f => FieldInfo f -> RowParser f 84 | f (FieldInfo name) = fieldByName (BS.fromString name) 85 | fieldInfos :: NP FieldInfo xs 86 | fieldInfos = T.demoteFieldInfos (Proxy @fields) 87 | guardMatchingColumnNumber (npLength fieldInfos) 88 | res <- 89 | fmap (to . SOP . Z) $ 90 | hsequence 91 | (hcliftA 92 | (Proxy :: Proxy FromField) 93 | f 94 | (T.demoteFieldInfos (Proxy :: Proxy fields))) 95 | setToLastCol 96 | pure res 97 | 98 | guardMatchingColumnNumber :: Word -> RowParser () 99 | guardMatchingColumnNumber numFields = 100 | RP $ do 101 | Row {rowresult} <- ask 102 | PQ.Col (fromIntegral -> numCols) <- liftIO' (PQ.nfields rowresult) 103 | when 104 | (numCols /= numFields) 105 | ((lift . lift . conversionError) (TooManyColumns numFields numCols)) 106 | 107 | liftIO' :: IO a -> ReaderT Row (StateT PQ.Column Conversion) a 108 | liftIO' = lift . lift . liftConversion 109 | 110 | -- | Thrown when there is no column of the given name. 111 | data NoSuchColumn = 112 | NoSuchColumn ByteString 113 | deriving (Show, Eq, Ord, Typeable) 114 | 115 | instance Exception NoSuchColumn 116 | 117 | -- | Thrown by 'gFromRow' when trying to deserialize to a record that 118 | -- has less fields than the current row has columns (counting both 119 | -- named and unnamed columns). 120 | data TooManyColumns = TooManyColumns 121 | { numRecordFields :: !Word -- ^ The expected number of record fields. 122 | , numColumns :: !Word -- ^ The number of columns in the row that should have been deserialized. 123 | } deriving (Show, Eq, Ord, Typeable) 124 | 125 | instance Exception TooManyColumns 126 | 127 | 128 | -- | This is similar to 'fieldWith' but instead of trying to 129 | -- deserialize the field at the current position it goes through all 130 | -- fields in the current row (starting at the beginning not the 131 | -- current position) and tries to deserialize the first field with a 132 | -- matching column name. 133 | fieldByNameWith :: FieldParser a -> ByteString {- ^ column name to look for -} -> RowParser a 134 | fieldByNameWith fieldP name = 135 | RP $ do 136 | Row {rowresult, row} <- ask 137 | ncols <- liftIO' (PQ.nfields rowresult) 138 | matchingCol <- 139 | liftIO' $ 140 | findM 141 | (\col -> (Just name ==) <$> PQ.fname rowresult col) 142 | [PQ.Col 0 .. ncols - 1] 143 | case matchingCol of 144 | Nothing -> (lift . lift . conversionError) (NoSuchColumn name) 145 | Just col -> 146 | (lift . lift) $ do 147 | oid <- liftConversion (PQ.ftype rowresult col) 148 | val <- liftConversion (PQ.getvalue rowresult row col) 149 | fieldP (Field rowresult col oid) val 150 | 151 | -- | This is a wrapper around 'fieldByNameWith' that gets the 152 | -- 'FieldParser' via the typeclass instance. Take a look at the docs 153 | -- for 'fieldByNameWith' for the details of this function. 154 | fieldByName :: FromField a => ByteString {- ^ column name to look for -} -> RowParser a 155 | fieldByName = fieldByNameWith fromField 156 | 157 | setToLastCol :: RowParser () 158 | setToLastCol = 159 | RP $ do 160 | Row {rowresult} <- ask 161 | ncols <- liftIO' (PQ.nfields rowresult) 162 | put ncols 163 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.18 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - generics-sop-0.3.1.0 6 | flags: {} 7 | extra-package-dbs: [] 8 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 3 | import Test.Hspec 4 | 5 | import Control.Exception 6 | import Database.PostgreSQL.Simple 7 | import Database.PostgreSQL.Simple.FromRow 8 | import qualified GHC.Generics as GHC 9 | import Generics.SOP 10 | 11 | import Database.PostgreSQL.Simple.FromRow.Named 12 | 13 | data Foobar = Foobar 14 | { foo :: !String 15 | , bar :: !Int 16 | } deriving (Show, Eq, Ord, GHC.Generic) 17 | 18 | 19 | instance Generic Foobar 20 | 21 | instance HasDatatypeInfo Foobar 22 | 23 | 24 | instance FromRow Foobar where 25 | fromRow = gFromRow 26 | 27 | withDatabaseConnection :: (Connection -> IO ()) -> IO () 28 | withDatabaseConnection = 29 | bracket 30 | (connectPostgreSQL "host=localhost port=5432 user=postgres dbname=postgres") 31 | close 32 | 33 | main :: IO () 34 | main = 35 | hspec $ do 36 | around withDatabaseConnection $ do 37 | describe "deserialize" $ do 38 | it "deserializes (foo, bar) correctly" $ \conn -> do 39 | query_ conn "select 'abc'::text as foo, 1 as bar" `shouldReturn` 40 | [Foobar "abc" 1] 41 | it "deserializes (bar, foo) correctly" $ \conn -> do 42 | query_ conn "select 1 as bar, 'abc'::text as foo" `shouldReturn` 43 | [Foobar "abc" 1] 44 | it "throws NoSuchColumn" $ \conn -> do 45 | (query_ conn "select 1, 2" :: IO [Foobar]) `shouldThrow` (==NoSuchColumn "foo") 46 | it "throws TooManyColumns" $ \conn -> do 47 | (query_ conn "select 1 bar, 'two'::text as foo, 3 as abc" :: IO [Foobar]) `shouldThrow` (==TooManyColumns 2 3) 48 | --------------------------------------------------------------------------------