module Network.OSM
(
TileID(..)
, TileCoords(..)
, Zoom
, OSMConfig(..)
, OSMState
, OSM
, evalOSM
, getBestFitTiles
, getTiles
, getTile
, defaultOSMConfig
, downloadBestFitTiles
, downloadTiles
, downloadTile
, osmTileURL
, pixelPosForCoord
, selectTilesWithFixedDimensions
, determineTileCoords
, selectedTiles
, copyrightText
)where
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)
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
osmTileURL :: String
osmTileURL = "http://tile.openstreetmap.org"
data TileCoords = TileCoords
{ minX :: Int
, maxX :: Int
, minY :: Int
, maxY :: Int
} deriving (Eq, Ord, Show)
newtype TileID = TID { unTID :: (Int, Int) } deriving (Eq, Ord, Show, Data, Typeable)
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]
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 = ((1tmp / pi) / 2.0) * n
in (xtile,ytile)
secant :: Floating a => a -> a
secant a = 1 / cos a
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)
in [ [ TID (xp, yp) | xp <- [truncate x nrColumns2..truncate x + nrColumns2]]
| yp <- [truncate y nrRows2..truncate y + nrRows2] ]
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
in Just $ TileCoords
{ maxX = maximum xs
, minX = minimum xs
, maxY = maximum ys
, minY = minimum ys
}
maxNumAutoTiles = 32
zoomCalc :: TileCoords -> Zoom
zoomCalc tCoords =
let numxtiles = maxX tCoords minX tCoords + 1
numytiles = maxY tCoords minY tCoords + 1
div = getZoomDiv numxtiles numytiles 0
in 16 div
getZoomDiv x y i
| (x+1)*(y+1) > maxNumAutoTiles = getZoomDiv (shiftR x 1) (shiftR y 1) (i+1)
| otherwise = i
selectedTiles :: TileCoords -> [[TileID]]
selectedTiles c = map (\j -> [TID (i,j) | i <- [minX c..maxX c]]) [minY c .. maxY c]
urlStr :: String -> TileID -> Zoom -> String
urlStr base (TID (xTile, yTile)) zoom = base ++"/"++show zoom++"/"++show xTile++"/"++show yTile++".png"
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
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
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)
project :: Double -> Double -> Zoom -> (Double,Double,Double,Double)
project x y zoom =
let unit = 1.0 / (2.0 ** fromIntegral zoom)
rely1 = y * unit
rely2 = rely1 + unit
limity = pi
rangey = 2.0 * limity
rely1' = limity rangey * rely1
rely2' = limity rangey * rely2
lat1 = projectMercToLat rely1'
lat2 = projectMercToLat rely2'
unit' = 360.0 / (2.0 ** fromIntegral zoom)
long1 = (180.0) + x * unit'
in (lat2,long1,lat1,long1+unit')
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)
copyrightText :: String
copyrightText = "Tile images © OpenStreetMap (and) contributors, CC-BY-SA"
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
in case (tiles',zoom) of
(Just coord, Just z) -> (coord,z)
_ -> (TileCoords 0 0 0 0,0)
data OSMConfig = OSMCfg
{ baseUrl :: String
, cache :: FilePath
, noCacheAction :: Maybe (TileID -> Zoom -> IO (Either Status B.ByteString))
, nrQueuedDownloads :: Int
, nrConcurrentDownloads :: Int
, networkEnabled :: Bool
}
data OSMState = OSMSt
{ acid :: AcidState TileCache
, neededTiles :: TBChan (TileID,Zoom)
, cfg :: OSMConfig }
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 :: 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
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
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
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
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)
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)
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)