├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app ├── DbAccess.hs ├── Main.hs ├── Md5Worker.hs └── Types.hs ├── cabal.project ├── mapbox-filter.cabal └── src └── Mapbox ├── DownCopy.hs ├── Expression.hs ├── Filters.hs ├── Interpret.hs ├── OldStyleConvert.hs ├── Style.hs └── UntypedExpression.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | 4 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for mapbox-filter 2 | 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Ondrej Palkovsky (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Mapbox-filter - filtering mbtiles file according to Mapbox GL JS styles 2 | 3 | A library that can interpret a subset of the Mapbox style epxression, a very simplified 4 | parser for the Mapbox GL JS style and an executable that can: 5 | 6 | - Dump the tile (.mvt, .pbf files) and show which features will be included given the style file at a particular zoom level. 7 | - Iterate through the `mbtiles` file and filter the tile contents according to the MapBox style, thus making the `mbtiles` file smaller. 8 | - Preprocess attributes with right-to-left (arabic etc.) text fields; as a result the 9 | mapbox-gl rtl plugin can be omitted. 10 | - Run a webserver for 11 | * serving the tiles from the `mbtile` file 12 | * serving the real-time filtered tiles 13 | * after serving a tile saving the compressed tile back to the database (Planetiler database only is currently supported in this mode) 14 | - Publish tiles to S3 so that you don't need to run a webserver at all. As this can 15 | take a very long time, incremental, differential and parallel upload is supported. 16 | 17 | This library supports only a subset of the expression language (https://www.mapbox.com/mapbox-gl-js/style-spec/#expressions-types). 18 | It's because I don't need that and most of the language isn't going to be used in the filter expression anyway. If you need 19 | features that are not implemented yet, create an issue. 20 | 21 | The filtering first executes the filtering expression and removes features that will not 22 | be displayed. Then it removes metadata that is not used in the styles. The removal 23 | process is currently somewhat crude (it retains all metadata used at the particular layer), 24 | but it should be enough for most usecases. 25 | 26 | Currently only the Planetiler mbtile files are supported for `filter` and `publish` commands. 27 | The `web` command should be compatibile with any mbtile file. 28 | 29 | ## How to compile 30 | 31 | 1. Install stack - https://docs.haskellstack.org/en/stable/README/ 32 | 2. `stack setup` 33 | 3. `stack build` 34 | 4. `stack install` - installs binary `mapbox-filter` to ~/.local/bin 35 | 5. or you can run `stack exec -- mapbox-filter` instead without installing 36 | 37 | I have not tested it but it will probably work on Windows as well. 38 | 39 | A special version of `text-icu` library is required. Everything should work correctly 40 | with stack, cabal users need to look into the `stack.yaml` file and install the library 41 | manually. 42 | 43 | ## Moving data from a zoom-level down 44 | 45 | Sometimes it might be desirable to move some data from a higher zoom-level to a lower zoom-level. 46 | The `copy-down` function replaces all data that is matched by the filter from the 47 | destination zoom level with data form one level up. In the following example, 48 | the river data is moved from zoom 9 to zoom 8. 49 | 50 | ``` 51 | { 52 | "dst-zoom": 8, 53 | "source-layer": "waterway", 54 | "filter": [ 55 | "all", 56 | ["==", ["geometry-type"], "LineString"], 57 | ["!=", ["string", ["get", "class"]], "stream"], 58 | [ 59 | "match", 60 | ["string", ["get", "brunnel"], ""], 61 | ["tunnel", "bridge"], 62 | false, 63 | true 64 | ] 65 | ] 66 | } 67 | ``` 68 | 69 | ## Examples 70 | 71 | Show CLI help: 72 | ``` 73 | $ mapbox-filter -h 74 | $ mapbox-filter publish -h 75 | ``` 76 | 77 | Apply the style on all the tiles in the `cz.mbtiles`. The process uses all available CPUs. 78 | You can you use multiple `-j` options to create one file containing data for all styles. 79 | ``` 80 | $ mapbox-filter filter -j mapboxstyle.json cz.mbtiles 81 | ``` 82 | 83 | Serve the mbtiles file. The endpoint for MapBox is: http://server_name:3000/tiles/metadata.json 84 | ``` 85 | $ mapbox-filter web -p 3000 cz.mbtiles 86 | ``` 87 | 88 | Serve the mbtiles file while doing online filtering according to the mapboxstyle.json file. 89 | Pre-process the right-to-left metadata text fields. 90 | ``` 91 | $ mapbox-filter web -p 3000 --rtl-convert -j mapboxstyle.json cz.mbtiles 92 | ``` 93 | 94 | Publish filtered mbtiles to S3. Higher parallelism might be desirable, use the `-p` 95 | parameter to facilitate more parallel uploads to S3. 96 | ``` 97 | $ mapbox-filter publish 98 | -j mapboxstyle.json 99 | -u https://s3.eu-central-1.amazonaws.com/my-test-bucket/styled-map 100 | -t s3://my-test-bucket/styled-map -p 10 cz.mbtiles 101 | ``` 102 | 103 | ## Incremental job 104 | 105 | Unless given the `-f` option, the filtering/publishing remembers roughly the last position 106 | and when restarted, the job starts from the last position. The information is retained in a file 107 | `.mbtiles.SOME_NUMBERS`. When the mbtile file is replaced or the style is changed, 108 | the `SOME_NUMBERS` change and a new full job is forced. 109 | 110 | ## Differential upload 111 | 112 | The S3 is billed by a access request; in order to minimize access costs, the program 113 | automatically creates a file `.mbtile.hashes`. When the publishing is complete, copy 114 | the file manually to S3 to have the information available later. 115 | Upon next job restart (regardless if with or without the `-f` option), you can specify 116 | the hash database with the `--hashes-db` parameter; only the changed tiles will be uploaded or deleted. 117 | A new hashes file will be created. 118 | This should minimize costs upon country updates, when only a minority of the tiles is changed. 119 | 120 | ## Performance considerations 121 | 122 | ### Parallelism and RTS tuning 123 | 124 | The `filter` and `publish` commands by default use as many cores as is available on the computer. 125 | However, sometimes this does not lead to better performance. You can limit the number of cores 126 | with a special RTS (runtime system) command `-N`. It might be also beneficial to tune garbage 127 | collector with the `-A` parameter; you may need to experiment with the settings. 128 | 129 | When publishing directly to S3, the bottleneck is usually the network; in such case it may be 130 | better to use higher parallelism to achieve higher throughput. The following command 131 | will use 16 cores, 80 parallel threads and has an allocation unit set to 1 megabyte: 132 | 133 | ``` 134 | $ mapbox-filter publish -j openmaptiles.json.js -u https://xxx.cloudfront.net/w --rtl-convert -t s3://my-map-bucket/w osm-planet.mbtiles -p80 +RTS -N16 -A1m 135 | ``` 136 | 137 | ### MD5 database tuning 138 | 139 | When publishing the data, a new database of md5 hashes is automatically created to aid with 140 | differential uploads. Unfortunately, the access to the database is serialized. Therefore, 141 | it might be best to run the job in ramdisk. On Linux, this would mean changing directory 142 | somewhere to `tmpfs`, e.g. `/dev/shm`. Create a symlink to the original `mbtiles` file 143 | (e.g. `/dev/shm/world.mbtiles`) and then run the command in the `/dev/shm` directory. 144 | The md5 database will be created on a ramdisk. 145 | 146 | Alternatively, SSD disk or some enterprise storage system with write cache 147 | might be fast enough with more assurance in case of power loss. 148 | 149 | ## What next 150 | 151 | This started as a way to learn typechecking in Haskell and how to make a typed AST using GADTs. 152 | It took about 1 day to make it work and it practically worked on the first try. Haskell is impressive. 153 | Obviously since the first day a lot of functionality and better performance was added. 154 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/DbAccess.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | 11 | module DbAccess where 12 | 13 | import Control.Exception.Safe (MonadThrow, catchAny, throwIO) 14 | import Control.Monad (void, when) 15 | import Control.Monad.IO.Class (MonadIO, liftIO) 16 | import Control.Monad.Reader (MonadReader, ReaderT (..), ask, 17 | asks, runReaderT) 18 | import Data.Maybe (fromMaybe) 19 | import qualified Data.Pool as DP 20 | import qualified Data.Text as T 21 | import Database.SQLite.Simple (Connection, Only (..), 22 | Query (..), execute, 23 | executeMany, execute_, query, 24 | query_, withConnection) 25 | import Database.SQLite.Simple.FromRow (FromRow (..)) 26 | import Database.SQLite.Simple.ToField (ToField (..)) 27 | import Database.SQLite.Simple.ToRow (ToRow (..)) 28 | import UnliftIO (MonadUnliftIO (..)) 29 | 30 | import Md5Worker 31 | import Types 32 | import Data.Foldable (for_) 33 | 34 | class MonadIO m => HasMbConn m where 35 | {-# MINIMAL withMbConn #-} 36 | withMbConn :: (Connection -> m a) -> m a 37 | mbQuery :: (ToRow q, FromRow r) => Query -> q -> m [r] 38 | mbQuery q p = 39 | withMbConn $ \conn -> 40 | liftIO $ query conn q p 41 | mbQuery_ :: FromRow r => Query -> m [r] 42 | mbQuery_ q = 43 | withMbConn $ \conn -> 44 | liftIO $ query_ conn q 45 | 46 | class MonadIO m => HasJobConn m where 47 | {-# MINIMAL getJobConn #-} 48 | getJobConn :: m Connection 49 | jobQuery :: (ToRow q, FromRow r) => Query -> q -> m [r] 50 | jobQuery q p = do 51 | conn <- getJobConn 52 | liftIO $ query conn q p 53 | jobQuery_ :: FromRow r => Query -> m [r] 54 | jobQuery_ q = do 55 | conn <- getJobConn 56 | liftIO $ query_ conn q 57 | jobExecute :: ToRow q => Query -> q -> m () 58 | jobExecute q p = do 59 | conn <- getJobConn 60 | liftIO $ execute conn q p 61 | 62 | 63 | class MonadIO m => HasMd5Queue m where 64 | -- | Return true if there is a change and the tile should be published/saved/etc. 65 | checkHashChanged :: (Zoom, Column, XyzRow) -> Maybe TileData -> m Bool 66 | addHash :: (Zoom, Column, XyzRow) -> Maybe TileData -> m () 67 | 68 | fetchTileTid :: (Monad m, HasMbConn m) => TileId -> m (Maybe TileData) 69 | fetchTileTid tid = do 70 | tres <- mbQuery "select tile_data from tiles_data where tile_data_id=?" (Only tid) 71 | case tres of 72 | [Only tdata] -> return (Just tdata) 73 | _ -> return Nothing 74 | 75 | fetchTileZXY :: (Monad m, HasMbConn m) => (Zoom, Column, TmsRow) -> m (Maybe TileData) 76 | fetchTileZXY (z,x,y) = do 77 | tres <- mbQuery "select tile_data from tiles where zoom_level=? and tile_column=? and tile_row=?" 78 | (z,x,y) 79 | case tres of 80 | [Only tdata] -> return (Just tdata) 81 | _ -> return Nothing 82 | 83 | getZooms :: (Monad m, HasMbConn m) => m [Zoom] 84 | getZooms = 85 | fmap fromOnly <$> mbQuery_ "select distinct zoom_level from tiles_shallow order by zoom_level" 86 | 87 | getTotalCount :: (Monad m, HasMbConn m, MonadFail m) => m Int 88 | getTotalCount = do 89 | [Only total_count] <- mbQuery_ "select count(*) from tiles_shallow" 90 | return total_count 91 | 92 | getColTiles :: (Monad m, HasMbConn m) => Zoom -> Column -> m [(Zoom, Column, TmsRow, TileId)] 93 | getColTiles z x = do 94 | let qry = "select zoom_level,tile_column,tile_row,tile_data_id from tiles_shallow where zoom_level=? AND tile_column=?" 95 | mbQuery qry (z, x) 96 | 97 | getMetaData :: (Monad m, HasMbConn m) => m [(T.Text, String)] 98 | getMetaData = mbQuery_ "select name,value from metadata" 99 | 100 | getDbMtime :: (Monad m, HasMbConn m) => m String 101 | getDbMtime = do 102 | mlines :: [Only String] <- mbQuery_ "select value from metadata where name='mtime'" 103 | case mlines of 104 | [Only res] -> return res 105 | _ -> return "" 106 | 107 | class Monad m => WriteMbTile m where 108 | updateMbtile :: (Zoom, Column, TmsRow, TileId) -> Maybe TileData -> m () 109 | vacuumDb :: m () 110 | 111 | 112 | -- Automatic instance for incremental jobs when db is available 113 | getJobZoomColumns :: (Monad m, HasJobConn m) => Zoom -> m [Column] 114 | getJobZoomColumns z = do 115 | let colquery = "select distinct tile_column from jobs where zoom_level=? order by tile_column" 116 | fmap fromOnly <$> jobQuery colquery (Only z) 117 | 118 | getIncompleteZooms :: (Monad m, HasJobConn m) => m [Zoom] 119 | getIncompleteZooms = fmap fromOnly <$> jobQuery_ "select distinct zoom_level from jobs order by zoom_level" 120 | 121 | getIncompleteColumns :: (Monad m, HasJobConn m) => Zoom -> m [Column] 122 | getIncompleteColumns z = 123 | fmap fromOnly <$> jobQuery "select tile_column from jobs where zoom_level=?" (Only z) 124 | 125 | getIncompleteCount :: (Monad m, HasJobConn m, MonadFail m) => m Int 126 | getIncompleteCount = do 127 | [Only res] <- jobQuery_ "select sum(tile_count) from jobs" 128 | return $ fromMaybe 0 res 129 | 130 | markColumnComplete :: (Monad m, HasJobConn m) => Zoom -> Column -> m () 131 | markColumnComplete z x = jobExecute "delete from jobs where zoom_level=? and tile_column=?" (z,x) 132 | 133 | markErrorTile :: (Monad m, HasJobConn m) => (Zoom, Column, TmsRow, TileId) -> m () 134 | markErrorTile (z,x,y, tid) = 135 | jobExecute "insert or replace into errors (zoom_level,tile_column,tile_row, tile_id) values (?,?,?,?)" (z,x,y, tid) 136 | 137 | getErrorTiles :: (Monad m, HasJobConn m) => m [(Zoom, Column, TmsRow, TileId)] 138 | getErrorTiles = jobQuery_ "select zoom_level,tile_column,tile_row, tile_id from errors" 139 | 140 | clearErrorTile :: (Monad m, HasJobConn m) => (Zoom,Column,TmsRow) -> m () 141 | clearErrorTile (z,x,y) = 142 | jobExecute "delete from errors where zoom_level=? and tile_column=? and tile_row=?" (z,x,y) 143 | 144 | data SingleEnv = SingleEnv { 145 | seMbConn :: Connection 146 | , seJobConn :: Connection 147 | } 148 | 149 | -- | Single-connection (writable) openmaptiles compatibile db 150 | newtype SingleDbRunner a = SingleDbRunner { 151 | unSingleDbRunner :: ReaderT SingleEnv IO a 152 | } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow) 153 | deriving instance MonadReader SingleEnv SingleDbRunner 154 | 155 | data StrictRowDesc = StrictRowDesc !Zoom !Column !Int 156 | instance ToRow StrictRowDesc where 157 | toRow (StrictRowDesc z x c) = [toField z, toField x, toField c] 158 | instance FromRow StrictRowDesc where 159 | fromRow = (\(a, b, c) -> StrictRowDesc a b c) <$> fromRow 160 | 161 | instance HasMd5Queue SingleDbRunner where 162 | checkHashChanged _ _ = return True 163 | addHash _ _ = return () 164 | 165 | checkJobDb :: Connection -> Connection -> Bool -> IO () 166 | checkJobDb jobconn mbconn forceFull = do 167 | exists <- tableExists jobconn "jobs" 168 | when (not exists || forceFull) $ do 169 | execute_ jobconn "drop table jobs" `catchAny` \_ -> return () 170 | execute_ jobconn "drop table errors" `catchAny` \_ -> return () 171 | execute_ jobconn "create table jobs (zoom_level int not null, tile_column int not null, tile_count int not null)" 172 | execute_ jobconn "create INDEX jobs_index ON jobs (zoom_level,tile_column)" 173 | execute_ jobconn "create table errors (zoom_level int, tile_column int, tile_row int, tile_id int)" 174 | putStrLn "Doing full database work, recreating job list" 175 | jobs :: [StrictRowDesc] <- query_ mbconn "select zoom_level, tile_column, count(*) from tiles group by zoom_level, tile_column" 176 | executeMany jobconn "insert into jobs(zoom_level,tile_column, tile_count) values (?,?,?)" jobs 177 | putStrLn "Job list done" 178 | where 179 | tableExists conn table = 180 | (void (query_ @(Only Int) conn (Query ("select count(*) from " <> table))) >> return True) 181 | `catchAny` \_ -> return False 182 | 183 | runSingleDb :: Bool -> FilePath -> FilePath -> SingleDbRunner a -> IO a 184 | runSingleDb forceFull mbpath jobpath (SingleDbRunner code) = 185 | withConnection mbpath $ \mbconn -> 186 | withConnection jobpath $ \jobconn -> do 187 | checkJobDb jobconn mbconn forceFull 188 | runReaderT code (SingleEnv mbconn jobconn) 189 | 190 | instance MonadUnliftIO SingleDbRunner where 191 | withRunInIO inner = 192 | SingleDbRunner . ReaderT $ \r -> 193 | withRunInIO $ \run -> 194 | inner (run . flip runReaderT r . unSingleDbRunner) 195 | 196 | instance MonadFail SingleDbRunner where 197 | fail str = throwIO (userError str) 198 | 199 | instance HasMbConn SingleDbRunner where 200 | withMbConn f = asks seMbConn >>= f 201 | 202 | instance HasJobConn SingleDbRunner where 203 | getJobConn = asks seJobConn 204 | 205 | instance WriteMbTile SingleDbRunner where 206 | updateMbtile (z,x,y,tid) mdata = do 207 | conn <- asks seMbConn 208 | liftIO $ case mdata of 209 | Just tdata -> execute conn "update tiles_data set tile_data=? where tile_data_id=?" (tdata, tid) 210 | Nothing -> do 211 | execute conn "delete from tiles_shallow where zoom_level=? AND tile_column=? AND tile_row=?" (z,x,y) 212 | execute conn "delete from tiles_data where tile_data_id=?" (Only tid) 213 | vacuumDb = do 214 | conn <- asks seMbConn 215 | liftIO $ execute_ conn "vacuum" 216 | 217 | -- | Single-connection (writable) openmaptiles compatibile db 218 | newtype MbRunner m a = MbRunner { 219 | unMbRunner :: ReaderT (DP.Pool Connection) m a 220 | } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow) 221 | deriving instance Monad m => MonadReader (DP.Pool Connection) (MbRunner m) 222 | 223 | instance MonadUnliftIO m => MonadUnliftIO (MbRunner m) where 224 | withRunInIO inner = 225 | MbRunner . ReaderT $ \r -> 226 | withRunInIO $ \run -> 227 | inner (run . flip runReaderT r . unMbRunner) 228 | 229 | instance MonadUnliftIO m => HasMbConn (MbRunner m) where 230 | withMbConn f = do 231 | pool <- ask 232 | withRunInIO $ \runInIO -> 233 | DP.withResource pool (\conn -> runInIO (f conn)) 234 | 235 | instance MonadThrow m => MonadFail (MbRunner m) where 236 | fail str = throwIO (userError str) 237 | 238 | runMb :: Monad m => DP.Pool Connection -> MbRunner m a -> m a 239 | runMb pool (MbRunner code) = runReaderT code pool 240 | 241 | data ParallelEnv = ParallelEnv { 242 | peMbPool :: DP.Pool Connection 243 | , peJobConn :: Connection 244 | , peMd5Queue :: Maybe Md5Queue 245 | } 246 | 247 | newtype ParallelDbRunner a = ParallelDbRunner { 248 | unParallelDbRunner :: ReaderT ParallelEnv IO a 249 | } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow) 250 | deriving instance MonadReader ParallelEnv ParallelDbRunner 251 | 252 | instance MonadUnliftIO ParallelDbRunner where 253 | withRunInIO inner = 254 | ParallelDbRunner . ReaderT $ \r -> 255 | withRunInIO $ \run -> 256 | inner (run . flip runReaderT r . unParallelDbRunner) 257 | 258 | instance MonadFail ParallelDbRunner where 259 | fail str = throwIO (userError str) 260 | 261 | instance HasMbConn ParallelDbRunner where 262 | withMbConn f = do 263 | pool <- asks peMbPool 264 | withRunInIO $ \runInIO -> 265 | DP.withResource pool (runInIO . f) 266 | 267 | instance HasJobConn ParallelDbRunner where 268 | getJobConn = asks peJobConn 269 | 270 | instance HasMd5Queue ParallelDbRunner where 271 | checkHashChanged param tile = do 272 | asks peMd5Queue >>= \case 273 | Nothing -> return True 274 | Just q -> liftIO $ tileChanged q param tile 275 | addHash _ Nothing = return () 276 | addHash param (Just tile) = do 277 | mq <- asks peMd5Queue 278 | for_ mq $ \q -> 279 | liftIO $ sendMd5Tile q param tile 280 | 281 | data ParallelConfig = ParallelConfig { 282 | pConnCount :: Int 283 | , pJobPath :: FilePath 284 | , pMd5Path :: Maybe FilePath 285 | , pOldMd5Path :: Maybe FilePath 286 | } 287 | 288 | runParallelDb :: ParallelConfig -> Bool -> DP.Pool Connection -> ParallelDbRunner a -> IO a 289 | runParallelDb ParallelConfig{pConnCount, pJobPath, pMd5Path, pOldMd5Path} forceFull 290 | mbpool (ParallelDbRunner code) = 291 | withConnection pJobPath $ \jobconn -> do 292 | DP.withResource mbpool $ \conn -> checkJobDb jobconn conn forceFull 293 | md5queue <- case pMd5Path of 294 | Nothing -> return Nothing 295 | Just mpath -> Just <$> runQueueThread pOldMd5Path mpath pConnCount 296 | res <- runReaderT code (ParallelEnv mbpool jobconn md5queue) 297 | for_ md5queue stopMd5Queue 298 | return res 299 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE DeriveGeneric #-} 8 | {-# LANGUAGE DeriveAnyClass #-} 9 | {-# LANGUAGE OverloadedRecordDot #-} 10 | {-# LANGUAGE TupleSections #-} 11 | 12 | module Main where 13 | 14 | import Codec.Compression.GZip (CompressParams (compressLevel), 15 | bestCompression, compressWith, 16 | decompress, defaultCompressParams) 17 | import Control.Concurrent (getNumCapabilities, 18 | threadDelay) 19 | import Control.Concurrent.ParallelIO.Global (globalPool, 20 | stopGlobalPool) 21 | import Control.Concurrent.ParallelIO.Local (Pool, parallel_, 22 | withPool) 23 | import Control.Exception.Safe (bracket, throwIO) 24 | import Control.Lens (over, (%~), (&), 25 | (<&>), (^.), (^..), 26 | (^?), _Just, traverseOf, _1, sequenceOf) 27 | import Control.Monad (forever, unless, void, 28 | when) 29 | import Control.Monad.IO.Class (liftIO) 30 | import Data.Aeson ((.=)) 31 | import qualified Data.Aeson as AE 32 | import qualified Data.Aeson.Lens as AEL 33 | import Data.Aeson.Encode.Pretty (encodePretty) 34 | import Data.Bool (bool) 35 | import qualified Data.ByteString as BS 36 | import qualified Data.ByteString.Lazy as BL 37 | import qualified Data.ByteString.Lazy.Char8 as BL8 38 | import Data.Foldable (for_) 39 | import qualified Data.HashMap.Strict as HMap 40 | import Data.List (nub) 41 | import Data.List.NonEmpty (NonEmpty, nonEmpty) 42 | import Data.Maybe (fromMaybe, mapMaybe) 43 | import qualified Data.Pool as DP 44 | import Data.Semigroup (sconcat) 45 | import Data.String.Conversions (cs) 46 | import Control.Newtype (Newtype(unpack)) 47 | import qualified Data.Text as T 48 | import qualified Data.Text.IO as T 49 | import qualified Data.Text.Lazy as TL 50 | import Data.Traversable (for) 51 | import Database.SQLite.Simple (Only (..), query_, 52 | withConnection) 53 | import qualified Database.SQLite.Simple as SQL 54 | import qualified Geography.VectorTile as VT 55 | import Geography.VectorTile (layers, linestrings, 56 | metadata, points, 57 | polygons, tile, untile, 58 | VectorTile, 59 | featureId) 60 | import Amazonka (AccessKey (..), 61 | SecretKey (..), 62 | runResourceT, send, 63 | setEndpoint, toBody, configureService, discover, newEnvFromManager) 64 | import Amazonka.S3 (BucketName (..), 65 | ObjectKey (..), newDeleteObject, newPutObject) 66 | import Amazonka.S3.PutObject (PutObject(contentType, contentEncoding, cacheControl)) 67 | import Network.HTTP.Client (managerConnCount, managerIdleConnectionCount, 68 | newManager) 69 | import Network.HTTP.Client.TLS (tlsManagerSettings) 70 | import Options.Applicative hiding (header, style) 71 | import System.Directory (createDirectoryIfMissing, 72 | doesFileExist, 73 | removeFile, listDirectory) 74 | import System.FilePath.Posix (takeDirectory, ()) 75 | import qualified System.Metrics.Counter as CNT 76 | import System.Posix.Files (getFileStatus, 77 | modificationTime, fileExist) 78 | import System.Posix.Types (EpochTime) 79 | import Text.Read (readMaybe) 80 | import UnliftIO (MonadUnliftIO, catchAny, 81 | race_, withRunInIO) 82 | import Web.Scotty (addHeader, get, header, 83 | json, raw, 84 | scotty, setHeader, pathParam) 85 | 86 | import DbAccess 87 | import Mapbox.Filters 88 | import Mapbox.Interpret (FeatureType (..), 89 | runFilter) 90 | import Mapbox.Style (MapboxStyle, lMinZoom, 91 | lSource, msLayers, 92 | _VectorType) 93 | import Mapbox.OldStyleConvert (convertToNew) 94 | import Mapbox.DownCopy (DownCopySpec, dDstZoom, copyDown) 95 | import Types 96 | import qualified Amazonka.S3 as S3 97 | import Amazonka.Auth (fromKeys) 98 | import qualified Data.Aeson.KeyMap as AEK 99 | import qualified Data.Aeson.Key as AEK 100 | import GHC.Generics (Generic) 101 | import Data.List (sort) 102 | 103 | data PublishTarget = PublishFs FilePath | PublishS3 BucketName 104 | deriving (Show) 105 | 106 | data PublishOpts = PublishOpts { 107 | pUrlPrefix :: T.Text 108 | , pStoreTgt :: PublishTarget 109 | , pThreads :: Maybe Int 110 | , pForceFull :: Bool 111 | , pS3Endpoint :: Maybe BS.ByteString 112 | , pDisableHashes :: Bool 113 | , pDiffHashes :: Maybe FilePath 114 | , pMbtiles :: FilePath 115 | } 116 | 117 | data CmdLine = 118 | CmdDump { 119 | fStyles :: NonEmpty FilePath 120 | , fSourceName :: Maybe T.Text 121 | , fZoomLevel :: Int 122 | , fMvtSource :: FilePath 123 | } 124 | | CmdMbtiles { 125 | fStyles :: NonEmpty FilePath 126 | , fRtlConvert :: Bool 127 | , fSourceName :: Maybe T.Text 128 | , fForceFull :: Bool 129 | , fMbtiles :: FilePath 130 | } 131 | | CmdWebServer { 132 | fModStyles :: [FilePath] 133 | , fCopyDown :: Maybe FilePath 134 | , fRtlConvert :: Bool 135 | , fSourceName :: Maybe T.Text 136 | , fWebPort :: Int 137 | , fMbtiles :: FilePath 138 | } 139 | | CmdPublish { 140 | fModStyles :: [FilePath] 141 | , fCopyDown :: Maybe FilePath 142 | , fRtlConvert :: Bool 143 | , fSourceName :: Maybe T.Text 144 | , fPublishOpts :: PublishOpts 145 | } 146 | | CmdConvert { 147 | fStyle :: FilePath 148 | } 149 | | CmdCreateMb { 150 | fInputDir :: FilePath 151 | , fMbtiles :: FilePath 152 | } 153 | 154 | -- | The same as 'some', but generate NonEmpty list (makes more sense) 155 | nsome :: Alternative f => f a -> f (NonEmpty a) 156 | nsome x = fromMaybe (error "'some' didn't return element") . nonEmpty <$> some x 157 | 158 | dumpOptions :: Parser CmdLine 159 | dumpOptions = 160 | CmdDump <$> nsome (strOption (short 'j' <> long "style" <> metavar "JSFILE" <> help "JSON mapbox style file")) 161 | <*> optional (strOption (short 's' <> long "source" <> help "Tile source name")) 162 | <*> option auto (short 'z' <> long "zoom" <> help "Tile zoom level") 163 | <*> argument str (metavar "SRCFILE" <> help "Source file") 164 | 165 | mbtileOptions :: Parser CmdLine 166 | mbtileOptions = 167 | CmdMbtiles <$> nsome (strOption (short 'j' <> long "style" <> metavar "JSFILE" <> help "JSON mapbox style file")) 168 | <*> switch (long "rtl-convert" <> help "Apply Right-to-left text conversion on metadata (Arabic etc.)") 169 | <*> optional (strOption (short 's' <> long "source" <> help "Tile source name")) 170 | <*> switch (short 'f' <> long "force-full" <> help "Force full recomputation") 171 | <*> argument str (metavar "MBTILES" <> help "MBTile SQLite database") 172 | 173 | webOptions :: Parser CmdLine 174 | webOptions = 175 | CmdWebServer <$> many (strOption (short 'j' <> long "style" <> metavar "JSFILE" <> help "JSON mapbox style file")) 176 | <*> optional (strOption (short 'c' <> long "copy-down" <> metavar "JSFILE" <> help "JSON copydown specification")) 177 | <*> switch (long "rtl-convert" <> help "Apply Right-to-left text conversion on metadata (Arabic etc.)") 178 | <*> optional (strOption (short 's' <> long "source" <> help "Tile source name")) 179 | <*> option auto (short 'p' <> long "port" <> help "Web port number") 180 | <*> argument str (metavar "MBTILES" <> help "MBTile SQLite database") 181 | 182 | convertOptions :: Parser CmdLine 183 | convertOptions = 184 | CmdConvert <$> argument str (metavar "FILENAME" <> help "Style source") 185 | 186 | createMbOptions :: Parser CmdLine 187 | createMbOptions = 188 | CmdCreateMb <$> argument str (metavar "DIRECTORY" <> help "Input directory") 189 | <*> argument str (metavar "MBTILE" <> help "Output MBTILE file") 190 | 191 | s3Bucket :: ReadM PublishTarget 192 | s3Bucket = maybeReader s3Reader <|> maybeReader (Just . PublishFs) 193 | where 194 | s3Reader txt = PublishS3 . BucketName . stripRightSlash <$> T.stripPrefix "s3://" (T.pack txt) 195 | 196 | stripRightSlash :: T.Text -> T.Text 197 | stripRightSlash = T.dropWhileEnd (== '/') 198 | 199 | publishOptions :: Parser CmdLine 200 | publishOptions = 201 | CmdPublish 202 | <$> many (strOption (short 'j' <> long "style" <> metavar "JSFILE" <> help "JSON mapbox style file")) 203 | <*> optional (strOption (short 'c' <> long "copy-down" <> metavar "JSFILE" <> help "JSON copydown specification")) 204 | <*> switch (long "rtl-convert" <> help "Apply Right-to-left text conversion on metadata (Arabic etc.)") 205 | <*> optional (strOption (short 's' <> long "source" <> help "Tile source name from mapbox style")) 206 | <*> (PublishOpts <$> 207 | (stripRightSlash <$> strOption (short 'u' <> long "url-prefix" <> help "External tile URL prefix")) 208 | <*> option s3Bucket (short 't' <> long "target" <> help "S3 target prefix for files (e.g. s3://my-bucket/map) or filesystem path") 209 | <*> optional (option auto (short 'p' <> long "parallelism" <> metavar "NUMBER" <> help "Spawn multiple threads for faster upload (default: number of cores)")) 210 | <*> switch (short 'f' <> long "force-full" <> help "Force full recomputation") 211 | <*> optional (strOption (long "s3-endpoint" <> metavar "HOSTNAME" <> help "Endpoint for S3 operations (use e.g. with Google Cloud Storage)")) 212 | <*> switch (long "disable-hashes" <> help "Do not compute hash database of the tiles") 213 | <*> optional (strOption (long "hashes-db" <> metavar "SQLITE" <> help "Old hashes.db for differential upload")) 214 | <*> argument str (metavar "MBTILES" <> help "MBTile SQLite database") 215 | ) 216 | 217 | 218 | cmdLineParser :: Parser CmdLine 219 | cmdLineParser = 220 | subparser $ 221 | command "dump" (info (helper <*> dumpOptions) (progDesc "Dump vector files contents.")) 222 | <> command "filter" (info (helper <*> mbtileOptions) (progDesc "Run filtering on a MBTiles database")) 223 | <> command "web" (info (helper <*> webOptions) (progDesc "Run a web server for serving tiles")) 224 | <> command "publish" (info (helper <*> publishOptions) (progDesc "Publish mbtile to S3")) 225 | <> command "convert-old-filter" (info (helper <*> convertOptions) 226 | (progDesc "Convert style with deprecated filter to new filter")) 227 | <> command "create-mbtile" (info (helper <*> createMbOptions) (progDesc "Create mbtile files ")) 228 | 229 | progOpts :: ParserInfo CmdLine 230 | progOpts = info (cmdLineParser <**> helper) 231 | ( fullDesc <> progDesc "Utilities for working with Mapbox style file") 232 | 233 | -- | Return style, update style minzoom levels to maxzoom if bigger 234 | getStyle :: NonEmpty FilePath -> IO MapboxStyle 235 | getStyle fnames = 236 | fmap sconcat <$> for fnames $ \fname -> do 237 | bstyle <- BS.readFile fname 238 | case AE.eitherDecodeStrict bstyle of 239 | Right res -> return res 240 | Left err -> error ("Parsing mapbox style failed: " <> err) 241 | 242 | -- | Check that the user correctly specified the source name and filter it out 243 | -- 244 | -- It is possible for the mbtiles to provide maxzoom of 14 and style to be for maxzoom 17. 245 | -- Therefore we update minzoom in the styles to be the maximum zoom in DB; this 246 | -- ensures that the features stay in the mbtiles database 247 | checkStyle :: Maybe T.Text -> Int -> MapboxStyle -> IO MapboxStyle 248 | checkStyle mtilesrc dbmaxzoom styl = do 249 | -- Print vector styles 250 | let sources = nub (styl ^.. msLayers . traverse . _VectorType . lSource) 251 | for_ sources $ \s -> 252 | T.putStrLn $ "Found vector source layer: " <> s 253 | tilesrc <- case sources of 254 | [nm] | Just nm == mtilesrc -> return nm 255 | | Nothing <- mtilesrc -> return nm 256 | lst | Just nm <- mtilesrc, nm `elem` lst -> return nm 257 | | otherwise -> error ("Invalid tile source specified, " <> show mtilesrc) 258 | return $ styl & msLayers %~ filter (\l -> l ^? _VectorType . lSource == Just tilesrc) 259 | & over (msLayers . traverse . _VectorType . lMinZoom . _Just) (min dbmaxzoom) 260 | 261 | -- | Generate metadata json based on modification text + database + other info 262 | genMetadata :: (Monad m, HasMbConn m) => TL.Text -> TL.Text -> m AE.Value 263 | genMetadata modTimeStr urlPrefix = do 264 | metalines <- getMetaData 265 | return $ AE.object $ 266 | concatMap addMetaLine (over (traverse . _1) AEK.fromText metalines) 267 | ++ ["tiles" .= [urlPrefix <> "/tiles/{z}/{x}/{y}?" <> modTimeStr], 268 | "tilejson" .= ("2.0.0" :: T.Text) 269 | ] 270 | where 271 | addMetaLine (key,val) 272 | | key `elem` ["attribution", "description", "name", "format", "basename", "id"] = 273 | [key .= val] 274 | | key `elem` ["minzoom", "maxzoom", "pixel_scale", "maskLevel", "planettime"], 275 | Just (dnum :: Int) <- readMaybe val = 276 | [key .= dnum] 277 | | key == "json", Just (AE.Object obj) <- AE.decode (cs val) = 278 | AEK.toList obj 279 | | key == "center", Just (lst :: [Double]) <- decodeArr val = 280 | [key .= lst] 281 | | key == "bounds", Just lst@[_ :: Double, _,_,_] <- decodeArr val = 282 | [key .= lst] 283 | | otherwise = [] 284 | where 285 | split _ [] = [] 286 | split c lst = 287 | let (start,rest) = span (/= c) lst 288 | in start : split c (drop 1 rest) 289 | decodeArr = traverse readMaybe . split ',' 290 | 291 | -- | Dump content of the mbtiles with hints about if the features are removed or retained 292 | dumpPbf :: MapboxStyle -> Int -> FilePath -> IO () 293 | dumpPbf style zoom fp = do 294 | mvt <- autoUnzip <$> BL.readFile fp 295 | case tile (cs mvt) of 296 | Left err -> error (show err) 297 | Right vtile -> 298 | for_ (vtile ^.. layers . traverse) $ \l -> do 299 | T.putStrLn "-----------------------------" 300 | T.putStrLn ("Layer: " <> cs (l ^. VT.name)) 301 | let lfilter = cfExpr (getLayerFilter False (l ^. VT.name) cfilters) 302 | for_ (l ^. points) (printCont lfilter Point) 303 | for_ (l ^. linestrings) (printCont lfilter LineString) 304 | for_ (l ^. polygons) (printCont lfilter Polygon) 305 | where 306 | autoUnzip :: BL.ByteString -> BL.ByteString 307 | autoUnzip bs | BL.unpack (BL.take 2 bs) == [0x1f,0x8b] = decompress bs 308 | | otherwise = bs 309 | 310 | cfilters = styleToCFilters zoom style 311 | 312 | printCont lfilter ptype feature = do 313 | let include = runFilter lfilter ptype feature 314 | putStrLn $ bool "- " " " include <> " " <> show (feature ^. featureId) <> " " <> show ptype <> " " <> show (HMap.toList (feature ^. metadata)) 315 | -- putStrLn $ show (feature ^. geometries) 316 | 317 | type JobAction m = ((Zoom, Column, TmsRow, TileId), Maybe TileData) -> m () 318 | 319 | compressParams :: CompressParams 320 | compressParams = defaultCompressParams{compressLevel=bestCompression} 321 | 322 | -- | Return nothing if there are no layers (and therefore no features) on the tile 323 | checkEmptyTile :: VectorTile -> Maybe VectorTile 324 | checkEmptyTile t 325 | | null (t ^. layers) = Nothing 326 | | otherwise = Just t 327 | 328 | 329 | -- | Run a filtering action on all tiles in the database and perform a JobAction 330 | runFilterJob :: 331 | forall m. (HasMbConn m, HasJobConn m, MonadUnliftIO m, MonadFail m, HasMd5Queue m) 332 | => Pool -- ^ Threadpool for parallel processing 333 | -> Maybe MapboxStyle -- ^ Filtering mapboxstyle 334 | -> Maybe DownCopySpec 335 | -> Bool -- ^ If true, convert right-to-left texts 336 | -> JobAction m -- ^ Action to perform on filtered tile 337 | -> m () 338 | runFilterJob pool mstyle mdownspec rtlconvert saveAction = do 339 | total_count <- getIncompleteCount 340 | liftIO $ putStrLn ("Remaining tiles: " <> show total_count) 341 | counter <- liftIO CNT.new -- TODO - take complete count from the job file... 342 | emptycnt <- liftIO CNT.new 343 | changecnt <- liftIO CNT.new 344 | skipcnt <- liftIO CNT.new 345 | zlevels <- getIncompleteZooms 346 | 347 | errors <- getErrorTiles 348 | unless (null errors) $ do 349 | liftIO $ putStrLn ("Processing error tiles: " <> show (length errors)) 350 | for_ errors $ \tileArg@(z,x,y,_) -> 351 | (do 352 | processTile counter emptycnt changecnt skipcnt tileArg 353 | clearErrorTile (z,x,y) 354 | ) `catchAny` \err -> liftIO $ putStrLn ("Tile " <> show tileArg <> " error: " <> show err) 355 | 356 | race_ (showStats total_count counter emptycnt changecnt skipcnt) $ 357 | for_ zlevels $ \zoom -> do 358 | liftIO $ putStrLn $ "Filtering zoom: " <> show zoom 359 | cols <- getJobZoomColumns zoom 360 | liftWithPool 2 $ \colPool -> -- Do some low limit for columns 361 | parallelFor_ colPool cols $ \col -> do 362 | tiles <- getColTiles zoom col 363 | parallelFor_ pool tiles $ \tileArg -> 364 | processTile counter emptycnt changecnt skipcnt tileArg 365 | `catchAny` \err -> do 366 | liftIO $ putStrLn ("Error on " <> show tileArg <> ": " <> show err) 367 | markErrorTile tileArg 368 | markColumnComplete zoom col 369 | where 370 | processTile counter emptycnt changecnt skipcnt pos@(z@(Zoom z'),x,y,tileid) = do 371 | liftIO $ CNT.inc counter 372 | mtiledata <- fetchTileTid tileid 373 | case mtiledata of 374 | Nothing -> liftIO $ putStrLn ("Tile failed to read from DB: " <> show tileid) 375 | Just tiledta -> do 376 | -- Fetch downcopy tiles 377 | duptiles <- fetchDownTiles mdownspec (z, x, toXyzY y z) 378 | 379 | newdta <- case mstyle of 380 | Nothing -> return (Just tiledta) 381 | Just style -> do 382 | let filtList = styleToCFilters z' style 383 | let generr = liftIO . throwIO . userError . show 384 | (tdta, tuptiles) <- either generr return (parseTiles (unTileData tiledta) duptiles) 385 | let res = filterVectorTile rtlconvert filtList (copyDown mdownspec tdta tuptiles) 386 | return (TileData . compressWith compressParams . cs . untile <$> checkEmptyTile res) 387 | liftIO $ whenNothing newdta (CNT.inc emptycnt) 388 | -- Check changes 389 | changed <- checkHashChanged (z,x,toXyzY y z) newdta 390 | if changed then do 391 | -- Call job action 392 | saveAction (pos, newdta) 393 | liftIO $ CNT.inc changecnt 394 | else liftIO $ CNT.inc skipcnt 395 | addHash (z,x,toXyzY y z) newdta 396 | 397 | liftWithPool n f = 398 | withRunInIO $ \runInIO -> 399 | withPool n $ \dbpool -> runInIO (f dbpool) 400 | parallelFor_ pool_ parlist job = 401 | withRunInIO $ \runInIO -> 402 | parallel_ pool_ (runInIO . job <$> parlist) 403 | 404 | whenNothing Nothing f = f 405 | whenNothing _ _ = return () 406 | 407 | showStats total_count counter emptycnt changecnt skipcnt = 408 | liftIO $ forever $ do 409 | let delay = 15 410 | start <- CNT.read counter 411 | threadDelay (delay * 1000000) 412 | end <- CNT.read counter 413 | emptyc <- CNT.read emptycnt 414 | changec <- CNT.read changecnt 415 | skipc <- CNT.read skipcnt 416 | let percent = round ((100 :: Double) * fromIntegral end / fromIntegral total_count) :: Int 417 | speed = round (fromIntegral (end - start) / (fromIntegral delay :: Double)) :: Int 418 | putStrLn $ "Completion status: " <> show percent 419 | <> "%, speed: " <> show speed <> " tiles/sec" 420 | <> " deleted: " <> show (round @_ @Int $ (100 :: Double) * fromIntegral emptyc / fromIntegral end) 421 | <> "%, written: " <> show (round @_ @Int $ (100 :: Double) * fromIntegral changec / fromIntegral end) 422 | <> "%, skipped: " <> show skipc 423 | 424 | -- | Filter all tiles in a database and save the filtered tiles back 425 | convertMbtiles :: MapboxStyle -> Bool -> FilePath -> Bool -> IO () 426 | convertMbtiles style rtlconvert mbtiles force = do 427 | runSingleDb force mbtiles (mbtiles <> ".filter") $ do 428 | runFilterJob globalPool (Just style) Nothing rtlconvert (uncurry updateMbtile) 429 | -- If we were shrinking, call vacuum on database 430 | vacuumDb 431 | stopGlobalPool 432 | 433 | -- | Publish the mbtile to an S3 target, make it ready for serving 434 | runPublishJob :: 435 | Maybe (MapboxStyle, EpochTime) -- ^ Parsed style + modification time of the style 436 | -> Maybe DownCopySpec 437 | -> Bool 438 | -> PublishOpts 439 | -> IO () 440 | runPublishJob mstyle mdownspec rtlconvert 441 | PublishOpts{pMbtiles, pForceFull, pStoreTgt, pUrlPrefix, pThreads, pS3Endpoint, pDiffHashes, pDisableHashes} = do 442 | -- Create http connection manager with higher limits 443 | conncount <- maybe getNumCapabilities return pThreads 444 | manager <- newManager tlsManagerSettings{managerConnCount=conncount, managerIdleConnectionCount=conncount} 445 | -- Generate AWS environ; fake AWS keys when publishing to filesystem 446 | let credential = case pStoreTgt of 447 | PublishFs{} -> pure . fromKeys (AccessKey "fake") (SecretKey "fake") -- Fake it if we publish to FS 448 | PublishS3{} -> discover 449 | env <- newEnvFromManager manager credential 450 | <&> maybe id (\host -> configureService (S3.defaultService & setEndpoint True host 443)) pS3Endpoint 451 | 452 | dbpool <- DP.newPool (DP.defaultPoolConfig (SQL.open pMbtiles) SQL.close 10 100) 453 | modstr <- runMb dbpool $ makeModtimeStr (snd <$> mstyle) 454 | 455 | withThreads $ \pool -> do 456 | let hashfile = pMbtiles <> ".hashes" 457 | let pConf = ParallelConfig { 458 | pConnCount = conncount 459 | , pJobPath = pMbtiles <> "." <> modstr 460 | , pMd5Path = if pDisableHashes then Nothing else Just hashfile 461 | , pOldMd5Path = pDiffHashes 462 | } 463 | runParallelDb pConf pForceFull dbpool $ do 464 | runFilterJob pool (fst <$> mstyle) mdownspec rtlconvert $ \((z,x,y,_), mnewdta) -> 465 | liftIO $ do 466 | let dstpath = "tiles/" <> mkPath (z,x,y) 467 | -- Skip empty tiles 468 | case mnewdta of 469 | Nothing -> 470 | case pStoreTgt of 471 | PublishFs root -> do 472 | let fpath = root dstpath 473 | exists <- doesFileExist fpath 474 | when exists (removeFile fpath) 475 | PublishS3 bucket -> 476 | runResourceT ( 477 | void $ send env (newDeleteObject bucket (ObjectKey (cs dstpath))) 478 | ) `catchAny` \e -> liftIO (print e) 479 | Just (TileData newdta) -> 480 | case pStoreTgt of 481 | PublishFs root -> do 482 | let fpath = root dstpath 483 | createDirectoryIfMissing True (takeDirectory fpath) 484 | BL.writeFile fpath newdta 485 | PublishS3 bucket -> 486 | runResourceT $ do 487 | let cmd = (newPutObject bucket (ObjectKey (cs dstpath)) (toBody newdta)) { 488 | contentType = Just "application/x-protobuf" 489 | , contentEncoding = Just "gzip" 490 | , cacheControl = Just "max-age=31536000" 491 | } 492 | void $ send env cmd 493 | meta <- genMetadata (cs modstr) (cs pUrlPrefix) 494 | case pStoreTgt of 495 | PublishFs root -> liftIO $ BL.writeFile (root "metadata.json") (AE.encode meta) 496 | PublishS3 bucket -> do 497 | let cmd = (newPutObject bucket "metadata.json" (toBody (AE.encode meta))) { 498 | contentType = Just "application/json" 499 | } 500 | runResourceT $ 501 | void (send env cmd) 502 | where 503 | mkPath (z'@(Zoom z), Column x, tms_y) = 504 | let (XyzRow xyz_y) = toXyzY tms_y z' 505 | in show z <> "/" <> show x <> "/" <> show xyz_y 506 | withThreads 507 | | Just tcount <- pThreads = withPool tcount 508 | | otherwise = bracket (return globalPool) (const stopGlobalPool) 509 | 510 | -- | Make a string containing modification time of db & style 511 | makeModtimeStr :: (Monad m, HasMbConn m) => Maybe EpochTime -> m String 512 | makeModtimeStr mtime = do 513 | dbmtime <- getDbMtime 514 | let stmtime = fromMaybe 0 mtime 515 | return (dbmtime <> "_" <> show stmtime) 516 | 517 | fetchDownTiles :: HasMbConn m => Maybe DownCopySpec -> (Zoom, Column, XyzRow) -> m [(TileData, (Int, Int))] 518 | fetchDownTiles (Just spec) (z, x, y) | spec ^. dDstZoom == unpack z = do 519 | let newtiles = [((z + 1, 2 * x + Column bx, toTmsY (2 * y + XyzRow by) (z + 1)), (bx, by)) 520 | | bx <- [0..1], by <- [0..1]] 521 | mapMaybe (sequenceOf _1) <$> traverseOf (traverse . _1) fetchTileZXY newtiles 522 | fetchDownTiles _ _ = return [] 523 | 524 | -- | Run a web server serving filtered/unfiltered tiles and metadata 525 | runWebServer :: Int -> Maybe (MapboxStyle, EpochTime) -> Maybe DownCopySpec -> Bool -> FilePath -> IO () 526 | runWebServer port mstyle mdownspec rtlconvert mbpath = do 527 | dbpool <- DP.newPool (DP.defaultPoolConfig (SQL.open mbpath) SQL.close 10 100) 528 | 529 | -- Generate a JSON to be included as a metadata file 530 | -- Run a web server 531 | scotty port $ do 532 | get "/tiles/metadata.json" $ do 533 | -- find out protocol and host 534 | proto <- fromMaybe "http" <$> header "X-Forwarded-Proto" 535 | host <- fromMaybe "localhost" <$> header "Host" 536 | metaJson <- liftIO $ runMb dbpool $ do 537 | mtime <- makeModtimeStr (snd <$> mstyle) 538 | genMetadata (cs mtime) (proto <> "://" <> host) 539 | addHeader "Access-Control-Allow-Origin" "*" 540 | json metaJson 541 | get "/tiles/:z/:x/:y" $ do 542 | z@(Zoom z') <- pathParam "z" 543 | x <- pathParam "x" 544 | y <- pathParam "y" 545 | let tms_y = toTmsY y z 546 | 547 | addHeader "Access-Control-Allow-Origin" "*" 548 | setHeader "Content-Type" "application/x-protobuf" 549 | setHeader "Cache-Control" "max-age=31536000" 550 | 551 | (rnewtile, duptiles) <- liftIO $ runMb dbpool $ do 552 | rnewtile <- fetchTileZXY (z, x, tms_y) 553 | duptiles <- fetchDownTiles mdownspec (z, x, y) 554 | return (rnewtile, duptiles) 555 | 556 | mnewtile <- case rnewtile of 557 | Just (TileData dta) -> 558 | case mstyle of 559 | Nothing -> return (Just dta) 560 | Just (style,_) -> do 561 | (tdta, tuptiles) <- either (fail . cs) return (parseTiles dta duptiles) 562 | let res = filterTile rtlconvert z' style (copyDown mdownspec tdta tuptiles) 563 | return (compressWith compressParams . cs . untile <$> checkEmptyTile res) 564 | _ -> return Nothing 565 | case mnewtile of 566 | Just dta -> do 567 | addHeader "Content-Encoding" "gzip" 568 | raw dta 569 | Nothing -> raw "" -- Empty tile 570 | 571 | -- | Parses tiles from a bytestring 572 | parseTiles :: BL8.ByteString -> [(TileData, (Int, Int))] -> Either T.Text (VectorTile, [(VectorTile, (Int, Int))]) 573 | parseTiles dta duptiles = do 574 | t1 <- tile (cs (decompress dta)) 575 | tlist <- traverseOf (traverse . _1) (tile . cs . decompress . unTileData) duptiles 576 | return (t1, tlist) 577 | 578 | -- | Read style from filepath, convert 'filter' to newstyle and write to stdout 579 | runConversion :: FilePath -> IO () 580 | runConversion fname = do 581 | bstyle <- BS.readFile fname 582 | case AE.eitherDecodeStrict bstyle of 583 | Left err -> error ("Parsing mapbox style failed: " <> err) 584 | Right (style :: AE.Value) -> do 585 | let mnewstyle = (AEL.key "layers" . AEL._Array . traverse . AEL.key "filter") convertToNew style 586 | case mnewstyle of 587 | Left err -> error ("Conversion error: " <> err) 588 | Right res -> BL8.putStrLn (encodePretty res) 589 | 590 | data SimpleMetadata = SimpleMetadata { 591 | name :: T.Text 592 | , format :: T.Text 593 | , minzoom :: Maybe Int 594 | , maxzoom :: Maybe Int 595 | , center :: Maybe (Double,Double,Int) 596 | , bounds :: Maybe (Double,Double,Double,Double) 597 | , attribution :: Maybe T.Text 598 | , description :: Maybe T.Text 599 | -- We skip 'type' because it breaks generic decoding... 600 | , version :: Maybe T.Text 601 | , vector_layers :: Maybe AE.Value 602 | } deriving (Show, Generic, AE.FromJSON) 603 | 604 | -- | Create an MBTile file from a published directory 605 | createMbtile :: FilePath -> FilePath -> IO () 606 | createMbtile inp outp = do 607 | -- Check that mbtile doesn't exist 608 | exists <- fileExist outp 609 | when exists $ do 610 | throwIO $ userError "The output file already exists." 611 | lmeta <- AE.eitherDecodeFileStrict (inp "metadata.json") 612 | (meta :: SimpleMetadata) <- either (throwIO . userError) return lmeta 613 | 614 | -- Create a new sqlite db, add tables 615 | withConnection outp $ \conn -> do 616 | createTables conn 617 | -- Create metadata information 618 | createMetadata conn meta 619 | -- Insert existing fields 620 | insertTiles conn (inp "tiles") (cs meta.format) 621 | where 622 | createTables conn = do 623 | SQL.execute_ conn "CREATE TABLE metadata (name text, value text)" 624 | SQL.execute_ conn "CREATE TABLE tiles (zoom_level integer, tile_column integer, tile_row integer, tile_data blob)" 625 | SQL.execute_ conn "CREATE UNIQUE INDEX tile_index on tiles (zoom_level, tile_column, tile_row)" 626 | createMetadata conn meta = do 627 | -- Mandatory fields 628 | writeMetaField conn "name" meta.name 629 | writeMetaField conn "format" meta.format 630 | -- Should fields 631 | for_ meta.minzoom $ \zoom -> writeMetaField conn "minzoom" (cs $ show zoom) 632 | for_ meta.maxzoom $ \zoom -> writeMetaField conn "maxzoom" (cs $ show zoom) 633 | for_ meta.center $ \(a,b,c) -> writeMetaField conn "center" (cs $ show a <> "," <> show b <> "," <> show c) 634 | for_ meta.bounds $ \(a,b,c,d) -> writeMetaField conn "bounds" (cs $ show a <> "," <> show b <> "," <> show c <> "," <> show d) 635 | -- Optional fields 636 | for_ meta.attribution $ writeMetaField conn "version" 637 | for_ meta.description $ writeMetaField conn "version" 638 | for_ meta.version $ writeMetaField conn "version" 639 | -- Vector 640 | for_ meta.vector_layers $ \vjson -> writeMetaField conn "json" (cs $ AE.encode (AEK.singleton "vector_layers" vjson)) 641 | 642 | writeMetaField :: SQL.Connection -> T.Text -> T.Text -> IO () 643 | writeMetaField conn field val = 644 | SQL.execute conn "INSERT INTO metadata(name,value) VALUES (?,?)" (field, val) 645 | 646 | insertTiles :: SQL.Connection -> FilePath -> String -> IO () 647 | insertTiles conn basedir suffix = do 648 | zooms <- listDirNums basedir 649 | for_ (sort zooms) $ \zoom -> do 650 | putStrLn ("Working on zoom: " <> show zoom) 651 | xs <- listDirNums (basedir show zoom) 652 | for_ (sort xs) $ \x -> do 653 | ys <- listFileNums (basedir show zoom show x) suffix 654 | for_ (sort ys) $ \(yfname, y) -> do 655 | content <- BS.readFile (basedir show zoom show x yfname) 656 | let tmsY = toTmsY (XyzRow y) (Zoom zoom) 657 | SQL.execute conn "INSERT INTO tiles (zoom_level,tile_column,tile_row,tile_data) values (?,?,?,?)" (zoom,x, tmsY, content) 658 | 659 | -- List files in directory that are convertible to an integer 660 | listDirNums :: FilePath -> IO [Int] 661 | listDirNums fpath = mapMaybe readMaybe <$> listDirectory fpath 662 | 663 | -- List numbers of files with a given suffix 664 | listFileNums :: FilePath -> String -> IO [(FilePath,Int)] 665 | listFileNums fpath suffix = do 666 | dfiles <- listDirectory fpath 667 | return $ mapMaybe (\f -> (f,) <$> decodeFname f) dfiles 668 | where 669 | decodeFname fname = readMaybe fname <|> (BS.stripSuffix (cs $ "." <> suffix) (cs fname) >>= readMaybe . cs) 670 | 671 | main :: IO () 672 | main = do 673 | opts <- execParser progOpts 674 | case opts of 675 | CmdDump{fMvtSource, fZoomLevel, fStyles, fSourceName} -> do 676 | style <- getStyle fStyles >>= checkStyle fSourceName 14 677 | dumpPbf style fZoomLevel fMvtSource 678 | CmdMbtiles{fMbtiles, fStyles, fSourceName, fForceFull, fRtlConvert} -> do 679 | maxzoom <- getMaxZoom fMbtiles 680 | style <- getStyle fStyles >>= checkStyle fSourceName maxzoom 681 | convertMbtiles style fRtlConvert fMbtiles fForceFull 682 | CmdWebServer{fModStyles, fCopyDown, fWebPort, fMbtiles, fSourceName, fRtlConvert} -> do 683 | maxzoom <- getMaxZoom fMbtiles 684 | mstyle <- getMStyle fModStyles fSourceName maxzoom 685 | downspec <- readCopyDown fCopyDown 686 | runWebServer fWebPort mstyle downspec fRtlConvert fMbtiles 687 | CmdPublish{fModStyles, fCopyDown, fSourceName, fRtlConvert, fPublishOpts} -> do 688 | maxzoom <- getMaxZoom (pMbtiles fPublishOpts) 689 | mstyle <- getMStyle fModStyles fSourceName maxzoom 690 | downspec <- readCopyDown fCopyDown 691 | runPublishJob mstyle downspec fRtlConvert fPublishOpts 692 | CmdConvert{fStyle} -> runConversion fStyle 693 | CmdCreateMb{fInputDir,fMbtiles} -> createMbtile fInputDir fMbtiles 694 | where 695 | -- We need to adjust minZoom in the styles to be at least the maximum zoom level 696 | -- in the database 697 | getMaxZoom dbname = do 698 | [Only maxzoom] <- withConnection dbname $ \conn -> 699 | query_ conn "select max(zoom_level) from tiles" 700 | return maxzoom 701 | 702 | getMStyle (nonEmpty -> Just stlist) tilesrc maxzoom = do 703 | st <- getStyle stlist >>= checkStyle tilesrc maxzoom 704 | mtimes <- fmap modificationTime <$> traverse getFileStatus stlist 705 | return (Just (st, maximum mtimes)) 706 | getMStyle _ _ _ = return Nothing 707 | 708 | readCopyDown Nothing = return Nothing 709 | readCopyDown (Just fname) = do 710 | fspec <- BS.readFile fname 711 | case AE.eitherDecodeStrict fspec of 712 | Right res -> return res 713 | Left err -> error ("Parsing copydown style failed: " <> err) 714 | -------------------------------------------------------------------------------- /app/Md5Worker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Create a database of md5 5 | module Md5Worker ( 6 | Md5Queue 7 | , sendMd5Tile 8 | , stopMd5Queue 9 | , tileChanged 10 | , runQueueThread 11 | ) where 12 | 13 | import Control.Concurrent (forkIO) 14 | import Control.Concurrent.BoundedChan 15 | import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, 16 | takeMVar) 17 | import Control.Exception.Safe (catchAny) 18 | import Crypto.Hash.MD5 (hashlazy) 19 | import qualified Data.ByteString as BS 20 | import Data.Maybe (listToMaybe) 21 | import qualified Data.Pool as DP 22 | import Database.SQLite.Simple (Connection, Only (..), query) 23 | import qualified Database.SQLite.Simple as SQL 24 | 25 | import Types (Column (..), TileData (..), 26 | XyzRow (..), Zoom (..)) 27 | 28 | data Md5Message = 29 | Md5AddFile (Zoom, Column, XyzRow) !BS.ByteString 30 | | Md5Exit (IO ()) 31 | 32 | data Md5Queue = Md5Queue { 33 | md5Q :: BoundedChan Md5Message 34 | , md5DbOld :: Maybe (DP.Pool Connection) 35 | } 36 | 37 | sendMd5Tile :: Md5Queue -> (Zoom, Column, XyzRow) -> TileData -> IO () 38 | sendMd5Tile queue pos mtdata = do 39 | let md5 = hashlazy . unTileData $ mtdata 40 | writeChan (md5Q queue) $! Md5AddFile pos md5 41 | 42 | stopMd5Queue :: Md5Queue -> IO () 43 | stopMd5Queue queue = do 44 | mvar <- newEmptyMVar :: IO (MVar ()) 45 | writeChan (md5Q queue) (Md5Exit (putMVar mvar ())) 46 | takeMVar mvar 47 | 48 | tileChanged :: Md5Queue -> (Zoom, Column, XyzRow) -> Maybe TileData -> IO Bool 49 | tileChanged Md5Queue{md5DbOld=Nothing} _ (Just _) = return True 50 | tileChanged Md5Queue{md5DbOld=Nothing} _ Nothing = return False 51 | tileChanged Md5Queue{md5DbOld=Just dbpool} (z,x,y) mtile = 52 | DP.withResource dbpool $ \conn -> do 53 | res <- query conn "select md5_hash from md5hash where zoom_level=? and tile_column=? and tile_row=?" (z,x,y) 54 | let mhash = (\(TileData dta) -> hashlazy dta) <$> mtile 55 | return (mhash /= listToMaybe (fromOnly <$> res)) 56 | 57 | runQueueThread :: Maybe FilePath -> FilePath -> Int -> IO Md5Queue 58 | runQueueThread olddbpath newdbpath thrcount = do 59 | queue <- newBoundedChan 400 60 | dbpool <- traverse mkPool olddbpath 61 | conn <- SQL.open newdbpath 62 | initDb conn 63 | _ <- forkIO (handleConn queue conn) 64 | return (Md5Queue queue dbpool) 65 | where 66 | mkPool path = DP.createPool (SQL.open path) SQL.close 1 100 thrcount 67 | 68 | handleConn q conn = do 69 | msg <- readChan q 70 | case msg of 71 | Md5Exit signal -> do 72 | -- Close db for access 73 | SQL.close conn 74 | signal 75 | Md5AddFile (z,x,y) md5 -> do 76 | SQL.execute conn "insert or replace into md5hash (zoom_level,tile_column,tile_row,md5_hash) values (?,?,?,?)" (z, x, y, md5) 77 | handleConn q conn 78 | -- Initialize db, return true if it was empty 79 | initDb :: Connection -> IO () 80 | initDb conn = 81 | (do 82 | SQL.execute_ conn "create table md5hash (zoom_level int not null, tile_column int not null, tile_row int not null, md5_hash blob not null)" 83 | SQL.execute_ conn "create index md5hash_index on md5hash (zoom_level, tile_column, tile_row)" 84 | )`catchAny` \_ -> return () 85 | -------------------------------------------------------------------------------- /app/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | 5 | module Types where 6 | 7 | import qualified Data.ByteString.Lazy as BL 8 | import Database.SQLite.Simple.FromField (FromField (..)) 9 | import Database.SQLite.Simple.ToField (ToField (..)) 10 | import Web.Scotty (Parsable) 11 | import Control.Newtype (Newtype(..)) 12 | import Data.Coerce (coerce) 13 | 14 | newtype TileId = TileId Int 15 | deriving (Show, ToField, FromField) 16 | 17 | newtype TileData = TileData { 18 | unTileData :: BL.ByteString 19 | } deriving (Show, ToField, FromField) 20 | 21 | newtype Zoom = Zoom Int 22 | deriving (Show, ToField, FromField, Parsable, Num) 23 | instance Newtype Zoom Int where 24 | pack = coerce 25 | unpack = coerce 26 | newtype XyzRow = XyzRow Int 27 | deriving (Show, ToField, Parsable, Num, Enum) 28 | newtype TmsRow = TmsRow Int 29 | deriving (Show, ToField, FromField, Num, Enum) 30 | newtype Column = Column Int 31 | deriving (Show, ToField, FromField, Parsable, Enum, Num) 32 | 33 | -- | Flip y coordinate between xyz and tms schemes 34 | toTmsY :: XyzRow -> Zoom -> TmsRow 35 | toTmsY (XyzRow y) (Zoom z) = TmsRow (2 ^ z - y - 1) 36 | 37 | toXyzY :: TmsRow -> Zoom -> XyzRow 38 | toXyzY (TmsRow y) (Zoom z) = XyzRow (2 ^ z - y - 1) 39 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | package text-icu 4 | extra-include-dirs: /opt/homebrew/Cellar/icu4c/73.2/include 5 | extra-lib-dirs: /opt/homebrew/Cellar/icu4c/73.2/lib 6 | 7 | source-repository-package 8 | type: git 9 | location: https://github.com/k-bx/protocol-buffers.git 10 | tag: ae8084f115fbdb699da2b2a163776b1a1167bf0f 11 | 12 | 13 | source-repository-package 14 | type: git 15 | location: https://github.com/ondrap/vectortiles.git 16 | tag: 818f2733582b7ba46f8414b80a4085753d3e6073 17 | -------------------------------------------------------------------------------- /mapbox-filter.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.6 2 | name: mapbox-filter 3 | version: 0.1.0.0 4 | description: Tools for working with vector Mapbox mbtiles files 5 | homepage: https://github.com/ondrap/mapbox-filter 6 | bug-reports: https://github.com/ondrap/mapbox-filter/issues 7 | author: Ondrej Palkovsky 8 | maintainer: palkovsky.ondrej@gmail.com 9 | copyright: 2018 Ondrej Palkovsky 10 | license: BSD-3-Clause 11 | license-file: LICENSE 12 | build-type: Simple 13 | 14 | extra-source-files: 15 | ChangeLog.md 16 | README.md 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/ondrap/mapbox-filter 21 | 22 | 23 | common deps 24 | build-depends: 25 | base >=4.7 && <5 26 | , aeson >= 2.1 27 | , scientific 28 | , recursion-schemes 29 | , text-icu >= 0.8.0.4 30 | , data-fix 31 | , string-conversions 32 | , unordered-containers 33 | , vectortiles >= 1.4.0 34 | , text 35 | , lens 36 | , bytestring 37 | , vector 38 | , sqlite-simple 39 | , zlib 40 | , optparse-applicative 41 | , parallel-io 42 | , transformers 43 | , unix 44 | , scotty 45 | , safe-exceptions 46 | , amazonka >= 2.0 47 | , amazonka-s3 48 | , ekg-core 49 | , async 50 | , http-client 51 | , http-client-tls 52 | , filepath 53 | , directory 54 | , resource-pool 55 | , mtl 56 | , unliftio 57 | , cryptohash-md5 58 | , BoundedChan 59 | , aeson-pretty 60 | , lens-aeson 61 | , newtype 62 | 63 | 64 | library 65 | import: deps 66 | hs-source-dirs: 67 | src 68 | exposed-modules: 69 | Mapbox.Expression 70 | Mapbox.Style 71 | Mapbox.Interpret 72 | Mapbox.Filters 73 | Mapbox.UntypedExpression 74 | Mapbox.OldStyleConvert 75 | Mapbox.DownCopy 76 | default-language: Haskell2010 77 | ghc-options: -Wall -Wcompat 78 | 79 | executable mapbox-filter 80 | import: deps 81 | main-is: Main.hs 82 | other-modules: DbAccess, Md5Worker, Types 83 | hs-source-dirs: 84 | app 85 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 86 | build-depends: 87 | mapbox-filter 88 | default-language: Haskell2010 89 | -------------------------------------------------------------------------------- /src/Mapbox/DownCopy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ApplicativeDo #-} 5 | 6 | module Mapbox.DownCopy where 7 | 8 | import Control.Lens ((&), (^.), (%~), makeLenses, over, _1, (.~)) 9 | import Data.List (foldl') 10 | import Data.Aeson (FromJSON (..), (.:)) 11 | import qualified Data.Aeson as AE 12 | import qualified Data.Text as T 13 | import qualified Data.ByteString.Lazy as BL 14 | import qualified Data.HashMap.Strict as HMap 15 | import Geography.VectorTile (VectorTile(..), 16 | linestrings, points, 17 | polygons, Point(..), geometries, layers, 18 | LineString(..), Polygon(..), extent, 19 | featureId) 20 | import Data.String.Conversions.Monomorphic (fromST) 21 | import qualified Data.Vector.Storable as VS 22 | import qualified Data.Vector as V 23 | 24 | import Mapbox.Filters (CFilters, simpleFilter, CFilter(..), simpleNegFilter) 25 | import Mapbox.Interpret (CompiledExpr, compileExpr) 26 | import Mapbox.Expression (typeCheckFilter) 27 | 28 | 29 | data DownCopySpec = DownCopySpec { 30 | _dDstZoom :: Int 31 | , _dSourceLayer :: BL.ByteString 32 | , _dFilter :: CompiledExpr Bool 33 | } 34 | makeLenses ''DownCopySpec 35 | 36 | instance FromJSON DownCopySpec where 37 | parseJSON = AE.withObject "DownCopySpec" $ \o -> do 38 | _dDstZoom <- o .: "dst-zoom" 39 | uexp <- o .: "filter" 40 | -- Directly typecheck and compile filter 41 | _dFilter <- either (fail . T.unpack) return (compileExpr <$> typeCheckFilter uexp) 42 | _dSourceLayer <- fromST <$> o .: "source-layer" 43 | return DownCopySpec{..} 44 | 45 | mkCFilters :: DownCopySpec -> CFilters 46 | mkCFilters fspec = HMap.singleton (fspec ^. dSourceLayer) (CFilter (fspec ^. dFilter) mempty) 47 | 48 | copyDown :: Maybe DownCopySpec -> VectorTile -> [(VectorTile, (Int, Int))] -> VectorTile 49 | copyDown _ mtile [] = mtile 50 | copyDown Nothing mtile _ = mtile 51 | copyDown (Just fspec) dsttile srcTiles = 52 | let fltdst = simpleNegFilter lfilters dsttile 53 | fltsrc = map shrinkTile . over (traverse . _1) (simpleFilter lfilters) $ srcTiles 54 | in foldl' mergeTile fltdst fltsrc 55 | where 56 | lfilters = mkCFilters fspec 57 | 58 | -- Divide by 2 and move according to offset 59 | shrinkTile (vtile, (dx, dy)) = 60 | over (layers . traverse) (applyOperation (dx, dy)) vtile 61 | 62 | applyOperation (dx, dy) layer = 63 | let ext = fromIntegral (layer ^. extent) -- tile square size 64 | op (Point x y) = Point ((dx * ext + x) `div` 2) ((dy * ext + y) `div` 2) 65 | in layer & points %~ over (traverse . geometries) (VS.map op) 66 | & linestrings %~ over (traverse . geometries . traverse) (applyLine op) 67 | & polygons %~ over (traverse . geometries . traverse) (applyPolygon op) 68 | 69 | applyLine op (LineString plist) = LineString (VS.map op plist) 70 | applyPolygon op (Polygon pp inp) = Polygon (VS.map op pp) (fmap (applyPolygon op) inp) 71 | 72 | -- Merge 2 tiles into one 73 | mergeTile (VectorTile _l1) (VectorTile _l2) = VectorTile (HMap.unionWith mergeLayer _l1 _l2) 74 | mergeLayer l1 l2 = l1 & points %~ (`addAndRenumber` (l2 ^. points)) 75 | & linestrings %~ (`addAndRenumber` (l2 ^. linestrings)) 76 | & polygons %~ (`addAndRenumber` (l2 ^. polygons)) 77 | addAndRenumber l1 l2 78 | | V.null l2 = l1 79 | | otherwise = V.fromListN (V.length l1 + V.length l2) 80 | (zipWith (\idx f -> f & featureId .~ idx) 81 | [1..] (V.toList l1 <> V.toList l2)) 82 | -------------------------------------------------------------------------------- /src/Mapbox/Expression.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Mapbox.Expression ( 7 | TExp(..) 8 | , TTyp(..) 9 | , UExp 10 | , typeCheckFilter 11 | , AnyValue(..) 12 | , AttrType(..) 13 | , BoolFunc(..) 14 | , CmpOp(..) 15 | , OrdOp(..) 16 | , ATExp(..) 17 | , tValToTTyp 18 | , anyValToTVal 19 | , tvalToAny 20 | , TValue(..) 21 | ) where 22 | 23 | import Control.Monad ((>=>)) 24 | import Data.Bool (bool) 25 | import Data.Fix (Fix (..)) 26 | import qualified Data.HashMap.Strict as HMap 27 | import Data.Maybe (isJust) 28 | import Data.Scientific (Scientific) 29 | import Data.String.Conversions (cs) 30 | import qualified Data.Text as T 31 | import Data.Type.Equality ((:~:) (..), TestEquality (..)) 32 | import Data.Foldable (toList) 33 | 34 | import Mapbox.UntypedExpression 35 | 36 | data CmpOp = CEq | CNeq 37 | deriving (Show) 38 | 39 | data OrdOp = CGt | CGeq | CLt | CLeq 40 | deriving (Show) 41 | 42 | data BoolFunc = BAll | BAny 43 | deriving (Show) 44 | 45 | data AttrType a where 46 | GeometryType :: AttrType T.Text 47 | FeatureId :: AttrType AnyValue 48 | instance Show (AttrType a) where 49 | showsPrec _ GeometryType = showString "geometry-type" 50 | showsPrec _ FeatureId = showString "id" 51 | 52 | data AnyValue = 53 | ABool Bool 54 | | ANum Scientific 55 | | AStr T.Text 56 | | ANumArray NumArray 57 | deriving (Show, Eq) 58 | 59 | data TTyp a where 60 | TTBool :: TTyp Bool 61 | TTNum :: TTyp Scientific 62 | TTStr :: TTyp T.Text 63 | TTNumArr :: TTyp NumArray 64 | TTAny :: TTyp AnyValue 65 | 66 | instance TestEquality TTyp where 67 | testEquality TTBool TTBool = Just Refl 68 | testEquality TTNum TTNum = Just Refl 69 | testEquality TTStr TTStr = Just Refl 70 | testEquality TTNumArr TTNumArr = Just Refl 71 | testEquality TTAny TTAny = Just Refl 72 | testEquality _ _ = Nothing 73 | 74 | typeEqual :: TTyp a -> TTyp b -> Bool 75 | typeEqual a b = isJust (testEquality a b) 76 | 77 | instance Show (TTyp a) where 78 | showsPrec _ TTBool = showString "Bool" 79 | showsPrec _ TTNum = showString "Number" 80 | showsPrec _ TTStr = showString "String" 81 | showsPrec _ TTNumArr = showString "NumArray" 82 | showsPrec _ TTAny = showString "Any" 83 | 84 | data TValue a where 85 | TVBool :: TValue Bool 86 | TVNum :: TValue Scientific 87 | TVStr :: TValue T.Text 88 | TVNumArr :: TValue NumArray 89 | 90 | tValToTTyp :: TValue a -> TTyp a 91 | tValToTTyp TVBool = TTBool 92 | tValToTTyp TVNum = TTNum 93 | tValToTTyp TVStr = TTStr 94 | tValToTTyp TVNumArr = TTNumArr 95 | 96 | anyValToTVal :: TValue a -> AnyValue -> Maybe a 97 | anyValToTVal TVBool (ABool b) = Just b 98 | anyValToTVal TVNum (ANum n) = Just n 99 | anyValToTVal TVStr (AStr s) = Just s 100 | anyValToTVal TVNumArr (ANumArray na) = Just na 101 | anyValToTVal _ _ = Nothing 102 | 103 | tvalToAny :: TTyp a -> a -> AnyValue 104 | tvalToAny TTBool b = ABool b 105 | tvalToAny TTNum n = ANum n 106 | tvalToAny TTStr t = AStr t 107 | tvalToAny TTNumArr a = ANumArray a 108 | tvalToAny TTAny a = a 109 | 110 | instance Show (TValue a) where 111 | showsPrec _ TVBool = showString "Bool" 112 | showsPrec _ TVNum = showString "Number" 113 | showsPrec _ TVStr = showString "String" 114 | showsPrec _ TVNumArr = showString "NumArray" 115 | 116 | class TOrderable a 117 | instance TOrderable Scientific 118 | instance TOrderable T.Text 119 | 120 | data ATExp = forall a . TExp a ::: TTyp a 121 | instance Show ATExp where 122 | showsPrec p (texp ::: ttyp) = showsPrec p texp . showString " :: " . showsPrec p ttyp 123 | 124 | data TExp a where 125 | TNum :: Scientific -> TExp Scientific 126 | TStr :: T.Text -> TExp T.Text 127 | TBool :: Bool -> TExp Bool 128 | TNumArr :: NumArray -> TExp NumArray 129 | TCmpOp :: Eq a => CmpOp -> TExp a -> TExp a -> TExp Bool 130 | TOrdOp :: (Ord a, TOrderable a) => OrdOp -> TExp a -> TExp a -> TExp Bool 131 | TBoolFunc :: BoolFunc -> [TExp Bool] -> TExp Bool 132 | TReadMeta :: TExp T.Text -> TExp AnyValue 133 | TCheckMeta :: TExp T.Text -> TExp Bool 134 | TNegate :: TExp Bool -> TExp Bool 135 | TConvert :: Bool -> TValue a -> [ATExp] -> TExp a 136 | TReadAttr :: AttrType a -> TExp a 137 | TMatch :: (Show a, Eq a) => TExp a -> [([a], TExp b)] -> TExp b -> TExp b 138 | TToAny :: ATExp -> TExp AnyValue 139 | 140 | instance Show (TExp a) where 141 | showsPrec p (TNum d) = showsPrec p d 142 | showsPrec p (TBool b) = showsPrec p b 143 | showsPrec p (TStr s) = showsPrec p s 144 | showsPrec p (TNumArr n) = showsPrec p n 145 | showsPrec p (TCmpOp _ e1 e2) = 146 | showString "(" . showsPrec p e1 . showString " == " . showsPrec p e2 . showString ")" 147 | showsPrec p (TOrdOp op n1 n2) = 148 | showString "(" . showsPrec p op . showString " " . showsPrec p n1 . showString " " . showsPrec p n2 . showString ")" 149 | showsPrec p (TBoolFunc func fncs) = showsPrec p func . showString " " . showsPrec p fncs 150 | showsPrec p (TReadMeta var) = showString "readMeta " . showsPrec p var 151 | showsPrec p (TNegate e) = showString "!(" . showsPrec p e . showString ")" 152 | showsPrec p (TCheckMeta var) = showString "hasMeta " . showsPrec p var 153 | showsPrec p (TConvert force restype exprs) = 154 | showsPrec p exprs . showString " ->" . bool (showString " ") (showString "! ") force . showsPrec p restype 155 | showsPrec p (TReadAttr atype) = showString "attr " . showsPrec p atype 156 | showsPrec p (TMatch inp cond def) = showString "match " . showsPrec p inp . showString " " . showsPrec p cond . showString " " . showsPrec p def 157 | showsPrec p (TToAny atval) = showString "*to_any* " . showsPrec p atval 158 | 159 | type Env = HMap.HashMap T.Text ATExp 160 | 161 | -- | Existential witness for equality constraint (add Show constraint for easier Show deriving) 162 | data HasEq a where 163 | HasEq :: (Show a, Eq a) => HasEq a 164 | 165 | -- | Return witness if the type has Eq instance 166 | hasEquality :: TTyp a -> HasEq a 167 | hasEquality TTBool = HasEq 168 | hasEquality TTNum = HasEq 169 | hasEquality TTStr = HasEq 170 | hasEquality TTNumArr = HasEq 171 | hasEquality TTAny = HasEq 172 | 173 | -- | Hacky conversion of literal/array of literals to list of literals; check type 174 | convertMatchLabel :: TTyp a -> ULabel -> Either T.Text [a] 175 | convertMatchLabel TTNum (LNum n) = Right [n] 176 | convertMatchLabel TTNum (LNumArr arr) = Right (toList arr) 177 | convertMatchLabel TTStr (LStr s) = Right [s] 178 | convertMatchLabel TTStr (LStrArr args) = Right args 179 | convertMatchLabel TTBool (LBool b) = Right [b] 180 | convertMatchLabel TTAny (LNum n) = Right [ANum n] 181 | convertMatchLabel TTAny (LNumArr arr) = Right (ANum <$> toList arr) 182 | convertMatchLabel TTAny (LStr s) = Right [AStr s] 183 | convertMatchLabel TTAny (LStrArr args) = Right (AStr <$> args) 184 | convertMatchLabel TTAny (LBool b) = Right [ABool b] 185 | convertMatchLabel _ arg = Left (cs $ "Impossible match label: " <> show arg) 186 | 187 | -- | Check that the input expression conforms to the requested type 188 | forceType :: TTyp a -> ATExp -> Either T.Text (TExp a) 189 | forceType t1 (mexp ::: t2) = 190 | case testEquality t1 t2 of 191 | Just Refl -> return mexp 192 | Nothing -> Left ("Expression " <> T.pack (show mexp) <> " has type " <> T.pack (show t2) 193 | <> ", expected " <> T.pack (show t1)) 194 | 195 | -- | Convert untyped expression to a typed expression 196 | typeCheck :: Env -> UExp -> Either T.Text ATExp 197 | typeCheck _ (Fix (UNum num)) = Right (TNum num ::: TTNum) 198 | typeCheck _ (Fix (UStr str)) = Right (TStr str ::: TTStr) 199 | typeCheck _ (Fix (UBool b)) = Right (TBool b ::: TTBool) 200 | typeCheck _ (Fix (UNumArr n)) = Right (TNumArr n ::: TTNumArr) 201 | typeCheck _ (Fix UFunction{}) = Left "Functions (stops) are not implemented." 202 | typeCheck env (Fix (UVar var)) = 203 | maybe (Left ("Variable " <> var <> " not found.")) Right (HMap.lookup var env) 204 | typeCheck env (Fix (ULet var expr next)) = do 205 | res <- typeCheck env expr 206 | typeCheck (HMap.insert var res env) next 207 | typeCheck env (Fix (UMatch inpexp table lelse)) = do 208 | (inp ::: intype) <- typeCheck env inpexp 209 | (def ::: outtype) <- typeCheck env lelse 210 | let evalpair (a,b) = (,) <$> convertMatchLabel intype a 211 | <*> (typeCheck env b >>= forceType outtype) 212 | pairs <- traverse evalpair table 213 | -- Add Eq constraint 214 | case hasEquality intype of 215 | HasEq -> return (TMatch inp pairs def ::: outtype) 216 | typeCheck env (Fix (UApp fname args)) = 217 | case fname of 218 | "string" -> do 219 | eargs <- traverse (typeCheck env) args 220 | return (TConvert False TVStr eargs ::: TTStr) 221 | "number" -> do 222 | eargs <- traverse (typeCheck env) args 223 | return (TConvert False TVNum eargs ::: TTNum) 224 | "boolean" -> do 225 | eargs <- traverse (typeCheck env) args 226 | return (TConvert False TVBool eargs ::: TTBool) 227 | "to-number" -> do 228 | eargs <- traverse (typeCheck env) args 229 | return (TConvert True TVNum eargs ::: TTNum) 230 | "to-string" -> do 231 | eargs <- traverse (typeCheck env) args 232 | return (TConvert True TVStr eargs ::: TTStr) 233 | "to-boolean" -> do 234 | eargs <- traverse (typeCheck env) args 235 | return (TConvert True TVBool eargs ::: TTBool) 236 | "get" | [arg] <- args -> do 237 | mname <- typeCheck env arg >>= forceType TTStr 238 | return (TReadMeta mname ::: TTAny) 239 | "!" | [arg] <- args -> do 240 | mexpr <- typeCheck env arg >>= forceType TTBool 241 | return (TNegate mexpr ::: TTBool) 242 | "has" | [arg] <- args -> do 243 | mname <- typeCheck env arg >>= forceType TTStr 244 | return (TCheckMeta mname ::: TTBool) 245 | _| Just op <- lookup fname [("==", CEq), ("!=", CNeq)], [arg1, arg2] <- args -> do 246 | (marg1 ::: t1) <- typeCheck env arg1 247 | (marg2 ::: t2) <- typeCheck env arg2 248 | -- We could theoretically downgrade to any completely, but let's do at least some 249 | -- type check and rule out some cases during compilation 250 | case (testEquality t1 t2, hasEquality t1) of 251 | (Just Refl, HasEq) -> return (TCmpOp op marg1 marg2 ::: TTBool) 252 | (Nothing, _) 253 | | typeEqual t1 TTAny || typeEqual t2 TTAny -> 254 | return (TCmpOp op (TToAny (marg1 ::: t1)) (TToAny (marg2 ::: t2)) ::: TTBool) 255 | | otherwise -> 256 | Left (cs $ "Comparing unequal things: " <> show arg1 <> ", " <> show arg2 257 | <> ": " <> show t1 <> "vs. " <> show t2) 258 | _| Just op <- lookup fname [("<", CLt), ("<=", CLeq), (">", CGt), (">=", CGeq)], 259 | [arg1, arg2] <- args -> do 260 | (marg1 ::: t1) <- typeCheck env arg1 261 | (marg2 ::: t2) <- typeCheck env arg2 262 | case testEquality t1 t2 of 263 | Just Refl -> 264 | case t1 of 265 | TTStr -> return (TOrdOp op marg1 marg2 ::: TTBool) 266 | TTNum -> return (TOrdOp op marg1 marg2 ::: TTBool) 267 | _ -> Left "Cannot compare other than str/num" 268 | Nothing -> Left (cs $ "Comparing unequal things: " <> show arg1 <> ", " <> show arg2 269 | <> ": " <> show t1 <> "vs. " <> show t2) 270 | _| Just op <- lookup fname [("any", BAny), ("all", BAll)] -> do 271 | margs <- traverse (typeCheck env >=> forceType TTBool) args 272 | return (TBoolFunc op margs ::: TTBool) 273 | "geometry-type" | [] <- args -> return (TReadAttr GeometryType ::: TTStr) 274 | _ -> Left ("Unknown function name / wrong param count: " <> fname) 275 | 276 | -- | Convert an untyped expression to a filter (Bool) expression 277 | typeCheckFilter :: UExp -> Either T.Text (TExp Bool) 278 | typeCheckFilter = typeCheck mempty >=> forceType TTBool 279 | -------------------------------------------------------------------------------- /src/Mapbox/Filters.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Helper module for 5 | module Mapbox.Filters where 6 | 7 | import Control.Applicative ((<|>)) 8 | import Control.Lens (filtered, over, toListOf, (&), (^.)) 9 | import Control.Monad.Trans.Class (lift) 10 | import Data.Bool (bool) 11 | import qualified Data.ByteString.Lazy as BL 12 | import qualified Data.HashMap.Strict as HMap 13 | import qualified Data.HashSet as HSet 14 | import Data.Maybe (fromMaybe) 15 | import Data.String.Conversions (cs) 16 | import qualified Data.Text as T 17 | import qualified Data.Vector as V 18 | import Geography.VectorTile (Feature, Layer, VectorTile, layers, 19 | linestrings, metadata, name, points, 20 | polygons, Val(St)) 21 | import Data.Text.ICU.Shape (shapeArabic, ShapeOption(..)) 22 | import Data.Text.ICU.BiDi (reorderParagraphs, WriteOption(..)) 23 | 24 | import Mapbox.Interpret (CompiledExpr, FeatureType (..), 25 | runFilter) 26 | import Mapbox.Style (MapboxStyle, lDisplayMeta, lFilter, 27 | lFilterMeta, lMaxZoom, lMinZoom, 28 | lSourceLayer, msLayers, _VectorType) 29 | 30 | -- TODO - we can make the metadata selection granular on a per-feature level... 31 | 32 | data CFilter = CFilter { 33 | cfExpr :: CompiledExpr Bool 34 | , cfMeta :: HSet.HashSet BL.ByteString 35 | } 36 | 37 | type CFilters = HMap.HashMap BL.ByteString CFilter 38 | 39 | -- | Return a filter from the CFilters map 40 | -- If the layer does not have a record in CFilters, it will be filtered out 41 | getLayerFilter :: Bool -> BL.ByteString -> CFilters -> CFilter 42 | getLayerFilter defval lname layerFilters = 43 | fromMaybe (CFilter (return defval) mempty) (HMap.lookup lname layerFilters) 44 | 45 | 46 | simpleFilter' :: Bool -> CFilters -> VectorTile -> VectorTile 47 | simpleFilter' defval layerFilters = over (layers . traverse) runLayerFilter 48 | where 49 | runLayerFilter :: Layer -> Layer 50 | runLayerFilter l = 51 | let lfilter = getLayerFilter defval (l ^. name) layerFilters 52 | in l & over points (V.filter (runFilter (cfExpr lfilter) Point)) 53 | & over linestrings (V.filter (runFilter (cfExpr lfilter) LineString)) 54 | & over polygons (V.filter (runFilter (cfExpr lfilter) Polygon)) 55 | 56 | simpleFilter :: CFilters -> VectorTile -> VectorTile 57 | simpleFilter = simpleFilter' False 58 | 59 | simpleNegFilter :: CFilters -> VectorTile -> VectorTile 60 | simpleNegFilter layerFilters = simpleFilter' True (fmap negFilters layerFilters) 61 | where 62 | negFilters (CFilter flt meta) = CFilter (not <$> flt) meta 63 | 64 | -- | Entry is list of layers with filter (non-existent filter should be replaced with 'return True') 65 | -- Returns nothing if the resulting tile is empty 66 | filterVectorTile :: Bool -> CFilters -> VectorTile -> VectorTile 67 | filterVectorTile rtlconvert layerFilters = 68 | over layers (HMap.filter (not . nullLayer)) . over (layers . traverse) runMetaFilter . simpleFilter layerFilters 69 | where 70 | nullLayer l = null (l ^. points) 71 | && null (l ^. linestrings) 72 | && null (l ^. polygons) 73 | 74 | runMetaFilter :: Layer -> Layer 75 | runMetaFilter l = 76 | let lfilter = getLayerFilter False (l ^. name) layerFilters 77 | in l & over points (fmap (clearMeta lfilter)) 78 | & over linestrings (fmap (clearMeta lfilter)) 79 | & over polygons (fmap (clearMeta lfilter)) 80 | 81 | clearMeta :: CFilter -> Feature a -> Feature a 82 | clearMeta cf = over metadata (fmap stringConversion . HMap.filterWithKey (\k _ -> k `elem` cfMeta cf)) 83 | 84 | stringConversion :: Val -> Val 85 | stringConversion | rtlconvert = valRtlConvert 86 | | otherwise = id 87 | where 88 | valRtlConvert (St bstr) = 89 | bstr & cs 90 | & shapeArabic [LettersShape] 91 | & reorderParagraphs [DoMirroring, RemoveBidiControls] 92 | & T.intercalate "\n" 93 | & cs 94 | & St 95 | valRtlConvert v = v 96 | 97 | 98 | -- | Convert style and zoom level to a map of (source_layer, filter) 99 | styleToCFilters :: Int -> MapboxStyle -> CFilters 100 | styleToCFilters zoom = 101 | HMap.fromListWith combineFilters 102 | . map (\l -> (cs (l ^. lSourceLayer), mkFilter l)) 103 | . toListOf (msLayers . traverse . _VectorType . filtered acceptFilter) 104 | where 105 | mkFilter vl = CFilter (fromMaybe (return True) (vl ^. lFilter)) 106 | (vl ^. lDisplayMeta <> vl ^. lFilterMeta) 107 | 108 | -- 'Or' on expressions, but if first fails, still try the second 109 | combineFilters :: CFilter -> CFilter -> CFilter 110 | combineFilters a b = 111 | let fa = cfExpr a 112 | fb = cfExpr b 113 | in CFilter ((fa >>= bool (lift Nothing) (return True)) <|> fb) 114 | (cfMeta a <> cfMeta b) 115 | 116 | acceptFilter l = zoomMinOk (l ^. lMinZoom) && zoomMaxOk (l ^. lMaxZoom) 117 | 118 | zoomMinOk Nothing = True 119 | zoomMinOk (Just minz) = zoom >= minz 120 | zoomMaxOk Nothing = True 121 | zoomMaxOk (Just maxz) = zoom <= maxz 122 | 123 | -- | Decode, filter, encode based on zoom level and mapbox style 124 | filterTile :: Bool -> Int -> MapboxStyle -> VectorTile -> VectorTile 125 | filterTile rtlconvert z style = filterVectorTile rtlconvert (styleToCFilters z style) 126 | -------------------------------------------------------------------------------- /src/Mapbox/Interpret.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Mapbox.Interpret ( 7 | compileExpr 8 | , runFilter 9 | , FeatureType(..) 10 | , FeatureInfo(..) 11 | , CompiledExpr 12 | ) where 13 | 14 | import Control.Applicative ((<|>)) 15 | import Control.Lens (makeLenses, view) 16 | import Control.Monad.Trans.Class (lift) 17 | import Control.Monad.Trans.Reader 18 | import qualified Data.ByteString.Lazy as BL 19 | import qualified Data.HashMap.Strict as HMap 20 | import Data.Maybe (fromMaybe) 21 | import Data.Scientific (fromFloatDigits) 22 | import Data.String.Conversions (cs) 23 | import Data.Type.Equality ((:~:) (..), TestEquality (..)) 24 | import Geography.VectorTile (Feature (..), Val (..)) 25 | import Text.Read (readMaybe) 26 | import qualified Data.Text as T 27 | 28 | import Mapbox.Expression (ATExp (..), AnyValue (..), 29 | AttrType (..), BoolFunc (..), 30 | CmpOp (..), OrdOp (..), TExp (..), 31 | TTyp (..), anyValToTVal, 32 | tValToTTyp, tvalToAny, TValue(..)) 33 | 34 | data FeatureType = Point | LineString | Polygon 35 | deriving (Show) 36 | 37 | data FeatureInfo = FeatureInfo { 38 | _fiId :: Word 39 | , _fiType :: FeatureType 40 | , _fiMeta :: HMap.HashMap BL.ByteString Val 41 | } 42 | makeLenses ''FeatureInfo 43 | 44 | type CompiledExpr a = ReaderT FeatureInfo Maybe a 45 | 46 | -- | Fail an expression interpretation 47 | failExpr :: CompiledExpr a 48 | failExpr = lift Nothing 49 | 50 | -- | Convert a typed expression into a runnable expression 51 | compileExpr :: TExp a -> CompiledExpr a 52 | compileExpr (TNum n) = return n 53 | compileExpr (TStr s) = return s 54 | compileExpr (TBool b) = return b 55 | compileExpr (TNumArr na) = return na 56 | compileExpr (TNegate e) = not <$> compileExpr e 57 | compileExpr (TReadAttr FeatureId) = ANum . fromIntegral <$> view fiId 58 | compileExpr (TReadAttr GeometryType) = do 59 | ftype <- view fiType 60 | return $ case ftype of 61 | Point -> "Point" 62 | LineString -> "LineString" 63 | Polygon -> "Polygon" 64 | compileExpr (TCheckMeta tattr) = do 65 | tname <- compileExpr tattr 66 | tmeta <- view fiMeta 67 | return (HMap.member (cs tname) tmeta) 68 | compileExpr (TReadMeta tattr) = do 69 | tname <- compileExpr tattr 70 | tmeta <- view fiMeta 71 | case HMap.lookup (cs tname) tmeta of 72 | Nothing -> failExpr 73 | Just (St aval) -> return (AStr (cs aval)) 74 | Just (Fl n) -> return (ANum (fromFloatDigits n)) 75 | Just (Do n) -> return (ANum (fromFloatDigits n)) 76 | Just (I64 n) -> return (ANum (fromIntegral n)) 77 | Just (W64 n) -> return (ANum (fromIntegral n)) 78 | Just (S64 n) -> return (ANum (fromIntegral n)) 79 | Just (B b) -> return (ABool b) 80 | compileExpr (TConvert False _ []) = failExpr 81 | compileExpr (TConvert False restyp ((vexpr ::: vtyp):rest)) = 82 | ( case testEquality (tValToTTyp restyp) vtyp of 83 | Just Refl -> compileExpr vexpr 84 | Nothing | TTAny <- vtyp -> compileExpr vexpr >>= maybe failExpr return . anyValToTVal restyp 85 | | otherwise -> failExpr 86 | ) <|> tryNextArg 87 | where 88 | tryNextArg = compileExpr (TConvert False restyp rest) 89 | compileExpr (TConvert True _ []) = failExpr 90 | compileExpr (TConvert True TVStr ((item ::: t):_)) = do 91 | val <- compileExpr item 92 | return $ case tvalToAny t val of 93 | ANum n -> T.pack (show n) 94 | ABool True -> "true" 95 | ABool False -> "false" 96 | AStr s -> s 97 | ANumArray a -> T.pack (show a) 98 | compileExpr (TConvert True TVNum ((item ::: t):rest)) = do 99 | val <- compileExpr item 100 | case toNum (tvalToAny t val) of 101 | Just res -> return res 102 | Nothing -> compileExpr (TConvert True TVNum rest) 103 | where 104 | toNum (ANum n) = Just n 105 | toNum (ABool True) = Just 1 106 | toNum (ABool False) = Just 0 107 | toNum (AStr s) = readMaybe (T.unpack s) 108 | toNum _ = Nothing 109 | compileExpr (TConvert True TVBool ((item ::: t):_)) = do -- boolean always convert, ignore rest 110 | val <- compileExpr item 111 | return (toBoolean (tvalToAny t val)) 112 | where 113 | toBoolean (AStr "") = False 114 | toBoolean (ANum 0) = False 115 | toBoolean (ABool b) = b 116 | -- TODO - NaN should be there too, but we probably can't get that into scientific 117 | toBoolean _ = True 118 | compileExpr (TConvert True _ _) = error "Not Implemented" 119 | compileExpr (TBoolFunc bf exprs) = 120 | bop bf <$> traverse compileExpr exprs 121 | where 122 | bop BAny = or 123 | bop BAll = and 124 | compileExpr (TCmpOp op e1 e2) = 125 | -- The position of 'nulls' is strange, it is actually not possible to get 126 | -- a null when working with vector tiles; when we get a 'null', the behaviour 127 | -- is treated as a failure everywhere, except conversion functions (tested) 128 | top <$> compileExpr e1 <*> compileExpr e2 129 | where 130 | top = case op of 131 | CEq -> (==) 132 | CNeq -> (/=) 133 | compileExpr (TOrdOp op e1 e2) = 134 | top <$> compileExpr e1 <*> compileExpr e2 135 | where 136 | top :: Ord a => a -> a -> Bool 137 | top = case op of 138 | CGt -> (>) 139 | CGeq -> (>=) 140 | CLt -> (<) 141 | CLeq -> (<=) 142 | compileExpr (TMatch inp cond def) = do 143 | einp <- compileExpr inp 144 | res <- matchCond einp cond 145 | compileExpr res 146 | where 147 | matchCond _ [] = return def 148 | matchCond val ((lbls,res):rest) 149 | | val `elem` lbls = return res 150 | | otherwise = matchCond val rest 151 | compileExpr (TToAny (arg ::: t)) = tvalToAny t <$> compileExpr arg 152 | 153 | -- | Run compiled expression on a particular feature 154 | runFilter :: CompiledExpr Bool -> FeatureType -> Feature gs -> Bool 155 | runFilter cexpr ftype f = 156 | let finfo = FeatureInfo (_featureId f) ftype (_metadata f) 157 | in fromMaybe False (runReaderT cexpr finfo) 158 | -------------------------------------------------------------------------------- /src/Mapbox/OldStyleConvert.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Mapbox.OldStyleConvert where 3 | 4 | import qualified Data.Aeson as AE 5 | import Data.Aeson (toJSON, Value(..)) 6 | import Data.Foldable (toList) 7 | import qualified Data.Text as T 8 | 9 | -- | Convert deprecated old-style filter to a new-style expression filter 10 | convertToNew :: AE.Value -> Either String AE.Value 11 | convertToNew (AE.Array arr) 12 | | (String fname:args) <- toList arr = runFunc fname args 13 | where 14 | runGet :: T.Text -> AE.Value 15 | runGet "$type" = toJSON [AE.String "geometry-type"] 16 | runGet "$id" = toJSON [AE.String "id"] 17 | runGet other = toJSON ["get", other] 18 | 19 | runFunc :: T.Text -> [AE.Value] -> Either String AE.Value 20 | runFunc "has" [String key] = Right $ toJSON ["has", key] 21 | runFunc "!has" [String key] = Right $ toJSON [String "!", toJSON ["has", key]] 22 | runFunc doper [String key, String val] 23 | | doper `elem` ["==", "!=", ">", ">=", "<", "<="] = 24 | Right $ toJSON [String doper, toJSON [String "string", runGet key], String val] 25 | runFunc doper [String key, Number val] 26 | | doper `elem` ["==", "!=", ">", ">=", "<", "<="] = 27 | Right $ toJSON [String doper, toJSON [String "number", runGet key], Number val] 28 | runFunc dfunc args 29 | | dfunc `elem` ["all", "any"] = do 30 | newargs <- traverse convertToNew args 31 | Right $ toJSON $ [String dfunc] ++ newargs 32 | | dfunc == "none" = do 33 | newargs <- traverse convertToNew args 34 | Right $ toJSON $ [String "all"] ++ map ((\x -> toJSON [String "!", x])) newargs 35 | runFunc "!in" (AE.String key:vals) = 36 | return $ toJSON [String "match", toJSON ["string", runGet key, ""], toJSON vals, toJSON False, toJSON True ] 37 | runFunc "in" (AE.String key:vals) = 38 | return $ toJSON [String "match", toJSON ["string", runGet key, ""], toJSON vals, toJSON True, toJSON False ] 39 | runFunc f args = Left ("Unknown func or params: " <> show f <> ", " <> show args) 40 | 41 | convertToNew v = Left ("Parse error: " <> show v) 42 | -------------------------------------------------------------------------------- /src/Mapbox/Style.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Mapbox.Style where 7 | 8 | import Control.Lens (makeLenses, makePrisms, (^.)) 9 | import Data.Aeson (FromJSON (..), (.!=), (.:), (.:?)) 10 | import qualified Data.Aeson as AE 11 | import qualified Data.ByteString.Lazy as BL 12 | import Data.Functor.Foldable (para) 13 | import qualified Data.HashMap.Strict as HMap 14 | import qualified Data.HashSet as HSet 15 | import Data.String.Conversions (cs) 16 | import qualified Data.Text as T 17 | 18 | import Mapbox.Expression (UExp, typeCheckFilter) 19 | import Mapbox.Interpret (CompiledExpr, compileExpr) 20 | import Mapbox.UntypedExpression (UExpF (..)) 21 | import Data.Fix (Fix(..)) 22 | 23 | data VectorLayer = VectorLayer { 24 | _lSource :: T.Text 25 | , _lSourceLayer :: T.Text 26 | , _lFilter :: Maybe (CompiledExpr Bool) 27 | , _lMinZoom :: Maybe Int 28 | , _lMaxZoom :: Maybe Int 29 | , _lDisplayMeta :: HSet.HashSet BL.ByteString -- ^ List of meta attributes needed for displaying 30 | , _lFilterMeta :: HSet.HashSet BL.ByteString -- ^ List of meta attributes needed for filtering 31 | } 32 | makeLenses ''VectorLayer 33 | instance Show VectorLayer where 34 | showsPrec p o = showParen (p > 10) $ 35 | showString "VectorLayer " . showsPrec p (o ^. lSource) 36 | . showChar ' ' . showsPrec p (o ^. lSourceLayer) 37 | . showChar ' ' . showString (maybe "no-filter" (const "has-filter") (o ^. lFilter)) 38 | . showChar ' ' . showsPrec p (o ^. lMinZoom) 39 | . showChar ' ' . showsPrec p (o ^. lMaxZoom) 40 | . showChar ' ' . showsPrec p (o ^. lDisplayMeta) 41 | . showChar ' ' . showsPrec p (o ^. lFilterMeta) 42 | 43 | data Layer = 44 | VectorType VectorLayer 45 | | RasterLayer T.Text 46 | | BackgroundLayer 47 | deriving (Show) 48 | makePrisms ''Layer 49 | 50 | -- | Go through the parsing tree and find references to metadata attributes 51 | scrapeExprMeta :: UExp -> HSet.HashSet T.Text 52 | scrapeExprMeta = para getMeta 53 | where 54 | getMeta (UApp "get" [(Fix (UStr tid),_)]) = HSet.singleton tid 55 | getMeta (UApp "get" _) = error "Unsupported computation in expression 'get', only direct strings allowed" 56 | getMeta (UApp "has" [(Fix (UStr tid),_)]) = HSet.singleton tid 57 | getMeta (UApp "has" _) = error "Unsupported computation in expression 'has', only direct strings allowed" 58 | getMeta (UApp _ lst) = mconcat (snd <$> lst) 59 | getMeta (ULet _ (_,s1) (_,s2)) = s1 <> s2 60 | getMeta (UStr str) = deinterpolate str 61 | getMeta (UFunction{ufProperty=Just tid}) = HSet.singleton tid 62 | getMeta _ = mempty 63 | -- Extract metadata names from {} notation from a string 64 | deinterpolate txt = 65 | case T.dropWhile (/= '{') txt of 66 | "" -> mempty 67 | rest -> 68 | let (var,next) = T.span (/= '}') (T.drop 1 rest) 69 | in HSet.singleton var <> deinterpolate next 70 | 71 | instance FromJSON Layer where 72 | parseJSON = AE.withObject "Layer" $ \o -> do 73 | ltype <- o .: "type" 74 | case (ltype :: T.Text) of 75 | "background" -> return BackgroundLayer 76 | "raster" -> do 77 | source <- o .: "source" 78 | return (RasterLayer source) 79 | _ -> do -- Vector layers 80 | _lMinZoom <- o .:? "minzoom" 81 | _lMaxZoom <- o .:? "maxzoom" 82 | _lSource <- o .: "source" 83 | _lSourceLayer <- o .: "source-layer" 84 | flt :: Maybe UExp <- o .:? "filter" 85 | -- Directly typecheck and compile filter 86 | _lFilter <- case flt of 87 | Nothing -> return Nothing 88 | Just uexp -> either (fail . T.unpack) (return . Just) (compileExpr <$> typeCheckFilter uexp) 89 | -- Scrape used attributes 90 | (paint :: HMap.HashMap T.Text UExp) <- o .:? "paint" .!= mempty 91 | layout <- o .:? "layout" .!= mempty 92 | let _lDisplayMeta = HSet.map cs $ foldMap (scrapeExprMeta . snd) (HMap.toList (paint <> layout)) 93 | let _lFilterMeta = HSet.map cs $ maybe mempty scrapeExprMeta flt 94 | return (VectorType VectorLayer{..}) 95 | 96 | newtype MapboxStyle = MapboxStyle { 97 | _msLayers :: [Layer] 98 | } deriving (Show) 99 | makeLenses ''MapboxStyle 100 | 101 | instance FromJSON MapboxStyle where 102 | parseJSON = AE.withObject "Style" $ \o -> 103 | MapboxStyle <$> o .: "layers" 104 | 105 | instance Semigroup MapboxStyle where 106 | MapboxStyle l1 <> MapboxStyle l2 = MapboxStyle (l1 <> l2) 107 | -------------------------------------------------------------------------------- /src/Mapbox/UntypedExpression.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE InstanceSigs #-} 7 | 8 | -- | Untyped expression parser for the mapbox style expressions 9 | module Mapbox.UntypedExpression where 10 | 11 | import Control.Applicative ((<|>)) 12 | import Data.Aeson ((.:?)) 13 | import qualified Data.Aeson as AE 14 | import Data.Functor.Classes 15 | import Data.Fix (Fix(..)) 16 | import Data.Scientific (Scientific) 17 | import qualified Data.Text as T 18 | import qualified Data.Vector as V 19 | import Data.Aeson.Types (Parser) 20 | 21 | type Id = T.Text 22 | 23 | type NumArray = V.Vector Scientific 24 | 25 | data ULabel = 26 | LStr T.Text 27 | | LStrArr [T.Text] 28 | | LBool Bool 29 | | LNumArr NumArray 30 | | LNum Scientific 31 | deriving (Show) 32 | 33 | instance AE.FromJSON ULabel where 34 | parseJSON v = LStr <$> AE.parseJSON v 35 | <|> LStrArr <$> AE.parseJSON v 36 | <|> LNum <$> AE.parseJSON v 37 | <|> LNumArr <$> AE.parseJSON v 38 | <|> LBool <$> AE.parseJSON v 39 | 40 | data UExpF r = 41 | UNum Scientific 42 | | UStr T.Text 43 | | UBool Bool 44 | | UNumArr NumArray 45 | | UVar Id 46 | | UApp Id [r] 47 | | UMatch r [(ULabel,r)] r 48 | | ULet Id r r 49 | | UFunction { ufProperty :: Maybe T.Text } -- Function - we should have 'base', 'stops' etc., currently unimplemented 50 | deriving (Show, Functor) 51 | type UExp = Fix UExpF 52 | 53 | instance Show1 UExpF where 54 | liftShowsPrec _ _ d (UNum n) = showParen (d > 10) $ showString "UNum " . showsPrec 11 n 55 | liftShowsPrec _ _ d (UStr n) = showParen (d > 10) $ showString "UStr " . showsPrec 11 n 56 | liftShowsPrec _ _ d (UBool n) = showParen (d > 10) $ showString "UBool " . showsPrec 11 n 57 | liftShowsPrec _ _ d (UVar n) = showParen (d > 10) $ showString "UVar " . showsPrec 11 n 58 | liftShowsPrec _ _ d (UNumArr n) = showParen (d > 10) $ showString "UNumArr " . showsPrec 11 n 59 | liftShowsPrec sp _ d (ULet tid x y) = showParen (d > 10) $ 60 | showString "ULet " . showsPrec 11 tid . showString " " 61 | . sp 11 x . showChar ' ' . sp 11 y 62 | liftShowsPrec sp _ d (UApp tid lst) = showParen (d > 10) $ 63 | showString "UApp " . showsPrec 11 tid . showString " " 64 | . mconcat (map (\l -> showChar ' ' . sp 11 l) lst) 65 | liftShowsPrec _ _ d (UFunction pid) = showParen (d > 10) $ showString "UFunction " . showsPrec 11 pid 66 | liftShowsPrec sp _ d (UMatch inp lst lelse) = showParen (d > 10) $ 67 | showString "UApp " . showString "match" . showString " " 68 | . sp 11 inp . mconcat (map (\(l,v) -> showChar '(' . showString (show l) . showChar ',' . sp 11 v . showChar ')') lst) 69 | . sp 11 lelse 70 | 71 | 72 | instance AE.FromJSON1 UExpF where 73 | liftParseJSON :: forall a. (AE.Value -> Parser a) -> (AE.Value -> Parser [a]) -> AE.Value -> Parser (UExpF a) 74 | liftParseJSON parse _ = uparse 75 | where 76 | uparse (AE.String str) = return (UStr str) 77 | uparse (AE.Number num) = return (UNum num) 78 | uparse (AE.Bool b) = return (UBool b) 79 | uparse AE.Null = fail "Null not supported as expression" 80 | uparse (AE.Object o) = do 81 | prop <- o .:? "property" 82 | return (UFunction prop) 83 | uparse (AE.Array arr) = numarr <|> expr 84 | where 85 | numarr = UNumArr <$> traverse AE.parseJSON arr 86 | 87 | expr | (idn:iargs) <- V.toList arr = do 88 | fid <- AE.parseJSON idn 89 | case (fid :: T.Text) of 90 | "let" -> letexpr iargs 91 | "var" -> varexpr iargs 92 | "match" -> matchexpr iargs 93 | _ -> UApp fid <$> traverse parse iargs 94 | | otherwise = fail "Empty array not supported" 95 | 96 | letexpr [AE.String vname, val, rest] = do 97 | uval <- parse val 98 | next <- parse rest 99 | return (ULet vname uval next) 100 | letexpr _ = fail "Invalid let expression" 101 | varexpr [AE.String nm] = return (UVar nm) 102 | varexpr _ = fail "Invalid var expression" 103 | 104 | matchexpr (idn:rest) = do 105 | inp <- parse idn 106 | (tbl, lastArg) <- parseMatchTable [] rest 107 | lelse <- parse lastArg 108 | return $ UMatch inp tbl lelse 109 | matchexpr args = fail ("Invalid match arguments: " <> show args) 110 | 111 | parseMatchTable :: [(ULabel, a)] -> [AE.Value] -> Parser ([(ULabel, a)], AE.Value) 112 | parseMatchTable tbl [dlast] = return (tbl, dlast) 113 | parseMatchTable tbl (lbl:v:rest) = do 114 | dlabel <- AE.parseJSON lbl 115 | dval <- parse v 116 | parseMatchTable ((dlabel, dval):tbl) rest 117 | parseMatchTable _ [] = fail "Wrong number of arguments to match" 118 | --------------------------------------------------------------------------------