mapping, bounding box positive validation, shuffling cache around

Database/Bloodhound/Client.hs

@@ -4,6 +4,8 @@ module Database.Bloodhound.Client
        ( createIndex
        , deleteIndex
        , defaultIndexSettings
+       , createMapping
+       , deleteMapping
        , indexDocument
        , getDocument
        , documentExists
@@ -26,6 +28,11 @@ module Database.Bloodhound.Client
        , Seminearring(..)
        , BoolMatch(..)
        , Term(..)
+       , GeoConstraint(..)
+       , GeoBoundingBoxConstraint(..)
+       , GeoBoundingBox(..)
+       , GeoFilterType(..)
+       , LatLon(..)
        )
        where
 
@@ -158,6 +165,12 @@ indexExists (Server server) indexName = do
   return exists where
     url = joinPath [server, indexName]
 
+refreshIndex :: Server -> IndexName -> IO Reply
+refreshIndex (Server server) indexName = dispatch url method body where
+  url = joinPath [server, indexName, "_refresh"]
+  method = NHTM.methodPost
+  body = Nothing
+
 data OpenCloseIndex = OpenIndex | CloseIndex deriving (Show)
 
 stringifyOCIndex oci = case oci of
@@ -180,6 +193,24 @@ closeIndex = openOrCloseIndexes CloseIndex
 
 type MappingName = String
 
+data FieldType = GeoPointType
+               | GeoShapeType
+               | FloatType
+               | IntegerType
+               | LongType
+               | ShortType
+               | ByteType deriving (Eq, Show)
+
+data FieldDefinition =
+  FieldDefinition { fieldType :: FieldType } deriving (Eq, Show)
+
+data MappingField =
+  MappingField   { fieldName       :: Text
+                 , fieldDefinition :: FieldDefinition } deriving (Eq, Show)
+
+data Mapping = Mapping { typeName :: Text
+                       , fields   :: [MappingField] } deriving (Eq, Show)
+
 createMapping :: ToJSON a => Server -> IndexName
                  -> MappingName -> a -> IO Reply
 createMapping (Server server) indexName mappingName mapping =
@@ -261,12 +292,6 @@ searchByType :: Server -> IndexName -> MappingName -> Search -> IO Reply
 searchByType (Server server) indexName mappingName search = dispatchSearch url search where
   url = joinPath [server, indexName, mappingName, "_search"]
 
-refreshIndex :: Server -> IndexName -> IO Reply
-refreshIndex (Server server) indexName = dispatch url method body where
-  url = joinPath [server, indexName, "_refresh"]
-  method = NHTM.methodPost
-  body = Nothing
-
 data Search = Search { queryBody  :: Maybe Query
                      , filterBody :: Maybe Filter } deriving (Show)
 
@@ -340,8 +365,8 @@ data Filter = AndFilter [Filter] Cache
             | IdentityFilter
             | BoolFilter BoolMatch
             | ExistsFilter FieldName -- always cached
-            | GeoBoundingBoxFilter GeoBoundingBoxConstraint GeoFilterType Cache
-            | GeoDistanceFilter GeoConstraint Distance Cache
+            | GeoBoundingBoxFilter GeoBoundingBoxConstraint GeoFilterType
+            | GeoDistanceFilter GeoConstraint Distance
               deriving (Show)
 
 class Monoid a => Seminearring a where
@@ -374,6 +399,28 @@ instance ToJSON Filter where
             ["field"  .= fieldName]]
   toJSON (BoolFilter boolMatch) =
     object ["bool"    .= toJSON boolMatch]
+  toJSON (GeoBoundingBoxFilter bbConstraint filterType) =
+    object ["geo_bounding_box" .= toJSON bbConstraint
+           , "type" .= toJSON filterType]
+
+instance ToJSON GeoBoundingBoxConstraint where
+  toJSON (GeoBoundingBoxConstraint geoBBField constraintBox cache) =
+    object [geoBBField .= toJSON constraintBox
+           , "_cache" .= cache]
+
+instance ToJSON GeoFilterType where
+  toJSON GeoFilterMemory  = "memory"
+  toJSON GeoFilterIndexed = "indexed"
+
+instance ToJSON GeoBoundingBox where
+  toJSON (GeoBoundingBox topLeft bottomRight) =
+    object ["top_left" .= toJSON topLeft
+           , "bottom_right" .= toJSON bottomRight]
+
+instance ToJSON LatLon where
+  toJSON (LatLon lat lon) =
+    object ["lat" .= lat
+           , "lon" .= lon]
 
 data Term = Term { termField :: Text
                  , termValue :: Text } deriving (Show)
@@ -397,6 +444,7 @@ instance ToJSON BoolMatch where
 -- "memory" or "indexed"
 data GeoFilterType = GeoFilterMemory | GeoFilterIndexed deriving (Show)
 
+
 data LatLon = LatLon { lat :: Double
                      , lon :: Double } deriving (Show)
 
@@ -407,6 +455,7 @@ data GeoBoundingBox =
 data GeoBoundingBoxConstraint =
   GeoBoundingBoxConstraint { geoBBField    :: FieldName
                            , constraintBox :: GeoBoundingBox
+                           , cache         :: Cache
                            } deriving (Show)
 
 data GeoConstraint =
