haskell-postgis (empty) → 0.1.0.1
raw patch · 9 files changed
+623/−0 lines, 9 filesdep +aesondep +basedep +binarysetup-changed
Dependencies added: aeson, base, binary, bytestring, bytestring-lexing, cpu, data-binary-ieee754, haskell-postgis, hspec, mtl, placeholders, text, unordered-containers, vector
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- haskell-postgis.cabal +68/−0
- src/Database/Postgis.hs +12/−0
- src/Database/Postgis/Geometry.hs +99/−0
- src/Database/Postgis/JSON.hs +124/−0
- src/Database/Postgis/Serialize.hs +243/−0
- tests/GeoSpec.hs +53/−0
- tests/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Peter++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskell-postgis.cabal view
@@ -0,0 +1,68 @@+-- Initial haskell-postgis.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: haskell-postgis+version: 0.1.0.1+synopsis: A haskell library for PostGIS geometry types.+description: A haskell library for PostGIS geometry types.+license: MIT+license-file: LICENSE+author: Peter+maintainer: pfrance@gmail.com+-- copyright: +category: Database+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ -- exposed-modules: + -- other-modules: + -- other-extensions: + build-depends:+ base >= 4.4 && <=5.0+ , vector+ , binary+ , bytestring-lexing + , cpu+ , mtl+ , data-binary-ieee754+ , text+ , bytestring+ , placeholders + , aeson + , unordered-containers+ hs-source-dirs: src + default-language: Haskell2010+ exposed-modules: + Database.Postgis+ , Database.Postgis.Geometry+ , Database.Postgis.Serialize+ , Database.Postgis.JSON++test-suite tests+ type: + exitcode-stdio-1.0+ hs-source-dirs: tests + main-is: Spec.hs+ default-language: Haskell2010+ other-modules: GeoSpec+ build-depends:+ base >= 4.4 && <=5.0+ , hspec >= 2.1+ , haskell-postgis+ , vector+ , binary+ , bytestring-lexing + , cpu+ , mtl+ , data-binary-ieee754+ , text+ , bytestring+ , placeholders + , aeson + , unordered-containers++source-repository head+ type: git+ location: https://github.com/ewestern/haskell-postgis
+ src/Database/Postgis.hs view
@@ -0,0 +1,12 @@++module Database.Postgis+ (+ module Database.Postgis.Geometry+ , readGeometry+ , writeGeometry++ ) where+import Database.Postgis.Geometry+import Database.Postgis.Serialize++
+ src/Database/Postgis/Geometry.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE GADTs, TypeFamilies #-}++module Database.Postgis.Geometry where++import qualified Data.Vector as V+import Data.Word++{-Linear rings—Rings are simple and closed, which means that linear rings may not self intersect.-}++{-Polygons—No two linear rings in the boundary of a polygon may cross each other. The linear rings in the boundary of a polygon may intersect, at most, at a single point but only as a tangent.--}++{-Multipolygons—The interiors of two polygons that are elements of a multipolygon may not intersect. The boundaries of any two polygons that are elements of a multipolygon may touch at only a finite number of points.-}++type SRID = Maybe Int +++class EWKBGeometry a where+ hasM :: a -> Bool+ hasZ :: a -> Bool+ geoType :: a -> Word32 + {-geometry :: a -> InnerGeo-}+++data Point = Point {+ _x :: {-# UNPACK #-} !Double+ , _y :: {-# UNPACK #-} !Double+ , _z :: Maybe Double+ , _m :: Maybe Double+} deriving (Show, Eq)++instance EWKBGeometry Point where+ hasM (Point x y z m) = m /= Nothing + hasZ (Point x y z m) = z /= Nothing + geoType _ = 1++type LinearRing = V.Vector Point++isClosed :: V.Vector Point -> Bool+isClosed v = V.head v == V.last v+++data LineString = LineString (V.Vector Point) deriving (Show, Eq)+++instance EWKBGeometry LineString where+ hasM (LineString ps) = hasM . V.head $ ps+ hasZ (LineString ps) = hasZ . V.head $ ps+ geoType _ = 2++data Polygon = Polygon (V.Vector LinearRing) deriving (Show, Eq)++hasMLinearRing :: LinearRing -> Bool+hasMLinearRing = hasM . V.head ++hasZLinearRing :: LinearRing -> Bool+hasZLinearRing = hasZ . V.head ++instance EWKBGeometry Polygon where+ hasM (Polygon ps) = hasMLinearRing . V.head $ ps+ hasZ (Polygon ps) = hasZLinearRing . V.head $ ps+ geoType _ = 3++data MultiPoint = MultiPoint (V.Vector Point) deriving (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 (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 (Show, Eq)++instance EWKBGeometry MultiPolygon where+ hasM (MultiPolygon ps) = hasM . V.head $ ps+ hasZ (MultiPolygon ps) = hasZ . V.head $ ps+ geoType _ = 6++srid :: Geometry -> SRID+srid g = case g of+ GeoPoint s p -> s+ GeoLineString s l -> s+ GeoPolygon s p -> s+ GeoMultiPoint s p -> s+ GeoMultiLineString s m -> s+ GeoMultiPolygon s m -> s++data Geometry =+ GeoPoint SRID Point+ | GeoLineString SRID LineString+ | GeoPolygon SRID Polygon+ | GeoMultiLineString SRID MultiLineString+ | GeoMultiPoint SRID MultiPoint+ | GeoMultiPolygon SRID MultiPolygon deriving (Show, Eq)
+ src/Database/Postgis/JSON.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Database.Postgis.JSON (+ ToJSON (..),+ FromJSON (..)+) where++import Control.Applicative ((<|>))+import Data.Aeson+import Data.Aeson.Types (Parser)+import Database.Postgis.Geometry+import qualified Data.Vector as V+import qualified Data.Text as T+import Development.Placeholders+import Data.Maybe+import Data.Monoid ((<>))+import Data.Vector ((!), (!?))+import qualified Data.HashMap.Lazy as HM+import Data.Text.Read (decimal)+++instance ToJSON Point where+ toJSON (Point x y m z) = toJSON $ catMaybes [Just x, Just y, m, z]++instance FromJSON Point where+ parseJSON = withArray "Point" $ \v' -> do+ v <- sequence $ fmap parseJSON v'+ return $ Point (v ! 0) (v ! 1) (v !? 2) (v !? 3)++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 + +instance ToJSON LineString where+ toJSON (LineString points) = object ["type" .= ("LineString" :: T.Text), "coordinates" .= V.map toJSON points]+++--+instance ToJSON Polygon where+ toJSON (Polygon rings) = object ["type" .= ("Polygon" :: T.Text), "coordinates" .= V.map toJSON rings]++instance FromJSON Polygon where+ parseJSON = withObject "Polygon" $ \o -> do+ ("Polygon" :: T.Text) <- o .: "type"+ ls <- o .: "coordinates"+ cs <- sequence $ fmap parseJSON ls+ return $ Polygon cs++---+instance ToJSON MultiPoint where+ toJSON (MultiPoint pg) = object ["type" .= ("MultiPoint" :: T.Text), "coordinates" .= V.map toJSON pg]++instance FromJSON MultiPoint where+ parseJSON = withObject "MultiPoint" $ \o -> do+ ("MultiPoint" :: T.Text) <- o .: "type"+ ls <- o .: "coordinates"+ cs <- sequence $ fmap parseJSON ls+ return $ MultiPoint cs++instance ToJSON MultiLineString where+ toJSON (MultiLineString ls) = object ["type" .= ("MultiLineString" :: T.Text), "coordinates" .= V.map toJSON ls]++instance FromJSON MultiLineString where+ parseJSON = withObject "MultiLineString" $ \o -> do+ ("MultiLineString" :: T.Text) <- o .: "type"+ ls <- o .: "coordinates"+ cs <- sequence $ fmap parseJSON ls+ return $ MultiLineString cs++instance ToJSON MultiPolygon where+ toJSON (MultiPolygon ps) = object ["type" .= ("MultiPolygon" :: T.Text), "coordinates" .= V.map toJSON ps]++instance FromJSON MultiPolygon where+ parseJSON = withObject "MultiPolygon" $ \o -> do+ ("MultiPolygon" :: T.Text) <- o .: "type"+ ls <- o .: "coordinates"+ cs <- sequence $ fmap 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 Nothing x = toJSON x++instance ToJSON Geometry where+ toJSON (GeoPoint s x) = go s x+ toJSON (GeoLineString s x) = go s x+ toJSON (GeoPolygon s x) = go s x+ toJSON (GeoMultiPoint s x) = go s x+ 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)] ]++parseCRS :: Value -> Parser (Maybe Int)+parseCRS = withObject "crs" $ \o -> do+ ("name" :: T.Text) <- o .: "type"+ prop <- o .: "prop"+ espg <- prop .: "name"+ let (x:y:xs) = T.split ((==) ':') espg+ case decimal y of+ Left e -> return Nothing+ Right (v,_) -> return $ Just v+ + +instance FromJSON Geometry where+ parseJSON o + = GeoPoint <$> parseCRS o <*> parseJSON o+ <|> GeoLineString <$> parseCRS o <*> parseJSON o+ <|> GeoPolygon <$> parseCRS o <*> parseJSON o+ <|> GeoMultiPoint <$> parseCRS o <*> parseJSON o+ <|> GeoMultiLineString <$> parseCRS o <*> parseJSON o+ <|> GeoMultiPolygon <$> parseCRS o <*> parseJSON o
+ src/Database/Postgis/Serialize.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE TypeFamilies, GADTs, FlexibleInstances, OverloadedStrings #-}+module Database.Postgis.Serialize where+import Database.Postgis.Geometry++import Data.ByteString.Lex.Integral+import Data.Bits+import Control.Monad.Reader+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BC+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import System.Endian+import qualified Data.Vector as V++import Data.Binary.IEEE754+import Data.Int+import Control.Applicative ((<$>))++wkbZ = 0x80000000 :: Word32+wkbM = 0x40000000 :: Word32+wkbSRID = 0x20000000 :: Word32+ewkbTypeOffset = 0x1fffffff :: Word32++writeGeometry :: Geometry -> BL.ByteString+writeGeometry = runPut . putGeometry ++readGeometry :: BL.ByteString -> Geometry+readGeometry = runGet getGeometry++type Getter = ReaderT Header Get +type Putter a = a -> Put ++instance Binary Endianness where+ get = fromHex <$> (getLazyByteString 2) + put = putLazyByteString . toHex++instance Binary Header where+ get = getHeader + put (Header bo gt s) = put bo >> (putInt . fromIntegral) gt >> putMaybe s putInt++class Hexable a where+ toHex :: a -> BL.ByteString+ fromHex :: BL.ByteString -> a++instance Hexable Endianness where+ toHex BigEndian = "00" :: BL.ByteString + toHex LittleEndian = "01" :: BL.ByteString + fromHex b = case (fromHexInt b) :: Word8 of+ 0 -> BigEndian+ 1 -> LittleEndian+ _ -> error $ "Not an Endian" ++ show b++instance Hexable Word32 where+ toHex = toHexWord 8+ fromHex = fromHexInt++instance Hexable Word64 where+ toHex = toHexWord 16 + fromHex = fromHexInt++--- converters++toHexWord :: Integral a => Int -> a -> BL.ByteString+toHexWord l w = case packHexadecimal w of+ Just s -> BL.fromChunks [padd l s]+ Nothing -> error "Cannot convert word" + where+ padd l bs =+ let diff = l - (BS.length bs )+ in BS.append (BC.replicate diff '0') bs++fromHexInt :: Integral a => BL.ByteString -> a+fromHexInt bs = case readHexadecimal lazy of+ Just (v, r) -> v+ Nothing -> error "Cannot parse hexadecimal"+ where+ lazy = BS.concat . BL.toChunks $ bs++data Header = Header {+ _byteOrder :: Endianness+ , _geoType :: Word32+ , _srid :: SRID+} deriving (Show)++---+makeHeader :: EWKBGeometry a => SRID -> a -> Header+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)] + in Header getSystemEndianness typ s ++putRing :: Putter LinearRing+putRing v = do+ putInt . V.length $ v + V.mapM_ putPoint v++putGeometry :: Putter Geometry+putGeometry (GeoPoint s p) = do+ put $ makeHeader s p+ putPoint p++putGeometry (GeoLineString s ls@(LineString v)) = do+ put $ makeHeader s ls + putRing v++putGeometry (GeoPolygon s pg@(Polygon rs)) = do+ put $ makeHeader s pg+ putInt . V.length $ rs + V.mapM_ putRing rs++putGeometry (GeoMultiPoint s mp@(MultiPoint ps)) = do+ put $ makeHeader s mp+ putInt . V.length $ ps + V.mapM_ (putGeometry . GeoPoint s) ps++putGeometry (GeoMultiLineString s mls@(MultiLineString ls)) = do+ put $ makeHeader s mls+ putInt . V.length $ ls + V.mapM_ (putGeometry . GeoLineString s) ls++putGeometry (GeoMultiPolygon s mpg@(MultiPolygon ps)) = do+ put $ makeHeader s mpg+ putInt . V.length $ ps + V.mapM_ (putGeometry . GeoPolygon s) ps++----+putPoint :: Putter Point+putPoint (Point x y m z) = putDouble x >> putDouble y >> putMaybe m putDouble >> putMaybe z putDouble++putDouble :: Putter Double+putDouble = putLazyByteString . toHex . (endFunc getSystemEndianness byteSwap64) . doubleToWord++putInt :: Putter Int+putInt = putLazyByteString . toHex . (endFunc getSystemEndianness byteSwap32) . fromIntegral++putMaybe :: Maybe a -> Putter a -> Put+putMaybe mi = case mi of+ Just i -> ($ i) + Nothing -> (\x -> return ())++--+-- getters +--+getGeometry :: Get Geometry +getGeometry = do+ h <- lookAhead get+ 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+ 1 -> mkGeo GeoPoint getGeoPoint+ 2 -> mkGeo GeoLineString getLineString + 3 -> mkGeo GeoPolygon getPolygon + 4 -> mkGeo GeoMultiPoint getMultiPoint + 5 -> mkGeo GeoMultiLineString getMultiLineString+ 6 -> mkGeo GeoMultiPolygon getMultiPolygon + _ -> error $ "not yet implemented" ++ (show t)+++getMultiPolygon :: Getter MultiPolygon +getMultiPolygon = do + lift getHeader+ n <- getInt+ ps <- V.replicateM n getPolygon+ return $ MultiPolygon ps++getMultiLineString :: Getter MultiLineString +getMultiLineString = do+ lift getHeader+ n <- getInt+ ls <- V.replicateM n getLineString + return $ MultiLineString ls++getMultiPoint :: Getter MultiPoint +getMultiPoint = do+ lift getHeader+ n <- getInt + ps <- V.replicateM n getGeoPoint+ return $ MultiPoint ps+ +getPolygon :: Getter Polygon +getPolygon = lift getHeader >> Polygon <$> (getInt >>= (\n -> V.replicateM n getRing))++getLineString :: Getter LineString +getLineString = lift getHeader >> LineString <$> getSegment++getRing :: Getter LinearRing+getRing = getSegment ++getSegment :: Getter (V.Vector Point)+getSegment = getInt >>= (\n -> V.replicateM n getPoint) + +getGeoPoint :: Getter Point+getGeoPoint = lift getHeader >> getPoint++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++getHeader :: Get Header+getHeader = do+ or <- get + t <- fromIntegral <$> getInt' or+ s <- if t .&. wkbSRID > 0 then (Just . fromIntegral) <$> getInt' or else return Nothing + return $ Header or t s++-- number parsers+endFunc :: Endianness -> (a -> a) -> (a -> a)+endFunc e f = case e of + BigEndian -> id+ LittleEndian -> f++-- +getNumber :: (Hexable a) => (a -> a) -> Int64 -> Endianness -> Get a+getNumber f l end = do+ bs <- getLazyByteString l+ case end of + BigEndian -> return $ fromHex bs+ LittleEndian -> return . f . fromHex $ bs ++-- word32 = 4 bytes * 2 nibbles+getInt' :: Endianness -> Get Int+getInt' = (fmap fromIntegral) . getNumber byteSwap32 8++getInt :: Getter Int +getInt = (getInt' <$> (asks _byteOrder)) >>= lift++-- word64 = 8 bytes * 2 nibbles+getDouble' :: Endianness -> Get Double +getDouble' = (fmap wordToDouble) . (getNumber byteSwap64 16)++getDouble :: Getter Double+getDouble = (getDouble' <$> (asks _byteOrder)) >>= lift
+ tests/GeoSpec.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+module GeoSpec where++import Test.Hspec+{-import Test.QuickCheck-}+import Control.Exception (evaluate)+import Database.Postgis+import Database.Postgis.Serialize+import Database.Postgis.JSON ()+import Data.Char+import Data.Aeson+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.Vector as V+import System.Endian++point1 = GeoPoint (Just 4326) (Point (-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)]))+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+toUpperBS = BLC.map toUpper ++spec = do+ describe "Hexable" $ do+ let be = "00" :: BL.ByteString+ le = "01" :: BL.ByteString+ it "should convert Endiannes to ByteString" $ do+ toHex BigEndian `shouldBe` be + toHex LittleEndian `shouldBe` le + it "should convert ByteString to Endianness" $ do+ fromHex be `shouldBe` BigEndian+ fromHex le `shouldBe` LittleEndian+ {-it "should convert int32 to a hex ByteString" $ do-}+ + {-describe "parseGeometry" $ do-}+ it "Should correctly parse a bytestring into a Point" $ do+ readGeometry point1BS `shouldBe` point1+ it "Should parse a bytestring into a LineString" $ do+ readGeometry linestring1BS `shouldBe` linestring1+ {-describe "writeGeometry" $ do-}+ it "Should correctly write a Point into a bytestring" $ do+ (toUpperBS $ writeGeometry point1) `shouldBe` point1BS+ it "Should write a LineString into a bytestring" $ do+ (toUpperBS $ writeGeometry linestring1) `shouldBe` linestring1BS + {-describe "Json" $ do-}+ it "Encodes a linestring" $ do+ encode linestring1 `shouldBe` linestringJSON+ ++
+ tests/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+