diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Przemyslaw Kopanski (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Przemyslaw Kopanski nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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/osm-conduit.cabal b/osm-conduit.cabal new file mode 100644 --- /dev/null +++ b/osm-conduit.cabal @@ -0,0 +1,48 @@ +name: osm-conduit +version: 0.1.0.0 +synopsis: Parse and operate on OSM data in efficient way +description: Convenient *.osm parsing. See "Data.Conduit.OSM" or README.md +homepage: http://github.com/przembot/osm-conduit#readme +license: BSD3 +license-file: LICENSE +author: Przemysław Kopański +maintainer: P.Kopanski@stud.elka.pw.edu.pl +copyright: (c) 2016 Przemysław Kopański +category: Data, Geography +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.Conduit.OSM + , Data.Conduit.OSM.Types + build-depends: base >= 4.7 && < 5 + , conduit + , xml-types + , xml-conduit >= 1.3.2 + , resourcet + , transformers + , text + , exceptions + ghc-options: -Wall + default-language: Haskell2010 + +test-suite osm-conduit-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , osm-conduit + , conduit + , text + , hspec + , exceptions + , resourcet + , xml-conduit + , xml-types + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/przembot/osm-conduit diff --git a/src/Data/Conduit/OSM.hs b/src/Data/Conduit/OSM.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/OSM.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Available conduit combinators to process data from *.osm file. +-- For the best performance, use any of conduitNodes/Ways/Relations/NWR. +-- Example: +-- +-- > import qualified Data.Conduit.List as CL +-- > import Text.XML.Stream.Parse (parseFile, def) +-- > printNodes filepath = parseFile def filepath =$ conduitNodes $$ CL.mapM_ print +-- + +module Data.Conduit.OSM + ( + sourceFileOSM + , conduitNWR + , conduitNodes + , conduitWays + , conduitRelations + , conduitOSM + ) + where + +import Data.Conduit (Consumer, Conduit, Source, ConduitM, (=$)) +import Data.Text (Text, unpack, toLower) +import Data.XML.Types (Event, Name) +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Trans.Resource (MonadResource) +import Control.Exception (ErrorCall(..)) +import Text.Read (readMaybe) +import Text.XML.Stream.Parse (AttrParser, tagName, requireAttr, attr + , ignoreAttrs, many, many', manyYield, manyYield' + , parseFile, def, choose, tagIgnoreAttrs) +import Data.Conduit.OSM.Types + + + +sourceFileOSM :: MonadResource m => FilePath -> Source m OSM +sourceFileOSM path = parseFile def path =$ conduitOSM + +conduitOSM :: MonadThrow m => Conduit Event m OSM +conduitOSM = manyYield parseOSM + +conduitNodes :: MonadThrow m => Conduit Event m Node +conduitNodes = loopConduit $ tagIgnoreAttrs "osm" $ manyYield' parseNode + +conduitWays :: MonadThrow m => Conduit Event m Way +conduitWays = loopConduit $ tagIgnoreAttrs "osm" $ manyYield' parseWay + +conduitRelations :: MonadThrow m => Conduit Event m Relation +conduitRelations = loopConduit $ tagIgnoreAttrs "osm" $ manyYield' parseRelation + +conduitNWR :: MonadThrow m => Conduit Event m NWRWrap +conduitNWR = loopConduit $ tagIgnoreAttrs "osm" $ manyYield' parseNWR + +-- | Keep yielding output if parser can still parse anything remaining +loopConduit :: Monad m => ConduitM i o m (Maybe ()) -> Conduit i m o +loopConduit cond = loop + where + loop = cond >>= maybe (return ()) (const loop) + +parseOSM :: MonadThrow m => Consumer Event m (Maybe OSM) +parseOSM = tagName "osm" tagParser $ \cont -> cont <$> parseBounds <*> many parseNode <*> many parseWay <*> many' parseRelation + where + tagParser = OSM <$> requireAttrRead "version" <*> attr "generator" <* ignoreAttrs + + +-- | Wrap nodes, ways and relations +parseNWR :: MonadThrow m => Consumer Event m (Maybe NWRWrap) +parseNWR = choose [ fmap N <$> parseNode + , fmap W <$> parseWay + , fmap R <$> parseRelation ] + + +parseNode :: MonadThrow m => Consumer Event m (Maybe Node) +parseNode = tagName "node" tagParser $ \cont -> cont <$> many' parseTag + where + tagParser = (\f latitude longitude tagz -> Node latitude longitude (f tagz)) + <$> nwrCommonParser + <*> requireAttrRead "lat" + <*> requireAttrRead "lon" + <* ignoreAttrs + + +parseWay :: MonadThrow m => Consumer Event m (Maybe Way) +parseWay = tagName "way" (nwrCommonParser <* ignoreAttrs) + $ \cont -> Way <$> many parseNd <*> (cont <$> many' parseTag) + + +parseRelation :: MonadThrow m => Consumer Event m (Maybe Relation) +parseRelation = tagName "relation" (nwrCommonParser <* ignoreAttrs) + $ \cont -> Relation <$> many parseMember <*> (cont <$> many' parseTag) + + +parseMember :: MonadThrow m => Consumer Event m (Maybe Member) +parseMember = tagName "member" tagParser return + where + tagParser = Member <$> (requireAttr "type" >>= readNWRType) + <*> requireAttr "ref" + <*> attr "role" + <* ignoreAttrs + + +parseNd :: MonadThrow m => Consumer Event m (Maybe Nd) +parseNd = tagName "nd" (Nd <$> requireAttr "ref" <* ignoreAttrs) return + + +parseTag :: MonadThrow m => Consumer Event m (Maybe Tag) +parseTag = tagName "tag" tagParser (return . Tag) + where + tagParser = (,) <$> requireAttr "k" <*> requireAttr "v" <* ignoreAttrs + +parseBounds :: MonadThrow m => Consumer Event m (Maybe Bounds) +parseBounds = tagName "bounds" tagParser return + where + tagParser = Bounds <$> requireAttrRead "minlat" + <*> requireAttrRead "minlon" + <*> requireAttrRead "maxlat" + <*> requireAttrRead "maxlon" + +nwrCommonParser :: AttrParser ([Tag] -> NWRCommon) +nwrCommonParser = NWRCommon <$> requireAttr "id" + <*> fmap (>>= readBool) (attr "visible") + <*> attr "chageset" + <*> attr "timestamp" + <*> attr "user" + +readNWRType :: Text -> AttrParser NWR +readNWRType a = + case toLower a of + "node" -> return NWRn + "relation" -> return NWRr + "way" -> return NWRw + _ -> throwM $ ErrorCall "unknown type in " + +fromStr :: Read a => Text -> Maybe a +fromStr = readMaybe . unpack + +requireAttrRead :: Read a => Name -> AttrParser a +requireAttrRead str = requireAttr str + >>= maybe (throwM $ ErrorCall "Could not parse attribute value") return . fromStr + +readBool :: Text -> Maybe Bool +readBool a + | toLower a == "true" = Just True + | toLower a == "false" = Just False + | otherwise = Nothing diff --git a/src/Data/Conduit/OSM/Types.hs b/src/Data/Conduit/OSM/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/OSM/Types.hs @@ -0,0 +1,103 @@ +-- | +-- The following data types correspond to documentation of API version 0.6. +-- See https://wiki.openstreetmap.org/wiki/API_v0.6/DTD +module Data.Conduit.OSM.Types where + +import Data.Text (Text) + + +type Version = Double +type Generator = Text + +data OSM = + OSM { + _version :: Version + , _generator :: Maybe Generator + , _bounds :: Maybe Bounds + , _nodes :: [Node] + , _ways :: [Way] + , _relations :: [Relation] + } + deriving (Show, Eq) + +data Bounds = + Bounds { + _minlat :: Lat + , _minlon :: Lon + , _maxlat :: Lat + , _maxlon :: Lon + } + deriving (Show, Eq) + +type Id = Text +type Lat = Double +type Lon = Double +type Changeset = Text +type Visible = Bool +type User = Text +type Timestamp = Text -- maybe data.time? +type Role = Text + +data Node = + Node { + _lat :: Lat + , _lon :: Lon + , _nCommon :: NWRCommon + } + deriving (Show, Eq) + +data Relation = + Relation { + _members :: [Member] + , _rCommon :: NWRCommon + } + deriving (Show, Eq) + +data Way = + Way { + _nds :: [Nd] + , _wCommon :: NWRCommon + } + deriving (Show, Eq) + +data NWRCommon = + NWRCommon { + _id :: Id + , _visible :: Maybe Visible + , _changeset :: Maybe Changeset + , _timestamp :: Maybe Timestamp + , _user :: Maybe User + , _tags :: [Tag] + } + deriving (Show, Eq) + +data NWR = NWRn | NWRw | NWRr + deriving (Show, Eq) + +data NWRWrap = N Node + | W Way + | R Relation + deriving (Show, Eq) + +data Member = + Member { + _type :: NWR + , _mRef :: Id + , _role :: Maybe Role + } + deriving (Show, Eq) + + +data Nd = + Nd { + _ref :: Id + } + deriving (Show, Eq) + +-- | Tag stores (Key, Value) +data Tag = + Tag { + _tag :: (Text, Text) + } + deriving (Show, Eq) + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} +import Test.Hspec +import Control.Monad.Catch (MonadThrow) +import Control.Monad.Trans.Resource (runResourceT) + +import Data.Text (Text) + +import Data.XML.Types (Event) +import Text.XML.Stream.Parse hiding (force) + +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.OSM +import Data.Conduit.OSM.Types + +main :: IO () +main = hspec $ do + describe "parser success" $ do + it "parse node with tags" $ do + parsed <- runTest testCase01 conduitOSM + parsed `shouldBe` [OSM 0.6 (Just "lulz generator") Nothing [Node 52.153 22.341 (NWRCommon "43221" (Just True) Nothing Nothing Nothing [Tag ("shop", "alcohol"), Tag ("area", "safe")])] [] []] + + it "parse way" $ do + parsed <- runTest testCase03 conduitOSM + parsed `shouldBe` [OSM 0.6 (Just "lulz generator") Nothing [] [Way [Nd "1234", Nd "2345", Nd "3456"] (NWRCommon "1995" (Just True) Nothing Nothing Nothing [Tag ("rodzaj drogi", "do ukochanej")]) ] [] ] + + it "parse relation" $ do + parsed <- runTest testCase04 conduitOSM + parsed `shouldBe` [OSM 0.6 (Just "lulz generator") Nothing [] [] [Relation [Member NWRn "1234" Nothing] (NWRCommon "4747" (Just True) Nothing Nothing Nothing [Tag ("testk", "testv")])]] + + describe "parser throws error" $ do + it "should throw when reading a double value fails" $ do + runTest testCase02 conduitOSM `shouldThrow` errorCall "Could not parse attribute value" + + describe "reading from file" $ do + it "should be able to read using sourceFileOSM" $ do + parsed <- runResourceT $ sourceFileOSM "test/readingTest.xml" $$ CL.consume + parsed `shouldBe` [OSM 0.6 Nothing Nothing [Node 12.34 34.56 (NWRCommon "1111" Nothing Nothing Nothing Nothing [])] [] []] + + describe "parsing ommiting osm tag" $ do + it "parse nwr at once" $ do + parsed <- runTest testCase05 conduitNWR + parsed `shouldMatchList` [ + N (Node 52.153 22.341 (NWRCommon "43221" (Just True) Nothing Nothing Nothing [])), + W (Way [Nd "12"] (NWRCommon "1337" (Just True) Nothing Nothing Nothing [])), + R (Relation [Member NWRn "1234" Nothing] (NWRCommon "4747" (Just True) Nothing Nothing Nothing [Tag ("testk", "testv")])) + ] + + it "parse nodes using conduitNodes" $ do + parsed <- runTest testCase01 conduitNodes + parsed `shouldBe` [Node 52.153 22.341 (NWRCommon "43221" (Just True) Nothing Nothing Nothing [Tag ("shop", "alcohol"), Tag ("area", "safe")])] + + it "parse ways using conduitWays" $ do + parsed <- runTest testCase03 conduitWays + parsed `shouldBe` [Way [Nd "1234", Nd "2345", Nd "3456"] (NWRCommon "1995" (Just True) Nothing Nothing Nothing [Tag ("rodzaj drogi", "do ukochanej")])] + + it "parse relations using conduitRelations" $ do + parsed <- runTest testCase04 conduitRelations + parsed `shouldBe` [Relation [Member NWRn "1234" Nothing] (NWRCommon "4747" (Just True) Nothing Nothing Nothing [Tag ("testk", "testv")])] + + it "parse items from many osm tags" $ do + parsed <- runTest testCase06 conduitNWR + parsed `shouldMatchList` [ + N (Node 52 20 (NWRCommon "21" (Just True) Nothing Nothing Nothing [])), + N (Node 52.153 22.341 (NWRCommon "43221" (Just True) Nothing Nothing Nothing [])) + ] + +runTest :: MonadThrow m => Source m Text -> Conduit Event m a -> m [a] +runTest tcase cond = tcase $$ parseText' def =$ cond =$ CL.consume + +xmlPrefix :: Text +xmlPrefix = "" + +testCase01 :: Monad m => Source m Text +testCase01 = CL.sourceList + [xmlPrefix + , "" + , "" + , "" + , "" + , "" + , "" + ] + +testCase02 :: Monad m => Source m Text +testCase02 = CL.sourceList + [xmlPrefix + , "" + , "" + , "" + , "" + , "" + ] + +testCase03 :: Monad m => Source m Text +testCase03 = CL.sourceList + [xmlPrefix + , "" + , "" + , "" + , "" + , "" + , "" + , "" + , "" + ] + +testCase04 :: Monad m => Source m Text +testCase04 = CL.sourceList + [xmlPrefix + , "" + , "" + , "" + , "" + , "" + , "" + ] + +testCase05 :: Monad m => Source m Text +testCase05 = CL.sourceList + [xmlPrefix + , "" + , "" + , "" + , "" + , "" + , "" + , "" + , "" + , "" + , "" + ] + +testCase06 :: Monad m => Source m Text +testCase06 = CL.sourceList + [xmlPrefix + , "" + , "" + , "" + , "" + , "" + , "" + ]