module Network.OSM
(
TileID(..)
, TileCoords(..)
, Zoom
, OSMConfig(..)
, OSMState
, OSM
, evalOSM
, getBestFitTiles
, getTiles
, getTile
, defaultOSMConfig
, downloadBestFitTiles
, downloadTiles
, downloadTile
, osmTileURL
, Frame(..)
, selectTilesForFrame
, tileCoordsForFrame
, pixelPositionForFrame
, pixelPosForCoord
, determineTileCoords
, selectedTiles
, osmCopyrightText
)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 Data.Default
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 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.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
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, Read, Data, Typeable)
derivePersistField "TileID"
tileNumber :: (Coordinate a) => a -> Zoom -> (Double, Double)
tileNumber a z =
let t = lat a
g = lon a
in tileNumbers' t g z
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)
where
secant :: Floating a => a -> a
secant a = 1 / cos a
data Frame a = Frame { width,height :: Int
, center :: a
, frameZoom :: Zoom
} deriving (Eq, Ord, Show, Read)
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)
in [ [ TID (xp, yp) | xp <- [truncate x nrColumns2..truncate x + nrColumns2]]
| yp <- [truncate y nrRows2..truncate y + nrRows2] ]
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
}
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)
determineTileCoords :: (Coordinate a) => [a] -> Zoom -> Maybe TileCoords
determineTileCoords [] _ = Nothing
determineTileCoords wpts z =
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'
}
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 <- liftIO $ newManager def
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 <- liftIO $ newManager def
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@(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)
osmCopyrightText :: String
osmCopyrightText = "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 :: Text
, noCacheAction :: Maybe (TileID -> Zoom -> IO (Either Status B.ByteString))
, nrQueuedDownloads :: Int
, nrConcurrentDownloads :: Int
, networkEnabled :: Bool
}
data OSMState = OSMSt
{ neededTiles :: TBChan (TileID,Zoom)
, dbPool :: ConnectionPool
, cfg :: OSMConfig }
newtype OSM a = OSM { runOSM :: StateT OSMState IO a }
deriving (Monad, MonadState OSMState)
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 = return . Left . (id :: X.SomeException -> X.SomeException)
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)
liftIO $ mapM_ forkIO $ replicate (nrConcurrentDownloads cfg) (monitorTileQueue cfg tc conn)
let s = OSMSt tc conn cfg
evalStateT (runOSM m) s
monitorTileQueue :: OSMConfig -> TBChan (TileID, Zoom) -> ConnectionPool -> IO ()
monitorTileQueue cfg tc p = forever (X.catch go hdl)
where
hdl :: X.SomeException -> IO ()
hdl err = return ()
go :: IO ()
go = do
(t,z) <- atomically $ readTBChan tc
b <- runSqlPool (getBy (TileCacheID t z)) p
case b of
Nothing -> doDownload t z
Just (Entity _ (TileEntry _ _ exp _)) -> do
now <- liftIO getCurrentTime
when (exp < now) (doDownload t z)
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) -> runSqlPool (insertBy (TileEntry t z exp bs) >> return ()) p
defaultOSMConfig :: IO OSMConfig
defaultOSMConfig = do
cache <- getDataFileName "TileCache"
return $ OSMCfg osmTileURL (T.pack cache) Nothing 64 2 True
buildUrl :: OSMConfig -> TileID -> Zoom -> String
buildUrl cfg t z = urlStr (baseUrl cfg) t z
getBestFitTiles :: (Coordinate a)
=> [a] -> OSM [[Either Status B.ByteString]]
getBestFitTiles cs = do
let (coords,zoom) = bestFitCoordinates cs
tids = selectedTiles coords
getTiles tids zoom
getTiles :: [[TileID]]
-> Zoom
-> OSM [[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 $ liftIO (newManager def) >>= \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 :: TileID -> Zoom -> OSM (Either Status B.ByteString)
getTile t zoom = do
ch <- gets neededTiles
p <- gets dbPool
nca <- gets (noCacheAction . cfg)
b <- runDB $ getBy (TileCacheID t zoom)
case b of
Nothing -> do
case nca of
Nothing -> blockingTileDownloadUpdateCache
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
net <- gets (networkEnabled . cfg)
base <- gets (baseUrl . cfg)
p <- gets dbPool
if net
then do
res <- liftIO $ downloadTileAndExprTime base zoom t
case res of
Right (delTime,bs) -> do
runDB (insertBy (TileEntry t zoom delTime bs) >> return ())
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)