osm-download 0.1.2 → 0.2

raw patch · 2 files changed

+322/−91 lines, 2 filesdep +acid-statedep +conduitdep +containersdep ~gpsdep ~http-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: acid-state, conduit, containers, http-types, monadIO, mtl, safecopy, stm, stm-chans, time, transformers, transformers-base

Dependency ranges changed: gps, http-conduit

API changes (from Hackage documentation)

Files

• Network/OSM.hs +301/−48
• osm-download.cabal +21/−43

@@ -1,28 +1,67 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable,+    FlexibleInstances, MultiParamTypeClasses, OverloadedStrings +    , GeneralizedNewtypeDeriving, FlexibleContexts #-} module Network.OSM-  (  -- * Types-    TileID+  (  -- * Basic Types+    TileID(..)   , TileCoords(..)-     -- * High Level Operations+  , Zoom+    -- * Types for tile cacheing+  , OSMConfig(..)+  , OSMState+  , OSM+    -- * High-level (cacheing) Operations+  , evalOSM+  , getBestFitTiles+  , getTiles+  , getTile+  , defaultOSMConfig+    -- * Network Operations   , downloadBestFitTiles+  , downloadTiles+  , downloadTile   , osmTileURL+  -- * Helper Functions   , pixelPosForCoord-  -- * Low level and helper functions+  , selectTilesWithFixedDimensions   , determineTileCoords   , selectedTiles-  , downloadTiles   -- * Legal   , copyrightText   )where -import Data.GPS-import Network.HTTP.Conduit-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L import Control.Monad+import Control.Monad.Base (liftBase) import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.GPS import Data.Maybe import Data.Word+import Network.HTTP.Conduit+import Network.HTTP.Types ( Status, statusOK, ResponseHeaders+                          , parseSimpleQuery, statusServiceUnavailable) +-- For the cacheing+import Control.Concurrent.MonadIO (forkIO)+import Control.Concurrent.STM+import Control.Concurrent.STM.TBChan+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader (ask)+import Control.Monad.State+import Data.Acid+import Data.Char (isDigit)+import Data.Conduit+import Data.Data+import Data.SafeCopy+import Data.Time+import Data.Typeable+import Paths_osm_download+import qualified Data.ByteString.Char8 as BC+import qualified Data.Map as M++type Zoom = Int+ -- | The official OSM tile server. osmTileURL :: String osmTileURL = "http://tile.openstreetmap.org"@@ -35,27 +74,69 @@                      , maxX :: Int                        , minY :: Int                        , maxY :: Int -                     } +                     } deriving (Eq, Ord, Show) -data TileID = TID { unTID :: (Int, Int) } deriving (Eq, Ord, Show)-       --- OSM defined a of converting a coordinate and zoom level to a list of tiles-tileNumbers :: Double -> Double -> Int -> [(Int,Int)]-tileNumbers latitude longitude zoom = -             let xtile = ((longitude+180) / 360) * fromInteger (shift (1::Integer) zoom)+-- |A TileID, along with a zoom level, uniquely identifies a single+-- OSM map tile.  The standard size is 256x256 pixels for such a tile.+newtype TileID = TID { unTID :: (Int, Int) } deriving (Eq, Ord, Show, Data, Typeable)++-- |An on-disk cache of tiles.  Failure to use a local cache results in+-- excessive requests to the tile server.  OSM admins might ban such users.+newtype TileCache = TC (M.Map (TileID,Zoom) (UTCTime,B.ByteString))+  deriving (Data, Typeable)++updateTC :: UTCTime -> (TileID,Zoom) -> B.ByteString -> Update TileCache ()+updateTC expire tid bs = do+  TC tc <- get+  let tc' = M.insert tid (expire,bs) tc+  put (TC tc')++queryTC :: (TileID,Zoom) -> Query TileCache (Maybe (UTCTime,B.ByteString))+queryTC tid = do+  TC st <- ask+  return $ M.lookup tid st++$(deriveSafeCopy 1 'base ''TileID)+$(deriveSafeCopy 1 'base ''TileCache)+$(makeAcidic ''TileCache ['updateTC, 'queryTC])++tileNumbers :: Integral t => Double -> Double -> Zoom -> [(t, t)]+tileNumbers t g z =+  let (a,b) = tileNumbers' t g z+      bounds x = [ceiling x, floor x]+  in [(xt,yt) | xt <- bounds a, yt <- bounds b]++-- |OSM defined method of converting a coordinate and zoom level to a tile+tileNumbers' :: Double -> Double -> Zoom -> (Double,Double)+tileNumbers' latitude longitude zoom = +             let n = 2^zoom+                 xtile = ((longitude+180) / 360) * n                  tmp = log (tan (latitude*pi / 180) + secant (latitude * pi / 180))-                 ytile = ((1-tmp / pi) / 2.0) * fromInteger (shift (1::Integer) zoom)-                 bounds x = [ceiling x, floor x]-             in [(xt,yt) | xt <- bounds xtile, yt <- bounds ytile]+                 ytile = ((1-tmp / pi) / 2.0) * n+             in (xtile,ytile)  secant :: Floating a => a -> a secant a = 1 / cos a +-- |Given a width, height and center, compute the tiles needed to fill the display+--+-- THIS ASSUMES tiles are 256x256 pixels!+selectTilesWithFixedDimensions :: (Coordinate a) => (Int,Int) -> a -> Zoom -> [[TileID]]+selectTilesWithFixedDimensions (w,h) center z =+  let (x,y) = tileNumbers' (lat center) (lon center) z+      nrColumns2, nrRows2 :: Int+      nrColumns2 = 1 + ceiling (fromIntegral w / 512)+      nrRows2    = 1 + ceiling (fromIntegral h / 512)+      -- FIXME hardcoding the tile server tile pixel width+  in [ [ TID (xp, yp) | xp <- [truncate x - nrColumns2..truncate x + nrColumns2]] +         | yp <- [truncate y - nrRows2..truncate y + nrRows2] ] +       -- FIXME not handling boundary conditions, such as +/-180 longitude!+ -- |Computes the rectangular map region to download based on GPS points and a zoom level-determineTileCoords :: (Lat a, Lon a) => [a] -> Int -> Maybe TileCoords+determineTileCoords :: (Coordinate a) => [a] -> Zoom -> Maybe TileCoords determineTileCoords [] _ = Nothing determineTileCoords wpts z =-    let (xs,ys) = unzip $ concatMap (\w -> tileNumbers (realToFrac $ lat w) (realToFrac $ lon w) z) wpts+    let (xs,ys) = unzip $ concatMap (\w -> tileNumbers (lat w) (lon w) z) wpts     in Just $ TileCoords          { maxX = maximum xs          , minX = minimum xs@@ -65,7 +146,7 @@  maxNumAutoTiles = 32 -zoomCalc :: TileCoords -> Int+zoomCalc :: TileCoords -> Zoom zoomCalc tCoords =     let numxtiles = maxX tCoords - minX tCoords + 1        numytiles = maxY tCoords - minY tCoords + 1@@ -82,25 +163,40 @@ selectedTiles c = map (\j -> [TID (i,j) | i <- [minX c..maxX c]]) [minY c .. maxY c]  -- | Formats the URL string-urlStr :: String -> Int -> Int -> Int -> String-urlStr base xTile yTile zoom = base ++"/"++show zoom++"/"++show xTile++"/"++show yTile++".png"+urlStr :: String -> TileID -> Zoom -> String+urlStr base (TID (xTile, yTile)) zoom = base ++"/"++show zoom++"/"++show xTile++"/"++show yTile++".png"  -- | Takes the boundaries of the OSM tiles and downloads the tiles, -- keeping them in proper grid patterns for latter stiching or -- side-by-side display.-downloadTiles :: String -> [[TileID]] -> Int -> IO [[B.ByteString]]-downloadTiles base ts zoom = do+downloadTiles :: String -> Zoom -> [[TileID]] -> IO [[Either Status B.ByteString]]+downloadTiles base zoom ts = runResourceT $ do+  man <- newManager+  mapM (mapM (liftM (fmap snd) . downloadTile' man base zoom)) ts+  +-- |Download a single tile form a given OSM server URL.+downloadTile :: String -> Zoom -> TileID -> IO (Either Status B.ByteString)+downloadTile base zoom t = runResourceT $ do+  man <- newManager+  liftM (fmap snd) (downloadTile' man base zoom t)++downloadTile' :: Manager -> String -> Zoom -> TileID -> ResourceT IO (Either Status (ResponseHeaders,B.ByteString))+downloadTile' man base zoom t = do   let packIt = B.concat . L.toChunks-  mapM (mapM (\(x,y) -> liftM packIt $ simpleHttp (urlStr base x y zoom))) (map (map unTID) ts)+  url' <- liftBase (parseUrl (urlStr base t zoom))+  rsp <- httpLbs url' man+  if statusCode rsp == statusOK+    then return (Right (responseHeaders rsp, packIt (responseBody rsp)))+    else return (Left $ statusCode rsp)  projectMercToLat :: Floating a => a -> a projectMercToLat rely = (180 / pi) * atan (sinh rely)  -- | Used by @pixelPosForCoord@ for N,S,E,W coordinates for (x,y) values-project :: Int -> Int -> Int -> (Double,Double,Double,Double)+project :: Double -> Double -> Zoom -> (Double,Double,Double,Double) project x y zoom =    let unit = 1.0 / (2.0 ** fromIntegral zoom)-      rely1 = fromIntegral y * unit+      rely1 = y * unit       rely2 = rely1 + unit       limity = pi       rangey = 2.0 * limity@@ -109,22 +205,21 @@       lat1 = projectMercToLat rely1'       lat2 = projectMercToLat rely2'       unit' = 360.0 / (2.0 ** fromIntegral zoom)-      long1 = (-180.0) + fromIntegral x * unit'+      long1 = (-180.0) + x * unit'   in (lat2,long1,lat1,long1+unit') -- S,W,N,E   --- | Takes a WptType, the OSM tile boundaries, and a zoom level then+-- | Takes a coordinate, the OSM tile boundaries, and a zoom level then -- generates (x,y) points to be placed on the Image.-pixelPosForCoord :: (Lon a, Lat a, Integral t) => [a] -> TileCoords -> Int -> (t, t)-pixelPosForCoord [] _ _ = (0,0)-pixelPosForCoord [wpt] tCoord zoom =-             let lat' = value $ lat wpt-                 lon' = value $ lon wpt-                 tile = maximum $ tileNumbers lat' lon' zoom-                 xoffset = (fst tile - minX tCoord) * 256-                 yoffset = (snd tile - minY tCoord) * 256+pixelPosForCoord :: (Coordinate a, Integral t) => a -> TileCoords -> Zoom -> (t, t)+pixelPosForCoord wpt tCoord zoom =+             let lat' = lat wpt+                 lon' = lon wpt+                 tile = tileNumbers' lat' lon' zoom+                 xoffset = (fst tile - fromIntegral (minX tCoord)) * 256+                 yoffset = (snd tile - fromIntegral (minY tCoord)) * 256                  (south,west,north,east) = (uncurry project tile zoom)-                 x = round $ (lon' - west) * 256.0 / (east - west) + fromIntegral xoffset-                 y = round $ (lat' - north) * 256.0 / (south - north) + fromIntegral yoffset+                 x = round $ (lon' - west) * 256.0 / (east - west) + xoffset+                 y = round $ (lat' - north) * 256.0 / (south - north) + yoffset              in (x,y)  -- | The suggested copyright text in accordance with@@ -139,17 +234,175 @@ -- The returned files should all be in an approriate grid for row/column display. -- See the test files of Main.hs and Main2.hs for examples of Repa stiching tiles -- into a single image or side by side display of individual tiles.-downloadBestFitTiles :: (Lat a, Lon a) => String -> [a] -> IO [[B.ByteString]]+downloadBestFitTiles :: (Coordinate a) => String -> [a] -> IO [[Either Status B.ByteString]] downloadBestFitTiles base points = do+  let (coords,zoom) = bestFitCoordinates points+      tids = selectedTiles coords+  downloadTiles base zoom tids++bestFitCoordinates :: (Coordinate a) => [a] -> (TileCoords, Zoom)+bestFitCoordinates points =    let tiles = determineTileCoords points 16       zoom = fmap zoomCalc tiles       tiles' = join               . fmap (determineTileCoords points)              $ zoom-  case tiles' of-     Nothing -> return []-     Just coord -> -         let tids = selectedTiles coord-         in concatMapM (downloadTiles base tids) (maybeToList zoom)+  in case (tiles',zoom) of+      (Just coord, Just z) -> (coord,z)+      _                    -> (TileCoords 0 0 0 0,0) -concatMapM f = liftM concat . mapM f++-- |The cacheing operations run in their own monad that describe the+-- location of the cache, the tile server URL, and the worker threads+-- the retrieve tiles.+data OSMConfig = OSMCfg+                { baseUrl      :: String+                , cache       :: FilePath                  -- ^ Path of the tile cache+                , noCacheAction :: Maybe (TileID -> Zoom -> IO (Either Status B.ByteString))+                                                           -- ^ Action to take if the tile is not cached.+                                                           --   Return 'Just' val for a default value.+                                                           --   Return 'Nothing' to wait for a tile server.+                , nrQueuedDownloads     :: Int             -- ^ Max download queue size+                , nrConcurrentDownloads :: Int             -- ^ Number of threads the tile downloading+                                                           --   can concurrently run in.  Tileserver+                                                           --   admins request this be no more than 2.+                , networkEnabled :: Bool                   -- ^ True if we should use the network to+                                                           -- download Tiles+                }++-- |The OSM operations maintain a list of tiles needing refreshed (for+-- local caching), the state of the local cache, and initial+-- configuration options.+data OSMState = OSMSt +                { acid        :: AcidState TileCache+                , neededTiles :: TBChan (TileID,Zoom)+                , cfg         :: OSMConfig }++-- |A Monad transformer allowing you acquire OSM maps+newtype OSM m a = OSM { runOSM :: StateT OSMState m a }+         deriving (Monad, MonadTrans, MonadState OSMState)++instance (MonadIO m) => MonadIO (OSM m) where+  liftIO = lift . liftIO++-- |evalOSM allows you to query an OSM server and the local cache.+-- Take note - the 'OSMConfig' thread limit is enforced per-evalOSM.+-- Running many evalOSM processes can result in a violation of the+-- limit and incur admin wrath.+evalOSM :: MonadIO m => OSM m a -> OSMConfig -> m a+evalOSM m cfg = do+  tc <- liftIO $ newTBChanIO (nrQueuedDownloads cfg)+  acid <- liftIO $ openLocalStateFrom (cache cfg) (TC M.empty)+  liftIO $ mapM_ forkIO $ replicate (nrConcurrentDownloads cfg) (monitorTileQueue cfg acid tc)+  let s = OSMSt acid tc cfg+  evalStateT (runOSM m) s++-- Pulls requested tiles off the queue, downloads them, and adds them+-- to the cache.  We need to re-check the cache to make sure someone+-- hasn't already inserted it while the item was queued.  We leave the+-- possibility that it is being downloaded in parallel by another+-- 'monitorTileQueue' as acceptable duplication of work.+monitorTileQueue :: OSMConfig -> AcidState TileCache -> TBChan (TileID, Zoom) -> IO ()+monitorTileQueue cfg acid tc = forever $ do+  (t,z) <- atomically $ readTBChan tc+  b <- liftIO $ query acid (QueryTC (t,z))+  case b of+    Nothing -> doDownload t z+    Just (exp,_) -> do+      now <- getCurrentTime+      when (exp < now) (doDownload t z)+ where  +   doDownload t z = do+     let addr = buildUrl cfg t z+     tileE <- downloadTileAndExprTime addr z t+     case tileE of+       Left err -> return ()+       Right (exp,bs)  -> update acid (UpdateTC exp (t,z) bs) >> createCheckpoint acid++-- |A default configuration using the main OSM server as a tile server+-- and a cabal-generated directory for the cache directory+defaultOSMConfig :: IO OSMConfig+defaultOSMConfig = do+  cache <- getDataFileName "TileCache"+  return $ OSMCfg osmTileURL cache Nothing 1024 2 True++buildUrl :: OSMConfig -> TileID -> Zoom -> String+buildUrl cfg t z = urlStr (baseUrl cfg) t z++-- |Like 'downloadBestFitTiles' but uses the cached copies when available.+getBestFitTiles :: (Coordinate a, MonadIO m)+                     => [a] -> OSM m [[Either Status B.ByteString]]+getBestFitTiles cs = do+  let (coords,zoom) = bestFitCoordinates cs+      tids = selectedTiles coords+  getTiles tids zoom++-- |Like 'downloadTiles' but uses the cached copies when available+getTiles :: (MonadIO m)+            => [[TileID]] +            -> Zoom +            -> OSM m [[Either Status B.ByteString]]+getTiles ts z = mapM (mapM (\t -> getTile t z)) ts++downloadTileAndExprTime ::    String +                           -> Zoom +                           -> TileID +                           -> IO (Either Status (UTCTime,B.ByteString))+downloadTileAndExprTime base z t = do+  res <- runResourceT $ newManager >>= \m -> downloadTile' m base z t+  case res of+    Right (hdrs,bs) -> do+      now <- getCurrentTime+      let maxSec = cacheLength hdrs+          delTime = addUTCTime (fromIntegral maxSec) now+      return $ Right (delTime,bs)+    Left e -> return (Left e)++-- |Like 'downloadTile' but uses a cached copy when available.+-- Downloaded copies are added to the cache.+-- +-- When the cached copy is out of date it will still be returned but a+-- new copy will be downloaded and added to the cache concurrently.+getTile :: (MonadIO m) => TileID -> Zoom -> OSM m (Either Status B.ByteString)+getTile t zoom = do+  st  <- gets acid+  ch  <- gets neededTiles+  nca <- gets (noCacheAction . cfg)+  b <- liftIO $ query st (QueryTC (t,zoom))+  case b of+    Nothing -> do+      case nca of+        Nothing  -> blockingTileDownloadUpdateCache+        Just act -> liftIO $ do+          atomically $ writeTBChan ch (t,zoom)+          act t zoom+    Just (expTime,x)  -> do+      liftIO $ do+         now <- getCurrentTime+         let exp = expTime < now+         when exp (atomically (tryWriteTBChan ch (t,zoom)) >> return ())+      return (Right x)+  where+    blockingTileDownloadUpdateCache = do+      st  <- gets acid+      net <- gets (networkEnabled . cfg)+      base <- gets (baseUrl . cfg)+      if net +       then do+        res <- liftIO $ downloadTileAndExprTime base zoom t+        case res of+           Right (delTime,bs) -> do+             liftIO $ do+               update st (UpdateTC delTime (t,zoom) bs)+               createCheckpoint st+             return (Right bs)+           Left err -> return (Left err)+       else return (Left statusServiceUnavailable)++-- | Determine the lenth of time to cache an HTTP response (in seconds)+cacheLength :: ResponseHeaders -> Int+cacheLength hdrs =+  let v = lookup "Cache-Control" hdrs+      c = fmap parseSimpleQuery v+      age = join . fmap (lookup "max-age") $ c+  in fromMaybe (7 * 24 * 60 * 60) (fmap (read . filter isDigit . ('0' :) . BC.unpack) $ age)

