diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,5 +1,43 @@ # Change log for esqueleto-postgis project +## Version 3.0.0 +* add spatial type, split up postgis from geoemetry. + this will allow us to deal with curveture of earth and other weird SRID's: + consider: +``` +converge=# SELECT ST_Distance( + ST_MakePoint(-118.24, 34.05)::geometry, -- LA + ST_MakePoint(-74.00, 40.71)::geometry -- NYC +) as distance_in_km; + distance_in_km +------------------- + 44.73849796316367 +(1 row) + +converge=# SELECT ST_Distance( + ST_MakePoint(-118.24, 34.05)::geography, + ST_MakePoint(-74.00, 40.71)::geography +) / 1000 as distance_in_km; + distance_in_km +-------------------- + 3944.7358246490203 +(1 row) +``` +The change is mostly backward compatible, +but I deleted some instances I didn't want to solve. +Furthermore the postgis type is arguably a bit more complicated now. + +I did have some minor breakage in the test suite on st_unions: +``` +- pure $ st_unions (val (Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)])) $ ++ pure $ st_unions @'Geometry (val (Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)])) $ +``` +You may need to tell the compiler weather to use geometry or geography. +But then it'll happen correct within the database as well. + +We don't allow mixing of the two. + + ## Version 2.2.0 * add st_dwithin to find stuf within a range diff --git a/esqueleto-postgis.cabal b/esqueleto-postgis.cabal --- a/esqueleto-postgis.cabal +++ b/esqueleto-postgis.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: esqueleto-postgis -version: 2.2.0 +version: 3.0.0 homepage: https://github.com/jappeace/esqueleto-postgis#readme bug-reports: https://github.com/jappeace/esqueleto-postgis/issues author: Jappie Klooster diff --git a/src/Database/Esqueleto/Postgis.hs b/src/Database/Esqueleto/Postgis.hs --- a/src/Database/Esqueleto/Postgis.hs +++ b/src/Database/Esqueleto/Postgis.hs @@ -1,12 +1,17 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Haskell bindings for postgres postgis -- for a good explenation see module Database.Esqueleto.Postgis - ( PostgisGeometry (..), - makePolygon, + ( + Postgis(..), + SpatialType(..), getPoints, -- * functions @@ -15,13 +20,19 @@ st_union, st_unions, st_dwithin, + st_distance , -- * points point, + point_v, st_point, st_point_xyz, st_point_xyzm, + -- * other + makePolygon, + PostgisGeometry, + -- * re-exports PointXY(..), PointXYZ(..), @@ -29,6 +40,8 @@ ) where +import Database.Esqueleto.Experimental(val) +import Data.Proxy import Data.Bifunctor (first) import Database.Esqueleto.Postgis.Ewkb (parseHexByteString) import Data.Foldable (Foldable (toList), fold) @@ -44,6 +57,7 @@ import Data.Sequence qualified as Seq import Data.String (IsString (..)) import Data.Text (Text, pack) +import Data.Text.Encoding(encodeUtf8) import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder qualified as Text @@ -73,11 +87,29 @@ tshow :: (Show a) => a -> Text tshow = pack . show + +-- | Spatial Reference System. +data SpatialType = Geometry -- ^ assume a flat space. + | Geography -- ^ assume curvature of the earth. + +class HasPgType (spatialType :: SpatialType) where + pgType :: Proxy spatialType -> Text + +instance HasPgType 'Geometry where + pgType _ = "geometry" + +instance HasPgType 'Geography where + pgType _ = "geography" + +-- | backwards compatibility, initial version only dealt in geometry +type PostgisGeometry = Postgis 'Geometry + + -- | like 'GeospatialGeometry' but not partial, eg no empty geometries. -- Also can put an inveriant on dimensions if a function requires it. -- for example 'st_intersects' 'PostgisGeometry' 'PointXY' can't work with 'PostgisGeometry' 'PointXYZ'. -- PointXY indicates a 2 dimension space, and PointXYZ a three dimension space. -data PostgisGeometry point +data Postgis (spatialType :: SpatialType) point = Point point | MultiPoint (NonEmpty point) | Line (LineString point) @@ -141,30 +173,29 @@ renderXYZM :: PointXYZM -> Text.Builder renderXYZM (PointXYZM {..}) = fromString (show _xyzmX) <> " " <> fromString (show _xyzmY) <> " " <> fromString (show _xyzmZ) <> " " <> fromString (show _xyzmM) -renderGeometry :: PostgisGeometry Text.Builder -> Text.Builder -renderGeometry = \case +renderGeometry :: forall (spatialType :: SpatialType) . HasPgType spatialType => Postgis spatialType Text.Builder -> Text.Builder +renderGeometry geom = + let result = renderGeometryUntyped geom + -- wrap it in quotes and cast it to whatever type we decided it should be + in "'" <> result <> "' :: " <> (Text.fromText $ pgType $ (Proxy @spatialType) ) + +-- can't add quotes and types in the recursion because it's already part of the string +renderGeometryUntyped :: Postgis spatialType Text.Builder -> Text.Builder +renderGeometryUntyped = \case Point point' -> "POINT(" <> point' <> ")" MultiPoint points -> "MULTIPOINT (" <> fold (Non.intersperse "," ((\x -> "(" <> x <> ")") <$> points)) <> ")" Line line -> "LINESTRING(" <> renderLines line <> ")" Multiline multiline -> "MULTILINESTRING(" <> fold (Non.intersperse "," ((\line -> "(" <> renderLines line <> ")") <$> multiline)) <> ")" Polygon polygon -> "POLYGON((" <> renderLines polygon <> "))" MultiPolygon multipolygon -> "MULTIPOLYGON(" <> fold (Non.intersperse "," ((\line -> "((" <> renderLines line <> "))") <$> multipolygon)) <> ")" - Collection collection -> "GEOMETRYCOLLECTION(" <> fold (Non.intersperse "," (renderGeometry <$> collection)) <> ")" + Collection collection -> "GEOMETRYCOLLECTION(" <> fold (Non.intersperse "," (renderGeometryUntyped <$> collection)) <> ")" -extractFirst :: PostgisGeometry a -> a -extractFirst = \case - Point point' -> point' - MultiPoint points -> Non.head points - Line line -> lineStringHead line - Multiline multiline -> lineStringHead $ Non.head multiline - Polygon polygon -> ringHead polygon - MultiPolygon multipolygon -> ringHead $ Non.head multipolygon - Collection collection -> extractFirst $ Non.head collection + renderLines :: (Foldable f) => f Text.Builder -> Text.Builder renderLines line = fold (List.intersperse "," $ toList line) -from2dGeospatialGeometry :: (Eq a, Show a) => (GeoPositionWithoutCRS -> Either GeomErrors a) -> GeospatialGeometry -> Either GeomErrors (PostgisGeometry a) +from2dGeospatialGeometry :: (Eq a, Show a) => (GeoPositionWithoutCRS -> Either GeomErrors a) -> GeospatialGeometry -> Either GeomErrors (Postgis spatialType a) from2dGeospatialGeometry interpreter = \case Geospatial.NoGeometry -> Left NoGeometry Geospatial.Point (GeoPoint point') -> (Point <$> interpreter point') @@ -198,53 +229,47 @@ (one :<| two :<| three :<| rem') -> Right $ makeLinearRing one two three rem' _other -> Left NotEnoughElements -instance PersistField PointXY where - toPersistValue geom = toPersistValue (Point geom) - fromPersistValue x = extractFirst <$> fromPersistValue x - -instance PersistFieldSql PointXY where - sqlType _ = SqlOther "geometry" - -instance PersistField (PostgisGeometry PointXY) where +instance HasPgType spatialType => PersistField (Postgis spatialType PointXY) where toPersistValue geom = - PersistText $ toStrict $ toLazyText $ renderGeometry $ renderPair <$> geom + PersistLiteral_ Unescaped $ encodeUtf8 $ toStrict $ toLazyText $ renderGeometry $ renderPair <$> geom fromPersistValue (PersistLiteral_ Escaped bs) = do result <- first pack $ parseHexByteString $ assertBase16 $ fromStrict bs first tshow $ (from2dGeospatialGeometry from2dGeoPositionWithoutCRSToPoint) result fromPersistValue other = Left ("PersistField.Polygon: invalid persist value:" <> tshow other) -instance PersistField (PostgisGeometry PointXYZ) where +instance HasPgType spatialType => PersistField (Postgis spatialType PointXYZ) where toPersistValue geom = - PersistText $ toStrict $ toLazyText $ renderGeometry $ renderXYZ <$> geom + PersistLiteral_ Unescaped $ encodeUtf8 $ toStrict $ toLazyText $ renderGeometry $ renderXYZ <$> geom fromPersistValue (PersistLiteral_ Escaped bs) = do result <- first pack $ parseHexByteString $ assertBase16 $ fromStrict bs first tshow $ (from2dGeospatialGeometry from3dGeoPositionWithoutCRSToPoint) result fromPersistValue other = Left ("PersistField.Polygon: invalid persist value:" <> tshow other) -instance PersistField (PostgisGeometry PointXYZM) where +instance HasPgType spatialType => PersistField (Postgis spatialType PointXYZM) where toPersistValue geom = - PersistText $ toStrict $ toLazyText $ renderGeometry $ renderXYZM <$> geom + PersistLiteral_ Unescaped $ encodeUtf8 $ toStrict $ toLazyText $ renderGeometry $ renderXYZM <$> geom fromPersistValue (PersistLiteral_ Escaped bs) = do result <- first pack $ parseHexByteString $ assertBase16 $ fromStrict bs first tshow $ (from2dGeospatialGeometry from4dGeoPositionWithoutCRSToPoint) result fromPersistValue other = Left ("PersistField.Polygon: invalid persist value:" <> tshow other) -instance PersistFieldSql (PostgisGeometry PointXY) where - sqlType _ = SqlOther "geometry" +instance forall spatialType . HasPgType spatialType => PersistFieldSql (Postgis spatialType PointXY) where + sqlType _ = SqlOther $ pgType $ Proxy @spatialType -instance PersistFieldSql (PostgisGeometry PointXYZ) where - sqlType _ = SqlOther "geometry" +instance HasPgType spatialType => PersistFieldSql (Postgis spatialType PointXYZ) where + sqlType _ = SqlOther $ pgType $ Proxy @spatialType -instance PersistFieldSql (PostgisGeometry PointXYZM) where - sqlType _ = SqlOther "geometry" +instance HasPgType spatialType => PersistFieldSql (Postgis spatialType PointXYZM) where + sqlType _ = SqlOther $ pgType $ Proxy @spatialType + -- | Returns TRUE if geometry A contains geometry B. -- https://postgis.net/docs/ST_Contains.html st_contains :: -- | geom a - SqlExpr (Value (PostgisGeometry a)) -> + SqlExpr (Value (Postgis spatialType a)) -> -- | geom b - SqlExpr (Value (PostgisGeometry a)) -> + SqlExpr (Value (Postgis spatialType a)) -> SqlExpr (Value Bool) st_contains a b = unsafeSqlFunction "ST_CONTAINS" (a, b) @@ -252,9 +277,9 @@ -- https://postgis.net/docs/ST_DWithin.html st_dwithin :: -- | geometry g1 - SqlExpr (Value (PostgisGeometry a)) -> + SqlExpr (Value (Postgis spatialType a)) -> -- | geometry g2 - SqlExpr (Value (PostgisGeometry a)) -> + SqlExpr (Value (Postgis spatialType a)) -> -- | distance of srid SqlExpr (Value Double) -> SqlExpr (Value Bool) @@ -277,20 +302,31 @@ -- pure unit -- @ st_union :: - SqlExpr (Value (PostgisGeometry a)) -> - SqlExpr (Value (PostgisGeometry a)) + SqlExpr (Value (Postgis spatialType a)) -> + SqlExpr (Value (Postgis spatialType a)) st_union a = unsafeSqlFunction "ST_union" a st_unions :: - SqlExpr (Value (PostgisGeometry a)) -> - SqlExpr (Value (PostgisGeometry a)) -> - SqlExpr (Value (PostgisGeometry a)) + forall spatialType a . HasPgType spatialType => + SqlExpr (Value (Postgis spatialType a)) -> + SqlExpr (Value (Postgis spatialType a)) -> + SqlExpr (Value (Postgis spatialType a)) st_unions a b = -- casts to prevent -- function st_union(unknown, unknown) is not unique", sqlErrorDetail = "", sqlErrorHint = "Could not choose a best candidate function. You might need to add explicit type casts. - -- TODO shouldn't we use sqlType here? - unsafeSqlFunction "ST_union" ((unsafeSqlCastAs "geometry" a), (unsafeSqlCastAs "geometry" b)) + unsafeSqlFunction "ST_union" ((unsafeSqlCastAs casted a), (unsafeSqlCastAs casted b)) + where + casted = (pgType $ Proxy @spatialType) +-- | calculate the distance between two points +-- https://postgis.net/docs/ST_Distance.html +st_distance :: + SqlExpr (Value (Postgis spatialType a)) -> + SqlExpr (Value (Postgis spatialType a)) -> + SqlExpr (Value Double) +st_distance a b = + unsafeSqlFunction "ST_distance" (a, b) + -- | Returns true if two geometries intersect. -- Geometries intersect if they have any point in common. -- https://postgis.net/docs/ST_Intersects.html @@ -300,14 +336,18 @@ SqlExpr (Value Bool) st_intersects a b = unsafeSqlFunction "ST_Intersects" (a, b) -point :: Double -> Double -> (PostgisGeometry PointXY) +point :: Double -> Double -> (Postgis spatialType PointXY) point x y = Point (PointXY {_xyX = x, _xyY = y}) -st_point :: SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value (PostgisGeometry PointXY)) +point_v :: HasPgType spatialType => Double -> Double -> SqlExpr (Value (Postgis spatialType PointXY)) +point_v = fmap val . point + +st_point :: SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value (Postgis spatialType PointXY)) st_point a b = unsafeSqlFunction "ST_POINT" (a, b) -st_point_xyz :: SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value (PostgisGeometry PointXYZ)) +st_point_xyz :: SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value (Postgis spatialType PointXYZ)) st_point_xyz a b c = unsafeSqlFunction "ST_POINT" (a, b, c) -st_point_xyzm :: SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value (PostgisGeometry PointXYZM)) +st_point_xyzm :: SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value (Postgis spatialType PointXYZM)) st_point_xyzm a b c m = unsafeSqlFunction "ST_POINT" (a, b, c, m) + diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -153,14 +153,14 @@ postgisBindingsTests = testGroup "postgis binding tests" - [ testGroup "roundtrip tests xy" $ + [ testGroup "roundtrip_tests_xy" $ (test') <$> (genCollection genPointxy : genGeometry genPointxy), testGroup "roundtrip tests xyz" $ (testxyz) <$> (genCollection genPointxyz : genGeometry genPointxyz), testGroup "roundtrip tests xyzm" $ (testxyzm) <$> (genCollection genPointxyzm : genGeometry genPointxyzm), testGroup "function bindings" $ - [ testCase ("it finds the one unit with st_contains") $ do + [ testCase ("it_finds_the_one_unit_with st_contains") $ do result <- runDB $ do _ <- insert $ @@ -221,9 +221,24 @@ testCase ("see if we can unions in PG and then get out some Haskell") $ do result <- runDB $ do selectOne $ - pure $ st_unions (val (Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)])) $ + pure $ st_unions @'Geometry (val (Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)])) $ val $ Polygon $ makePolygon (PointXY 2 0) (PointXY 2 2) (PointXY 4 2) $ Seq.fromList [(PointXY 4 0)] unValue <$> result @?= (Just $ Polygon $ makeLinearRing (PointXY {_xyX = 0.0, _xyY = 2.0}) (PointXY {_xyX = 2.0, _xyY = 2.0}) (PointXY {_xyX = 4.0, _xyY = 2.0}) (Seq.fromList [PointXY {_xyX = 4.0, _xyY = 0.0}, PointXY {_xyX = 2.0, _xyY = 0.0}, PointXY {_xyX = 0.0, _xyY = 0.0}])), + + testCase ("st_distance@geom can distance PG and then get out some Haskell, doing it wrong with geometry") $ do + result <- runDB $ do + selectOne $ + pure $ st_distance @'Geometry + (point_v (-118.24) 34.05) -- LA + (point_v (-74.00) 40.71) -- NYC + unValue <$> result @?= (Just 44.73849796316367), -- not 44km, but geometry does that + testCase ("st_distance@geography can distance PG and then get out some Haskell, doing it wrong with geometry") $ do + result <- runDB $ do + selectOne $ + pure $ st_distance @'Geography + (point_v (-118.24) 34.05) -- LA + (point_v (-74.00) 40.71) -- NYC + unValue <$> result @?= (Just 3_944_735.82464902), -- correct! (in m) testCase ("see if we can get just the units in the polygons") $ do result <- runDB $ do _ <-