osm-download 0.2 → 0.3

raw patch · 2 files changed

+182/−123 lines, 2 filesdep +data-defaultdep +monad-controldep +persistentdep −acid-statedep −safecopydep ~bytestringdep ~conduitdep ~http-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default, monad-control, persistent, persistent-sqlite, persistent-template, pool-conduit, text

Dependencies removed: acid-state, safecopy

Dependency ranges changed: bytestring, conduit, http-conduit

API changes (from Hackage documentation)

Files

• Network/OSM.hs +170/−117
• osm-download.cabal +12/−6

@@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable,-    FlexibleInstances, MultiParamTypeClasses, OverloadedStrings -    , GeneralizedNewtypeDeriving, FlexibleContexts #-}+    FlexibleInstances, MultiParamTypeClasses, OverloadedStrings+    , GeneralizedNewtypeDeriving, FlexibleContexts+    , QuasiQuotes, GADTs, UndecidableInstances #-} module Network.OSM   (  -- * Basic Types     TileID(..)@@ -21,13 +22,17 @@   , downloadTiles   , downloadTile   , osmTileURL+  -- * Frame-oriented operations+  , Frame(..)+  , selectTilesForFrame+  , tileCoordsForFrame+  , pixelPositionForFrame   -- * Helper Functions   , pixelPosForCoord-  , selectTilesWithFixedDimensions   , determineTileCoords   , selectedTiles   -- * Legal-  , copyrightText+  , osmCopyrightText   )where  import Control.Monad@@ -41,6 +46,7 @@ import Network.HTTP.Conduit import Network.HTTP.Types ( Status, statusOK, ResponseHeaders                           , parseSimpleQuery, statusServiceUnavailable)+import Data.Default  -- For the cacheing import Control.Concurrent.MonadIO (forkIO)@@ -49,17 +55,24 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (ask) import Control.Monad.State-import Data.Acid+import Control.Monad.Trans.Control+import Database.Persist+import Database.Persist.Sqlite hiding (get)+import Database.Persist.TH+import Database.Sqlite (Error) import Data.Char (isDigit) import Data.Conduit import Data.Data-import Data.SafeCopy+import Data.Text (Text)+import qualified Data.Text as T import Data.Time import Data.Typeable import Paths_osm_download import qualified Data.ByteString.Char8 as BC import qualified Data.Map as M+import qualified Control.Exception as X +-- FIXME zoom should be a newtype with Num instance that saturates (doesn't over/under flow) type Zoom = Int  -- | The official OSM tile server.@@ -71,83 +84,100 @@ -- using 'selectedTiles' before final download with 'downloadTiles'. data TileCoords = TileCoords                      { minX :: Int-                     , maxX :: Int  -                     , minY :: Int  -                     , maxY :: Int +                     , maxX :: Int+                     , minY :: Int+                     , maxY :: Int                      } deriving (Eq, Ord, Show)  -- |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+newtype TileID = TID { unTID :: (Int, Int) } deriving (Eq, Ord, Show, Read, Data, Typeable) -$(deriveSafeCopy 1 'base ''TileID)-$(deriveSafeCopy 1 'base ''TileCache)-$(makeAcidic ''TileCache ['updateTC, 'queryTC])+derivePersistField "TileID" -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]+tileNumber :: (Coordinate a) => a -> Zoom -> (Double, Double)+tileNumber a z =+  let t = lat a+      g = lon a+  in tileNumbers' t g z  -- |OSM defined method of converting a coordinate and zoom level to a tile tileNumbers' :: Double -> Double -> Zoom -> (Double,Double)-tileNumbers' latitude longitude zoom = +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) * n              in (xtile,ytile)+ where+  secant :: Floating a => a -> a+  secant a = 1 / cos a -secant :: Floating a => a -> a-secant a = 1 / cos a+-- A frame is a point of view including the number of pixels+-- (width,height), center, and zoom.  All pixel positions with respect+-- to a frame are from the lower left corner of the lower left tile of+-- the grid that displays the frame.+data Frame a = Frame { width,height :: Int+                     , center       :: a+                     , frameZoom    :: Zoom+                     } deriving (Eq, Ord, Show, Read) --- |Given a width, height and center, compute the tiles needed to fill the display+-- |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 =+selectTilesForFrame :: (Coordinate a) => Frame a -> [[TileID]]+selectTilesForFrame (Frame 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] ] +  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! +tileCoordsForFrame :: (Coordinate a) => Frame a -> TileCoords+tileCoordsForFrame frm =+  let (xs,ys) = unzip . map unTID . concat . selectTilesForFrame $ frm+  in TileCoords+     { maxX = maximum xs+     , minX = minimum xs+     , maxY = maximum ys+     , minY = minimum ys+     }++-- Gives the position of the coordinate in the frame with the origin as+-- the lower left (note this is different from the lower level operations!)+pixelPositionForFrame :: (Coordinate a) => Frame a -> a -> (Int,Int)+pixelPositionForFrame frm q =+  let coords = tileCoordsForFrame frm+      (x,y') = pixelPosForCoord q coords (frameZoom frm)+  in (x + 128, y' + 128)+     -- FIXME ^^^ I'm not sure why it's off by half a tile in each dimension+ -- |Computes the rectangular map region to download based on GPS points and a zoom level determineTileCoords :: (Coordinate a) => [a] -> Zoom -> Maybe TileCoords determineTileCoords [] _ = Nothing determineTileCoords wpts z =-    let (xs,ys) = unzip $ concatMap (\w -> tileNumbers (lat w) (lon w) z) wpts+    let (xs,ys) = unzip $ map (flip tileNumber z) wpts+        xs' = map truncate xs+        ys' = map truncate ys     in Just $ TileCoords-         { maxX = maximum xs-         , minX = minimum xs-         , maxY = maximum ys-         , minY = minimum ys+         { maxX = maximum xs'+         , minX = minimum xs'+         , maxY = maximum ys'+         , minY = minimum ys'          }  maxNumAutoTiles = 32 +-- Computes a reasonable zoom level for the given tile coordinates+-- Resulting zoom levles are always <= 16!+--+-- Basically, zooms out until there will be less than 'maxNumAutoTiles' tiles. zoomCalc :: TileCoords -> Zoom-zoomCalc tCoords = +zoomCalc tCoords =    let numxtiles = maxX tCoords - minX tCoords + 1        numytiles = maxY tCoords - minY tCoords + 1        div = getZoomDiv numxtiles numytiles 0@@ -171,13 +201,13 @@ -- side-by-side display. downloadTiles :: String -> Zoom -> [[TileID]] -> IO [[Either Status B.ByteString]] downloadTiles base zoom ts = runResourceT $ do-  man <- newManager+  man <- liftIO $ newManager def   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+  man <- liftIO $ newManager def   liftM (fmap snd) (downloadTile' man base zoom t)  downloadTile' :: Manager -> String -> Zoom -> TileID -> ResourceT IO (Either Status (ResponseHeaders,B.ByteString))@@ -194,7 +224,7 @@  -- | Used by @pixelPosForCoord@ for N,S,E,W coordinates for (x,y) values project :: Double -> Double -> Zoom -> (Double,Double,Double,Double)-project x y zoom = +project x y zoom =   let unit = 1.0 / (2.0 ** fromIntegral zoom)       rely1 = y * unit       rely2 = rely1 + unit@@ -207,25 +237,26 @@       unit' = 360.0 / (2.0 ** fromIntegral zoom)       long1 = (-180.0) + x * unit'   in (lat2,long1,lat1,long1+unit') -- S,W,N,E-  + -- | Takes a coordinate, the OSM tile boundaries, and a zoom level then--- generates (x,y) points to be placed on the Image.+-- generates (x,y) points to be placed on the Image. The origin is+-- in the upper left of the picture. 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) + xoffset-                 y = round $ (lat' - north) * 256.0 / (south - north) + yoffset-             in (x,y)+  let lat' = lat wpt+      lon' = lon wpt+      tile@(tx,ty) = tileNumbers' lat' lon' zoom+      xoffset = (tx - fromIntegral (minX tCoord)) * 256+      yoffset = (ty - fromIntegral (minY tCoord)) * 256+      (south,west,north,east) = (uncurry project tile zoom)+      x = truncate $ (lon' - west) * 256.0  / (east - west)   + xoffset+      y = truncate $ (lat' - north) * 256.0 / (south - north) + yoffset+  in (x,y)  -- | The suggested copyright text in accordance with -- <http://wiki.openstreetmap.org/wiki/Legal_FAQ>-copyrightText :: String-copyrightText = "Tile images © OpenStreetMap (and) contributors, CC-BY-SA"+osmCopyrightText :: String+osmCopyrightText = "Tile images © OpenStreetMap (and) contributors, CC-BY-SA"  -- | Takes the tile server base URL, -- the set of coordinates that must appear within the map boundaries, and users@@ -241,10 +272,10 @@   downloadTiles base zoom tids  bestFitCoordinates :: (Coordinate a) => [a] -> (TileCoords, Zoom)-bestFitCoordinates points = +bestFitCoordinates points =   let tiles = determineTileCoords points 16       zoom = fmap zoomCalc tiles-      tiles' = join +      tiles' = join              . fmap (determineTileCoords points)              $ zoom   in case (tiles',zoom) of@@ -257,7 +288,7 @@ -- the retrieve tiles. data OSMConfig = OSMCfg                 { baseUrl      :: String-                , cache       :: FilePath                  -- ^ Path of the tile cache+                , cache       :: Text                      -- ^ 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.@@ -273,28 +304,49 @@ -- |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)+data OSMState = OSMSt+                { neededTiles :: TBChan (TileID,Zoom)+                , dbPool      :: ConnectionPool                 , 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)+newtype OSM a = OSM { runOSM :: StateT OSMState IO a }+         deriving (Monad, MonadState OSMState) -instance (MonadIO m) => MonadIO (OSM m) where-  liftIO = lift . liftIO+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|+TileEntry+    tileID TileID+    zoom   Zoom+    tileExpiration UTCTime+    tileData B.ByteString+    TileCacheID tileID zoom+|] +instance MonadIO OSM where+  liftIO = OSM . liftIO++runDB :: SqlPersist IO a -> OSM a+runDB f = do+  p <- gets dbPool+  v <- liftIO (X.catch (liftM Right $ runSqlPool f p) hdl)+  case v of+   Left e -> runDB f+   Right x -> return x+ where+  -- hdl :: Error -> IO (Either Error a)+  hdl = return . Left . (id :: X.SomeException -> X.SomeException)+ -- |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+evalOSM :: OSM a -> OSMConfig -> IO a+evalOSM m cfg = withSqlitePool (cache cfg) (2 * (nrConcurrentDownloads cfg + 1))+  $ \conn -> do+  runSqlPool (runMigration migrateAll) conn   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+  liftIO $ mapM_ forkIO $ replicate (nrConcurrentDownloads cfg) (monitorTileQueue cfg tc conn)+  let s = OSMSt tc conn cfg   evalStateT (runOSM m) s  -- Pulls requested tiles off the queue, downloads them, and adds them@@ -302,54 +354,58 @@ -- 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+monitorTileQueue :: OSMConfig -> TBChan (TileID, Zoom) -> ConnectionPool -> IO ()+monitorTileQueue cfg tc p = forever (X.catch go hdl)+ where+ hdl :: X.SomeException {- Error -} -> IO ()+ hdl err = return () -- Silently ignore SQL errors (usually ErrorBusy)+ go :: IO ()+ go = do   (t,z) <- atomically $ readTBChan tc-  b <- liftIO $ query acid (QueryTC (t,z))+  b     <- runSqlPool (getBy (TileCacheID t z)) p   case b of     Nothing -> doDownload t z-    Just (exp,_) -> do-      now <- getCurrentTime+    Just (Entity _ (TileEntry _ _ exp _)) -> do+      now <- liftIO getCurrentTime       when (exp < now) (doDownload t z)- where  -   doDownload t z = do+ doDownload :: TileID -> Zoom -> IO ()+ 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+       Right (exp,bs)  -> runSqlPool (insertBy (TileEntry t z exp bs) >> return ()) p  -- |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+  return $ OSMCfg osmTileURL (T.pack cache) Nothing 64 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 :: (Coordinate a)+                     => [a] -> OSM [[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 :: [[TileID]]+         -> Zoom+         -> OSM [[Either Status B.ByteString]] getTiles ts z = mapM (mapM (\t -> getTile t z)) ts -downloadTileAndExprTime ::    String -                           -> Zoom -                           -> TileID +downloadTileAndExprTime ::    String+                           -> Zoom+                           -> TileID                            -> IO (Either Status (UTCTime,B.ByteString)) downloadTileAndExprTime base z t = do-  res <- runResourceT $ newManager >>= \m -> downloadTile' m base z t+  res <- runResourceT $ liftIO (newManager def) >>= \m -> downloadTile' m base z t   case res of     Right (hdrs,bs) -> do       now <- getCurrentTime@@ -360,41 +416,38 @@  -- |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 :: TileID -> Zoom -> OSM (Either Status B.ByteString) getTile t zoom = do-  st  <- gets acid   ch  <- gets neededTiles+  p   <- gets dbPool   nca <- gets (noCacheAction . cfg)-  b <- liftIO $ query st (QueryTC (t,zoom))+  b   <- runDB $ getBy (TileCacheID 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 ())+        Just act -> do+          liftIO $ atomically $ tryWriteTBChan ch (t,zoom)+          liftIO $ act t zoom+    Just (Entity _ (TileEntry _ _ expTime x))  -> do+      now <- liftIO getCurrentTime+      let exp = expTime < now+      when exp (liftIO $ atomically (tryWriteTBChan ch (t,zoom)) >> return ())       return (Right x)   where     blockingTileDownloadUpdateCache = do-      st  <- gets acid-      net <- gets (networkEnabled . cfg)+      net  <- gets (networkEnabled . cfg)       base <- gets (baseUrl . cfg)-      if net +      p    <- gets dbPool+      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+             runDB (insertBy (TileEntry t zoom delTime bs) >> return ())              return (Right bs)            Left err -> return (Left err)        else return (Left statusServiceUnavailable)

