diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for postgresql-pure +## 0.2.2.0 + +2020.07.19 + +- Default implementations get to be given for `FromRecord` and `ToRecord`. + ## 0.2.1.0 2020.07.14 @@ -12,11 +18,11 @@ ### Breaking changes -- Remove orphan `IsLabel` instance definitions; #2 thanks to @nakaji-dayo. +- Remove orphan `IsLabel` instance definitions; [#2](https://github.com/iij-ii/postgresql-pure/pull/2) thanks to [@nakaji-dayo](https://github.com/nakaji-dayo). ### Other changes -- Add cleartext password authentication; #1 thanks to @goodlyrottenapple. +- Add cleartext password authentication; [#1](https://github.com/iij-ii/postgresql-pure/pull/1) thanks to [@goodlyrottenapple](https://github.com/goodlyrottenapple). - Change the Haskell type corresponding to `timetz` from `(TimeOfDay, TimeZone)` to `TimeOfDayWithTimeZone`. - Not only tuples but also other types which have `Length` type function can be record. @@ -26,7 +32,7 @@ - Expose a function for type class instance implementations. - A new instance `FromField String`. -- New instances for `FromRecord`, `ToRecord`. +- New instances for `FromRecord` and `ToRecord`. ## 0.1.2.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # postgresql-pure -[![Hackage](https://matrix.hackage.haskell.org/api/v2/packages/postgresql-pure/badge)](http://hackage.haskell.org/package/postgresql-pure) [![Haddock](https://img.shields.io/badge/Haddock-0.2.1.0-blue)](https://iij-ii.github.io/postgresql-pure/) [![CI build](https://github.com/iij-ii/postgresql-pure/workflows/build/badge.svg)](https://github.com/iij-ii/postgresql-pure/actions?query=workflow%3Abuild) [![CI test](https://github.com/iij-ii/postgresql-pure/workflows/test/badge.svg)](https://github.com/iij-ii/postgresql-pure/actions?query=workflow%3Atest) +[![Hackage](https://matrix.hackage.haskell.org/api/v2/packages/postgresql-pure/badge)](http://hackage.haskell.org/package/postgresql-pure) [![Haddock](https://img.shields.io/badge/Haddock-0.2.2.0-blue)](https://iij-ii.github.io/postgresql-pure/) [![CI build](https://github.com/iij-ii/postgresql-pure/workflows/build/badge.svg)](https://github.com/iij-ii/postgresql-pure/actions?query=workflow%3Abuild) [![CI test](https://github.com/iij-ii/postgresql-pure/workflows/test/badge.svg)](https://github.com/iij-ii/postgresql-pure/actions?query=workflow%3Atest) ## Copyright diff --git a/postgresql-pure.cabal b/postgresql-pure.cabal --- a/postgresql-pure.cabal +++ b/postgresql-pure.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: e4d2fa99f191645581a127977d9ca699f4f42439e9ca768d527f4a8c37823ce8 +-- hash: 5f059edd27ff8ab95243b3a3495424fd88f57773838ad8494cfa4c4d1816aff7 name: postgresql-pure -version: 0.2.1.0 +version: 0.2.2.0 synopsis: pure Haskell PostgreSQL driver description: pure Haskell PostgreSQL driver category: Database diff --git a/src/Database/PostgreSQL/Pure/Internal/Builder.hs b/src/Database/PostgreSQL/Pure/Internal/Builder.hs --- a/src/Database/PostgreSQL/Pure/Internal/Builder.hs +++ b/src/Database/PostgreSQL/Pure/Internal/Builder.hs @@ -3,7 +3,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -29,11 +31,13 @@ import Database.PostgreSQL.Pure.Internal.Data (BindParameterFormatCodes (BindParameterFormatCodesAll, BindParameterFormatCodesAllDefault, BindParameterFormatCodesEach), BindResultFormatCodes (BindResultFormatCodesAllDefault, BindResultFormatCodesEach, BindResultFormatCodesNothing), - FormatCode (BinaryFormat, TextFormat), Oid (Oid), + FormatCode (BinaryFormat, TextFormat), + GToRecord (gToRecord), Oid (Oid), PortalName (PortalName), PreparedStatementName (PreparedStatementName), - Query (Query), TimeOfDayWithTimeZone (TimeOfDayWithTimeZone), ToField (toField), - ToRecord (toRecord)) + Query (Query), + TimeOfDayWithTimeZone (TimeOfDayWithTimeZone), + ToField (toField), ToRecord (toRecord)) import Database.PostgreSQL.Pure.Internal.Exception (cantReachHere) import qualified Database.PostgreSQL.Pure.Internal.MonadFail as MonadFail import qualified Database.PostgreSQL.Pure.Oid as Oid @@ -51,10 +55,10 @@ import qualified Data.Map.Strict as M import Data.Scientific (FPFormat (Exponent), Scientific, formatScientific, scientific) -import Data.Time (Day, DiffTime, NominalDiffTime, TimeOfDay, - UTCTime) +import Data.Time (Day, DiffTime, NominalDiffTime, TimeOfDay, UTCTime) import Data.Time.LocalTime (LocalTime) import Data.Tuple.Single (Single, pattern Single) +import qualified GHC.Generics as Generics import qualified PostgreSQL.Binary.Encoding as BE startup @@ -1098,6 +1102,22 @@ sequence $ uncurry (toField backendParams encode Nothing) <$> zip fs vs toRecord backendParams encode (Just os) fs vs = assert (length os == length fs && length fs == length vs) $ sequence $ uncurry3 (toField backendParams encode) <$> zip3 (Just <$> os) fs vs + +-- generics +instance GToRecord f => GToRecord (Generics.M1 i t f) where + gToRecord backendParams encode os fs (Generics.M1 r) = gToRecord backendParams encode os fs r + +instance ToField c => GToRecord (Generics.K1 i c) where + gToRecord backendParams encode (Just (o:os)) (f:fs) (Generics.K1 v) = (, Just os, fs) . (:[]) <$> toField backendParams encode (Just o) f v + gToRecord backendParams encode Nothing (f:fs) (Generics.K1 v) = (, Nothing, fs) . (:[]) <$> toField backendParams encode Nothing f v + gToRecord _ _ (Just []) _ _ = fail "there are too few OIDs" + gToRecord _ _ _ [] _ = fail "there are too few format codes" + +instance (GToRecord f, GToRecord g) => GToRecord (f Generics.:*: g) where + gToRecord backendParams encode os fs (f Generics.:*: g) = do + (record, os', fs') <- gToRecord backendParams encode os fs f + (record', os'', fs'') <- gToRecord backendParams encode os' fs' g + pure (record ++ record', os'', fs'') uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c diff --git a/src/Database/PostgreSQL/Pure/Internal/Data.hs b/src/Database/PostgreSQL/Pure/Internal/Data.hs --- a/src/Database/PostgreSQL/Pure/Internal/Data.hs +++ b/src/Database/PostgreSQL/Pure/Internal/Data.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -67,8 +68,10 @@ , StringEncoder , FromField (..) , FromRecord (..) + , GFromRecord (..) , ToField (..) , ToRecord (..) + , GToRecord (..) , Pretty (..) ) where @@ -90,6 +93,8 @@ import Data.Time (TimeOfDay, TimeZone) import Data.Word (Word8) import Foreign (ForeignPtr) +import GHC.Generics (Generic (Rep)) +import qualified GHC.Generics as Generics import Hexdump (prettyHex, simpleHex) import Network.Socket (Socket) import qualified Network.Socket as NS @@ -454,7 +459,16 @@ class FromRecord a where -- | Decoder of a record. fromRecord :: StringDecoder -> [ColumnInfo] -> AP.Parser a + default fromRecord :: (Generic a, GFromRecord (Rep a)) => StringDecoder -> [ColumnInfo] -> AP.Parser a + fromRecord decode infos = do + (rep, infos') <- gFromRecord decode infos + case infos' of + [] -> pure $ Generics.to rep + is -> fail $ "length mismatch: too many: actual: " <> show (length is) +class GFromRecord f where + gFromRecord :: StringDecoder -> [ColumnInfo] -> AP.Parser ((f p), [ColumnInfo]) + -- | This means that @a@ can be encoded to a field. class ToField a where -- | Encoder of a field. @@ -464,6 +478,23 @@ class ToRecord a where -- | Encoder of a field. toRecord :: MonadFail m => BackendParameters -> StringEncoder -> Maybe [Oid] -> [FormatCode] -> a -> m [Maybe BS.ByteString] + default toRecord :: (MonadFail m, Generic a, GToRecord (Rep a)) => BackendParameters -> StringEncoder -> Maybe [Oid] -> [FormatCode] -> a -> m [Maybe BS.ByteString] + toRecord backendParams encode Nothing fs v = do + (record, os, fs') <- gToRecord backendParams encode Nothing fs $ Generics.from v + case (os, fs') of + (Nothing, []) -> pure record + (Nothing, _) -> fail "There are too many format codes" + (_, _) -> error "can't reach here" + toRecord backendParams encode os fs v = do + (record, os', fs') <- gToRecord backendParams encode os fs $ Generics.from v + case (os', fs') of + (Just [], []) -> pure record + (Just _, []) -> fail "There are too many OIDs" + (Just _, _) -> fail "There are too many format codes" + (_, _) -> error "can't reach here" + +class GToRecord f where + gToRecord :: (MonadFail m) => BackendParameters -> StringEncoder -> Maybe [Oid] -> [FormatCode] -> f p -> m ([Maybe BS.ByteString], Maybe [Oid], [FormatCode]) -- | Type of PostgreSQL @sql_identifier@ type. newtype SqlIdentifier = SqlIdentifier BS.ByteString deriving (Show, Read, Eq) diff --git a/src/Database/PostgreSQL/Pure/Internal/Parser.hs b/src/Database/PostgreSQL/Pure/Internal/Parser.hs --- a/src/Database/PostgreSQL/Pure/Internal/Parser.hs +++ b/src/Database/PostgreSQL/Pure/Internal/Parser.hs @@ -5,8 +5,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -42,7 +44,7 @@ , valueParser ) where -import Database.PostgreSQL.Pure.Internal.Data (AuthenticationMD5Password (AuthenticationMD5Password), AuthenticationResponse (AuthenticationMD5PasswordResponse, AuthenticationOkResponse, AuthenticationCleartextPasswordResponse), +import Database.PostgreSQL.Pure.Internal.Data (AuthenticationMD5Password (AuthenticationMD5Password), AuthenticationResponse (AuthenticationCleartextPasswordResponse, AuthenticationMD5PasswordResponse, AuthenticationOkResponse), BackendKeyData (BackendKeyData), ColumnInfo (ColumnInfo, typeOid), CommandComplete (CommandComplete), @@ -52,12 +54,13 @@ ErrorFields (ErrorFields), FormatCode (BinaryFormat, TextFormat), FromField (fromField), FromRecord (fromRecord), - Notice (Notice), Oid (Oid), + GFromRecord (gFromRecord), Notice (Notice), Oid (Oid), ParameterDescription (ParameterDescription), ParameterStatus (ParameterStatus), Raw (Null, Value), ReadyForQuery (ReadyForQuery), Response (..), RowDescription (RowDescription), - SqlIdentifier (SqlIdentifier), StringDecoder, TimeOfDayWithTimeZone (TimeOfDayWithTimeZone), + SqlIdentifier (SqlIdentifier), StringDecoder, + TimeOfDayWithTimeZone (TimeOfDayWithTimeZone), TransactionState (Block, Failed, Idle), TypeLength (FixedLength, VariableLength)) import qualified Database.PostgreSQL.Pure.Internal.Data as Data @@ -86,12 +89,12 @@ import Data.Memory.Endian (BE, ByteSwap, fromBE) import Data.Scientific (Scientific, scientific) import qualified Data.Text as Text -import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, - UTCTime, utc) +import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, UTCTime, utc) import Data.Tuple.Single (Single, pattern Single) import Data.Word (Word16, Word32, Word64, Word8) import Foreign (withForeignPtr) import Foreign.Storable (Storable, peekByteOff, sizeOf) +import qualified GHC.Generics as Generics import GHC.Stack (HasCallStack, callStack, prettyCallStack) import qualified PostgreSQL.Binary.Decoding as BD import System.IO.Unsafe (unsafeDupablePerformIO) @@ -1057,6 +1060,20 @@ -- list instance {-# OVERLAPPABLE #-} FromField a => FromRecord [a] where fromRecord decode is = sequence $ column decode <$> is + +-- generic +instance GFromRecord f => GFromRecord (Generics.M1 i t f) where + gFromRecord decode infos = (\(r, is) -> (Generics.M1 r, is)) <$> gFromRecord decode infos + +instance FromField c => GFromRecord (Generics.K1 i c) where + gFromRecord decode (i:infos) = (, infos) . Generics.K1 <$> column decode i + gFromRecord _ [] = fail "length mismatch: too few" + +instance (GFromRecord f, GFromRecord g) => GFromRecord (f Generics.:*: g) where + gFromRecord decode infos = do + (rep, infos') <- gFromRecord decode infos + (rep', infos'') <- gFromRecord decode infos' + pure (rep Generics.:*: rep', infos'') -- | For implementing 'fromRecord'. column :: FromField a => StringDecoder -> ColumnInfo -> AP.Parser a diff --git a/template/Builder.hs b/template/Builder.hs --- a/template/Builder.hs +++ b/template/Builder.hs @@ -3,7 +3,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -29,11 +31,13 @@ import Database.PostgreSQL.Pure.Internal.Data (BindParameterFormatCodes (BindParameterFormatCodesAll, BindParameterFormatCodesAllDefault, BindParameterFormatCodesEach), BindResultFormatCodes (BindResultFormatCodesAllDefault, BindResultFormatCodesEach, BindResultFormatCodesNothing), - FormatCode (BinaryFormat, TextFormat), Oid (Oid), + FormatCode (BinaryFormat, TextFormat), + GToRecord (gToRecord), Oid (Oid), PortalName (PortalName), PreparedStatementName (PreparedStatementName), - Query (Query), TimeOfDayWithTimeZone (TimeOfDayWithTimeZone), ToField (toField), - ToRecord (toRecord)) + Query (Query), + TimeOfDayWithTimeZone (TimeOfDayWithTimeZone), + ToField (toField), ToRecord (toRecord)) import Database.PostgreSQL.Pure.Internal.Exception (cantReachHere) import qualified Database.PostgreSQL.Pure.Internal.MonadFail as MonadFail import qualified Database.PostgreSQL.Pure.Oid as Oid @@ -51,10 +55,10 @@ import qualified Data.Map.Strict as M import Data.Scientific (FPFormat (Exponent), Scientific, formatScientific, scientific) -import Data.Time (Day, DiffTime, NominalDiffTime, TimeOfDay, - UTCTime) +import Data.Time (Day, DiffTime, NominalDiffTime, TimeOfDay, UTCTime) import Data.Time.LocalTime (LocalTime) import Data.Tuple.Single (Single, pattern Single) +import qualified GHC.Generics as Generics import qualified PostgreSQL.Binary.Encoding as BE startup @@ -549,6 +553,22 @@ sequence $ uncurry (toField backendParams encode Nothing) <$> zip fs vs toRecord backendParams encode (Just os) fs vs = assert (length os == length fs && length fs == length vs) $ sequence $ uncurry3 (toField backendParams encode) <$> zip3 (Just <$> os) fs vs + +-- generics +instance GToRecord f => GToRecord (Generics.M1 i t f) where + gToRecord backendParams encode os fs (Generics.M1 r) = gToRecord backendParams encode os fs r + +instance ToField c => GToRecord (Generics.K1 i c) where + gToRecord backendParams encode (Just (o:os)) (f:fs) (Generics.K1 v) = (, Just os, fs) . (:[]) <$> toField backendParams encode (Just o) f v + gToRecord backendParams encode Nothing (f:fs) (Generics.K1 v) = (, Nothing, fs) . (:[]) <$> toField backendParams encode Nothing f v + gToRecord _ _ (Just []) _ _ = fail "there are too few OIDs" + gToRecord _ _ _ [] _ = fail "there are too few format codes" + +instance (GToRecord f, GToRecord g) => GToRecord (f Generics.:*: g) where + gToRecord backendParams encode os fs (f Generics.:*: g) = do + (record, os', fs') <- gToRecord backendParams encode os fs f + (record', os'', fs'') <- gToRecord backendParams encode os' fs' g + pure (record ++ record', os'', fs'') uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c diff --git a/template/Parser.hs b/template/Parser.hs --- a/template/Parser.hs +++ b/template/Parser.hs @@ -5,8 +5,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -42,7 +44,7 @@ , valueParser ) where -import Database.PostgreSQL.Pure.Internal.Data (AuthenticationMD5Password (AuthenticationMD5Password), AuthenticationResponse (AuthenticationMD5PasswordResponse, AuthenticationOkResponse, AuthenticationCleartextPasswordResponse), +import Database.PostgreSQL.Pure.Internal.Data (AuthenticationMD5Password (AuthenticationMD5Password), AuthenticationResponse (AuthenticationCleartextPasswordResponse, AuthenticationMD5PasswordResponse, AuthenticationOkResponse), BackendKeyData (BackendKeyData), ColumnInfo (ColumnInfo, typeOid), CommandComplete (CommandComplete), @@ -52,12 +54,13 @@ ErrorFields (ErrorFields), FormatCode (BinaryFormat, TextFormat), FromField (fromField), FromRecord (fromRecord), - Notice (Notice), Oid (Oid), + GFromRecord (gFromRecord), Notice (Notice), Oid (Oid), ParameterDescription (ParameterDescription), ParameterStatus (ParameterStatus), Raw (Null, Value), ReadyForQuery (ReadyForQuery), Response (..), RowDescription (RowDescription), - SqlIdentifier (SqlIdentifier), StringDecoder, TimeOfDayWithTimeZone (TimeOfDayWithTimeZone), + SqlIdentifier (SqlIdentifier), StringDecoder, + TimeOfDayWithTimeZone (TimeOfDayWithTimeZone), TransactionState (Block, Failed, Idle), TypeLength (FixedLength, VariableLength)) import qualified Database.PostgreSQL.Pure.Internal.Data as Data @@ -86,12 +89,12 @@ import Data.Memory.Endian (BE, ByteSwap, fromBE) import Data.Scientific (Scientific, scientific) import qualified Data.Text as Text -import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, - UTCTime, utc) +import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, UTCTime, utc) import Data.Tuple.Single (Single, pattern Single) import Data.Word (Word16, Word32, Word64, Word8) import Foreign (withForeignPtr) import Foreign.Storable (Storable, peekByteOff, sizeOf) +import qualified GHC.Generics as Generics import GHC.Stack (HasCallStack, callStack, prettyCallStack) import qualified PostgreSQL.Binary.Decoding as BD import System.IO.Unsafe (unsafeDupablePerformIO) @@ -813,6 +816,20 @@ -- list instance {-# OVERLAPPABLE #-} FromField a => FromRecord [a] where fromRecord decode is = sequence $ column decode <$> is + +-- generic +instance GFromRecord f => GFromRecord (Generics.M1 i t f) where + gFromRecord decode infos = (\(r, is) -> (Generics.M1 r, is)) <$> gFromRecord decode infos + +instance FromField c => GFromRecord (Generics.K1 i c) where + gFromRecord decode (i:infos) = (, infos) . Generics.K1 <$> column decode i + gFromRecord _ [] = fail "length mismatch: too few" + +instance (GFromRecord f, GFromRecord g) => GFromRecord (f Generics.:*: g) where + gFromRecord decode infos = do + (rep, infos') <- gFromRecord decode infos + (rep', infos'') <- gFromRecord decode infos' + pure (rep Generics.:*: rep', infos'') -- | For implementing 'fromRecord'. column :: FromField a => StringDecoder -> ColumnInfo -> AP.Parser a