Support hasql-1.8 (#345)

The IP type was changed in hasql-1.8. Rather than forcing a breaking
change, we export instances for both the old and new types.

Resolves #341

changelog.d/20241008_181955_teofilcamarasu_hasql_1_8.md

@@ -0,0 +1,4 @@
+### Added
+
+- Support hasql-1.8
+

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

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

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"