@@ -1,5 +1,5 @@ Name:                osm-download-Version:             0.2+Version:             0.3 Synopsis:            Download Open Street Map tiles Description:         Download and locally cache open street map tiles based on HTTP                      cache control headers.@@ -16,13 +16,16 @@ Library   Exposed-modules:     Network.OSM   Build-depends:       base >= 4 && < 5-                     , conduit >= 0.0 && < 0.1-                     , http-conduit >= 1.1 && < 1.2+                     , conduit >= 0.2 && < 0.3+                     , pool-conduit >= 0.0.0.1+                     , http-conduit >= 1.2 && < 1.3                      , http-types >= 0.6 && < 0.7-                     , bytestring, gps >= 1.0.1 && < 1.1+                     , bytestring >= 0.8 && < 1.0+                     , gps >= 1.0.1 && < 1.1                      , containers >= 0.3 && < 0.5-                     , acid-state >= 0.6 && < 0.7-                     , safecopy >= 0.6 && < 0.7+                     , persistent-sqlite >= 0.8 && < 0.9+                     , persistent-template >= 0.8 && < 0.9+                     , persistent >= 0.8 && < 0.9                      , mtl >= 2.0 && < 2.1                      , transformers-base >= 0.4 && < 0.5                      , transformers >= 0.2 && < 0.3@@ -30,6 +33,9 @@                      , stm >= 2.2 && < 2.3                       , monadIO >= 0.10 && < 0.11                      , stm-chans >= 1.2 && < 1.3+                     , text >= 0.11 && < 0.12+                     , monad-control >= 0.3 && < 0.4+                     , data-default >= 0.3 && < 0.4   Other-modules:      Paths_osm_download    -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools: