diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-postgis.cabal b/haskell-postgis.cabal new file mode 100644 --- /dev/null +++ b/haskell-postgis.cabal @@ -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 diff --git a/src/Database/Postgis.hs b/src/Database/Postgis.hs new file mode 100644 --- /dev/null +++ b/src/Database/Postgis.hs @@ -0,0 +1,12 @@ + +module Database.Postgis + ( + module Database.Postgis.Geometry + , readGeometry + , writeGeometry + + ) where +import Database.Postgis.Geometry +import Database.Postgis.Serialize + + diff --git a/src/Database/Postgis/Geometry.hs b/src/Database/Postgis/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Database/Postgis/Geometry.hs @@ -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) diff --git a/src/Database/Postgis/JSON.hs b/src/Database/Postgis/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Database/Postgis/JSON.hs @@ -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 diff --git a/src/Database/Postgis/Serialize.hs b/src/Database/Postgis/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Database/Postgis/Serialize.hs @@ -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 diff --git a/tests/GeoSpec.hs b/tests/GeoSpec.hs new file mode 100644 --- /dev/null +++ b/tests/GeoSpec.hs @@ -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 + + + diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +