module Database.Mbtiles
(
MbtilesT
, Mbtiles
, MbtilesMeta
, MBTilesError(..)
, Z(..)
, X(..)
, Y(..)
, runMbtilesT
, runMbtiles
, getTile
, writeTile
, writeTiles
, updateTile
, updateTiles
, getMetadata
, getName
, getType
, getVersion
, getDescription
, getFormat
) where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import qualified Data.ByteString.Lazy as BL
import Data.HashMap.Strict ((!))
import qualified Data.HashMap.Strict as M hiding ((!))
import Data.Monoid
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
mkMbtilesData c d =
MbtilesData <$>
openStmt c getTileQuery <*>
pure c <*>
pure d
closeAll MbtilesData{r = rs, conn = c} =
closeStmt rs >> closeConn c
type ValidationResult = (Connection, MbtilesMeta)
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 -> Mbtiles 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
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, z, y, toTile t)) ts
findMeta :: Text -> MbtilesMeta -> Text
findMeta t m = m ! t