@@ -426,7 +475,7 @@ data DistanceUnits = Miles
 data DistanceType = Arc | SloppyArc | Plane deriving (Show)
 
 -- geo_point?
-data OptimizeBbox = GeoFilterType | NoOptimizeBbox deriving (Show)
+data OptimizeBbox = OptimizeGeoFilterType GeoFilterType | NoOptimizeBbox deriving (Show)
 
 data Distance =
   Distance { coefficient :: Double

README.org

@@ -1,5 +1,15 @@
+* PRE-ALPHA, THERE IS NOTHING FOR YOU HERE
+
 * Bloodhound
 
 Elasticsearch client and query DSL for Haskell
 
-** PRE-ALPHA, THERE IS NOTHING FOR YOU HERE
+** Possible future functionality
+
+Runtime checking for cycles in data structures:
+
+check for n > 1 occurrences in DFS:
+
+http://hackage.haskell.org/package/stable-maps-0.0.5/docs/System-Mem-StableName-Dynamic.html
+
+http://hackage.haskell.org/package/stable-maps-0.0.5/docs/System-Mem-StableName-Dynamic-Map.html

tests/tests.hs

@@ -16,40 +16,54 @@ import qualified Network.HTTP.Types.Status as NHTS
 import Test.Hspec
 
 
-testServer = Server "http://localhost:9200"
-testIndex = "twitter"
+testServer  = Server "http://localhost:9200"
+testIndex   = "twitter"
+testMapping = "tweet"
 validateStatus resp expected = (NHTS.statusCode $ responseStatus resp) `shouldBe` (expected :: Int)
 createExampleIndex = createIndex testServer defaultIndexSettings testIndex
 deleteExampleIndex = deleteIndex testServer testIndex
 
+data Location = Location { lat :: Double
+                         , lon :: Double } deriving (Eq, Generic, Show)
+
 data Tweet = Tweet { user     :: Text
                    , postDate :: UTCTime
-                   , message  :: Text }
+                   , message  :: Text
+                   , location :: Location }
            deriving (Eq, Generic, Show)
 
-instance ToJSON Tweet
+instance ToJSON   Tweet
 instance FromJSON Tweet
+instance ToJSON   Location
+instance FromJSON Location
+
+data TweetMapping = TweetMapping deriving (Eq, Show)
+
+instance ToJSON TweetMapping where
+  toJSON TweetMapping =
+    object ["tweet" .=
+            object ["properties" .=
+                    object ["location" .= object ["type" .= ("geo_point" :: Text)]]]]
 
 exampleTweet = Tweet { user     = "bitemyapp"
                      , postDate = UTCTime
                                   (ModifiedJulianDay 55000)
                                   (secondsToDiffTime 10)
-                     , message  = "Use haskell!" }
+                     , message  = "Use haskell!"
+                     , location = Location 40.12 (-71.34) }
 
 insertData :: IO ()
 insertData = do
   let encoded = encode exampleTweet
   _ <- deleteExampleIndex
   created <- createExampleIndex
-  docCreated <- indexDocument (Server "http://localhost:9200") "twitter" "tweet" exampleTweet "1"
-  _ <- refreshIndex testServer "twitter"
+  mappingCreated <- createMapping testServer testIndex testMapping TweetMapping
+  docCreated <- indexDocument testServer testIndex testMapping exampleTweet "1"
+  _ <- refreshIndex testServer testIndex
   return ()
 
-queryTweet :: IO (Either String Tweet)
-queryTweet = do
-  let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False)
-                    <&&> IdentityFilter
-  let search = Search Nothing (Just queryFilter)
+searchTweet :: Search -> IO (Either String Tweet)
+searchTweet search = do
   reply <- searchByIndex testServer "twitter" search
   let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
   let myTweet = fmap (hitSource . head . hits . searchHits) result
@@ -73,8 +87,26 @@ main = hspec $ do
       let newTweet = eitherDecode (responseBody docInserted) :: Either String (EsResult Tweet)
       fmap _source newTweet `shouldBe` Right exampleTweet
 
-  describe "document filtering" $ do
-    it "returns documents expected from composed filters" $ do
+  describe "filtering API" $ do
+    it "returns document for composed boolmatch and identity" $ do
       _ <- insertData
-      myTweet <- queryTweet
+      let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False)
+                        <&&> IdentityFilter
+      let search = Search Nothing (Just queryFilter)
+      myTweet <- searchTweet search
+      myTweet `shouldBe` Right exampleTweet
+
+    it "returns document for existential query" $ do
+      _ <- insertData
+      let search = Search Nothing (Just (ExistsFilter "user"))
+      myTweet <- searchTweet search
+      myTweet `shouldBe` Right exampleTweet
+
+    it "returns document for geo boundingbox query" $ do
+      _ <- insertData
+      let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12))
+      let bbConstraint = GeoBoundingBoxConstraint "tweet.location" box False
+      let geoFilter = GeoBoundingBoxFilter bbConstraint GeoFilterMemory
+      let search = Search Nothing (Just geoFilter)
+      myTweet <- searchTweet search
       myTweet `shouldBe` Right exampleTweet