diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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 diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -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; 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: 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, 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 @@ -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) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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})}] ] ]