diff --git a/server/src-lib/Hasura/RQL/DML/Internal.hs b/server/src-lib/Hasura/RQL/DML/Internal.hs index 74a39677..136786de 100644 --- a/server/src-lib/Hasura/RQL/DML/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Internal.hs @@ -236,7 +236,13 @@ mkColExtrAl :: (IsIden a) => Maybe a -> (PGCol, PGColType) -> S.Extractor mkColExtrAl alM (c, pct) = if pct == PGGeometry || pct == PGGeography then S.mkAliasedExtrFromExp - (S.SEFnApp "ST_AsGeoJSON" [S.mkSIdenExp c] Nothing `S.SETyAnn` S.jsonType) alM + ( S.SEFnApp "ST_AsGeoJSON" + [ S.mkSIdenExp c + , S.SEUnsafe "15" -- max decimal digits + , S.SEUnsafe "4" -- to print out crs + ] Nothing + `S.SETyAnn` S.jsonType + ) alM else S.mkAliasedExtr c alM -- validate headers diff --git a/server/src-lib/Hasura/SQL/GeoJSON.hs b/server/src-lib/Hasura/SQL/GeoJSON.hs index a774ebe1..39da6b50 100644 --- a/server/src-lib/Hasura/SQL/GeoJSON.hs +++ b/server/src-lib/Hasura/SQL/GeoJSON.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Hasura.SQL.GeoJSON ( Point(..) @@ -10,16 +11,18 @@ module Hasura.SQL.GeoJSON , Polygon(..) , MultiPolygon(..) , GeometryCollection(..) - , Geometry(..) + , GeometryWithCRS(..) ) where -import qualified Data.Aeson as J -import qualified Data.Aeson.Types as J -import qualified Data.Text as T -import qualified Data.Vector as V +import qualified Data.Aeson as J +import qualified Data.Aeson.Casing as J +import qualified Data.Aeson.TH as J +import qualified Data.Aeson.Types as J +import qualified Data.Text as T +import qualified Data.Vector as V import Control.Monad -import Data.Maybe (maybeToList) +import Data.Maybe (maybeToList) import Hasura.Prelude data Position @@ -81,7 +84,7 @@ newtype MultiLineString deriving (Show, Eq, J.ToJSON, J.FromJSON) newtype GeometryCollection - = GeometryCollection { unGeometryCollection :: [Geometry] } + = GeometryCollection { unGeometryCollection :: [GeometryWithCRS] } deriving (Show, Eq, J.ToJSON, J.FromJSON) data LinearRing @@ -129,27 +132,35 @@ data Geometry | GGeometryCollection !GeometryCollection deriving (Show, Eq) -encToCoords :: (J.ToJSON a) => T.Text -> a -> J.Value -encToCoords ty a = - J.object [ "type" J..= ty, "coordinates" J..= a] +data GeometryWithCRS + = GeometryWithCRS + { _gwcGeom :: !Geometry + , _gwcCrs :: !(Maybe CRS) + } deriving (Show, Eq) -instance J.ToJSON Geometry where - toJSON = \case - GPoint o -> encToCoords "Point" o - GMultiPoint o -> encToCoords "MultiPoint" o - GLineString o -> encToCoords "LineString" o - GMultiLineString o -> encToCoords "MultiLineString" o - GPolygon o -> encToCoords "Polygon" o - GMultiPolygon o -> encToCoords "MultiPoylgon" o +encToCoords :: (J.ToJSON a) => T.Text -> a -> Maybe CRS -> J.Value +encToCoords ty a Nothing = + J.object [ "type" J..= ty, "coordinates" J..= a] +encToCoords ty a (Just crs) = + J.object [ "type" J..= ty, "coordinates" J..= a, "crs" J..= crs] + +instance J.ToJSON GeometryWithCRS where + toJSON (GeometryWithCRS geom crsM) = case geom of + GPoint o -> encToCoords "Point" o crsM + GMultiPoint o -> encToCoords "MultiPoint" o crsM + GLineString o -> encToCoords "LineString" o crsM + GMultiLineString o -> encToCoords "MultiLineString" o crsM + GPolygon o -> encToCoords "Polygon" o crsM + GMultiPolygon o -> encToCoords "MultiPoylgon" o crsM GGeometryCollection o -> J.object [ "type" J..= ("GeometryCollection"::T.Text) , "geometries" J..= o ] -instance J.FromJSON Geometry where +instance J.FromJSON GeometryWithCRS where parseJSON = J.withObject "Geometry" $ \o -> do ty <- o J..: "type" - case ty of + geom <- case ty of "Point" -> GPoint <$> o J..: "coordinates" "MultiPoint" -> GMultiPoint <$> o J..: "coordinates" "LineString" -> GLineString <$> o J..: "coordinates" @@ -158,3 +169,29 @@ instance J.FromJSON Geometry where "MultiPoylgon" -> GMultiPolygon <$> o J..: "coordinates" "GeometryCollection" -> GGeometryCollection <$> o J..: "geometries" _ -> fail $ "unexpected geometry type: " <> ty + crsM <- o J..:? "crs" + return $ GeometryWithCRS geom crsM + +data CRSNameProps + = CRSNameProps + { _cnpName :: !Text + } deriving (Show, Eq) + +data CRSLinkProps + = CRSLinkProps + { _clpHref :: !Text + , _clpType :: !(Maybe Text) + } deriving (Show, Eq) + +data CRS + = CRSName !CRSNameProps + | CRSLink !CRSLinkProps + deriving (Show, Eq) + +$(J.deriveJSON (J.aesonDrop 4 J.camelCase) ''CRSNameProps) +$(J.deriveJSON (J.aesonDrop 4 J.camelCase) ''CRSLinkProps) +$(J.deriveJSON + J.defaultOptions { J.constructorTagModifier = J.camelCase . drop 3 + , J.sumEncoding = J.TaggedObject "type" "properties" + } + ''CRS) diff --git a/server/src-lib/Hasura/SQL/Value.hs b/server/src-lib/Hasura/SQL/Value.hs index 054a43ad..64a04302 100644 --- a/server/src-lib/Hasura/SQL/Value.hs +++ b/server/src-lib/Hasura/SQL/Value.hs @@ -44,7 +44,7 @@ data PGColValue | PGNull !PGColType | PGValJSON !Q.JSON | PGValJSONB !Q.JSONB - | PGValGeo !Geometry + | PGValGeo !GeometryWithCRS | PGValUnknown !T.Text deriving (Show, Eq)