module Network.OSM
(
TileID(..)
, TileCoords(..)
, Zoom
, OSMConfig(..)
, OSMState
, OSM
, evalOSM
, getBestFitTiles
, getTiles
, getTile
, defaultOSMConfig
, downloadBestFitTiles
, downloadTiles
, downloadTile
, osmTileURL
, Frame(..)
, selectTilesForFrame
, tileCoordsForFrame
, point2pixel
, pixel2point
, getFrameHeight
, tile2point
, point2tile
, pixelPosForCoord
, coordForPixelPos
, 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 Geo.Computations
import Data.Maybe
import Data.Word
import Network.HTTP.Conduit
import Network.HTTP.Types ( Status, ok200, ResponseHeaders
, parseSimpleQuery, serviceUnavailable503)
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 System.Directory
import Paths_osm_download
import qualified Data.ByteString.Char8 as BC
import qualified Data.Map as M
import qualified Control.Exception as X
import Debug.Trace
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"
point2tile :: Point -> Zoom -> TileID
point2tile a z =
let t = pntLat a
g = pntLon a
(x,y) = point2tileRaw t g z
in TID (floor x, floor y)
point2tileRaw :: Double -> Double -> Zoom -> (Double,Double)
point2tileRaw 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
tile2point :: TileID -> Zoom -> Point
tile2point (TID (fromIntegral -> x, fromIntegral -> y)) zoom =
let n = 2^zoom
lon_deg = x / n * 360 180
lat_rad = atan ( sinh ( pi * (1 2 * y / n)))
in pt (lat_rad * 180/pi) lon_deg Nothing Nothing
data Frame = Frame { width,height :: Int
, center :: Point
, frameZoom :: Zoom
} deriving (Eq, Ord, Show, Read)
selectTilesForFrame :: Frame -> [[TileID]]
selectTilesForFrame (Frame w h center z) =
let (x,y) = point2tileRaw (pntLat center) (pntLon 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] ]
getFrameHeight :: Frame -> Int
getFrameHeight f = 256 * length (selectTilesForFrame f)
tileCoordsForFrame :: Frame -> 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
}
point2pixel :: Frame -> Point -> (Int,Int)
point2pixel frm q =
let coords = tileCoordsForFrame frm
(x,y') = pixelPosForCoord q coords (frameZoom frm)
in (x, y')
pixel2point :: Frame -> (Int,Int) -> Point
pixel2point frm q =
let coords = tileCoordsForFrame frm
in coordForPixelPos q coords (frameZoom frm)
determineTileCoords :: [Point] -> Zoom -> Maybe TileCoords
determineTileCoords [] _ = Nothing
determineTileCoords wpts z =
let (xs,ys) = unzip $ map (\p -> point2tileRaw (pntLat p) (pntLon p) 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 = urlStr base t zoom
url' <- liftBase (parseUrl url)
rsp <- httpLbs url' man
if (responseStatus rsp) == ok200
then return (Right (responseHeaders rsp, packIt (responseBody rsp)))
else return (Left $ responseStatus rsp)
pixelPosForCoord :: Integral t => Point -> TileCoords -> Zoom -> (t, t)
pixelPosForCoord wpt (TileCoords {..}) zoom =
let lat' = pntLat wpt
lon' = pntLon wpt
tile@(tx,ty) = point2tileRaw lat' lon' zoom
xoffset = (tx fromIntegral minX) * 256
yRange = fromIntegral $ maxY minY
yoffset = (ty fromIntegral minY) * 256 ( 1 (ty fromIntegral (floor ty))) * 256
in trace ("lat: " ++ show lat' ++ "\tlon: " ++ show lon' ++ "\ntx: " ++ show tx ++ "\tty: " ++ show ty ++ "\nminX: " ++ show minX ++ "\t minY: " ++ show minY ++ "\nmaxX: " ++ show maxX ++ "\tmaxY: " ++ show maxY ++ "\nxoffset: " ++ show xoffset ++ "\tyoffset: " ++ show yoffset) (truncate xoffset, truncate yoffset)
coordForPixelPos :: Integral t => (t,t) -> TileCoords -> Zoom -> Point
coordForPixelPos (fromIntegral -> x,fromIntegral -> y) (TileCoords{..}) zoom =
let lon = x * (east west) / 256 + west
lat = y * (south north) / 256 + north
tx = x/256 + fromIntegral minX
ty = y/256 + fromIntegral minY
in pt lat lon Nothing Nothing
osmCopyrightText :: String
osmCopyrightText = "Tile images © OpenStreetMap (and) contributors, CC-BY-SA"
downloadBestFitTiles :: String -> [Point] -> IO [[Either Status B.ByteString]]
downloadBestFitTiles base points = do
let (coords,zoom) = bestFitCoordinates points
tids = selectedTiles coords
downloadTiles base zoom tids
bestFitCoordinates :: [Point] -> (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
tileE <- downloadTileAndExprTime (baseUrl cfg) 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
getDataDir >>= createDirectoryIfMissing True
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 :: [Point] -> 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 serviceUnavailable503)
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)