mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-09-21 15:38:40 +03:00
Graphql-engine now accepts crs key to specify the Coordinate Reference System as accepted in GeoJSON 2008 spec. - [x] Server
This commit is contained in:
parent
a9dc756a40
commit
5e619cc479
@ -236,7 +236,13 @@ mkColExtrAl :: (IsIden a) => Maybe a -> (PGCol, PGColType) -> S.Extractor
|
|||||||
mkColExtrAl alM (c, pct) =
|
mkColExtrAl alM (c, pct) =
|
||||||
if pct == PGGeometry || pct == PGGeography
|
if pct == PGGeometry || pct == PGGeography
|
||||||
then S.mkAliasedExtrFromExp
|
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
|
else S.mkAliasedExtr c alM
|
||||||
|
|
||||||
-- validate headers
|
-- validate headers
|
||||||
|
@ -1,6 +1,7 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
module Hasura.SQL.GeoJSON
|
module Hasura.SQL.GeoJSON
|
||||||
( Point(..)
|
( Point(..)
|
||||||
@ -10,16 +11,18 @@ module Hasura.SQL.GeoJSON
|
|||||||
, Polygon(..)
|
, Polygon(..)
|
||||||
, MultiPolygon(..)
|
, MultiPolygon(..)
|
||||||
, GeometryCollection(..)
|
, GeometryCollection(..)
|
||||||
, Geometry(..)
|
, GeometryWithCRS(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.Aeson as J
|
import qualified Data.Aeson as J
|
||||||
import qualified Data.Aeson.Types as J
|
import qualified Data.Aeson.Casing as J
|
||||||
import qualified Data.Text as T
|
import qualified Data.Aeson.TH as J
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Aeson.Types as J
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Vector as V
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Maybe (maybeToList)
|
import Data.Maybe (maybeToList)
|
||||||
import Hasura.Prelude
|
import Hasura.Prelude
|
||||||
|
|
||||||
data Position
|
data Position
|
||||||
@ -81,7 +84,7 @@ newtype MultiLineString
|
|||||||
deriving (Show, Eq, J.ToJSON, J.FromJSON)
|
deriving (Show, Eq, J.ToJSON, J.FromJSON)
|
||||||
|
|
||||||
newtype GeometryCollection
|
newtype GeometryCollection
|
||||||
= GeometryCollection { unGeometryCollection :: [Geometry] }
|
= GeometryCollection { unGeometryCollection :: [GeometryWithCRS] }
|
||||||
deriving (Show, Eq, J.ToJSON, J.FromJSON)
|
deriving (Show, Eq, J.ToJSON, J.FromJSON)
|
||||||
|
|
||||||
data LinearRing
|
data LinearRing
|
||||||
@ -129,27 +132,35 @@ data Geometry
|
|||||||
| GGeometryCollection !GeometryCollection
|
| GGeometryCollection !GeometryCollection
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
encToCoords :: (J.ToJSON a) => T.Text -> a -> J.Value
|
data GeometryWithCRS
|
||||||
encToCoords ty a =
|
= GeometryWithCRS
|
||||||
J.object [ "type" J..= ty, "coordinates" J..= a]
|
{ _gwcGeom :: !Geometry
|
||||||
|
, _gwcCrs :: !(Maybe CRS)
|
||||||
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
instance J.ToJSON Geometry where
|
encToCoords :: (J.ToJSON a) => T.Text -> a -> Maybe CRS -> J.Value
|
||||||
toJSON = \case
|
encToCoords ty a Nothing =
|
||||||
GPoint o -> encToCoords "Point" o
|
J.object [ "type" J..= ty, "coordinates" J..= a]
|
||||||
GMultiPoint o -> encToCoords "MultiPoint" o
|
encToCoords ty a (Just crs) =
|
||||||
GLineString o -> encToCoords "LineString" o
|
J.object [ "type" J..= ty, "coordinates" J..= a, "crs" J..= crs]
|
||||||
GMultiLineString o -> encToCoords "MultiLineString" o
|
|
||||||
GPolygon o -> encToCoords "Polygon" o
|
instance J.ToJSON GeometryWithCRS where
|
||||||
GMultiPolygon o -> encToCoords "MultiPoylgon" o
|
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 ->
|
GGeometryCollection o ->
|
||||||
J.object [ "type" J..= ("GeometryCollection"::T.Text)
|
J.object [ "type" J..= ("GeometryCollection"::T.Text)
|
||||||
, "geometries" J..= o
|
, "geometries" J..= o
|
||||||
]
|
]
|
||||||
|
|
||||||
instance J.FromJSON Geometry where
|
instance J.FromJSON GeometryWithCRS where
|
||||||
parseJSON = J.withObject "Geometry" $ \o -> do
|
parseJSON = J.withObject "Geometry" $ \o -> do
|
||||||
ty <- o J..: "type"
|
ty <- o J..: "type"
|
||||||
case ty of
|
geom <- case ty of
|
||||||
"Point" -> GPoint <$> o J..: "coordinates"
|
"Point" -> GPoint <$> o J..: "coordinates"
|
||||||
"MultiPoint" -> GMultiPoint <$> o J..: "coordinates"
|
"MultiPoint" -> GMultiPoint <$> o J..: "coordinates"
|
||||||
"LineString" -> GLineString <$> o J..: "coordinates"
|
"LineString" -> GLineString <$> o J..: "coordinates"
|
||||||
@ -158,3 +169,29 @@ instance J.FromJSON Geometry where
|
|||||||
"MultiPoylgon" -> GMultiPolygon <$> o J..: "coordinates"
|
"MultiPoylgon" -> GMultiPolygon <$> o J..: "coordinates"
|
||||||
"GeometryCollection" -> GGeometryCollection <$> o J..: "geometries"
|
"GeometryCollection" -> GGeometryCollection <$> o J..: "geometries"
|
||||||
_ -> fail $ "unexpected geometry type: " <> ty
|
_ -> 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)
|
||||||
|
@ -44,7 +44,7 @@ data PGColValue
|
|||||||
| PGNull !PGColType
|
| PGNull !PGColType
|
||||||
| PGValJSON !Q.JSON
|
| PGValJSON !Q.JSON
|
||||||
| PGValJSONB !Q.JSONB
|
| PGValJSONB !Q.JSONB
|
||||||
| PGValGeo !Geometry
|
| PGValGeo !GeometryWithCRS
|
||||||
| PGValUnknown !T.Text
|
| PGValUnknown !T.Text
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user