diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,6 +25,7 @@ - **Date/time types**: Date, Time, Timestamp, Timestamptz, Timetz, Interval - **Network address types**: Inet, Cidr, Macaddr, Macaddr8 - **Geometric types**: Point, Line, Lseg, Box, Path, Polygon, Circle +- **PostGIS types**: Geometry - **Bit string types**: Bit, Varbit - **UUID type**: Uuid - **JSON types**: Json, Jsonb diff --git a/postgresql-types.cabal b/postgresql-types.cabal --- a/postgresql-types.cabal +++ b/postgresql-types.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: postgresql-types -version: 0.1.3.2 +version: 0.1.4.0 category: PostgreSQL, Codecs synopsis: Precise PostgreSQL types representation and driver-agnostic codecs description: @@ -114,6 +114,7 @@ PostgresqlTypes.Date PostgresqlTypes.Float4 PostgresqlTypes.Float8 + PostgresqlTypes.Geometry PostgresqlTypes.Hstore PostgresqlTypes.Inet PostgresqlTypes.Int2 @@ -156,7 +157,6 @@ PostgresqlTypes.Via.IsScalar build-depends: - QuickCheck >=2.14 && <3, aeson >=2.2 && <3, attoparsec >=0.14 && <0.19, base >=4.11 && <5, @@ -165,11 +165,12 @@ hashable >=1.3 && <2, jsonifier ^>=0.2.1.3, mtl >=2.2 && <3, + postgresql-types-algebra ^>=0.1, postgresql-types:jsonifier-aeson, postgresql-types:time-extras, - postgresql-types-algebra ^>=0.1, ptr-peeker ^>=0.2, ptr-poker ^>=0.1.3, + QuickCheck >=2.14 && <3, scientific >=0.3 && <1, tagged ^>=0.8.9, text >=1.2 && <3, @@ -221,14 +222,15 @@ PostgresqlTypes.DateSpec PostgresqlTypes.Float4Spec PostgresqlTypes.Float8Spec + PostgresqlTypes.GeometrySpec PostgresqlTypes.HstoreSpec PostgresqlTypes.InetSpec PostgresqlTypes.Int2Spec PostgresqlTypes.Int4Spec PostgresqlTypes.Int8Spec PostgresqlTypes.IntervalSpec - PostgresqlTypes.JsonSpec PostgresqlTypes.JsonbSpec + PostgresqlTypes.JsonSpec PostgresqlTypes.LineSpec PostgresqlTypes.LsegSpec PostgresqlTypes.Macaddr8Spec @@ -257,17 +259,18 @@ hspec-discover:hspec-discover >=2 && <3 build-depends: - QuickCheck >=2.14 && <3, aeson >=2.2 && <3, attoparsec >=0.14 && <0.15, base >=4.11 && <5, bytestring >=0.10 && <0.13, containers >=0.6 && <0.9, + hashable >=1.3 && <2, hspec >=2.11 && <3, postgresql-types, postgresql-types-algebra ^>=0.1, ptr-peeker ^>=0.2, ptr-poker ^>=0.1.2.16, + QuickCheck >=2.14 && <3, quickcheck-classes ^>=0.6.5, quickcheck-instances ^>=0.3.33, scientific >=0.3 && <1, @@ -294,7 +297,6 @@ PqProcedures.Procedures.RunStatement build-depends: - QuickCheck >=2.14 && <3, async >=2.2.6 && <2.3, attoparsec >=0.14 && <0.15, base >=4.11 && <5, @@ -305,6 +307,7 @@ postgresql-types-algebra ^>=0.1, ptr-peeker ^>=0.2, ptr-poker ^>=0.1.2.16, + QuickCheck >=2.14 && <3, quickcheck-instances ^>=0.3.33, stm >=2.5 && <3, tagged ^>=0.8.9, diff --git a/src/integration-tests/Main.hs b/src/integration-tests/Main.hs --- a/src/integration-tests/Main.hs +++ b/src/integration-tests/Main.hs @@ -78,6 +78,17 @@ withType @(PostgresqlTypes.Varchar 0) [mappingSpec] withType @(PostgresqlTypes.Varchar 255) [mappingSpec] + -- Postgres with a pre-installed PostGIS build, whose initdb already runs + -- @CREATE EXTENSION postgis@ in the default database, so every connection + -- sees the registered @geometry@ type immediately. + -- + -- This is the multi-architecture rebuild of the official @postgis/postgis@ + -- image, which publishes amd64 only. It is what the official image's own + -- README points at for arm64. + withContainer "imresamu/postgis:17-3.5" do + withConnection Nothing do + withType @PostgresqlTypes.Geometry [mappingSpec] + withContainer "postgres:14" do withConnection (Just 3) do withType @(PostgresqlTypes.Bit 1) [mappingSpec] diff --git a/src/library/PostgresqlTypes.hs b/src/library/PostgresqlTypes.hs --- a/src/library/PostgresqlTypes.hs +++ b/src/library/PostgresqlTypes.hs @@ -47,6 +47,9 @@ Polygon, Circle, + -- * PostGIS Types + Geometry, + -- * Bit String Types Bit, Varbit, @@ -82,6 +85,7 @@ import PostgresqlTypes.Date import PostgresqlTypes.Float4 import PostgresqlTypes.Float8 +import PostgresqlTypes.Geometry import PostgresqlTypes.Hstore import PostgresqlTypes.Inet import PostgresqlTypes.Int2 diff --git a/src/library/PostgresqlTypes/Geometry.hs b/src/library/PostgresqlTypes/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/library/PostgresqlTypes/Geometry.hs @@ -0,0 +1,1024 @@ +module PostgresqlTypes.Geometry + ( Geometry, + Shape (..), + Coord (..), + NurbsCurve (..), + CurveSegment (..), + Curve (..), + Surface (..), + + -- * Accessors + toSrid, + toShape, + + -- * Constructors + refineFromShape, + refineFromShapeAndSrid, + ) +where + +import qualified Data.Attoparsec.Text as Attoparsec +import qualified Data.ByteString as ByteString +import qualified Data.Text as Text +import GHC.Float (castDoubleToWord64, castWord64ToDouble) +import PostgresqlTypes.Algebra +import PostgresqlTypes.Prelude +import PostgresqlTypes.Via +import qualified PtrPeeker +import qualified PtrPoker.Write as Write +import qualified Test.QuickCheck as QuickCheck +import qualified TextBuilder + +-- | PostGIS @geometry@ extension type. A 'Shape' with an optional spatial reference identifier (SRID). +-- +-- All coordinates of one geometry share a single dimensionality: every 'Coord' in the shape tree uses the same constructor. +-- This is what PostGIS itself guarantees and what its wire format can express, since the dimensionality is carried once, in the type header. +-- The 'refineFromShape' and 'refineFromShapeAndSrid' constructors enforce it. +-- +-- The binary format is [EWKB](https://postgis.net/docs/using_postgis_dbmanagement.html#EWKB_EWKT) — the format @geometry_send@ emits and @geometry_recv@ accepts. +-- Output is little-endian (NDR); input is accepted in either byte order. +-- The textual format is the hexadecimal encoding of the same payload, which is what @geometry_out@ produces and @geometry_in@ accepts. +-- +-- Unlike the built-in PostgreSQL types, @geometry@ is registered by @CREATE EXTENSION postgis@ and receives a different OID in every database. +-- 'baseOid' and 'arrayOid' are therefore 'Nothing', and drivers are expected to resolve the OID by 'typeName' at runtime. +-- +-- __Full shape coverage.__ 'Shape' supports every geometry kind PostGIS's @geometry@ column can hold — all +-- sixteen @LWTYPE@ kinds, from the seven basic OGC shapes (@Point@, @LineString@, @Polygon@, @MultiPoint@, +-- @MultiLineString@, @MultiPolygon@, @GeometryCollection@) through the ISO\/SQL-MM curve and surface extensions +-- (@CircularString@, @CompoundCurve@, @CurvePolygon@, @MultiCurve@, @MultiSurface@, @PolyhedralSurface@, +-- @Triangle@, @TIN@) and NURBS curves. See 'Shape'\'s own Haddock for the full constructor list. +-- +-- __NURBS curves__ ('NurbsCurveShape') are the one shape not validated against a real PostGIS server: support for +-- them only landed in PostGIS's development branch in June 2026, no released PostGIS version speaks the wire +-- format yet, and that format has seen several revisions and may still change upstream. This codec is derived +-- from the ISO/IEC 13249-3:2016 spec and hand-built fixtures alone. Accordingly, 'NurbsCurveShape' is deliberately +-- excluded from the 'Arbitrary'\/'shrink' instances below and from the real-server integration test suite. +-- +-- [PostGIS docs](https://postgis.net/docs/geometry.html). +data Geometry + = Geometry + -- | Spatial reference identifier. + (Maybe Int32) + -- | Shape. + Shape + deriving stock (Eq, Ord) + deriving (Show, Read, IsString) via (ViaIsScalar Geometry) + +-- | One of the sixteen OGC\/ISO geometry kinds that a 'Geometry' can hold — PostGIS's complete @LWTYPE@ +-- vocabulary, from the seven basic OGC shapes through the ISO\/SQL-MM curve, surface and TIN extensions. +-- See the note on 'Geometry' for the full-coverage summary and the 'NurbsCurveShape' caveat. +data Shape + = -- | Single coordinate. + PointShape Coord + | -- | Line connecting two or more coordinates. + LineStringShape [Coord] + | -- | One or more linear rings. The first is the exterior ring, the rest are interior rings (holes). + -- Every ring is closed: its last coordinate repeats its first. + PolygonShape [[Coord]] + | -- | Circular arc string: a sequence of circular arcs, each defined by three consecutive + -- coordinates (start, midpoint on the arc, end), where the end of one arc is the start of the + -- next. Requires an odd number of coordinates, at least three. + CircularStringShape [Coord] + | -- | Collection of points. + MultiPointShape [Coord] + | -- | Collection of line strings. + MultiLineStringShape [[Coord]] + | -- | Collection of polygons, each given as its list of rings. + MultiPolygonShape [[[Coord]]] + | -- | Collection of polygon faces forming a surface, each given as its list of rings. + PolyhedralSurfaceShape [[[Coord]]] + | -- | Heterogeneous collection of shapes. + -- + -- Members do not carry their own SRID: they inherit the one of the enclosing 'Geometry'. + GeometryCollectionShape [Shape] + | -- | A single linear ring, or none. Unlike 'PolygonShape', a triangle admits at most one ring: no + -- holes, and no more than one exterior boundary. The empty list represents a triangle with no ring + -- at all; a non-empty one is closed, its last coordinate repeating its first. + TriangleShape [Coord] + | -- | Non-Uniform Rational B-Spline curve (ISO/IEC 13249-3:2016). + -- + -- __Caution:__ untested against any real PostGIS server. See the note on 'Geometry'. + NurbsCurveShape NurbsCurve + | -- | Triangulated irregular network: a homogeneous collection of triangles, each given as its + -- ring, matching 'TriangleShape'\'s own representation — the empty list is a triangle with no + -- ring at all, a non-empty one is closed with its last coordinate repeating its first. + TinShape [[Coord]] + | -- | Curve assembled by chaining line and arc segments end to end. + -- + -- Members are restricted to 'CurveSegment' rather than 'Shape': unlike + -- 'GeometryCollectionShape', which legitimately allows arbitrary nesting per OGC, a compound + -- curve's members can only be a @LineString@ or a @CircularString@, never another + -- @CompoundCurve@ or anything else. 'CurveSegment' makes that illegal nesting unrepresentable + -- at compile time, the same reasoning that already led 'MultiPointShape' to store raw + -- @['Coord']@ rather than @['Shape']@. + CompoundCurveShape [CurveSegment] + | -- | Polygon whose rings may be curved: each ring is a full 'Curve' rather than a plain sequence + -- of coordinates. + -- + -- Members are restricted to 'Curve' rather than 'Shape' for the same reason 'CompoundCurveShape' + -- is restricted to 'CurveSegment': a curve polygon's ring can only be a @LineString@, a + -- @CircularString@ or a @CompoundCurve@, never a @Polygon@ or anything else. + CurvePolygonShape [Curve] + | -- | Heterogeneous collection of curves. + -- + -- Members are restricted to 'Curve' rather than 'Shape', again for the same reason as + -- 'CompoundCurveShape': a multi-curve's member can only be a @LineString@, a @CircularString@ or + -- a @CompoundCurve@, never a @Polygon@ or anything else. + MultiCurveShape [Curve] + | -- | Heterogeneous collection of surfaces. + -- + -- Members are restricted to 'Surface' rather than 'Shape', for the same reason + -- 'CompoundCurveShape' is restricted to 'CurveSegment': a multi-surface's member can only be a + -- @Polygon@ or a @CurvePolygon@, never anything else. + MultiSurfaceShape [Surface] + deriving stock (Eq, Ord, Show, Read) + +-- | Coordinate in one of the four dimensionalities PostGIS supports. +-- +-- @Z@ is an elevation, @M@ is a measure — an application-defined value interpolated along the geometry. +data Coord + = -- | 2D. + XyCoord + -- | X ordinate. + Double + -- | Y ordinate. + Double + | -- | 3D. + XyzCoord + -- | X ordinate. + Double + -- | Y ordinate. + Double + -- | Z ordinate. + Double + | -- | 2D with a measure. + XymCoord + -- | X ordinate. + Double + -- | Y ordinate. + Double + -- | M ordinate. + Double + | -- | 3D with a measure. + XyzmCoord + -- | X ordinate. + Double + -- | Y ordinate. + Double + -- | Z ordinate. + Double + -- | M ordinate. + Double + deriving stock (Eq, Ord, Show, Read) + +-- | Non-Uniform Rational B-Spline curve, per ISO/IEC 13249-3:2016 (SQL/MM Spatial). +-- +-- __Caution:__ untested against any real PostGIS server. See the note on 'Geometry'. +data NurbsCurve + = NurbsCurve + -- | Degree. + Word32 + -- | Control points, each paired with its weight. A weight of @1@ is unweighted. + [(Coord, Double)] + -- | Knot vector. + [Double] + deriving stock (Eq, Ord, Show, Read) + +-- | One continuous curve segment: the building block of a 'CompoundCurveShape'. +-- +-- Deliberately does not reuse 'Shape' — see the Haddock on 'CompoundCurveShape' for why. +data CurveSegment + = -- | Straight segment, wire-compatible with 'LineStringShape'. + LineSegment [Coord] + | -- | Circular-arc segment, wire-compatible with 'CircularStringShape'. + ArcSegment [Coord] + deriving stock (Eq, Ord, Show, Read) + +-- | Any curve: a single segment, or several chained end-to-end (an OGC/SQL-MM @CompoundCurve@). +-- +-- The building block of 'CurvePolygonShape'\'s rings and 'MultiCurveShape'\'s members. Deliberately +-- does not reuse 'Shape', for the same reason 'CurveSegment' does not: a ring or member here can +-- only be a @LineString@, a @CircularString@ or a @CompoundCurve@, never a @Polygon@ or anything else. +data Curve + = -- | Single segment, wire-compatible with 'LineStringShape' or 'CircularStringShape', depending + -- on the wrapped 'CurveSegment'\'s own constructor. + SegmentCurve CurveSegment + | -- | Several segments chained end to end, wire-compatible with 'CompoundCurveShape'. + ChainedCurve [CurveSegment] + deriving stock (Eq, Ord, Show, Read) + +-- | Any surface: a plain polygon, or one whose rings may be curved (an OGC/SQL-MM @CurvePolygon@). +-- +-- The building block of 'MultiSurfaceShape'\'s members. Deliberately does not reuse 'Shape', for the +-- same reason 'Curve' does not: a member here can only be a @Polygon@ or a @CurvePolygon@, never +-- anything else. +data Surface + = -- | Plain polygon, wire-compatible with 'PolygonShape'. + PolygonSurface [[Coord]] + | -- | Polygon with possibly curved rings, wire-compatible with 'CurvePolygonShape'. + CurvedSurface [Curve] + deriving stock (Eq, Ord, Show, Read) + +instance Hashable Geometry where + hashWithSalt salt (Geometry srid shape) = + salt `hashWithSalt` srid `hashWithSalt` shape + +instance Hashable Shape where + hashWithSalt salt = \case + PointShape coord -> salt `hashWithSalt` (0 :: Int) `hashWithSalt` coord + LineStringShape coords -> salt `hashWithSalt` (1 :: Int) `hashWithSalt` coords + PolygonShape rings -> salt `hashWithSalt` (2 :: Int) `hashWithSalt` rings + MultiPointShape coords -> salt `hashWithSalt` (3 :: Int) `hashWithSalt` coords + MultiLineStringShape lineStrings -> salt `hashWithSalt` (4 :: Int) `hashWithSalt` lineStrings + MultiPolygonShape polygons -> salt `hashWithSalt` (5 :: Int) `hashWithSalt` polygons + GeometryCollectionShape shapes -> salt `hashWithSalt` (6 :: Int) `hashWithSalt` shapes + CircularStringShape coords -> salt `hashWithSalt` (7 :: Int) `hashWithSalt` coords + TriangleShape coords -> salt `hashWithSalt` (8 :: Int) `hashWithSalt` coords + PolyhedralSurfaceShape polygons -> salt `hashWithSalt` (9 :: Int) `hashWithSalt` polygons + NurbsCurveShape nurbsCurve -> salt `hashWithSalt` (10 :: Int) `hashWithSalt` nurbsCurve + TinShape triangles -> salt `hashWithSalt` (11 :: Int) `hashWithSalt` triangles + CompoundCurveShape segments -> salt `hashWithSalt` (12 :: Int) `hashWithSalt` segments + CurvePolygonShape curves -> salt `hashWithSalt` (13 :: Int) `hashWithSalt` curves + MultiCurveShape curves -> salt `hashWithSalt` (14 :: Int) `hashWithSalt` curves + MultiSurfaceShape surfaces -> salt `hashWithSalt` (15 :: Int) `hashWithSalt` surfaces + +instance Hashable Coord where + hashWithSalt salt = \case + XyCoord x y -> salt `hashWithSalt` (0 :: Int) `hashWithSalt` x `hashWithSalt` y + XyzCoord x y z -> salt `hashWithSalt` (1 :: Int) `hashWithSalt` x `hashWithSalt` y `hashWithSalt` z + XymCoord x y m -> salt `hashWithSalt` (2 :: Int) `hashWithSalt` x `hashWithSalt` y `hashWithSalt` m + XyzmCoord x y z m -> salt `hashWithSalt` (3 :: Int) `hashWithSalt` x `hashWithSalt` y `hashWithSalt` z `hashWithSalt` m + +instance Hashable NurbsCurve where + hashWithSalt salt (NurbsCurve degree controlPoints knots) = + salt `hashWithSalt` degree `hashWithSalt` controlPoints `hashWithSalt` knots + +instance Hashable CurveSegment where + hashWithSalt salt = \case + LineSegment coords -> salt `hashWithSalt` (0 :: Int) `hashWithSalt` coords + ArcSegment coords -> salt `hashWithSalt` (1 :: Int) `hashWithSalt` coords + +instance Hashable Curve where + hashWithSalt salt = \case + SegmentCurve segment -> salt `hashWithSalt` (0 :: Int) `hashWithSalt` segment + ChainedCurve segments -> salt `hashWithSalt` (1 :: Int) `hashWithSalt` segments + +instance Hashable Surface where + hashWithSalt salt = \case + PolygonSurface rings -> salt `hashWithSalt` (0 :: Int) `hashWithSalt` rings + CurvedSurface curves -> salt `hashWithSalt` (1 :: Int) `hashWithSalt` curves + +instance Arbitrary Geometry where + arbitrary = do + dim <- QuickCheck.elements [XyDim, XyzDim, XymDim, XyzmDim] + shape <- QuickCheck.sized (shapeGen dim) + srid <- sridGen + pure (Geometry srid shape) + + shrink (Geometry srid shape) = + mconcat + [ mapMaybe (`refineFromShapeAndSrid` srid) (shrinkShape shape), + mapMaybe (refineFromShapeAndSrid shape) (shrinkSrid srid) + ] + +instance IsScalar Geometry where + schemaName = Tagged Nothing + typeName = Tagged "geometry" + baseOid = Tagged Nothing + arrayOid = Tagged Nothing + typeParams = Tagged [] + + binaryEncoder (Geometry srid shape) = + -- 'Geometry' is only constructible via 'refineFromShapeAndSrid' and + -- 'binaryDecoder', both of which reject shape trees whose coordinates + -- disagree on dimensionality, so 'shapeDim' cannot fail here. + writeGeometry srid (fromMaybe XyDim (shapeDim shape)) shape + + binaryDecoder = runExceptT do + (srid, shape) <- readGeometry + case refineFromShapeAndSrid shape srid of + Just geometry -> pure geometry + Nothing -> + throwError + ( DecodingError + ["geometry"] + ( UnsupportedValueDecodingErrorReason + "All coordinates of a geometry must share the same dimensionality" + (shapeName shape) + ) + ) + + textualEncoder geometry = + foldMap TextBuilder.hexadecimal (ByteString.unpack (Write.toByteString (binaryEncoder geometry))) + + textualDecoder = do + hexText <- Attoparsec.takeText + bytes <- either fail pure (parseHexBytes hexText) + case PtrPeeker.runVariableOnByteStringWithRemainders (binaryDecoder @Geometry) bytes of + Left bytesNeeded -> + fail ("geometry: EWKB payload is short of " <> show bytesNeeded <> " bytes") + Right (Left err, _) -> + fail ("geometry: " <> show err) + Right (Right geometry, remainder) + | ByteString.null remainder -> pure geometry + | otherwise -> + fail ("geometry: " <> show (ByteString.length remainder) <> " bytes left after the EWKB payload") + where + parseHexBytes :: Text -> Either String ByteString + parseHexBytes = fmap ByteString.pack . parseHexPairs . Text.unpack + parseHexPairs :: [Char] -> Either String [Word8] + parseHexPairs = \case + [] -> Right [] + [_] -> Left "Odd number of hexadecimal digits" + a : b : rest -> (:) <$> parseHexPair a b <*> parseHexPairs rest + parseHexPair :: Char -> Char -> Either String Word8 + parseHexPair a b = do + high <- parseHexDigit a + low <- parseHexDigit b + pure (high * 16 + low) + parseHexDigit :: Char -> Either String Word8 + parseHexDigit c + | c >= '0' && c <= '9' = Right (fromIntegral (ord c - ord '0')) + | c >= 'a' && c <= 'f' = Right (fromIntegral (ord c - ord 'a' + 10)) + | c >= 'A' && c <= 'F' = Right (fromIntegral (ord c - ord 'A' + 10)) + | otherwise = Left ("Invalid hexadecimal digit: " <> [c]) + +-- * Accessors + +-- | Extract the spatial reference identifier, if the geometry carries one. +toSrid :: Geometry -> Maybe Int32 +toSrid (Geometry srid _) = srid + +-- | Extract the shape. +toShape :: Geometry -> Shape +toShape (Geometry _ shape) = shape + +-- * Constructors + +-- | Construct a 'Geometry' without an SRID. +-- +-- Returns 'Nothing' if the coordinates of the shape tree do not all share the same dimensionality. +refineFromShape :: Shape -> Maybe Geometry +refineFromShape shape = refineFromShapeAndSrid shape Nothing + +-- | Construct a 'Geometry' with an optional SRID. +-- +-- Returns 'Nothing' if the coordinates of the shape tree do not all share the same dimensionality +-- or if the SRID is not a positive integer. PostGIS normalises @srid <= 0@ to @SRID_UNKNOWN@ (0), +-- which breaks the round-trip: the value would encode with the SRID flag but decode back as +-- 'Nothing', so those values are rejected. +refineFromShapeAndSrid :: Shape -> Maybe Int32 -> Maybe Geometry +refineFromShapeAndSrid shape srid + | maybe True (0 <) srid = Geometry srid shape <$ shapeDim shape + | otherwise = Nothing + +-- * Dimensionality + +-- | Dimensionality shared by all coordinates of a geometry. +data Dim = XyDim | XyzDim | XymDim | XyzmDim + deriving stock (Eq, Ord, Show) + +-- | Dimensionality that every coordinate of the shape tree agrees on, or 'Nothing' if they disagree. +-- +-- A tree with no coordinates at all, such as an empty @MultiPoint@, is 'XyDim'. +shapeDim :: Shape -> Maybe Dim +shapeDim shape = fromMaybe XyDim <$> goShape Nothing shape + where + goShape :: Maybe Dim -> Shape -> Maybe (Maybe Dim) + goShape acc = \case + PointShape coord -> goCoord acc coord + LineStringShape coords -> goCoords acc coords + CircularStringShape coords -> goCoords acc coords + PolygonShape rings -> foldM goCoords acc rings + MultiPointShape coords -> goCoords acc coords + MultiLineStringShape lineStrings -> foldM goCoords acc lineStrings + MultiPolygonShape polygons -> foldM (foldM goCoords) acc polygons + PolyhedralSurfaceShape polygons -> foldM (foldM goCoords) acc polygons + GeometryCollectionShape shapes -> foldM goShape acc shapes + TriangleShape coords -> goCoords acc coords + NurbsCurveShape (NurbsCurve _ controlPoints _) -> goCoords acc (fst <$> controlPoints) + TinShape triangles -> foldM goCoords acc triangles + CompoundCurveShape segments -> foldM goSegment acc segments + CurvePolygonShape curves -> foldM goCurve acc curves + MultiCurveShape curves -> foldM goCurve acc curves + MultiSurfaceShape surfaces -> foldM goSurface acc surfaces + goSegment :: Maybe Dim -> CurveSegment -> Maybe (Maybe Dim) + goSegment acc = \case + LineSegment coords -> goCoords acc coords + ArcSegment coords -> goCoords acc coords + goCurve :: Maybe Dim -> Curve -> Maybe (Maybe Dim) + goCurve acc = \case + SegmentCurve segment -> goSegment acc segment + ChainedCurve segments -> foldM goSegment acc segments + goSurface :: Maybe Dim -> Surface -> Maybe (Maybe Dim) + goSurface acc = \case + PolygonSurface rings -> foldM goCoords acc rings + CurvedSurface curves -> foldM goCurve acc curves + goCoords :: Maybe Dim -> [Coord] -> Maybe (Maybe Dim) + goCoords = foldM goCoord + goCoord :: Maybe Dim -> Coord -> Maybe (Maybe Dim) + goCoord acc coord = + let dim = coordDim coord + in case acc of + Nothing -> Just (Just dim) + Just acc' -> if acc' == dim then Just (Just dim) else Nothing + +coordDim :: Coord -> Dim +coordDim = \case + XyCoord {} -> XyDim + XyzCoord {} -> XyzDim + XymCoord {} -> XymDim + XyzmCoord {} -> XyzmDim + +-- * EWKB header + +-- | Byte order of an EWKB payload, as signalled by its leading marker byte. +data ByteOrder + = -- | XDR. Marker @0@. + BigEndianByteOrder + | -- | NDR. Marker @1@. + LittleEndianByteOrder + +-- | OGC type codes, as they appear in the low bits of the EWKB type header. +pointTypeCode, lineStringTypeCode, polygonTypeCode, multiPointTypeCode, multiLineStringTypeCode, multiPolygonTypeCode, geometryCollectionTypeCode, circularStringTypeCode, triangleTypeCode, polyhedralSurfaceTypeCode, tinTypeCode, compoundCurveTypeCode, curvePolygonTypeCode, multiCurveTypeCode, multiSurfaceTypeCode :: Word32 +pointTypeCode = 1 +lineStringTypeCode = 2 +polygonTypeCode = 3 +multiPointTypeCode = 4 +multiLineStringTypeCode = 5 +multiPolygonTypeCode = 6 +geometryCollectionTypeCode = 7 +circularStringTypeCode = 8 +compoundCurveTypeCode = 9 +curvePolygonTypeCode = 10 +multiCurveTypeCode = 11 +multiSurfaceTypeCode = 12 +triangleTypeCode = 17 +polyhedralSurfaceTypeCode = 15 +tinTypeCode = 16 + +-- | ISO/IEC 13249-3 (SQL/MM) type code for a NURBS curve. +-- +-- Unlike the seven OGC shapes above, PostGIS's WKB writer signals a NURBS curve's dimensionality +-- through this code's magnitude rather than through 'zFlag'\/'mFlag': the wire byte is +-- @nurbsCurveBaseTypeCode + isoDimOffset dim@, e.g. @1021@ for an XYZ curve. See 'isoDimOffset'. +nurbsCurveBaseTypeCode :: Word32 +nurbsCurveBaseTypeCode = 21 + +-- | Dimensionality offset that PostGIS's WKB writer adds to 'nurbsCurveBaseTypeCode', per the +-- ISO/IEC 13249-3 (SQL/MM) extended-WKB numbering scheme: plain 2D types occupy 1-999, @+1000@ +-- selects the Z variant, @+2000@ the M variant and @+3000@ the ZM variant. +-- +-- __Assumption, not verified against a released PostGIS:__ NURBS curve support only exists on +-- PostGIS's development branch (merged June 2026) and no released version speaks this format, so +-- this can't be checked against real server output. The @+1000@\/@+2000@\/@+3000@ offsets are given +-- directly by the ticket that specified this feature, and the "no offset means 2D" reading follows +-- the same SQL/MM scheme PostGIS already uses for its other ISO curve\/surface type codes (e.g. +-- @CircularString@ = 8, @CompoundCurve@ = 9, none of which this codebase implements) — those, too, +-- carry no offset for their bare 2D form. If PostGIS's actual NURBS implementation turns out to +-- reserve 0 for something other than XY, only this function and 'isoOffsetToDim' need to change. +isoDimOffset :: Dim -> Word32 +isoDimOffset = \case + XyDim -> 0 + XyzDim -> 1000 + XymDim -> 2000 + XyzmDim -> 3000 + +-- | Inverse of 'isoDimOffset'. 'Nothing' for any offset PostGIS's NURBS writer is not documented to emit. +isoOffsetToDim :: Word32 -> Maybe Dim +isoOffsetToDim = \case + 0 -> Just XyDim + 1 -> Just XyzDim + 2 -> Just XymDim + 3 -> Just XyzmDim + _ -> Nothing + +-- | Flag bits of the EWKB type header. +zFlag, mFlag, sridFlag :: Word32 +zFlag = 0x80000000 +mFlag = 0x40000000 +sridFlag = 0x20000000 + +-- | Mask that liblwgeom applies to separate the OGC type code from the EWKB flags. +-- +-- The four top bits are the @Z@, @M@, @SRID@ and bounding-box markers. PostGIS never emits the +-- bounding-box one in WKB, but it is masked off all the same, exactly as @lwtype_from_wkb_state@ does. +typeCodeMask :: Word32 +typeCodeMask = 0x0FFFFFFF + +dimToFlags :: Dim -> Word32 +dimToFlags = \case + XyDim -> 0 + XyzDim -> zFlag + XymDim -> mFlag + XyzmDim -> zFlag .|. mFlag + +shapeToTypeCode :: Shape -> Word32 +shapeToTypeCode = \case + PointShape {} -> pointTypeCode + LineStringShape {} -> lineStringTypeCode + PolygonShape {} -> polygonTypeCode + MultiPointShape {} -> multiPointTypeCode + MultiLineStringShape {} -> multiLineStringTypeCode + MultiPolygonShape {} -> multiPolygonTypeCode + PolyhedralSurfaceShape {} -> polyhedralSurfaceTypeCode + GeometryCollectionShape {} -> geometryCollectionTypeCode + CircularStringShape {} -> circularStringTypeCode + TriangleShape {} -> triangleTypeCode + NurbsCurveShape {} -> nurbsCurveBaseTypeCode + TinShape {} -> tinTypeCode + CompoundCurveShape {} -> compoundCurveTypeCode + CurvePolygonShape {} -> curvePolygonTypeCode + MultiCurveShape {} -> multiCurveTypeCode + MultiSurfaceShape {} -> multiSurfaceTypeCode + +-- | Name of the shape in the OGC vocabulary. Used for reporting decoding errors. +shapeName :: Shape -> Text +shapeName = \case + PointShape {} -> "Point" + LineStringShape {} -> "LineString" + PolygonShape {} -> "Polygon" + MultiPointShape {} -> "MultiPoint" + MultiLineStringShape {} -> "MultiLineString" + MultiPolygonShape {} -> "MultiPolygon" + PolyhedralSurfaceShape {} -> "PolyhedralSurface" + GeometryCollectionShape {} -> "GeometryCollection" + CircularStringShape {} -> "CircularString" + TriangleShape {} -> "Triangle" + NurbsCurveShape {} -> "NurbsCurve" + TinShape {} -> "TIN" + CompoundCurveShape {} -> "CompoundCurve" + CurvePolygonShape {} -> "CurvePolygon" + MultiCurveShape {} -> "MultiCurve" + MultiSurfaceShape {} -> "MultiSurface" + +-- * Binary encoder + +-- | Encode a geometry as EWKB, in little-endian byte order. +-- +-- The SRID flag and field are only emitted when an SRID is given. PostGIS stores the SRID on the outer +-- geometry alone, so the sub-geometries of the @Multi@ and collection shapes are written without one. +writeGeometry :: Maybe Int32 -> Dim -> Shape -> Write.Write +writeGeometry srid dim shape = + mconcat + [ Write.word8 1, + Write.lWord32 (typeCode .|. maybe 0 (const sridFlag) srid), + foldMap (Write.lWord32 . fromIntegral) srid, + writeShape dim shape + ] + where + -- A NURBS curve is the one shape whose dimensionality PostGIS's writer bakes into the type + -- code's magnitude (see 'isoDimOffset') instead of the Z\/M flag bits every other shape uses. + -- The SRID flag above is unaffected either way: it is a separate bit that both schemes share. + typeCode = case shape of + NurbsCurveShape {} -> shapeToTypeCode shape + isoDimOffset dim + _ -> shapeToTypeCode shape .|. dimToFlags dim + +writeShape :: Dim -> Shape -> Write.Write +writeShape dim = \case + PointShape coord -> writeCoord coord + LineStringShape coords -> writeCoords coords + CircularStringShape coords -> writeCoords coords + PolygonShape rings -> writeCount rings <> foldMap writeCoords rings + MultiPointShape coords -> writeCount coords <> foldMap (writeSubGeometry . PointShape) coords + MultiLineStringShape lineStrings -> writeCount lineStrings <> foldMap (writeSubGeometry . LineStringShape) lineStrings + MultiPolygonShape polygons -> writeCount polygons <> foldMap (writeSubGeometry . PolygonShape) polygons + PolyhedralSurfaceShape polygons -> writeCount polygons <> foldMap (writeSubGeometry . PolygonShape) polygons + GeometryCollectionShape shapes -> writeCount shapes <> foldMap writeSubGeometry shapes + TriangleShape coords -> case coords of + [] -> Write.lWord32 0 + _ -> Write.lWord32 1 <> writeCoords coords + NurbsCurveShape nurbsCurve -> writeNurbsCurve nurbsCurve + TinShape triangles -> writeCount triangles <> foldMap (writeSubGeometry . TriangleShape) triangles + CompoundCurveShape segments -> writeCount segments <> foldMap writeSegment segments + CurvePolygonShape curves -> writeCount curves <> foldMap writeCurve curves + MultiCurveShape curves -> writeCount curves <> foldMap writeCurve curves + MultiSurfaceShape surfaces -> writeCount surfaces <> foldMap writeSurface surfaces + where + writeCount :: [a] -> Write.Write + writeCount = Write.lWord32 . fromIntegral . length + writeCoords :: [Coord] -> Write.Write + writeCoords coords = writeCount coords <> foldMap writeCoord coords + writeSubGeometry :: Shape -> Write.Write + writeSubGeometry = writeGeometry Nothing dim + writeSegment :: CurveSegment -> Write.Write + writeSegment = \case + LineSegment coords -> writeSubGeometry (LineStringShape coords) + ArcSegment coords -> writeSubGeometry (CircularStringShape coords) + writeCurve :: Curve -> Write.Write + writeCurve = \case + SegmentCurve segment -> writeSegment segment + ChainedCurve segments -> writeSubGeometry (CompoundCurveShape segments) + writeSurface :: Surface -> Write.Write + writeSurface = \case + PolygonSurface rings -> writeSubGeometry (PolygonShape rings) + CurvedSurface curves -> writeSubGeometry (CurvePolygonShape curves) + +-- | Encode the ordinates of a coordinate. +-- +-- Which of them are present is determined by the coordinate's own constructor, which the 'Geometry' +-- invariant keeps in agreement with the dimensionality announced in the header. +writeCoord :: Coord -> Write.Write +writeCoord = \case + XyCoord x y -> writeDouble x <> writeDouble y + XyzCoord x y z -> writeDouble x <> writeDouble y <> writeDouble z + XymCoord x y m -> writeDouble x <> writeDouble y <> writeDouble m + XyzmCoord x y z m -> writeDouble x <> writeDouble y <> writeDouble z <> writeDouble m + where + writeDouble = Write.lWord64 . castDoubleToWord64 + +-- | Encode a NURBS curve's body: degree, then the count-prefixed control points, then the +-- count-prefixed knot vector. Mirrors 'readNurbsCurve'. +writeNurbsCurve :: NurbsCurve -> Write.Write +writeNurbsCurve (NurbsCurve degree controlPoints knots) = + mconcat + [ Write.lWord32 degree, + Write.lWord32 (fromIntegral (length controlPoints)), + foldMap writeNurbsControlPoint controlPoints, + Write.lWord32 (fromIntegral (length knots)), + foldMap writeDouble knots + ] + where + writeDouble = Write.lWord64 . castDoubleToWord64 + +-- | Encode one control point: its own (redundant, but ISO-mandated) byte-order marker — always NDR, +-- matching the rest of this encoder — then its coordinates, then the weight flag byte. A weight of +-- exactly @1.0@ is the default and is written as flag @0@ with the weight omitted; any other value, +-- including @0.0@, is written explicitly as flag @1@ followed by the weight. +writeNurbsControlPoint :: (Coord, Double) -> Write.Write +writeNurbsControlPoint (coord, weight) = + mconcat + [ Write.word8 1, + writeCoord coord, + if weight == 1.0 + then Write.word8 0 + else Write.word8 1 <> Write.lWord64 (castDoubleToWord64 weight) + ] + +-- * Binary decoder + +-- | Decode an EWKB geometry, yielding its SRID and shape. +-- +-- Sub-geometries are decoded through the same function: EWKB lets them carry an SRID field of their +-- own, which has to be consumed to keep the stream aligned, but PostGIS ignores its value in favour +-- of the one of the enclosing geometry. The callers below accordingly discard it. +readGeometry :: ExceptT DecodingError PtrPeeker.Variable (Maybe Int32, Shape) +readGeometry = do + byteOrderMarker <- lift (PtrPeeker.fixed PtrPeeker.unsignedInt1) + byteOrder <- case byteOrderMarker of + 0 -> pure BigEndianByteOrder + 1 -> pure LittleEndianByteOrder + _ -> + throwError + ( DecodingError + ["byte-order-marker"] + (UnexpectedValueDecodingErrorReason "0 or 1" (TextBuilder.toText (TextBuilder.decimal byteOrderMarker))) + ) + typeWithFlags <- lift (readWord32 byteOrder) + let maskedTypeCode = typeWithFlags .&. typeCodeMask + -- A NURBS curve is the one shape whose dimensionality is not carried in the Z/M flag bits + -- (testBit 31 / testBit 30): PostGIS's writer instead bakes it into the type code's magnitude + -- (see 'isoDimOffset'). Detect that case first, from the masked type code alone, before falling + -- back to the ordinary flag-bit interpretation every other shape uses. + (dim, typeCode) <- + if maskedTypeCode `mod` 1000 == nurbsCurveBaseTypeCode + then case isoOffsetToDim (maskedTypeCode `div` 1000) of + Just isoDim -> pure (isoDim, nurbsCurveBaseTypeCode) + Nothing -> + throwError + ( DecodingError + ["type-code"] + ( UnsupportedValueDecodingErrorReason + "Unknown NURBS curve ISO dimensionality offset" + (TextBuilder.toText (TextBuilder.decimal maskedTypeCode)) + ) + ) + else + pure + ( case (testBit typeWithFlags 31, testBit typeWithFlags 30) of + (False, False) -> XyDim + (True, False) -> XyzDim + (False, True) -> XymDim + (True, True) -> XyzmDim, + maskedTypeCode + ) + srid <- + if testBit typeWithFlags 29 + then Just . fromIntegral <$> lift (readWord32 byteOrder) + else pure Nothing + shape <- readShape byteOrder dim typeCode + pure (srid, shape) + +readShape :: ByteOrder -> Dim -> Word32 -> ExceptT DecodingError PtrPeeker.Variable Shape +readShape byteOrder dim typeCode + | typeCode == pointTypeCode = + PointShape <$> lift (readCoord byteOrder dim) + | typeCode == lineStringTypeCode = + LineStringShape <$> lift readCoords + | typeCode == circularStringTypeCode = + CircularStringShape <$> lift readCoords + | typeCode == polygonTypeCode = + PolygonShape <$> lift (readSequence readCoords) + | typeCode == multiPointTypeCode = + MultiPointShape <$> readSubShapes "MultiPoint" "Point" \case + PointShape coord -> Just coord + _ -> Nothing + | typeCode == multiLineStringTypeCode = + MultiLineStringShape <$> readSubShapes "MultiLineString" "LineString" \case + LineStringShape coords -> Just coords + _ -> Nothing + | typeCode == multiPolygonTypeCode = + MultiPolygonShape <$> readSubShapes "MultiPolygon" "Polygon" \case + PolygonShape rings -> Just rings + _ -> Nothing + | typeCode == polyhedralSurfaceTypeCode = + PolyhedralSurfaceShape <$> readSubShapes "PolyhedralSurface" "Polygon" \case + PolygonShape rings -> Just rings + _ -> Nothing + | typeCode == geometryCollectionTypeCode = do + count <- lift (readWord32 byteOrder) + GeometryCollectionShape <$> replicateM (fromIntegral count) (snd <$> readGeometry) + | typeCode == triangleTypeCode = do + ringCount <- lift (readWord32 byteOrder) + case ringCount of + 0 -> pure (TriangleShape []) + 1 -> TriangleShape <$> lift readCoords + _ -> + throwError + ( DecodingError + ["Triangle"] + (UnexpectedValueDecodingErrorReason "0 or 1 rings" (TextBuilder.toText (TextBuilder.decimal ringCount))) + ) + | typeCode == nurbsCurveBaseTypeCode = + NurbsCurveShape <$> readNurbsCurve byteOrder dim + | typeCode == tinTypeCode = + TinShape <$> readSubShapes "TIN" "Triangle" \case + TriangleShape coords -> Just coords + _ -> Nothing + | typeCode == compoundCurveTypeCode = + CompoundCurveShape <$> readSubShapes "CompoundCurve" "LineString or CircularString" \case + LineStringShape coords -> Just (LineSegment coords) + CircularStringShape coords -> Just (ArcSegment coords) + _ -> Nothing + | typeCode == curvePolygonTypeCode = + CurvePolygonShape <$> readSubShapes "CurvePolygon" "LineString, CircularString or CompoundCurve" readCurveProjection + | typeCode == multiCurveTypeCode = + MultiCurveShape <$> readSubShapes "MultiCurve" "LineString, CircularString or CompoundCurve" readCurveProjection + | typeCode == multiSurfaceTypeCode = + MultiSurfaceShape <$> readSubShapes "MultiSurface" "Polygon or CurvePolygon" readSurfaceProjection + | otherwise = + throwError + ( DecodingError + ["type-code"] + (UnsupportedValueDecodingErrorReason "Unknown geometry type code" (TextBuilder.toText (TextBuilder.decimal typeCode))) + ) + where + readCoords :: PtrPeeker.Variable [Coord] + readCoords = readSequence (readCoord byteOrder dim) + -- A count-prefixed sequence of elements. + readSequence :: PtrPeeker.Variable a -> PtrPeeker.Variable [a] + readSequence element = do + count <- readWord32 byteOrder + replicateM (fromIntegral count) element + -- A count-prefixed sequence of sub-geometries, each of which is required to be of the shape + -- that the given projection accepts. The arguments are the name of the shape being decoded and + -- the name of the sub-shape, both for reporting errors. + readSubShapes :: + Text -> + Text -> + (Shape -> Maybe a) -> + ExceptT DecodingError PtrPeeker.Variable [a] + readSubShapes name subShapeName project = do + count <- lift (readWord32 byteOrder) + replicateM (fromIntegral count) do + shape <- snd <$> readGeometry + case project shape of + Just projection -> pure projection + Nothing -> + throwError + ( DecodingError + [name] + (UnexpectedValueDecodingErrorReason subShapeName (shapeName shape)) + ) + -- Projection shared by 'CurvePolygonShape' and 'MultiCurveShape': both admit the same three + -- shapes as a ring\/member, wire-compatible with 'Curve'\'s own two constructors. + readCurveProjection :: Shape -> Maybe Curve + readCurveProjection = \case + LineStringShape coords -> Just (SegmentCurve (LineSegment coords)) + CircularStringShape coords -> Just (SegmentCurve (ArcSegment coords)) + CompoundCurveShape segments -> Just (ChainedCurve segments) + _ -> Nothing + -- Projection for 'MultiSurfaceShape': a member is either a plain 'PolygonShape' or a + -- 'CurvePolygonShape', wire-compatible with 'Surface'\'s own two constructors. + readSurfaceProjection :: Shape -> Maybe Surface + readSurfaceProjection = \case + PolygonShape rings -> Just (PolygonSurface rings) + CurvePolygonShape curves -> Just (CurvedSurface curves) + _ -> Nothing + +readCoord :: ByteOrder -> Dim -> PtrPeeker.Variable Coord +readCoord byteOrder = \case + XyDim -> XyCoord <$> readDouble <*> readDouble + XyzDim -> XyzCoord <$> readDouble <*> readDouble <*> readDouble + XymDim -> XymCoord <$> readDouble <*> readDouble <*> readDouble + XyzmDim -> XyzmCoord <$> readDouble <*> readDouble <*> readDouble <*> readDouble + where + readDouble = castWord64ToDouble <$> readWord64 byteOrder + +-- | Decode a NURBS curve's body: degree, then the count-prefixed control points, then the +-- count-prefixed knot vector. Mirrors 'writeNurbsCurve'. +-- +-- No arithmetic relationship between the degree, control point count and knot count is checked: +-- as elsewhere in this codebase, already-server-validated structure is trusted rather than +-- re-validated. +readNurbsCurve :: ByteOrder -> Dim -> ExceptT DecodingError PtrPeeker.Variable NurbsCurve +readNurbsCurve byteOrder dim = do + degree <- lift (readWord32 byteOrder) + pointCount <- lift (readWord32 byteOrder) + controlPoints <- replicateM (fromIntegral pointCount) (readNurbsControlPoint dim) + knotCount <- lift (readWord32 byteOrder) + knots <- lift (replicateM (fromIntegral knotCount) readDouble) + pure (NurbsCurve degree controlPoints knots) + where + readDouble = castWord64ToDouble <$> readWord64 byteOrder + +-- | Decode one control point: its own (redundant, but ISO-mandated) byte-order marker, then its +-- coordinates in that byte order, then a weight flag byte — @0@ means the default weight @1.0@ +-- (omitted on the wire), @1@ means an explicit weight follows. +readNurbsControlPoint :: Dim -> ExceptT DecodingError PtrPeeker.Variable (Coord, Double) +readNurbsControlPoint dim = do + pointByteOrderMarker <- lift (PtrPeeker.fixed PtrPeeker.unsignedInt1) + pointByteOrder <- case pointByteOrderMarker of + 0 -> pure BigEndianByteOrder + 1 -> pure LittleEndianByteOrder + _ -> + throwError + ( DecodingError + ["nurbs-curve", "control-point", "byte-order-marker"] + (UnexpectedValueDecodingErrorReason "0 or 1" (TextBuilder.toText (TextBuilder.decimal pointByteOrderMarker))) + ) + coord <- lift (readCoord pointByteOrder dim) + hasWeight <- lift (PtrPeeker.fixed PtrPeeker.unsignedInt1) + weight <- case hasWeight of + 0 -> pure 1.0 + _ -> lift (castWord64ToDouble <$> readWord64 pointByteOrder) + pure (coord, weight) + +readWord32 :: ByteOrder -> PtrPeeker.Variable Word32 +readWord32 = \case + BigEndianByteOrder -> PtrPeeker.fixed PtrPeeker.beUnsignedInt4 + LittleEndianByteOrder -> PtrPeeker.fixed PtrPeeker.leUnsignedInt4 + +readWord64 :: ByteOrder -> PtrPeeker.Variable Word64 +readWord64 = \case + BigEndianByteOrder -> PtrPeeker.fixed PtrPeeker.beUnsignedInt8 + LittleEndianByteOrder -> PtrPeeker.fixed PtrPeeker.leUnsignedInt8 + +-- * QuickCheck generators + +-- | Generate an SRID within PostGIS's user-assignable range. +-- +-- Values outside of it do not survive a roundtrip: @0@ means \"no SRID\" and loses the flag on output, +-- and anything above @SRID_MAXIMUM@ (999999) gets remapped modulo into the range above +-- @SRID_USER_MAXIMUM@ that PostGIS reserves for itself. @[1, 998999]@ is also where the real EPSG and +-- @spatial_ref_sys@ codes live. +sridGen :: QuickCheck.Gen (Maybe Int32) +sridGen = QuickCheck.oneof [pure Nothing, Just <$> QuickCheck.choose (1, 998_999)] + +shrinkSrid :: Maybe Int32 -> [Maybe Int32] +shrinkSrid = filter (maybe True (\srid -> srid >= 1 && srid <= 998_999)) . shrink + +-- | Generate a shape whose every coordinate is of the given dimensionality and which satisfies the +-- structural constraints OGC places on it, so that PostGIS accepts it. +-- +-- __'NurbsCurveShape' is deliberately never generated here.__ NURBS curve support is not in any +-- released PostGIS version (see the note on 'Geometry'), and the real-server integration test +-- suite draws its 'Geometry' values from this generator; producing one here would break that suite +-- against a server that cannot parse it. Do not add it without first revisiting that risk. +shapeGen :: Dim -> Int -> QuickCheck.Gen Shape +shapeGen dim size = + QuickCheck.oneof (if size <= 1 then simple else simple <> compound) + where + simple = + [ PointShape <$> coordGen dim, + LineStringShape <$> lineStringCoordsGen dim, + CircularStringShape <$> circularStringCoordsGen dim, + PolygonShape . pure <$> ringCoordsGen dim, + MultiPointShape <$> QuickCheck.listOf (coordGen dim), + QuickCheck.oneof [pure (TriangleShape []), TriangleShape <$> ringCoordsGen dim] + ] + compound = + [ MultiLineStringShape <$> QuickCheck.listOf (lineStringCoordsGen dim), + MultiPolygonShape <$> QuickCheck.listOf (QuickCheck.listOf1 (ringCoordsGen dim)), + PolyhedralSurfaceShape <$> QuickCheck.listOf (QuickCheck.listOf1 (ringCoordsGen dim)), + TinShape <$> QuickCheck.listOf (QuickCheck.oneof [pure [], ringCoordsGen dim]), + CompoundCurveShape <$> QuickCheck.listOf (segmentGen dim), + CurvePolygonShape <$> QuickCheck.listOf (curveGen dim), + MultiCurveShape <$> QuickCheck.listOf (curveGen dim), + MultiSurfaceShape <$> QuickCheck.listOf (surfaceGen dim), + GeometryCollectionShape <$> QuickCheck.resize subSize (QuickCheck.listOf (shapeGen dim subSize)) + ] + subSize = div size 4 + +-- | Generate the coordinates of a line string, of which OGC requires at least two. +lineStringCoordsGen :: Dim -> QuickCheck.Gen [Coord] +lineStringCoordsGen dim = do + extra <- QuickCheck.choose (0, 6 :: Int) + QuickCheck.vectorOf (2 + extra) (coordGen dim) + +-- | Generate the coordinates of a circular string. PostGIS's @geometry_recv@ enforces +-- @LW_PARSER_CHECK_MINPOINTS | LW_PARSER_CHECK_ODD@ for circular strings: an odd number of +-- coordinates, at least three, each consecutive triple describing one circular arc. +circularStringCoordsGen :: Dim -> QuickCheck.Gen [Coord] +circularStringCoordsGen dim = do + extraArcs <- QuickCheck.choose (0, 3 :: Int) + QuickCheck.vectorOf (3 + 2 * extraArcs) (coordGen dim) + +-- | Generate the coordinates of a linear ring, which OGC requires to be closed and to consist of at +-- least four coordinates: three distinct ones plus the repetition of the first that closes it. +ringCoordsGen :: Dim -> QuickCheck.Gen [Coord] +ringCoordsGen dim = do + extra <- QuickCheck.choose (0, 5 :: Int) + firstCoord <- coordGen dim + restCoords <- QuickCheck.vectorOf (2 + extra) (coordGen dim) + pure (firstCoord : restCoords <> [firstCoord]) + +coordGen :: Dim -> QuickCheck.Gen Coord +coordGen = \case + XyDim -> XyCoord <$> arbitrary <*> arbitrary + XyzDim -> XyzCoord <$> arbitrary <*> arbitrary <*> arbitrary + XymDim -> XymCoord <$> arbitrary <*> arbitrary <*> arbitrary + XyzmDim -> XyzmCoord <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +-- | Generate one curve segment, matching 'CurveSegment'\'s own two constructors. +segmentGen :: Dim -> QuickCheck.Gen CurveSegment +segmentGen dim = + QuickCheck.oneof + [ LineSegment <$> lineStringCoordsGen dim, + ArcSegment <$> circularStringCoordsGen dim + ] + +-- | Generate a curve: either a single segment or several chained end to end, matching 'Curve'\'s own +-- two constructors. +curveGen :: Dim -> QuickCheck.Gen Curve +curveGen dim = + QuickCheck.oneof + [ SegmentCurve <$> segmentGen dim, + ChainedCurve <$> QuickCheck.listOf (segmentGen dim) + ] + +-- | Generate a surface, matching 'Surface'\'s own two constructors. A plain polygon surface has at +-- least one ring, matching 'PolygonShape'\'s own generator. +surfaceGen :: Dim -> QuickCheck.Gen Surface +surfaceGen dim = + QuickCheck.oneof + [ PolygonSurface . pure <$> ringCoordsGen dim, + CurvedSurface <$> QuickCheck.listOf (curveGen dim) + ] + +-- | Shrink a shape by dropping members of its collections. +-- +-- Individual coordinates are never dropped or shrunk: that would either change the dimensionality of +-- the tree or break the closure of a ring, producing a shape PostGIS rejects. +shrinkShape :: Shape -> [Shape] +shrinkShape = \case + PointShape _ -> [] + LineStringShape coords -> + LineStringShape <$> filter ((>= 2) . length) (shrinkMembers coords) + CircularStringShape coords -> + CircularStringShape <$> filter (\cs -> length cs >= 3 && odd (length cs)) (shrinkMembers coords) + PolygonShape rings -> + PolygonShape <$> filter (not . null) (shrinkMembers rings) + MultiPointShape coords -> + MultiPointShape <$> shrinkMembers coords + MultiLineStringShape lineStrings -> + MultiLineStringShape <$> shrinkMembers lineStrings + MultiPolygonShape polygons -> + MultiPolygonShape <$> shrinkMembers polygons + PolyhedralSurfaceShape polygons -> + PolyhedralSurfaceShape <$> shrinkMembers polygons + GeometryCollectionShape shapes -> + GeometryCollectionShape <$> QuickCheck.shrinkList shrinkShape shapes + TriangleShape coords -> + [TriangleShape [] | not (null coords)] + TinShape triangles -> + TinShape <$> shrinkMembers triangles + -- 'shapeGen' never produces this constructor (see the comment there), so this is never called + -- with one in practice. Covered only so the pattern match above stays exhaustive. + NurbsCurveShape _ -> [] + CompoundCurveShape segments -> + -- Members are dropped wholesale, never shrunk internally: shrinking a segment's own coordinate + -- list risks breaking the odd-≥3 invariant an 'ArcSegment' requires, the same reason + -- 'CircularStringShape' does not delegate to a plain 'shrinkMembers' either. + CompoundCurveShape <$> shrinkMembers segments + CurvePolygonShape curves -> + -- Same reasoning as 'CompoundCurveShape': members are dropped wholesale, never shrunk internally. + CurvePolygonShape <$> shrinkMembers curves + MultiCurveShape curves -> + MultiCurveShape <$> shrinkMembers curves + MultiSurfaceShape surfaces -> + -- Same reasoning as 'MultiCurveShape': members are dropped wholesale, never shrunk internally. + MultiSurfaceShape <$> shrinkMembers surfaces + where + shrinkMembers :: [a] -> [[a]] + shrinkMembers = QuickCheck.shrinkList (const []) diff --git a/src/unit-tests/PostgresqlTypes/GeometrySpec.hs b/src/unit-tests/PostgresqlTypes/GeometrySpec.hs new file mode 100644 --- /dev/null +++ b/src/unit-tests/PostgresqlTypes/GeometrySpec.hs @@ -0,0 +1,600 @@ +module PostgresqlTypes.GeometrySpec (spec) where + +import qualified Data.Attoparsec.Text +import Data.Data (Proxy (Proxy)) +import Data.Either +import Data.Hashable (hashWithSalt) +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified PostgresqlTypes.Algebra +import PostgresqlTypes.Geometry (Coord (..), Curve (..), CurveSegment (..), Geometry, NurbsCurve (..), Shape (..), Surface (..)) +import qualified PostgresqlTypes.Geometry as Geometry +import Test.Hspec +import Test.QuickCheck +import qualified TextBuilder +import qualified UnitTests.Scripts as Scripts +import Prelude + +spec :: Spec +spec = do + describe "Show/Read laws" do + Scripts.testShowRead (Proxy @Geometry) + + describe "IsScalar laws" do + Scripts.testIsScalar (Proxy @Geometry) + + describe "Constructors" do + describe "refineFromShape" do + it "accepts a 2D point" do + let shape = PointShape (XyCoord 1 2) + fmap Geometry.toShape (Geometry.refineFromShape shape) `shouldBe` Just shape + + it "accepts a line string of uniformly 3D coordinates" do + let shape = LineStringShape [XyzCoord 0 0 1, XyzCoord 1 1 2] + fmap Geometry.toShape (Geometry.refineFromShape shape) `shouldBe` Just shape + + it "rejects a line string mixing 2D and 3D coordinates" do + Geometry.refineFromShape (LineStringShape [XyCoord 0 0, XyzCoord 1 1 2]) + `shouldBe` Nothing + + it "rejects a collection mixing plain and measured shapes" do + Geometry.refineFromShape + ( GeometryCollectionShape + [ PointShape (XyCoord 0 0), + PointShape (XymCoord 1 1 3) + ] + ) + `shouldBe` Nothing + + describe "refineFromShapeAndSrid" do + it "threads the SRID through to the geometry" do + let shape = PointShape (XyCoord 13.4 52.5) + fmap Geometry.toSrid (Geometry.refineFromShapeAndSrid shape (Just 4326)) + `shouldBe` Just (Just 4326) + + it "rejects SRID 0" do + Geometry.refineFromShapeAndSrid (PointShape (XyCoord 0 0)) (Just 0) + `shouldBe` Nothing + + it "rejects a negative SRID" do + Geometry.refineFromShapeAndSrid (PointShape (XyCoord 0 0)) (Just (-5)) + `shouldBe` Nothing + + it "accepts Nothing" do + Geometry.refineFromShapeAndSrid (PointShape (XyCoord 0 0)) Nothing + `shouldSatisfy` isJust + + it "accepts a positive SRID" do + Geometry.refineFromShapeAndSrid (PointShape (XyCoord 0 0)) (Just 1) + `shouldSatisfy` isJust + + describe "Accessors" do + describe "toSrid" do + it "extracts the SRID" do + fmap Geometry.toSrid (Geometry.refineFromShapeAndSrid (PointShape (XyCoord 0 0)) (Just 4326)) + `shouldBe` Just (Just 4326) + + describe "toShape" do + it "extracts the shape" do + let shape = PointShape (XyCoord 1 2) + fmap Geometry.toShape (Geometry.refineFromShape shape) `shouldBe` Just shape + + describe "Wire format" do + -- Fixture produced by PostGIS itself: + -- SELECT ST_AsEWKB(ST_SetSRID(ST_MakePoint(1, 2), 4326)); + -- + -- Byte-order marker NDR (01), type 1 with the SRID flag (01000020), SRID 4326 (E6100000), + -- x = 1.0 (000000000000F03F), y = 2.0 (0000000000000040). + let pointHex = "0101000020E6100000000000000000F03F0000000000000040" + point = Geometry.refineFromShapeAndSrid (PointShape (XyCoord 1 2)) (Just 4326) + + it "decodes a point PostGIS produced" do + fmap Just (decodeHex pointHex) `shouldBe` Right point + + it "encodes a point the way PostGIS does" do + fmap encodeHex point `shouldBe` Just (Text.toLower pointHex) + + it "accepts big-endian input" do + -- The same point, XDR: marker 00, then every multi-byte field byte-swapped. + fmap Just (decodeHex "0020000001000010E63FF00000000000004000000000000000") + `shouldBe` Right point + + it "rejects an invalid byte-order marker" do + decodeHex "0201000000000000000000F03F0000000000000040" `shouldSatisfy` isLeft + + it "rejects an unknown type code" do + decodeHex "0163000000000000000000F03F0000000000000040" `shouldSatisfy` isLeft + + it "rejects trailing bytes" do + decodeHex "0101000000000000000000F03F00000000000000400000" `shouldSatisfy` isLeft + + it "rejects a truncated payload" do + decodeHex "0101000000000000000000F03F" `shouldSatisfy` isLeft + + -- Fixture derived by hand from the EWKB layout (no live PostGIS instance required for this test): + -- a CircularString of one arc through (0,0), (1,2), (2,0), with SRID 4326. + -- + -- Byte-order marker NDR (01), type 8 (CircularString) with the SRID flag (08000020), SRID 4326 + -- (E6100000), coordinate count 3 (03000000), then the three coordinates: (0,0), (1,2), (2,0), + -- each ordinate as a little-endian IEEE-754 double. + let circularStringHex = "0108000020E61000000300000000000000000000000000000000000000000000000000F03F000000000000004000000000000000400000000000000000" + circularString = + Geometry.refineFromShapeAndSrid + (CircularStringShape [XyCoord 0 0, XyCoord 1 2, XyCoord 2 0]) + (Just 4326) + + it "decodes a circular string" do + fmap Just (decodeHex circularStringHex) `shouldBe` Right circularString + + it "encodes a circular string the way PostGIS does" do + fmap encodeHex circularString `shouldBe` Just (Text.toLower circularStringHex) + + -- Fixture produced by PostGIS itself: + -- SELECT ST_AsEWKB(ST_SetSRID(ST_GeomFromText( + -- 'POLYHEDRALSURFACE(((0 0, 1 0, 0 1, 0 0)), ((0 0, 0 1, -1 0, 0 0)))' + -- ), 4326)); + let polyhedralSurfaceHex = "010F000020E6100000020000000103000000010000000400000000000000000000000000000000000000000000000000F03F00000000000000000000000000000000000000000000F03F0000000000000000000000000000000001030000000100000004000000000000000000000000000000000000000000000000000000000000000000F03F000000000000F0BF000000000000000000000000000000000000000000000000" + polyhedralSurface = + Geometry.refineFromShapeAndSrid + ( PolyhedralSurfaceShape + [ [[XyCoord 0 0, XyCoord 1 0, XyCoord 0 1, XyCoord 0 0]], + [[XyCoord 0 0, XyCoord 0 1, XyCoord (-1) 0, XyCoord 0 0]] + ] + ) + (Just 4326) + + it "decodes a polyhedral surface PostGIS produced" do + fmap Just (decodeHex polyhedralSurfaceHex) `shouldBe` Right polyhedralSurface + + it "encodes a polyhedral surface the way PostGIS does" do + fmap encodeHex polyhedralSurface `shouldBe` Just (Text.toLower polyhedralSurfaceHex) + + it "rejects a polyhedral surface whose member is a line string" do + decodeHex + ( mconcat + [ "01", -- NDR + "0F000000", -- PolyhedralSurface + "01000000", -- 1 member + "01", -- NDR + "02000000", -- LineString, where a Polygon is required + "02000000", -- 2 coordinates + "000000000000F03F0000000000000040", + "00000000000008400000000000001040" + ] + ) + `shouldSatisfy` isLeft + + it "rejects a multi-point whose member is a line string" do + decodeHex + ( mconcat + [ "01", -- NDR + "04000000", -- MultiPoint + "01000000", -- 1 member + "01", -- NDR + "02000000", -- LineString, where a Point is required + "02000000", -- 2 coordinates + "000000000000F03F0000000000000040", + "00000000000008400000000000001040" + ] + ) + `shouldSatisfy` isLeft + + it "rejects a collection whose members disagree on dimensionality" do + decodeHex + ( mconcat + [ "01", -- NDR + "07000000", -- GeometryCollection + "02000000", -- 2 members + "01", -- NDR + "01000000", -- Point, 2D + "000000000000F03F0000000000000040", + "01", -- NDR + "01000080", -- Point, 3D + "000000000000F03F00000000000000400000000000000840" + ] + ) + `shouldSatisfy` isLeft + + -- A triangle is a polygon restricted to 0 or 1 rings: a ring-count word32, followed by that one + -- ring's coordinates when present. + let emptyTriangleHex = + mconcat + [ "01", -- NDR + "11000000", -- type 17 (Triangle), no flags + "00000000" -- 0 rings + ] + emptyTriangle = Geometry.refineFromShape (TriangleShape []) + + it "decodes an empty triangle" do + fmap Just (decodeHex emptyTriangleHex) `shouldBe` Right emptyTriangle + + it "encodes an empty triangle" do + fmap encodeHex emptyTriangle `shouldBe` Just (Text.toLower emptyTriangleHex) + + let nonEmptyTriangleHex = + mconcat + [ "01", -- NDR + "11000000", -- type 17 (Triangle), no flags + "01000000", -- 1 ring + "04000000", -- 4 coordinates + "00000000000000000000000000000000", -- (0, 0) + "00000000000010400000000000000000", -- (4, 0) + "00000000000000000000000000000840", -- (0, 3) + "00000000000000000000000000000000" -- (0, 0), closing the ring + ] + nonEmptyTriangle = + Geometry.refineFromShape + (TriangleShape [XyCoord 0 0, XyCoord 4 0, XyCoord 0 3, XyCoord 0 0]) + + it "decodes a non-empty triangle" do + fmap Just (decodeHex nonEmptyTriangleHex) `shouldBe` Right nonEmptyTriangle + + it "encodes a non-empty triangle" do + fmap encodeHex nonEmptyTriangle `shouldBe` Just (Text.toLower nonEmptyTriangleHex) + + it "rejects a triangle with more than one ring" do + decodeHex + ( mconcat + [ "01", -- NDR + "11000000", -- Triangle + "02000000" -- 2 rings, which a Triangle disallows + ] + ) + `shouldSatisfy` isLeft + + -- Fixture produced by PostGIS itself: + -- SELECT ST_AsEWKB(ST_SetSRID(ST_GeomFromText( + -- 'TIN (((0 0, 1 0, 0 1, 0 0)), ((0 0, 0 1, -1 0, 0 0)))' + -- ), 4326)); + let tinHex = "0110000020E6100000020000000111000000010000000400000000000000000000000000000000000000000000000000F03F00000000000000000000000000000000000000000000F03F0000000000000000000000000000000001110000000100000004000000000000000000000000000000000000000000000000000000000000000000F03F000000000000F0BF000000000000000000000000000000000000000000000000" + tin = + Geometry.refineFromShapeAndSrid + ( TinShape + [ [XyCoord 0 0, XyCoord 1 0, XyCoord 0 1, XyCoord 0 0], + [XyCoord 0 0, XyCoord 0 1, XyCoord (-1) 0, XyCoord 0 0] + ] + ) + (Just 4326) + + it "decodes a TIN PostGIS produced" do + fmap Just (decodeHex tinHex) `shouldBe` Right tin + + it "encodes a TIN the way PostGIS does" do + fmap encodeHex tin `shouldBe` Just (Text.toLower tinHex) + + it "rejects a TIN whose member isn't a triangle" do + decodeHex + ( mconcat + [ "01", -- NDR + "10000000", -- TIN + "01000000", -- 1 member + "01", -- NDR + "03000000", -- Polygon, where a Triangle is required + "01000000", -- 1 ring + "04000000", -- 4 coordinates + "0000000000000000", -- (0, 0) + "0000000000000000", + "000000000000F03F", -- (1, 0) + "0000000000000000", + "0000000000000000", -- (0, 1) + "000000000000F03F", + "0000000000000000", -- (0, 0), closing the ring + "0000000000000000" + ] + ) + `shouldSatisfy` isLeft + + -- Fixture derived by hand from the EWKB layout (no live PostGIS instance required for this test): + -- a CompoundCurve made of one line segment through (0,0)-(1,1), followed by one arc segment + -- through (1,1), (2,2), (3,0), with no SRID. + -- + -- Byte-order marker NDR (01), type 9 (CompoundCurve), no flags (09000000), member count 2 + -- (02000000), then each member as a full sub-geometry: a LineString (type 2) of 2 coordinates, + -- and a CircularString (type 8) of 3 coordinates, each with its own byte-order marker. + let compoundCurveHex = + "01090000000200000001020000000200000000000000000000000000000000000000000000000000F03F000000000000F03F010800000003000000000000000000F03F000000000000F03F0000000000000040000000000000004000000000000008400000000000000000" + compoundCurve = + Geometry.refineFromShape + ( CompoundCurveShape + [ LineSegment [XyCoord 0 0, XyCoord 1 1], + ArcSegment [XyCoord 1 1, XyCoord 2 2, XyCoord 3 0] + ] + ) + + it "decodes a compound curve" do + fmap Just (decodeHex compoundCurveHex) `shouldBe` Right compoundCurve + + it "encodes a compound curve the way PostGIS does" do + fmap encodeHex compoundCurve `shouldBe` Just (Text.toLower compoundCurveHex) + + it "rejects a compound curve whose member is neither a line nor an arc" do + decodeHex + ( mconcat + [ "01", -- NDR + "09000000", -- CompoundCurve + "01000000", -- 1 member + "01", -- NDR + "01000000", -- Point, where a LineString or CircularString is required + "000000000000F03F0000000000000040" + ] + ) + `shouldSatisfy` isLeft + + -- Fixture derived by hand from the EWKB layout (no live PostGIS instance required for this test): + -- a CurvePolygon of two rings, exercising both of 'Curve'\'s constructors as ring members: a + -- plain closed square via 'SegmentCurve' wrapping a 'LineSegment', and a closed ring assembled + -- from a line and an arc via 'ChainedCurve'. + -- + -- Byte-order marker NDR (01), type 10 (CurvePolygon), no flags (0A000000), ring count 2 + -- (02000000), then each ring as a full sub-geometry: a LineString (type 2) of 5 coordinates + -- forming the square (0,0)-(4,0)-(4,4)-(0,4)-(0,0), and a CompoundCurve (type 9) of 2 members — a + -- LineString from (1,1) to (2,1), then a CircularString through (2,1), (2,2), (1,1) — closing the + -- ring back on its start. + let curvePolygonHex = + "010A000000020000000102000000050000000000000000000000000000000000000000000000000010400000000000000000000000000000104000000000000010400000000000000000000000000000104000000000000000000000000000000000010900000002000000010200000002000000000000000000F03F000000000000F03F0000000000000040000000000000F03F0108000000030000000000000000000040000000000000F03F00000000000000400000000000000040000000000000F03F000000000000F03F" + curvePolygon = + Geometry.refineFromShape + ( CurvePolygonShape + [ SegmentCurve (LineSegment [XyCoord 0 0, XyCoord 4 0, XyCoord 4 4, XyCoord 0 4, XyCoord 0 0]), + ChainedCurve + [ LineSegment [XyCoord 1 1, XyCoord 2 1], + ArcSegment [XyCoord 2 1, XyCoord 2 2, XyCoord 1 1] + ] + ] + ) + + it "decodes a curve polygon" do + fmap Just (decodeHex curvePolygonHex) `shouldBe` Right curvePolygon + + it "encodes a curve polygon the way PostGIS does" do + fmap encodeHex curvePolygon `shouldBe` Just (Text.toLower curvePolygonHex) + + it "rejects a curve polygon whose ring is a polygon" do + decodeHex + ( mconcat + [ "01", -- NDR + "0A000000", -- CurvePolygon + "01000000", -- 1 ring + "01", -- NDR + "03000000", -- Polygon, where a LineString, CircularString or CompoundCurve is required + "01000000", -- 1 ring + "04000000", -- 4 coordinates + "0000000000000000", -- (0, 0) + "0000000000000000", + "000000000000F03F", -- (1, 0) + "0000000000000000", + "0000000000000000", -- (0, 1) + "000000000000F03F", + "0000000000000000", -- (0, 0), closing the ring + "0000000000000000" + ] + ) + `shouldSatisfy` isLeft + + -- Fixture derived by hand from the EWKB layout (no live PostGIS instance required for this test): + -- a MultiCurve made of the same line and arc as the 'compoundCurveHex' fixture above, but as two + -- independent members rather than segments chained into one 'CompoundCurveShape'. + -- + -- Byte-order marker NDR (01), type 11 (MultiCurve), no flags (0B000000), member count 2 + -- (02000000), then each member as a full sub-geometry: a LineString (type 2) of 2 coordinates, + -- and a CircularString (type 8) of 3 coordinates. + let multiCurveHex = + "010B0000000200000001020000000200000000000000000000000000000000000000000000000000F03F000000000000F03F010800000003000000000000000000F03F000000000000F03F0000000000000040000000000000004000000000000008400000000000000000" + multiCurve = + Geometry.refineFromShape + ( MultiCurveShape + [ SegmentCurve (LineSegment [XyCoord 0 0, XyCoord 1 1]), + SegmentCurve (ArcSegment [XyCoord 1 1, XyCoord 2 2, XyCoord 3 0]) + ] + ) + + it "decodes a multi-curve" do + fmap Just (decodeHex multiCurveHex) `shouldBe` Right multiCurve + + it "encodes a multi-curve the way PostGIS does" do + fmap encodeHex multiCurve `shouldBe` Just (Text.toLower multiCurveHex) + + it "rejects a multi-curve whose member is a polygon" do + decodeHex + ( mconcat + [ "01", -- NDR + "0B000000", -- MultiCurve + "01000000", -- 1 member + "01", -- NDR + "03000000", -- Polygon, where a LineString, CircularString or CompoundCurve is required + "01000000", -- 1 ring + "04000000", -- 4 coordinates + "0000000000000000", -- (0, 0) + "0000000000000000", + "000000000000F03F", -- (1, 0) + "0000000000000000", + "0000000000000000", -- (0, 1) + "000000000000F03F", + "0000000000000000", -- (0, 0), closing the ring + "0000000000000000" + ] + ) + `shouldSatisfy` isLeft + + -- Fixture derived by hand from the EWKB layout (no live PostGIS instance required for this test): + -- a MultiSurface of two members, exercising both of 'Surface'\'s constructors: a plain triangular + -- 'Polygon' (wire-compatible with 'PolygonSurface') and a 'CurvePolygon' whose one ring happens + -- to be a plain 'LineString' (wire-compatible with 'CurvedSurface'). + -- + -- Byte-order marker NDR (01), type 12 (MultiSurface), no flags (0C000000), member count 2 + -- (02000000), then each member as a full sub-geometry: a Polygon (type 3) of 1 ring of 4 + -- coordinates forming the closed triangle (0,0)-(1,0)-(0,1)-(0,0), and a CurvePolygon (type 10) + -- of 1 ring, that ring itself a LineString (type 2) of 5 coordinates forming the closed square + -- (0,0)-(4,0)-(4,4)-(0,4)-(0,0). + let multiSurfaceHex = + "010C000000020000000103000000010000000400000000000000000000000000000000000000000000000000F03F00000000000000000000000000000000000000000000F03F00000000000000000000000000000000010A000000010000000102000000050000000000000000000000000000000000000000000000000010400000000000000000000000000000104000000000000010400000000000000000000000000000104000000000000000000000000000000000" + multiSurface = + Geometry.refineFromShape + ( MultiSurfaceShape + [ PolygonSurface [[XyCoord 0 0, XyCoord 1 0, XyCoord 0 1, XyCoord 0 0]], + CurvedSurface [SegmentCurve (LineSegment [XyCoord 0 0, XyCoord 4 0, XyCoord 4 4, XyCoord 0 4, XyCoord 0 0])] + ] + ) + + it "decodes a multi-surface" do + fmap Just (decodeHex multiSurfaceHex) `shouldBe` Right multiSurface + + it "encodes a multi-surface the way PostGIS does" do + fmap encodeHex multiSurface `shouldBe` Just (Text.toLower multiSurfaceHex) + + it "rejects a multi-surface whose member is neither a polygon nor a curve polygon" do + decodeHex + ( mconcat + [ "01", -- NDR + "0C000000", -- MultiSurface + "01000000", -- 1 member + "01", -- NDR + "01000000", -- Point, where a Polygon or CurvePolygon is required + "000000000000F03F0000000000000040" + ] + ) + `shouldSatisfy` isLeft + + describe "NurbsCurve" do + -- These fixtures cannot be captured from a real server: NURBS curve support only exists on + -- PostGIS's development branch (merged June 2026), no released PostGIS version speaks this + -- format, and the format has seen several revisions. They are instead reasoned by hand from + -- the wire layout PostGIS's WKB reader/writer (@lwin_wkb.c@/@lwout_wkb.c@) is documented to + -- use for ISO/IEC 13249-3:2016 NURBS curves: + -- + -- * Byte-order marker, then a type code whose *magnitude* (not the usual Z/M flag bits) + -- encodes dimensionality: base code 21, +1000/+2000/+3000 for XYZ/XYM/XYZM, no offset + -- for plain XY. The SRID flag bit is the ordinary EWKB one. + -- * @degree@ (Word32), then count-prefixed control points, each with its own redundant + -- byte-order marker, its coordinates, and a weight flag byte (0 = default weight 1.0 + -- omitted, 1 = an explicit weight double follows). + -- * A count-prefixed knot vector of plain doubles. + -- + -- Every multi-byte field below is little-endian (NDR), and doubles use the same IEEE 754 hex + -- encoding as the 'pointHex' fixture above (e.g. 1.0 = 000000000000F03F, 2.0 = + -- 0000000000000040, verified the same way: byte-swap the well-known big-endian bit pattern). + + it "decodes and re-encodes a 2D curve with default weights" do + -- A quadratic (degree 2) curve through (0,0), (1,1), (2,0), clamped knot vector + -- [0,0,0,1,1,1], no SRID, every control point at the default weight (flag byte 0). + let hex = + mconcat + [ "01", -- NDR + "15000000", -- type code: base 21 + ISO offset 0 (XY), no SRID flag + "02000000", -- degree = 2 + "03000000", -- 3 control points + "01", -- control point 1: its own NDR marker + "0000000000000000", -- x = 0.0 + "0000000000000000", -- y = 0.0 + "00", -- default weight (1.0, omitted) + "01", -- control point 2: its own NDR marker + "000000000000F03F", -- x = 1.0 + "000000000000F03F", -- y = 1.0 + "00", -- default weight + "01", -- control point 3: its own NDR marker + "0000000000000040", -- x = 2.0 + "0000000000000000", -- y = 0.0 + "00", -- default weight + "06000000", -- 6 knots + "0000000000000000", -- 0.0 + "0000000000000000", -- 0.0 + "0000000000000000", -- 0.0 + "000000000000F03F", -- 1.0 + "000000000000F03F", -- 1.0 + "000000000000F03F" -- 1.0 + ] + shape = + NurbsCurveShape + ( NurbsCurve + 2 + [ (XyCoord 0 0, 1.0), + (XyCoord 1 1, 1.0), + (XyCoord 2 0, 1.0) + ] + [0, 0, 0, 1, 1, 1] + ) + geometry = Geometry.refineFromShape shape + + fmap Just (decodeHex hex) `shouldBe` Right geometry + fmap encodeHex geometry `shouldBe` Just (Text.toLower hex) + + it "decodes and re-encodes a 3D curve with a mix of default and custom weights, under an SRID" do + -- A cubic (degree 3) curve with 2 control points: (0,0,0) with an explicit weight of 2.5, + -- and (1,1,1) at the default weight. SRID 4326, same as the 'pointHex' fixture. + let hex = + mconcat + [ "01", -- NDR + "FD030020", -- type code: base 21 + ISO offset 1000 (XYZ) = 1021 (0x3FD), | SRID flag + "E6100000", -- SRID 4326 + "03000000", -- degree = 3 + "02000000", -- 2 control points + "01", -- control point 1: its own NDR marker + "0000000000000000", -- x = 0.0 + "0000000000000000", -- y = 0.0 + "0000000000000000", -- z = 0.0 + "01", -- explicit weight follows + "0000000000000440", -- weight = 2.5 + "01", -- control point 2: its own NDR marker + "000000000000F03F", -- x = 1.0 + "000000000000F03F", -- y = 1.0 + "000000000000F03F", -- z = 1.0 + "00", -- default weight (1.0, omitted) + "04000000", -- 4 knots + "0000000000000000", -- 0.0 + "0000000000000000", -- 0.0 + "000000000000F03F", -- 1.0 + "000000000000F03F" -- 1.0 + ] + shape = + NurbsCurveShape + ( NurbsCurve + 3 + [ (XyzCoord 0 0 0, 2.5), + (XyzCoord 1 1 1, 1.0) + ] + [0, 0, 1, 1] + ) + geometry = Geometry.refineFromShapeAndSrid shape (Just 4326) + + fmap Just (decodeHex hex) `shouldBe` Right geometry + fmap encodeHex geometry `shouldBe` Just (Text.toLower hex) + + it "decodes and re-encodes the empty curve" do + -- Degree 0, no control points, no knots. No SRID. + let hex = + mconcat + [ "01", -- NDR + "15000000", -- type code: base 21 + ISO offset 0 (XY), no SRID flag + "00000000", -- degree = 0 + "00000000", -- 0 control points + "00000000" -- 0 knots + ] + shape = NurbsCurveShape (NurbsCurve 0 [] []) + geometry = Geometry.refineFromShape shape + + fmap Just (decodeHex hex) `shouldBe` Right geometry + fmap encodeHex geometry `shouldBe` Just (Text.toLower hex) + + describe "Hashable" do + it "agrees with Eq on negative zero" do + -- Hashing the EWKB bytes would break this: the two coordinates are equal, yet their IEEE + -- representations differ. + let positive = Geometry.refineFromShape (PointShape (XyCoord 0 0)) + negative = Geometry.refineFromShape (PointShape (XyCoord (-0.0) (-0.0))) + positive `shouldBe` negative + fmap (hashWithSalt 0) positive `shouldBe` fmap (hashWithSalt 0) negative + + describe "Property Tests" do + it "roundtrips through the accessors and refineFromShapeAndSrid" do + property \(geometry :: Geometry) -> + Geometry.refineFromShapeAndSrid (Geometry.toShape geometry) (Geometry.toSrid geometry) + === Just geometry + +decodeHex :: Text -> Either String Geometry +decodeHex = + Data.Attoparsec.Text.parseOnly + (PostgresqlTypes.Algebra.textualDecoder @Geometry <* Data.Attoparsec.Text.endOfInput) + +encodeHex :: Geometry -> Text +encodeHex = TextBuilder.toText . PostgresqlTypes.Algebra.textualEncoder