haskell-postgis 0.1.0.2 → 0.2.0

raw patch · 6 files changed

+87/−63 lines, 6 filesdep +eitherPVP ok

version bump matches the API change (PVP)

Dependencies added: either

API changes (from Hackage documentation)

Files

• haskell-postgis.cabal +2/−1
• src/Database/Postgis.hs +1/−0
• src/Database/Postgis/Geometry.hs +15/−12
• src/Database/Postgis/JSON.hs +42/−30
• src/Database/Postgis/Serialize.hs +25/−18
• tests/GeoSpec.hs +2/−2

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                haskell-postgis-version:             0.1.0.2+version:             0.2.0 synopsis:            A haskell library for PostGIS geometry types. description:         A collection of types and parsers to use with the PostGIS extesion to PostgreSQL. license:             MIT@@ -32,6 +32,7 @@       , placeholders        , aeson         , unordered-containers+      , either   hs-source-dirs: src        default-language:    Haskell2010   exposed-modules: 

@@ -8,6 +8,7 @@   ) where import Database.Postgis.Geometry (           SRID,+          Position(..),           Point(..),           LineString(..),           LinearRing,

@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs, TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}  module Database.Postgis.Geometry where @@ -7,6 +8,7 @@ import Data.Word import Data.Data import Data.Typeable+import Data.Maybe  {-Linear rings—Rings are simple and closed, which means that linear rings may not self intersect.-} @@ -22,26 +24,27 @@   hasZ :: a -> Bool   geoType :: a -> Word32  --data Point = Point  {+data Position = Position {     _x :: Double   , _y :: Double   , _z :: Maybe Double   , _m :: Maybe Double } deriving (Data, Typeable, Show, Eq) -instance EWKBGeometry Point where-  hasM (Point x y z m) = m /= Nothing -  hasZ (Point x y z m) = z /= Nothing +newtype Point = Point Position deriving (Data, Typeable, Show, Eq, EWKBGeometry)++instance EWKBGeometry Position where+  hasM (Position x y z m) = isJust m+  hasZ (Position x y z m) = isJust z   geoType _ = 1 -type LinearRing = V.Vector Point+type LinearRing = V.Vector Position -isClosed :: V.Vector Point -> Bool+isClosed :: V.Vector Position -> Bool isClosed v = V.head v == V.last v  -data LineString = LineString (V.Vector Point) deriving (Data, Typeable, Show, Eq)+newtype LineString = LineString (V.Vector Position) deriving (Data, Typeable, Show, Eq)   instance EWKBGeometry LineString where@@ -49,7 +52,7 @@   hasZ (LineString ps) = hasZ . V.head $ ps   geoType _ = 2 -data Polygon = Polygon (V.Vector LinearRing) deriving (Data, Typeable, Show, Eq)+newtype Polygon = Polygon (V.Vector LinearRing) deriving (Data, Typeable, Show, Eq)  hasMLinearRing :: LinearRing -> Bool hasMLinearRing = hasM . V.head @@ -62,21 +65,21 @@   hasZ (Polygon ps) = hasZLinearRing . V.head $ ps   geoType _ = 3 -data MultiPoint = MultiPoint (V.Vector Point) deriving (Data, Typeable, Show, Eq)+newtype MultiPoint = MultiPoint (V.Vector Position) deriving (Data, Typeable, Show, Eq)  instance EWKBGeometry MultiPoint where   hasM (MultiPoint ps) = hasM . V.head $ ps   hasZ (MultiPoint ps) = hasZ . V.head $ ps   geoType _ = 4 -data MultiLineString = MultiLineString (V.Vector LineString) deriving (Data, Typeable, Show, Eq)+newtype MultiLineString = MultiLineString (V.Vector LineString) deriving (Data, Typeable, Show, Eq)  instance EWKBGeometry MultiLineString where   hasM (MultiLineString ps) = hasM . V.head $ ps   hasZ (MultiLineString ps) = hasZ . V.head $ ps   geoType _ = 5 -data MultiPolygon = MultiPolygon (V.Vector Polygon) deriving (Data, Typeable, Show, Eq)+newtype MultiPolygon = MultiPolygon (V.Vector Polygon) deriving (Data, Typeable, Show, Eq)  instance EWKBGeometry MultiPolygon where   hasM (MultiPolygon ps) = hasM . V.head $ ps

@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -19,23 +18,36 @@ import Data.Vector ((!), (!?)) import qualified Data.HashMap.Lazy as HM import Data.Text.Read (decimal)+import Data.Either.Combinators (rightToMaybe) +instance ToJSON Position where+  toJSON (Position x y m z) = toJSON $ catMaybes [Just x, Just y, m, z] +instance FromJSON Position where+  parseJSON = withArray "Position" $ \v' -> do+    v <- mapM parseJSON v'+    return $ Position (v ! 0) (v ! 1) (v !? 2) (v !? 3)+ instance ToJSON Point where-  toJSON (Point x y m z) = toJSON $ catMaybes [Just x, Just y, m, z]+  toJSON (Point position) = object+    [ "type" .= ("Point" :: T.Text)+    , "coordinates" .= toJSON position+    ]  instance FromJSON Point where-  parseJSON = withArray "Point" $ \v' -> do-    v <- sequence $ fmap parseJSON v'-    return $ Point (v ! 0) (v ! 1) (v !? 2) (v !? 3)+  parseJSON = withObject "Point" $ \o -> do+    ("Point" :: T.Text) <- o .: "type"+    cs <- o .: "coordinates"+    pos <- parseJSON cs+    return $ Point pos  instance FromJSON LineString where   parseJSON = withObject "LineString" $ \o -> do     ("LineString" :: T.Text) <- o .: "type"     cs <- o .: "coordinates"-    vs <- sequence $ fmap parseJSON cs-    return $ LineString vs -    +    vs <- mapM parseJSON cs+    return $ LineString vs+ instance ToJSON LineString where   toJSON (LineString points) = object ["type" .= ("LineString" :: T.Text), "coordinates" .=  V.map toJSON points] @@ -48,7 +60,7 @@   parseJSON = withObject "Polygon" $ \o -> do     ("Polygon" :: T.Text) <- o .: "type"     ls <- o .: "coordinates"-    cs <- sequence $ fmap parseJSON ls+    cs <- mapM parseJSON ls     return $ Polygon cs  ---@@ -59,7 +71,7 @@   parseJSON = withObject "MultiPoint" $ \o -> do     ("MultiPoint" :: T.Text) <- o .: "type"     ls <- o .: "coordinates"-    cs <- sequence $ fmap parseJSON ls+    cs <- mapM parseJSON ls     return $ MultiPoint cs  instance ToJSON MultiLineString where@@ -69,7 +81,7 @@   parseJSON = withObject "MultiLineString" $ \o -> do     ("MultiLineString" :: T.Text) <- o .: "type"     ls <- o .: "coordinates"-    cs <- sequence $ fmap parseJSON ls+    cs <- mapM parseJSON ls     return $ MultiLineString cs  instance ToJSON MultiPolygon where@@ -79,17 +91,17 @@   parseJSON = withObject "MultiPolygon" $ \o -> do     ("MultiPolygon" :: T.Text) <- o .: "type"     ls <- o .: "coordinates"-    cs <- sequence $ fmap parseJSON ls+    cs <- mapM parseJSON ls     return $ MultiPolygon cs  addKeyToValue :: Value -> T.Text -> Value -> Maybe Value addKeyToValue (Object hm) k v = Just . Object $ HM.insert k v hm addKeyToValue _ _ _ = Nothing-  + go :: ToJSON a => SRID -> a -> Value-go (Just s) x = -    let v = toJSON x -    in maybe v id $ addKeyToValue v "crs" $ sridToJson s+go (Just s) x =+    let v = toJSON x+    in fromMaybe v $ addKeyToValue v "crs" $ sridToJson s go Nothing x = toJSON x  instance ToJSON Geometry where@@ -100,24 +112,24 @@   toJSON (GeoMultiLineString s x) =  go s x   toJSON (GeoMultiPolygon s x) =  go s x -sridToJson srid = -  object ["type" .= ("name" :: T.Text), "properties" .= object ["name" .= ("ESPG:" <> (show srid)  :: String)] ]+sridToJson srid =+  object ["type" .= ("name" :: T.Text), "properties" .= object ["name" .= ("ESPG:" <> show srid  :: String)] ]   parseCRS :: Value -> Parser (Maybe Int)-parseCRS = withObject "crs" $ \o ->  do-  crs <- o .: "crs" -  ("name"::T.Text) <- crs .: "type"-  prop <- crs .: "properties"-  espg <-  prop .: "name"-  let (x:y:xs) = T.split ((==) ':') espg-  case decimal y of-    Left e ->  return Nothing-    Right (v,_) -> return $ Just v-    -  +parseCRS = withObject "crs" $ \o ->+  (o .:? "crs") >>= maybe (return Nothing) _parseCRS+  where+    _parseCRS crs = do+        ("name"::T.Text) <- crs .: "type"+        prop <- crs .: "properties"+        espg <-  prop .: "name"+        -- FIXME: any string before : allowed+        let (x:y:xs) = T.split (':' ==) espg+        return $ rightToMaybe (decimal y) >>= Just . fst+ instance FromJSON Geometry where-  parseJSON o  +  parseJSON o     =   GeoPoint <$> parseCRS o <*> parseJSON o     <|> GeoLineString <$> parseCRS o <*> parseJSON o     <|> GeoPolygon <$> parseCRS o <*> parseJSON o

@@ -13,6 +13,7 @@ import Data.Binary.Put import System.Endian import qualified Data.Vector as V+import Data.Maybe  import Data.Binary.IEEE754 import Data.Int@@ -33,7 +34,7 @@ type Putter a = a -> Put   instance Binary Endianness where-  get = fromHex <$> (getLazyByteString 2) +  get = fromHex <$> getLazyByteString 2   put = putLazyByteString . toHex  instance Binary Header where@@ -89,13 +90,13 @@ makeHeader s geo =   let gt = geoType geo       wOr acc (p, h) = if p then h .|. acc else acc-      typ = foldl wOr gt [(hasM geo, wkbM), (hasZ geo, wkbZ), (s /= Nothing, wkbSRID)]   +      typ = foldl wOr gt [(hasM geo, wkbM), (hasZ geo, wkbZ), (isJust s, wkbSRID)]   in Header getSystemEndianness typ s   putRing :: Putter LinearRing putRing v = do   putInt . V.length $ v  -  V.mapM_ putPoint v+  V.mapM_ putPosition v  putGeometry :: Putter Geometry putGeometry (GeoPoint s p) = do@@ -114,7 +115,7 @@ putGeometry (GeoMultiPoint s mp@(MultiPoint ps)) = do   put $ makeHeader s mp   putInt . V.length $ ps -  V.mapM_ (putGeometry . GeoPoint s)  ps+  V.mapM_ putPosition ps  putGeometry (GeoMultiLineString s mls@(MultiLineString ls)) = do   put $ makeHeader s mls@@ -127,8 +128,11 @@   V.mapM_ (putGeometry . GeoPolygon s)  ps  ----+putPosition :: Putter Position+putPosition (Position x y m z) = putDouble x >> putDouble y >> putMaybe m putDouble >> putMaybe z putDouble+ putPoint :: Putter Point-putPoint (Point x y m z) = putDouble x >> putDouble y >> putMaybe m putDouble >> putMaybe z putDouble+putPoint (Point position) = putPosition position  putDouble :: Putter Double putDouble = putLazyByteString . toHex . (endFunc getSystemEndianness byteSwap64) . doubleToWord@@ -147,7 +151,7 @@ getGeometry :: Get Geometry  getGeometry = do   h <- lookAhead get-  let t = (_geoType h) .&. ewkbTypeOffset+  let t = _geoType h .&. ewkbTypeOffset       mkGeo :: (SRID -> a -> Geometry) -> Getter a -> Get Geometry       mkGeo cons p = cons (_srid h) <$> runReaderT p h   case t of@@ -178,7 +182,7 @@ getMultiPoint = do   lift getHeader   n <- getInt -  ps <- V.replicateM n getGeoPoint+  ps <- V.replicateM n getPosition   return $ MultiPoint ps   getPolygon :: Getter Polygon @@ -190,22 +194,25 @@ getRing :: Getter LinearRing getRing = getSegment  -getSegment :: Getter (V.Vector Point)-getSegment = getInt >>= (\n -> V.replicateM n getPoint) +getSegment :: Getter (V.Vector Position)+getSegment = getInt >>= (\n -> V.replicateM n getPosition)    getGeoPoint :: Getter Point getGeoPoint = lift getHeader >> getPoint +getPosition :: Getter Position+getPosition = do+  gt <- asks _geoType +  let hasM = (gt .&. wkbM) > 0+      hasZ = (gt .&. wkbZ) > 0+  x <- getDouble+  y <- getDouble+  z <- if hasZ then Just <$> getDouble else return Nothing+  m <- if hasM then Just <$> getDouble else return Nothing+  return $ Position x y z m+ getPoint :: Getter Point-getPoint = do-    gt <- asks _geoType -    let hasM = if (gt .&. wkbM) > 0 then True else False -        hasZ = if (gt .&. wkbZ) > 0 then True else False-    x <- getDouble-    y <- getDouble-    z <- if hasZ then Just <$> getDouble else return Nothing-    m <- if hasM then Just <$> getDouble else return Nothing-    return $ Point x y z m+getPoint = getPosition >>= return . Point  getHeader :: Get Header getHeader = do

@@ -14,10 +14,10 @@ import qualified Data.Vector as V import System.Endian -point1 = GeoPoint (Just 4326) (Point (-79.4217280000002) 42.289467099999925 Nothing Nothing)+point1 = GeoPoint (Just 4326) (Point (Position (-79.4217280000002) 42.289467099999925 Nothing Nothing)) point1BS ="0101000020E6100000BCF36F97FDDA53C042E207420D254540"  :: BL.ByteString linestring1BS = "0102000020E610000005000000805C4A99F98B5DC0BC5768BDDB0E4140805C9A58F98B5DC0C05798F5DC0E4140805C6C2DF88B5DC0C457C846E30E41407E5C3E5CF78B5DC0C857D0B2E70E41407E5CAA69F68B5DC0CC57B813EA0E4140" :: BL.ByteString-linestring1 = GeoLineString (Just 4326) (LineString (V.fromList [(Point (-118.18710930120324) 34.11608092875346 Nothing Nothing), (Point (-118.1870938785014) 34.11611814440357 Nothing Nothing), (Point (-118.18702254850541) 34.116310928176546 Nothing Nothing), (Point (-118.18697267618151) 34.116445876817636 Nothing Nothing), (Point (-118.18691484104963)  34.11651846409913 Nothing Nothing)]))+linestring1 = GeoLineString (Just 4326) (LineString (V.fromList [(Position (-118.18710930120324) 34.11608092875346 Nothing Nothing), (Position (-118.1870938785014) 34.11611814440357 Nothing Nothing), (Position (-118.18702254850541) 34.116310928176546 Nothing Nothing), (Position (-118.18697267618151) 34.116445876817636 Nothing Nothing), (Position (-118.18691484104963)  34.11651846409913 Nothing Nothing)])) linestringJSON = "{\"coordinates\":[[-118.18710930120324,34.11608092875346],[-118.1870938785014,34.11611814440357],[-118.18702254850541,34.116310928176546],[-118.18697267618151,34.116445876817636],[-118.18691484104963,34.11651846409913]],\"crs\":{\"type\":\"name\",\"properties\":{\"name\":\"ESPG:4326\"}},\"type\":\"LineString\"}"  toUpperBS :: BL.ByteString -> BL.ByteString