diff --git a/Geo/GPX/Conduit.hs b/Geo/GPX/Conduit.hs new file mode 100644 --- /dev/null +++ b/Geo/GPX/Conduit.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts #-} +{-| This is a partial parsing of the GPX 1.0 and 1.0 exchange types. + -} +module Geo.GPX.Conduit + ( Track(..), GPX(..), Segment(..), Point(..) + , readGPXFile, pt + ) where + +import Control.Monad.Trans.Control +import Control.Monad +import Data.Conduit +import Data.Conduit.Text +import Data.Conduit.List as L +import Data.Void (Void) +import Data.Time.Format +import Data.Text (Text) +import qualified Data.Text as T +import System.Locale +import System.FilePath +import Data.String +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime, buildTime, parseTime) +import Data.XML.Types +import Text.XML hiding (parseText) +import Text.XML.Stream.Parse +import qualified Data.Attoparsec.Text as AT + +import Debug.Trace + + +-- |A GPX file usually is a single track (but can be many) +-- with one or more segments and many points in each segment. +data GPX = GPX { -- waypoints :: [Waypoint] + -- , routes :: [Route] + tracks :: [Track] } + deriving (Eq, Ord, Show, Read) +data Track = Track + { trkName :: Maybe Text + , trkDescription :: Maybe Text + , segments :: [Segment] + } + deriving (Eq, Ord, Show, Read) + +-- |A GPX segments is just a bundle of points. +data Segment = Segment { points :: [Point] } + deriving (Eq, Ord, Show, Read) + +type Latitude = Double +type Longitude = Double + +-- |Track point is a full-fledged representation of all the data +-- available in most GPS loggers. It is possible you don't want +-- all this data and can just made do with coordinates (via 'Pnt') +-- or a custom derivative. +data Point = Point + { pntLat :: Latitude + , pntLon :: Longitude + , pntEle :: Maybe Double -- ^ In meters + , pntTime :: Maybe UTCTime + -- , pntSpeed :: Maybe Double -- ^ Non-standard. Usually in meters/second. + } + deriving (Eq, Ord, Show, Read) + +pt :: Latitude -> Longitude -> Maybe Double -> Maybe UTCTime -> Point +pt t g e m = Point t g e m + +zeroPoint = Point 0 0 Nothing Nothing + +readGPXFile :: FilePath -> IO (Maybe GPX) +readGPXFile fp = runResourceT (parseFile def (fromString fp) $$ conduitGPX) + +parseGPX :: (MonadThrow m, MonadBaseControl IO m) => Text -> m (Maybe GPX) +parseGPX t = runResourceT (yield t =$= mapOutput snd (parseText def) + $$ conduitGPX) + +conduitGPX :: MonadThrow m => Sink Event m (Maybe GPX) +conduitGPX = + tagPredicate ((== "gpx") . nameLocalName) + ignoreAttrs + (\_ -> do + skipTagAndContents "metadata" + ts <- many conduitTrack + return $ GPX ts) + +skipTagAndContents :: (MonadThrow m) => Text -> Pipe Event Event Void () m () +skipTagAndContents n = do + tagPredicate ((== n) . nameLocalName) ignoreAttrs + (const $ L.sinkNull) + return () + + +conduitTrack :: MonadThrow m => Sink Event m (Maybe Track) +conduitTrack = do + tagPredicate ((== "trk") . nameLocalName) ignoreAttrs $ \_ -> do + n <- join `fmap` tagPredicate (("name" ==) . nameLocalName) ignoreAttrs (const contentMaybe) + d <- join `fmap` tagPredicate (("desc" ==) . nameLocalName) ignoreAttrs (const contentMaybe) + segs <- many conduitSegment + return (Track n d segs) + +conduitSegment :: MonadThrow m => Sink Event m (Maybe Segment) +conduitSegment = do + tagPredicate ((== "trkseg") . nameLocalName) ignoreAttrs $ \_ -> do + pnts <- (many conduitPoint) + return (Segment pnts) + +conduitPoint :: MonadThrow m => Sink Event m (Maybe Point) +conduitPoint = + tagPredicate ((== "trkpt") . nameLocalName ) + (do l <- parseDouble `fmap` requireAttr "lat" + g <- parseDouble `fmap` requireAttr "lon" + return $ zeroPoint { pntLon = g, pntLat = l }) + parseETS + +-- Parse elevation, time, and speed tags +parseETS :: MonadThrow m => Point -> Sink Event m Point +parseETS pnt = do + let nameParse :: Name -> Maybe (Point -> Text -> Point) + nameParse n = + case nameLocalName n of + "ele" -> Just (\p t -> p { pntEle = Just (parseDouble t) }) + "time" -> Just (\p t -> p { pntTime = (parseUTC t) }) + "speed" -> Just (\p _ -> p ) -- We ignore 'speed' + _ -> Nothing + handleName :: (MonadThrow m) => pnt -> (pnt -> Text -> pnt) -> Sink Event m pnt + handleName p op = fmap (op p) content + skipTagAndContents "extensions" + pnt' <- tag nameParse return (handleName pnt) + case pnt' of + Nothing -> return pnt + Just p -> parseETS p + +parseDouble :: Text -> Double +parseDouble l = either (const 0) id (AT.parseOnly AT.double l) + +parseUTC :: Text -> Maybe UTCTime +parseUTC = either (const Nothing) id . AT.parseOnly (do + yearMonthDay <- AT.manyTill AT.anyChar (AT.char 'T') + hourMinSec <- AT.manyTill AT.anyChar (AT.choice [AT.char '.', AT.char 'Z']) + fraction <- AT.choice [AT.manyTill AT.anyChar (AT.char 'Z'), return ""] + -- The Time package version 1.4 does not handle F T and Q property for + -- buildTime. + -- return (buildTime defaultTimeLocale + -- [('F', yearMonthDay), ('T', hourMinSec), ('Q', fraction)])) + return (parseTime defaultTimeLocale "%F %T %Q" + (unwords [yearMonthDay,hourMinSec,'.':fraction])) + ) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Thomas M. DuBuisson + +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 Thomas M. DuBuisson 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/gpx-conduit.cabal b/gpx-conduit.cabal new file mode 100644 --- /dev/null +++ b/gpx-conduit.cabal @@ -0,0 +1,32 @@ +-- gpx-conduit.cabal auto-generated by cabal init. For additional +-- options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +Name: gpx-conduit +Version: 0.1 +Synopsis: Read GPX files using conduits +Description: Read GPX files into simple Point types. +License: BSD3 +License-file: LICENSE +Author: Thomas M. DuBuisson +Maintainer: Thomas.DuBuisson@gmail.com +Copyright: Thomas M. DuBuisson (2012) +Category: Data +Build-type: Simple +-- Extra-source-files: +Cabal-version: >=1.6 + +Library + Exposed-modules: Geo.GPX.Conduit + Build-depends: base == 4.* + , xml-conduit == 1.0.* + , conduit == 0.5.* + , attoparsec == 0.10.* + , time == 1.4.* + , text == 0.11.* + , xml-types == 0.3.* + , old-locale == 1.0.* + , filepath == 1.3.* + , monad-control == 0.3.* + , void == 0.5.* + -- Other-modules: + -- Build-tools: