bloodhound-1.0.0.0: tests/Test/VectorTileSpec.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-x-partial #-}
module Test.VectorTileSpec (spec) where
import Data.Aeson (decode, encode)
import Data.ByteString.Lazy.Char8 qualified as BL8
import Database.Bloodhound.Common.Requests qualified as Requests
( searchVectorTile,
searchVectorTileWith,
)
import TestsUtils.Common
import TestsUtils.Import
spec :: Spec
spec = do
describe "VectorTileGridAgg JSON" $ do
it "encodes geotile as \"geotile\"" $
encode VectorTileGridAggGeotile `shouldBe` "\"geotile\""
it "encodes geohex as \"geohex\"" $
encode VectorTileGridAggGeohex `shouldBe` "\"geohex\""
it "decodes \"geotile\" / \"geohex\" and rejects unknown values" $ do
decode "\"geotile\"" `shouldBe` Just VectorTileGridAggGeotile
decode "\"geohex\"" `shouldBe` Just VectorTileGridAggGeohex
decode "\"bogus\"" `shouldBe` (Nothing :: Maybe VectorTileGridAgg)
describe "VectorTileGridType JSON" $ do
it "round-trips grid / point / centroid" $ do
encode VectorTileGridTypeGrid `shouldBe` "\"grid\""
encode VectorTileGridTypePoint `shouldBe` "\"point\""
encode VectorTileGridTypeCentroid `shouldBe` "\"centroid\""
decode "\"point\"" `shouldBe` Just VectorTileGridTypePoint
decode "\"bogus\"" `shouldBe` (Nothing :: Maybe VectorTileGridType)
describe "Tile coordinate newtypes JSON" $ do
it "TileZoom / TileX / TileY encode as bare numbers" $ do
encode (TileZoom 13 :: TileZoom) `shouldBe` "13"
encode (TileX 4207 :: TileX) `shouldBe` "4207"
encode (TileY 2692 :: TileY) `shouldBe` "2692"
it "round-trip via decode" $ do
decode "13" `shouldBe` Just (TileZoom 13 :: TileZoom)
decode "0" `shouldBe` Just (TileX 0 :: TileX)
decode "4294967295" `shouldBe` Just (TileY 4294967295 :: TileY)
describe "VectorTileOptions params" $ do
it "renders nothing for defaultVectorTileOptions" $
vectorTileOptionsParams defaultVectorTileOptions `shouldBe` []
it "renders exact_bounds as a boolean string" $
let opts = defaultVectorTileOptions {vtoExactBounds = Just True}
in lookup "exact_bounds" (vectorTileOptionsParams opts) `shouldBe` Just (Just "true")
it "renders with_labels as a boolean string" $
let opts = defaultVectorTileOptions {vtoWithLabels = Just False}
in lookup "with_labels" (vectorTileOptionsParams opts) `shouldBe` Just (Just "false")
it "renders extent as a number string" $
let opts = defaultVectorTileOptions {vtoExtent = Just 2048}
in lookup "extent" (vectorTileOptionsParams opts) `shouldBe` Just (Just "2048")
it "renders size as a number string" $
let opts = defaultVectorTileOptions {vtoSize = Just 1000}
in lookup "size" (vectorTileOptionsParams opts) `shouldBe` Just (Just "1000")
it "renders grid_precision as a number string" $
let opts = defaultVectorTileOptions {vtoGridPrecision = Just 4}
in lookup "grid_precision" (vectorTileOptionsParams opts) `shouldBe` Just (Just "4")
it "renders grid_agg as the wire value" $
let opts = defaultVectorTileOptions {vtoGridAgg = Just VectorTileGridAggGeohex}
in lookup "grid_agg" (vectorTileOptionsParams opts) `shouldBe` Just (Just "geohex")
it "renders grid_type as the wire value" $
let opts = defaultVectorTileOptions {vtoGridType = Just VectorTileGridTypeCentroid}
in lookup "grid_type" (vectorTileOptionsParams opts) `shouldBe` Just (Just "centroid")
it "renders track_total_hits=true for All" $
let opts = defaultVectorTileOptions {vtoTrackTotalHits = Just VectorTileTrackTotalHitsAll}
in lookup "track_total_hits" (vectorTileOptionsParams opts) `shouldBe` Just (Just "true")
it "renders track_total_hits=false for Off" $
let opts = defaultVectorTileOptions {vtoTrackTotalHits = Just VectorTileTrackTotalHitsOff}
in lookup "track_total_hits" (vectorTileOptionsParams opts) `shouldBe` Just (Just "false")
it "renders track_total_hits=N for UpTo" $
let opts = defaultVectorTileOptions {vtoTrackTotalHits = Just (VectorTileTrackTotalHitsUpTo 1000)}
in lookup "track_total_hits" (vectorTileOptionsParams opts) `shouldBe` Just (Just "1000")
it "renders every option at once, preserving order" $
let opts =
defaultVectorTileOptions
{ vtoExactBounds = Just True,
vtoExtent = Just 4096,
vtoGridAgg = Just VectorTileGridAggGeotile,
vtoGridPrecision = Just 8,
vtoGridType = Just VectorTileGridTypeGrid,
vtoSize = Just 10000,
vtoTrackTotalHits = Just VectorTileTrackTotalHitsAll,
vtoWithLabels = Just True
}
params = vectorTileOptionsParams opts
in params
`shouldBe` [ ("exact_bounds", Just "true"),
("extent", Just "4096"),
("grid_agg", Just "geotile"),
("grid_precision", Just "8"),
("grid_type", Just "grid"),
("size", Just "10000"),
("track_total_hits", Just "true"),
("with_labels", Just "true")
]
describe "searchVectorTile endpoint shape" $ do
-- Pure checks against the BHRequest shape; no live backend needed.
let idx = [qqIndexName|museums|]
field = FieldName "location"
zoom = TileZoom 13
x = TileX 4207
y = TileY 2692
search = mkSearch (Just (MatchAllQuery Nothing)) Nothing
it "GETs /{index}/_mvt/{field}/{zoom}/{x}/{y} with a JSON body" $ do
let req = Requests.searchVectorTile idx field zoom x y search
bhRequestMethod req `shouldBe` "GET"
getRawEndpoint (bhRequestEndpoint req)
`shouldBe` ["museums", "_mvt", "location", "13", "4207", "2692"]
bhRequestBody req `shouldSatisfy` isJust
it "serialises the Search body as a JSON object" $ do
let req = Requests.searchVectorTile idx field zoom x y search
Just body = bhRequestBody req
Just value = decode body :: Maybe Value
case value of
Object _ -> pure ()
_ -> expectationFailure "searchVectorTile body should be a JSON object"
it "uses no URI parameters by default" $ do
let req = Requests.searchVectorTile idx field zoom x y search
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` []
it "forwards VectorTileOptions as URI parameters" $ do
let opts = defaultVectorTileOptions {vtoExtent = Just 2048, vtoGridPrecision = Just 2}
req = Requests.searchVectorTileWith idx field zoom x y opts search
getRawEndpointQueries (bhRequestEndpoint req)
`shouldBe` [("extent", Just "2048"), ("grid_precision", Just "2")]
it "builds the canonical ES docs example URL" $ do
-- Example from the ES docs:
-- GET museums/_mvt/location/13/4207/2692
let req = Requests.searchVectorTile idx field zoom x y search
getRawEndpoint (bhRequestEndpoint req)
`shouldBe` ["museums", "_mvt", "location", "13", "4207", "2692"]
it "accepts tile coordinate 0/0/0 (whole-world tile)" $ do
let req = Requests.searchVectorTile idx field (TileZoom 0) (TileX 0) (TileY 0) search
getRawEndpoint (bhRequestEndpoint req)
`shouldBe` ["museums", "_mvt", "location", "0", "0", "0"]
describe "searchVectorTile binary response" $
-- Live integration smoke test. The MVT endpoint requires a geo_point
-- or geo_shape field; if the test backend doesn't have one, the
-- request fails with a structured EsError. Either outcome exercises
-- the binary-response decoder: success returns raw bytes; failure
-- parses the JSON error body. The test passes as long as the
-- decoder produces one of these outcomes rather than blowing up.
it "returns bytes or a structured EsError on a live cluster" $
withTestEnv $ do
_ <- insertData
result <-
tryPerformBHRequest $
Requests.searchVectorTile
testIndex
(FieldName "user")
(TileZoom 0)
(TileX 0)
(TileY 0)
(mkSearch (Just (MatchAllQuery Nothing)) Nothing)
case result of
Right bytes ->
liftIO $ (BL8.length bytes >= 0) `shouldBe` True
Left (_ :: EsError) ->
-- Server-side rejection (e.g. field is not a geo_point);
-- the binary decoder correctly surfaced the JSON error.
pure ()