module Database.Mbtiles
(
MbtilesT
, MbtilesIO
, MbtilesMeta
, MBTilesError(..)
, Z(..)
, X(..)
, Y(..)
, Tile(..)
, ToTile(..)
, FromTile(..)
, runMbtilesT
, runMbtiles
, MbtilesPool
, getMbtilesPool
, runMbtilesPoolT
, getTile
, writeTile
, writeTiles
, updateTile
, updateTiles
, getMetadata
, getName
, getType
, getVersion
, getDescription
, getFormat
, TileStream
, startTileStream
, endTileStream
, nextTile
) where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Control
import qualified Data.ByteString.Lazy as BL
import Data.HashMap.Strict ((!))
import qualified Data.HashMap.Strict as M hiding ((!))
import Data.Monoid
import Data.Pool
import Data.Text (Text)
import Database.Mbtiles.Query
import Database.Mbtiles.Types
import Database.Mbtiles.Utility
import Database.SQLite.Simple
import System.Directory
runMbtilesT :: (MonadIO m) => FilePath -> MbtilesT m a -> m (Either MBTilesError a)
runMbtilesT mbtilesPath mbt = do
m <- validateMBTiles mbtilesPath
either (return . Left) processMbt m
where
processMbt (c, d) = do
m <- mkMbtilesData c d
v <- runReaderT (unMbtilesT mbt) m
closeAll m
return $ Right v
type MbtilesPool = Pool MbtilesData
getMbtilesPool :: (MonadIO m) => FilePath -> m (Either MBTilesError MbtilesPool)
getMbtilesPool fp = do
m <- validateMBTiles fp
either (return . Left) (fmap Right . liftIO . buildPool) m
where
buildPool (_, d) =
createPool (openConnection d) closeAll 1 900 1000
openConnection d = open fp >>= flip mkMbtilesData d
runMbtilesPoolT :: (MonadBaseControl IO m) => MbtilesPool -> MbtilesT m a -> m a
runMbtilesPoolT p mbt = withResource p (runReaderT (unMbtilesT mbt))
type ValidationResult = (Connection, MbtilesMeta)
closeAll :: (MonadIO m) => MbtilesData -> m ()
closeAll MbtilesData{r = rs, conn = c} =
closeStmt rs >> closeConn c
mkMbtilesData :: (MonadIO m) => Connection -> MbtilesMeta -> m MbtilesData
mkMbtilesData c d =
MbtilesData <$>
openStmt c getTileQuery <*>
pure c <*>
pure d
validateMBTiles :: (MonadIO m) => FilePath -> m (Either MBTilesError ValidationResult)
validateMBTiles mbtilesPath = liftIO $
doesFileExist mbtilesPath >>=
ifExistsOpen >>=
validator schema >>=
validator metadata >>=
validator tiles >>=
validator metadataValues
where
ifExistsOpen False = return $ Left DoesNotExist
ifExistsOpen True = Right <$> open mbtilesPath
schema c = do
valid <- mconcat $ map (fmap All) [doesTableExist c tilesTable, doesTableExist c metadataTable]
if getAll valid then return $ Right c else return $ Left InvalidSchema
metadata = columnChecker metadataTable metadataColumns InvalidMetadata
tiles = columnChecker tilesTable tilesColumns InvalidTiles
metadataValues c = do
m <- getDBMetadata c
if all (`M.member` m) requiredMeta
then return $ Right (c, m)
else return $ Left InvalidMetadata
runMbtiles :: FilePath -> MbtilesIO a -> IO (Either MBTilesError a)
runMbtiles = runMbtilesT
getTile :: (MonadIO m, FromTile a) => Z -> X -> Y -> MbtilesT m (Maybe a)
getTile (Z z) (X x) (Y y) = MbtilesT $ do
rs <- r <$> ask
fmap unwrapTile <$> liftIO (do
bindNamed rs [":zoom" := z, ":col" := x, ":row" := y']
res <- nextRow rs
reset rs
return res)
where unwrapTile (Only bs) = fromTile bs
y' = wrapYTMS (Z z) (Y y)
startTileStream :: (MonadIO m) => MbtilesT m TileStream
startTileStream = MbtilesT $ asks conn >>= liftIO . openTileStream
endTileStream :: (MonadIO m) => TileStream -> MbtilesT m ()
endTileStream = liftIO . closeTileStream
resetTileStream :: (MonadIO m) => TileStream -> MbtilesT m ()
resetTileStream (TileStream ts) = liftIO $ reset ts
nextTile :: (MonadIO m, FromTile a) => TileStream -> MbtilesT m (Maybe (Tile a))
nextTile (TileStream ts) = liftIO $ nextRow ts
getMetadata :: (MonadIO m) => MbtilesT m MbtilesMeta
getMetadata = MbtilesT $ reader meta
getName :: (MonadIO m) => MbtilesT m Text
getName = findMeta "name" <$> getMetadata
getType :: (MonadIO m) => MbtilesT m Text
getType = findMeta "type" <$> getMetadata
getVersion :: (MonadIO m) => MbtilesT m Text
getVersion = findMeta "version" <$> getMetadata
getDescription :: (MonadIO m) => MbtilesT m Text
getDescription = findMeta "description" <$> getMetadata
getFormat :: (MonadIO m) => MbtilesT m Text
getFormat = findMeta "format" <$> getMetadata
writeTile :: (MonadIO m, ToTile a) => Z -> X -> Y -> a -> MbtilesT m ()
writeTile z x y t = writeTiles [(z, x, y, t)]
writeTiles :: (MonadIO m, ToTile a) => [(Z, X, Y, a)] -> MbtilesT m ()
writeTiles = execQueryOnTiles newTileQuery
updateTile :: (MonadIO m, ToTile a) => Z -> X -> Y -> a -> MbtilesT m ()
updateTile z x y t = updateTiles [(z, x, y, t)]
updateTiles :: (MonadIO m, ToTile a) => [(Z, X, Y, a)] -> MbtilesT m ()
updateTiles = execQueryOnTiles updateTileQuery
execQueryOnTiles :: (MonadIO m, ToTile a) => Query -> [(Z, X, Y, a)] -> MbtilesT m ()
execQueryOnTiles q ts = MbtilesT $ do
c <- conn <$> ask
liftIO $
executeMany c q $
map (\(z, x, y, t) -> (z, x, wrapYTMS z y, toTile t)) ts
findMeta :: Text -> MbtilesMeta -> Text
findMeta t m = m ! t