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