esqueleto-postgis 1.0.1 → 1.1.0

raw patch · 5 files changed

+190/−37 lines, 5 filesdep ~basedep ~containersdep ~esqueletoPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, containers, esqueleto, persistent

API changes (from Hackage documentation)

Files

• Changelog.md +6/−0
• Readme.md +15/−1
• esqueleto-postgis.cabal +5/−5
• src/Database/Esqueleto/Postgis.hs +69/−16
• test/Test.hs +95/−15

@@ -1,5 +1,11 @@ # Change log for esqueleto-postgis project +## Version 1.1.0 ++ Add st_union++ add getPoitns to escape the postgis geometry more easily.++ bump bounds++ ## Version 1.0.1  + fix insane bounds by cabal genbounds.    I think this was caused due to running it from the flake which

@@ -1,5 +1,5 @@ [![https://jappieklooster.nl](https://img.shields.io/badge/blog-jappieklooster.nl-lightgrey)](https://jappieklooster.nl/tag/haskell.html)-[![Githbu actions build status](https://img.shields.io/github/workflow/status/jappeace/haskell-template-project/Test)](https://github.com/jappeace/haskell-template-project/actions)+[![Githbu actions build status](https://img.shields.io/github/workflow/status/jappeace/esqueleto-postgis/Test)](https://github.com/jappeace/esqueleto-postgis/actions) [![Jappiejappie](https://img.shields.io/badge/discord-jappiejappie-black?logo=discord)](https://discord.gg/Hp4agqy) [![Hackage version](https://img.shields.io/hackage/v/esqueleto-postgis.svg?label=Hackage)](https://hackage.haskell.org/package/esqueleto-postgis)  @@ -15,6 +15,20 @@ Then the esqueleto combinators are defined around this datatype.  # Tutorial++most linux distributions support this out of the box.+nixos needs some special care:+```nix+services.postgresql = {+   enable = true;+   package = (pkgs.postgresql_12.withPackages (p: [ p.postgis ]));+};+```+For mac you've to [install](https://postgis.net/documentation/getting_started/install_macos/) postgis.+```sh+brew install postgis+```+ Make sure to enable to postgis extension on your database (it's activated per database): ```sql CREATE EXTENSION postgis;

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           esqueleto-postgis-version:        1.0.1+version:        1.1.0 homepage:       https://github.com/jappeace/esqueleto-postgis#readme bug-reports:    https://github.com/jappeace/esqueleto-postgis/issues author:         Jappie Klooster@@ -59,11 +59,11 @@     -fno-omit-yields    build-depends:-      base >=4.9.1.0 && <4.20.0.0,-      containers >= 0.6.5 && < 0.8,-      esqueleto >= 3.5.10 && < 3.6,+      base >=4.9.1.0 && <4.23.0.0,+      containers >= 0.6.5 && < 0.9,+      esqueleto >= 3.5.10 && < 3.7,       text >= 1.2.5 && < 2.2,-      persistent >= 2.13.3 && < 2.15,+      persistent >= 2.13.3 && < 2.19,       geojson >= 4.1.1 && < 4.2,       wkt-geom >= 0.0.12 && < 0.1, 

@@ -7,12 +7,15 @@ module Database.Esqueleto.Postgis   ( PostgisGeometry (..),     makePolygon,+    getPoints,      -- * functions     st_contains,     st_intersects,+    st_union,      -- * points+    point,     st_point,     st_point_xyz,     st_point_xyzm,@@ -22,14 +25,15 @@ import Data.Bifunctor (first) import Data.Ewkb (parseHexByteString) import Data.Foldable (Foldable (toList), fold)-import Data.Geospatial (GeoPoint (..), GeoPositionWithoutCRS (..), GeospatialGeometry, PointXY (..), PointXYZ, PointXYZM)+import Data.Geospatial (GeoPoint (..), GeoPositionWithoutCRS (..), GeospatialGeometry, PointXY (..), PointXYZ (..), PointXYZM (..)) import Data.Geospatial qualified as Geospatial import Data.Hex (Hex (..))-import Data.LineString (LineString)-import Data.LinearRing (LinearRing, makeLinearRing, toSeq)+import Data.LineString (LineString, fromLineString, lineStringHead)+import Data.LinearRing (LinearRing, fromLinearRing, makeLinearRing, ringHead, toSeq) import Data.List qualified as List-import Data.List.NonEmpty (nonEmpty)+import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.List.NonEmpty qualified as Non+import Data.Semigroup qualified as S import Data.Sequence (Seq (..), (|>)) import Data.Sequence qualified as Seq import Data.String (IsString (..))@@ -40,11 +44,25 @@ import Database.Esqueleto.Experimental (SqlExpr, Value) import Database.Esqueleto.Internal.Internal (unsafeSqlFunction) import Database.Persist.Sql-import GHC.Base (NonEmpty)-import Data.Geospatial (PointXYZM(..))-import Data.Geospatial (PointXYZ(..)) -tshow :: Show a => a -> Text+-- | unwrap postgis geometry so you can for example return it from an API+getPoints :: PostgisGeometry point -> NonEmpty point+getPoints geom = case geom of+  Point p -> p :| []+  MultiPoint pts -> pts+  Line ls -> linestringNonEmpty ls+  Multiline lss -> S.sconcat (fmap linestringNonEmpty lss)+  Polygon ring -> linearRingNonEmpty ring+  MultiPolygon rings -> S.sconcat (fmap linearRingNonEmpty rings)+  Collection geoms -> S.sconcat (fmap getPoints geoms)++linestringNonEmpty :: LineString a -> NonEmpty a+linestringNonEmpty ls = lineStringHead ls :| drop 1 (fromLineString ls)++linearRingNonEmpty :: LinearRing a -> NonEmpty a+linearRingNonEmpty ls = ringHead ls :| drop 1 (fromLinearRing ls)++tshow :: (Show a) => a -> Text tshow = pack . show  -- | like 'GeospatialGeometry' but not partial, eg no empty geometries, also only works@@ -108,32 +126,39 @@ renderPair :: PointXY -> Text.Builder renderPair (PointXY {..}) = fromString (show _xyX) <> " " <> fromString (show _xyY) - renderXYZ :: PointXYZ -> Text.Builder renderXYZ (PointXYZ {..}) = fromString (show _xyzX) <> " " <> fromString (show _xyzY) <> " " <> fromString (show _xyzZ) - 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-  Point point -> "POINT(" <> point <> ")"+  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)) <> ")"+  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)) <> ")" -renderLines :: Foldable f => f Text.Builder -> Text.Builder+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 interpreter = \case   Geospatial.NoGeometry -> Left NoGeometry-  Geospatial.Point (GeoPoint point) -> (Point <$> interpreter point)+  Geospatial.Point (GeoPoint point') -> (Point <$> interpreter point')   Geospatial.MultiPoint (Geospatial.GeoMultiPoint points) -> do     list' <- sequence $ toList (interpreter <$> points)     case nonEmpty list' of@@ -157,7 +182,6 @@       Just nonEmpty' -> Right $ Collection nonEmpty'       Nothing -> Left EmptyCollection - toLinearRing :: (Eq a, Show a) => (GeoPositionWithoutCRS -> Either GeomErrors a) -> Seq (LinearRing GeoPositionWithoutCRS) -> Either GeomErrors (LinearRing a) toLinearRing interpreter polygon = do   aSeq <- traverse interpreter (foldMap toSeq polygon)@@ -165,6 +189,13 @@     (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   toPersistValue geom =     PersistText $ toStrict $ toLazyText $ renderGeometry $ renderPair <$> geom@@ -208,6 +239,25 @@   SqlExpr (Value Bool) st_contains a b = unsafeSqlFunction "ST_CONTAINS" (a, b) +-- | allows union of geometries, eg group a bunch together, for example:+--+-- @+--  mCombined <- selectOne $ do+--    grid <- from $ table @Grid+--    pure $ st_union $ grid ^. GridGeom+--+--+--  select $  do+--    unit <- from $ table @Unit+--    forM_ mCombined $ \combined ->+--      where_ $ (unit ^. UnitGeom) `st_intersects` (val $ unValue combined)+--    pure unit+-- @+st_union ::+  SqlExpr (Value (PostgisGeometry a)) ->+  SqlExpr (Value (PostgisGeometry a))+st_union a = unsafeSqlFunction "ST_union" a+ -- | Returns true if two geometries intersect. --   Geometries intersect if they have any point in common. --   https://postgis.net/docs/ST_Intersects.html@@ -216,6 +266,9 @@   SqlExpr (Value (PostgisGeometry a)) ->   SqlExpr (Value Bool) st_intersects a b = unsafeSqlFunction "ST_Intersects" (a, b)++point :: Double -> Double -> (PostgisGeometry PointXY)+point x y = Point (PointXY {_xyX = x, _xyY = y})  st_point :: SqlExpr (Value Double) -> SqlExpr (Value Double) -> SqlExpr (Value (PostgisGeometry PointXY)) st_point a b = unsafeSqlFunction "ST_POINT" (a, b)

@@ -17,15 +17,17 @@  module Main where +import Control.Monad (forM_) import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger (..), runStderrLoggingT) import Control.Monad.Trans.Resource (MonadThrow, ResourceT, runResourceT) import Data.Geospatial (PointXY (..), PointXYZ (..), PointXYZM (..)) import Data.LineString (LineString, makeLineString)-import Data.LinearRing (LinearRing)+import Data.LinearRing (LinearRing, makeLinearRing) import Data.List.NonEmpty (NonEmpty) import Data.Sequence (Seq) import qualified Data.Sequence as Seq+import Data.Text import Database.Esqueleto.Experimental import Database.Esqueleto.Postgis import Database.Persist@@ -53,6 +55,10 @@ share   [mkPersist sqlSettings, mkMigrate "migrateAll"]   [persistUpperCase|+  Grid+    geom (PostgisGeometry PointXY)+    label Text+   Unit sql=unit     geom       (PostgisGeometry PointXY)     deriving Eq Show@@ -100,7 +106,7 @@   testCase "roundtrip xyz geometry" $ do     someUnit <- Gen.sample (Unityz <$> gen)     result <- runDB $ do-      _ <-  insert someUnit+      _ <- insert someUnit       selectList @(Unityz) [] []     (entityVal <$> result) @?= [someUnit] @@ -126,10 +132,11 @@       testGroup "function bindings" $         [ testCase ("it finds the one unit with st_contains") $ do             result <- runDB $ do-              _ <- insert $-                Unit-                  { unitGeom = Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)]-                  }+              _ <-+                insert $+                  Unit+                    { unitGeom = Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)]+                    }                selectOne $ do                 unit <- from $ table @Unit@@ -138,10 +145,11 @@             unValue <$> result @?= (Just (1 :: Int)),           testCase ("it finds the one unit with intersection st_point") $ do             result <- runDB $ do-              _ <- insert $-                Unit-                  { unitGeom = Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)]-                  }+              _ <-+                insert $+                  Unit+                    { unitGeom = Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)]+                    }                selectOne $ do                 unit <- from $ table @Unit@@ -150,16 +158,88 @@             unValue <$> result @?= (Just (1 :: Int)),           testCase ("it finds the one unit with intersection st_intersects") $ do             result <- runDB $ do-              _ <- insert $-                Unit-                  { unitGeom = Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)]-                  }+              _ <-+                insert $+                  Unit+                    { unitGeom = Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)]+                    }                selectOne $ do                 unit <- from $ table @Unit                 where_ $ unit ^. UnitGeom `st_intersects` (st_point (val 1) (val 1))                 pure countRows-            unValue <$> result @?= (Just (1 :: Int))+            unValue <$> result @?= (Just (1 :: Int)),+          testCase ("see if we can union in PG and then get out some Haskell") $ do+            result <- runDB $ do+              _ <-+                insert $+                  Grid+                    { gridGeom = Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)],+                      gridLabel = "x"+                    }+              _ <-+                insert $+                  Grid+                    { gridGeom = Polygon $ makePolygon (PointXY 2 0) (PointXY 2 2) (PointXY 4 2) $ Seq.fromList [(PointXY 4 0)],+                      gridLabel = "y"+                    }++              selectOne $ do+                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 ("see if we can get just the units in the polygons") $ do+            result <- runDB $ do+              _ <-+                insert $+                  Grid+                    { gridGeom = Polygon $ makePolygon (PointXY 0 0) (PointXY 0 2) (PointXY 2 2) $ Seq.fromList [(PointXY 2 0)],+                      gridLabel = "x"+                    }+              _ <-+                insert $+                  Grid+                    { gridGeom = Polygon $ makePolygon (PointXY 2 0) (PointXY 2 2) (PointXY 4 2) $ Seq.fromList [(PointXY 4 0)],+                      gridLabel = "y"+                    }+              _ <-+                insert $+                  Unit+                    { unitGeom = point 1 1+                    }+              _ <-+                insert $+                  Unit+                    { unitGeom = point 1 2+                    }++              _ <-+                insert $+                  Unit+                    { unitGeom = point 2 2+                    }+              _ <-+                insert $+                  Unit+                    { unitGeom = point 9 9+                    }+              _ <-+                insert $+                  Unit+                    { unitGeom = point 10 10+                    }++              mCombined <- selectOne $ do+                grid <- from $ table @Grid+                pure $ st_union $ grid ^. GridGeom++              select $ do+                unit <- from $ table @Unit+                forM_ mCombined $ \combined ->+                  where_ $ (unit ^. UnitGeom) `st_intersects` (val $ unValue combined)+                pure unit++            entityVal <$> result @?= [Unit {unitGeom = Point (PointXY {_xyX = 1.0, _xyY = 1.0})}, Unit {unitGeom = Point (PointXY {_xyX = 1.0, _xyY = 2.0})}, Unit {unitGeom = Point (PointXY {_xyX = 2.0, _xyY = 2.0})}]         ]     ]