esqueleto-postgis 2.2.0 → 3.0.0

raw patch · 4 files changed

+147/−54 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Changelog.md +38/−0
• esqueleto-postgis.cabal +1/−1
• src/Database/Esqueleto/Postgis.hs +90/−50
• test/Test.hs +18/−3

@@ -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 

@@ -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

@@ -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 <https://postgis.net/> 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)+

@@ -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               _ <-