diff --git a/changelog.d/20241008_181955_teofilcamarasu_hasql_1_8.md b/changelog.d/20241008_181955_teofilcamarasu_hasql_1_8.md new file mode 100644 index 00000000..9c4c560a --- /dev/null +++ b/changelog.d/20241008_181955_teofilcamarasu_hasql_1_8.md @@ -0,0 +1,4 @@ +### Added + +- Support hasql-1.8 + diff --git a/rel8.cabal b/rel8.cabal index 857959de..9b864f70 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -26,13 +26,16 @@ library , base16 >= 1.0 , base-compat ^>= 0.11 || ^>= 0.12 || ^>= 0.13 || ^>= 0.14 , bifunctors + , binary-parser ^>= 0.5 + , data-dword ^>= 0.3 , bytestring , case-insensitive , comonad , contravariant , data-textual - , hasql >= 1.6.1.2 && < 1.8 - , network-ip + , hasql >= 1.6.1.2 && < 1.9 + , network-ip ^>= 0.3 + , iproute ^>= 1.7 , opaleye ^>= 0.10.2.1 , pretty , profunctors @@ -248,6 +251,7 @@ test-suite tests , hedgehog ^>= 1.0 || ^>= 1.1 || ^>= 1.2 || ^>= 1.3 || ^>= 1.4 || ^>= 1.5 , mmorph , network-ip + , iproute , rel8 , scientific , tasty diff --git a/src/Rel8/Type.hs b/src/Rel8/Type.hs index c8ca035c..1b31028b 100644 --- a/src/Rel8/Type.hs +++ b/src/Rel8/Type.hs @@ -27,14 +27,19 @@ import qualified Data.Aeson.Parser as Aeson -- base import Control.Applicative ((<|>)) import Data.Fixed (Fixed) -import Data.Int ( Int16, Int32, Int64 ) +import Data.Int ( Int8, Int16, Int32, Int64 ) +import Data.Word (Word8, Word32) import Data.List.NonEmpty ( NonEmpty ) import Data.Kind ( Constraint, Type ) import Prelude +import Data.Bits (Bits (..)) +import Data.DoubleWord (fromHiAndLo) +import Text.Read (readMaybe) -- bytestring import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as Lazy ( ByteString ) import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict ) @@ -51,6 +56,9 @@ import qualified Hasql.Decoders as Hasql -- network-ip import qualified Network.IP.Addr as IP +import qualified Data.IP +import qualified BinaryParser + -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote ) @@ -433,7 +441,9 @@ instance DBType (IP.NetAddr IP.IP) where Opaleye.ConstExpr . Opaleye.StringLit . IP.printNetAddr , decode = Decoder - { binary = Hasql.inet + { binary = (Hasql.custom . const . BinaryParser.run $ netaddrParser + (\netmask x -> IP.netAddr (IP.IPv4 $ IP.IP4 x) netmask) + (\netmask x1 x2 x3 x4 -> IP.netAddr (IP.IPv6 $ IP.IP6 $ fromHiAndLo (fromHiAndLo x1 x2) (fromHiAndLo x3 x4)) netmask) :: Hasql.Value (IP.NetAddr IP.IP)) , parser = parse $ textual <|> (`IP.netAddr` 32) . IP.IPv4 <$> textual @@ -443,6 +453,53 @@ instance DBType (IP.NetAddr IP.IP) where , typeName = "inet" } +-- | Corresponds to @inet@ +instance DBType Data.IP.IPRange where + typeInformation = TypeInformation + { encode = + Opaleye.ConstExpr . Opaleye.StringLit . show + , decode = + Decoder + { binary = (Hasql.custom . const . BinaryParser.run $ netaddrParser + (\netmask x -> Data.IP.IPv4Range $ Data.IP.makeAddrRange (Data.IP.toIPv4w x) $ fromIntegral netmask) + (\netmask x1 x2 x3 x4 -> Data.IP.IPv6Range $ Data.IP.makeAddrRange (Data.IP.toIPv6w (x1, x2, x3, x4)) $ fromIntegral netmask)) + , parser = \str -> case readMaybe $ BS8.unpack str of + Just x -> Right x + Nothing -> Left "Failed to parse inet" + , delimiter = ',' + } + , typeName = "inet" + } + +-- | Address family AF_INET +inetAddressFamily :: Word8 +inetAddressFamily = + 2 + +-- | Address family AF_INET6 +inet6AddressFamily :: Word8 +inet6AddressFamily = + 3 + +-- | This is vendored from `postgresql-binary`. +netaddrParser :: (Word8 -> Word32 -> ip) -> (Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> ip) -> BinaryParser.BinaryParser ip +netaddrParser mkIpv4 mkIpv6 = do + af <- intOfSize 1 + netmask <- intOfSize 1 + isCidr <- intOfSize @Int8 1 + ipSize <- intOfSize @Int8 1 + if | af == inetAddressFamily -> + mkIpv4 netmask <$> intOfSize 4 + | af == inet6AddressFamily -> + mkIpv6 netmask <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 + | otherwise -> BinaryParser.failure ("Unknown address family: " <> Text.pack (show af)) + +intOfSize :: (Integral a, Bits a) => Int -> BinaryParser.BinaryParser a +intOfSize x = + fmap integralPack (BinaryParser.bytesOfSize x) + where + integralPack = BS.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0 + instance Sql DBType a => DBType [a] where typeInformation = listTypeInformation nullable typeInformation diff --git a/tests/Main.hs b/tests/Main.hs index e4358cc8..7371e057 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -66,6 +66,8 @@ import Control.Monad.Morph ( hoist ) import Network.IP.Addr (NetAddr, IP, IP4(..), IP6(..), IP46(..), net4Addr, net6Addr, fromNetAddr46, Net4Addr, Net6Addr) import Data.DoubleWord (Word128(..)) +import qualified Data.IP + -- rel8 import Rel8 ( Result ) import qualified Rel8 @@ -459,6 +461,7 @@ testDBType getTestDatabase = testGroup "DBType instances" , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 , dbTypeTest "INet" genNetAddrIP + , dbTypeTest "INet" genIPRange ] where @@ -573,6 +576,23 @@ testDBType getTestDatabase = testGroup "DBType instances" in fromNetAddr46 <$> Gen.choice [ genIPv4, genIPv6 ] + genIPRange :: Gen (Data.IP.IPRange) + genIPRange = + let + genIP4Mask :: Gen Int + genIP4Mask = Gen.integral (Range.linearFrom 0 0 32) + + genIPv4 :: Gen Data.IP.IPv4 + genIPv4 = Data.IP.toIPv4w <$> genWord32 + + genIP6Mask :: Gen Int + genIP6Mask = Gen.integral (Range.linearFrom 0 0 128) + + genIPv6 :: Gen (Data.IP.IPv6) + genIPv6 = Data.IP.toIPv6w <$> ((,,,) <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32) + + in Gen.choice [ Data.IP.IPv4Range <$> (Data.IP.makeAddrRange <$> genIPv4 <*> genIP4Mask), Data.IP.IPv6Range <$> (Data.IP.makeAddrRange <$> genIPv6 <*> genIP6Mask)] + testDBEq :: IO TmpPostgres.DB -> TestTree testDBEq getTestDatabase = testGroup "DBEq instances"