diff --git a/Network/OSM.hs b/Network/OSM.hs --- a/Network/OSM.hs +++ b/Network/OSM.hs @@ -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) diff --git a/osm-download.cabal b/osm-download.cabal --- a/osm-download.cabal +++ b/osm-download.cabal @@ -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: