diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,5 +1,14 @@ # Change log for esqueleto-postgis project +## Version 4.0.0 +Hotfix! + ++ `st_union` can't work on geography, banned that. ++ `st_intersects` was to strict and worked only on geography ++ add `st_transform_geometry` and `st_transform_geography` to convert between the two. ++ hopefully I've explained the srid system somewhat understandable, it's kinda confusing. ++ restrict `st_contains` to geometry as well . + ## 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: 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: 3.0.0 +version: 4.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 @@ -8,6 +8,13 @@ -- | Haskell bindings for postgres postgis -- for a good explenation see +-- +-- Make sure to use the correct 'SpatialType'. +-- Earth spanning applications should use Geography, +-- local applications should use 'Geometry' because it's more convenient. +-- +-- if you can't use a function for example when you're using 'Geography'. +-- there is the option to 'st_transform_geography'. module Database.Esqueleto.Postgis ( Postgis(..), @@ -28,10 +35,22 @@ st_point, st_point_xyz, st_point_xyzm, - -- * other + -- * transform + st_transform_geography, + st_transform_geometry, + -- ** srid + SRID, + wgs84, + mercator , + britishNationalGrid, + SridUnit (..), + + + -- * other makePolygon, PostgisGeometry, + HasPgType, -- * re-exports PointXY(..), @@ -88,10 +107,14 @@ tshow = pack . show --- | Spatial Reference System. +-- | Guarantees we don't accidently mix curved space with flat space. +-- Postgis will catch this too, this just put's it in the type system. data SpatialType = Geometry -- ^ assume a flat space. | Geography -- ^ assume curvature of the earth. +-- | technical typeclass to bind a spatial type to a string value. +-- because we represent the constructors as a datakind, we need +-- this to go back to a value. class HasPgType (spatialType :: SpatialType) where pgType :: Proxy spatialType -> Text @@ -267,9 +290,9 @@ -- https://postgis.net/docs/ST_Contains.html st_contains :: -- | geom a - SqlExpr (Value (Postgis spatialType a)) -> + SqlExpr (Value (Postgis 'Geometry a)) -> -- | geom b - SqlExpr (Value (Postgis spatialType a)) -> + SqlExpr (Value (Postgis 'Geometry a)) -> SqlExpr (Value Bool) st_contains a b = unsafeSqlFunction "ST_CONTAINS" (a, b) @@ -285,6 +308,66 @@ SqlExpr (Value Bool) st_dwithin a b c = unsafeSqlFunction "ST_DWithin" (a, b, c) +-- | SRID +-- you can find your local like this: https://blog.rustprooflabs.com/2020/11/postgis-find-local-srid +-- geography appears to use 'wgs84'. So I hardcoded the use going from geom to geography as that. +-- +-- you can use the num instance to put in whatever. +-- however, if you miss a srid please submit a PR. +newtype SRID (unit :: SridUnit) = SRID Int + deriving newtype (Num, PersistField) + +-- | default for geography type in postgis. +-- Geodetic CRS: WGS 84 +-- https://epsg.io/4326 +wgs84 :: SRID 'Degree +wgs84 = 4326 + +-- | most maps are in this, it has some large distortions further away from equator +-- https://epsg.io/3857 +mercator :: SRID 'Linear +mercator = 3857 + +-- | if you're in england this is pretty good. +-- https://epsg.io/27700 +britishNationalGrid :: SRID 'Linear +britishNationalGrid = 27700 + + +-- | Diferent 'SRID' come in different units, +-- important for converting from geograhy to geometry. +data SridUnit = Linear -- ^ meters or feet + | Degree -- ^ spheroids + +-- | Project a geography onto a geometry. +-- allows using of functions such as 'st_union' which only work in flat space (geometry). +-- https://postgis.net/docs/ST_Transform.html +st_transform_geography :: forall a. SRID 'Linear -> + SqlExpr (Value (Postgis 'Geography a)) -> -- ^ g1 (library handles the conversion) + SqlExpr (Value (Postgis 'Geometry a)) +st_transform_geography srid geography = + unsafeSqlFunction "ST_Transform" (casted, val srid) + where + casted :: SqlExpr (Value (Postgis 'Geometry a)) + casted = unsafe_cast_pg_type geography + +-- | project a geometry as a geography, assumes 'wgs84'. +-- https://postgis.net/docs/ST_Transform.html +st_transform_geometry :: SqlExpr (Value (Postgis 'Geometry a)) -> -- ^ g1 (library handles the conversion) + SqlExpr (Value (Postgis 'Geography a)) +st_transform_geometry input = unsafe_cast_pg_type transformed + where + transformed :: SqlExpr (Value (Postgis 'Geometry a)) + transformed = + unsafeSqlFunction "ST_Transform" (input, val wgs84) + +-- postgis doesn't appear to care about casting between spaces, +-- the user probably wants to use st_transform instead. +unsafe_cast_pg_type :: forall two one a . HasPgType two => SqlExpr (Value (Postgis one a)) -> SqlExpr (Value (Postgis two a)) +unsafe_cast_pg_type = unsafeSqlCastAs castAs + where + castAs = pgType $ Proxy @two + -- | allows union of geometries, eg group a bunch together, -- https://postgis.net/docs/ST_Union.html -- for example: @@ -302,21 +385,20 @@ -- pure unit -- @ st_union :: - SqlExpr (Value (Postgis spatialType a)) -> - SqlExpr (Value (Postgis spatialType a)) + SqlExpr (Value (Postgis 'Geometry a)) -> + SqlExpr (Value (Postgis 'Geometry a)) st_union a = unsafeSqlFunction "ST_union" a st_unions :: - forall spatialType a . HasPgType spatialType => - SqlExpr (Value (Postgis spatialType a)) -> - SqlExpr (Value (Postgis spatialType a)) -> - SqlExpr (Value (Postgis spatialType a)) + SqlExpr (Value (Postgis 'Geometry a)) -> + SqlExpr (Value (Postgis 'Geometry a)) -> + SqlExpr (Value (Postgis 'Geometry 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. unsafeSqlFunction "ST_union" ((unsafeSqlCastAs casted a), (unsafeSqlCastAs casted b)) where - casted = (pgType $ Proxy @spatialType) + casted = (pgType $ Proxy @'Geometry) -- | calculate the distance between two points -- https://postgis.net/docs/ST_Distance.html @@ -331,8 +413,8 @@ -- Geometries intersect if they have any point in common. -- https://postgis.net/docs/ST_Intersects.html st_intersects :: - SqlExpr (Value (PostgisGeometry a)) -> - SqlExpr (Value (PostgisGeometry a)) -> + SqlExpr (Value (Postgis spatialType a)) -> -- ^ geomA or geogA + SqlExpr (Value (Postgis spatialType a)) -> -- ^ geomB or geogB SqlExpr (Value Bool) st_intersects a b = unsafeSqlFunction "ST_Intersects" (a, b) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -71,6 +71,10 @@ geom (PostgisGeometry PointXY) label Text + GeoGrid + geo (Postgis 'Geography PointXY) + label Text + Unit sql=unit geom (PostgisGeometry PointXY) deriving Eq Show @@ -218,10 +222,30 @@ grid <- from $ table @Grid pure $ st_union $ grid ^. GridGeom 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 ("union_in_PG_and then get out some Haskell") $ do + result <- runDB $ do + _ <- + insert $ + GeoGrid + { geoGridGeo = Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)], + geoGridLabel = "x" + } + _ <- + insert $ + GeoGrid + { geoGridGeo = Polygon $ makePolygon (PointXY 2 0) (PointXY 2 2) (PointXY 4 2) $ Seq.fromList [(PointXY 4 0)], + geoGridLabel = "y" + } + + selectOne $ do + grid <- from $ table @GeoGrid + pure $ st_transform_geometry $ st_union $ st_transform_geography mercator $ grid ^. GeoGridGeo + -- as degrees it doesn't appear to be merging them. + unValue <$> result @?= (Just (Polygon (makeLinearRing (PointXY {_xyX = 1.9999999999999996, _xyY = 1.9999999999999996}) (PointXY {_xyX = 3.999999999999999, _xyY = 1.9999999999999996}) (PointXY {_xyX = 3.999999999999999, _xyY = 0.0}) (Seq.fromList [PointXY {_xyX = 1.9999999999999996, _xyY = 0.0},PointXY {_xyX = 0.0, _xyY = 0.0},PointXY {_xyX = 0.0, _xyY = 1.9999999999999996}])))), testCase ("see if we can unions in PG and then get out some Haskell") $ do result <- runDB $ do selectOne $ - pure $ st_unions @'Geometry (val (Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)])) $ + pure $ st_unions (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}])),