@@ -1,58 +1,36 @@--- osm-download.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.--- The name of the package. Name:                osm-download---- The package version. See the Haskell package versioning policy--- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for--- standards guiding when and how versions should be incremented.-Version:             0.1.2---- A short (one-line) description of the package.+Version:             0.2 Synopsis:            Download Open Street Map tiles---- A longer description of the package.--- Description:         ---- The license under which the package is released.+Description:         Download and locally cache open street map tiles based on HTTP+                     cache control headers. License:             BSD3---- The file containing the license text. License-file:        LICENSE---- The package author(s). Author:              Rob Stewart, Thomas M. DuBuisson---- An email address to which users can send suggestions, bug reports,--- and patches. Maintainer:          Thomas.DuBuisson@gmail.com---- A copyright notice.--- Copyright:           -+-- Copyright: Category:            Network- Build-type:          Simple---- Extra files to be distributed with the package, such as examples or--- a README. -- Extra-source-files:  ---- Constraint on the version of Cabal needed to build this package.-Cabal-version:       >=1.2-+Cabal-version:       >=1.6  Library-  -- Modules exported by the library.   Exposed-modules:     Network.OSM-  -  -- Packages needed in order to build this package.-  Build-depends:       base >= 4 && < 5, http-conduit, bytestring, gps-  -  -- Modules not exported by this package.-  -- Other-modules:       -  +  Build-depends:       base >= 4 && < 5+                     , conduit >= 0.0 && < 0.1+                     , http-conduit >= 1.1 && < 1.2+                     , http-types >= 0.6 && < 0.7+                     , bytestring, gps >= 1.0.1 && < 1.1+                     , containers >= 0.3 && < 0.5+                     , acid-state >= 0.6 && < 0.7+                     , safecopy >= 0.6 && < 0.7+                     , mtl >= 2.0 && < 2.1+                     , transformers-base >= 0.4 && < 0.5+                     , transformers >= 0.2 && < 0.3+                     , time >= 1.2 && < 1.3+                     , stm >= 2.2 && < 2.3 +                     , monadIO >= 0.10 && < 0.11+                     , stm-chans >= 1.2 && < 1.3+  Other-modules:      Paths_osm_download    -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools: