@@ -0,0 +1,130 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+
4+module Test
5+ where
6+
7+import Database.V5.Bloodhound
8+import Data.Aeson
9+import Data.Text (Text)
10+import Data.Time.Clock (NominalDiffTime, UTCTime (..),
11+ secondsToDiffTime)
12+import GHC.Generics
13+import Data.Time.Calendar (Day (..), fromGregorian)
14+import Network.HTTP.Client hiding (Proxy)
15+import qualified Data.HashMap.Strict as HM
16+
17+testServer :: Server
18+testServer = Server "http://localhost:9200"
19+testIndex :: IndexName
20+testIndex = IndexName "bloodhound-tests-twitter-1"
21+testMapping :: MappingName
22+testMapping = MappingName "tweet"
23+withTestEnv :: BH IO a -> IO a
24+withTestEnv = withBH defaultManagerSettings testServer
25+createExampleIndex :: (MonadBH m) => m Reply
26+createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
27+deleteExampleIndex :: (MonadBH m) => m Reply
28+deleteExampleIndex = deleteIndex testIndex
29+insertData :: BH IO Reply
30+insertData = do
31+ resetIndex
32+ insertData' defaultIndexDocumentSettings
33+
34+insertData' :: IndexDocumentSettings -> BH IO Reply
35+insertData' ids = do
36+ r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
37+ _ <- refreshIndex testIndex
38+ return r
39+
40+searchTweet :: Search -> BH IO (Either EsError Tweet)
41+searchTweet search = do
42+ result <- searchTweets search
43+ let myTweet :: Either EsError Tweet
44+ myTweet = grabFirst result
45+ return myTweet
46+
47+searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet))
48+searchTweets search = parseEsResponse =<< searchByIndex testIndex search
49+
50+data Tweet = Tweet { user :: Text
51+ , postDate :: UTCTime
52+ , message :: Text
53+ , age :: Int
54+ , location :: Location
55+ , extra :: Maybe Text }
56+ deriving (Eq, Generic, Show)
57+
58+instance ToJSON Tweet where
59+ toJSON = genericToJSON defaultOptions
60+instance FromJSON Tweet where
61+ parseJSON = genericParseJSON defaultOptions
62+instance ToJSON Location where
63+ toJSON = genericToJSON defaultOptions
64+instance FromJSON Location where
65+ parseJSON = genericParseJSON defaultOptions
66+
67+data Location = Location { lat :: Double
68+ , lon :: Double } deriving (Eq, Generic, Show)
69+
70+
71+grabFirst :: Either EsError (SearchResult a) -> Either EsError a
72+grabFirst r =
73+ case fmap (hitSource . head . hits . searchHits) r of
74+ (Left e) -> Left e
75+ (Right Nothing) -> Left (EsError 500 "Source was missing")
76+ (Right (Just x)) -> Right x
77+
78+resetIndex :: BH IO ()
79+resetIndex = do
80+ _ <- deleteExampleIndex
81+ _ <- createExampleIndex
82+ _ <- putMapping testIndex testMapping TweetMapping
83+ return ()
84+
85+data TweetMapping = TweetMapping deriving (Eq, Show)
86+
87+instance ToJSON TweetMapping where
88+ toJSON TweetMapping =
89+ object ["tweet" .=
90+ object ["properties" .=
91+ object [ "user" .= object [ "type" .= ("string" :: Text)
92+ , "fielddata" .= True
93+ ]
94+ -- Serializing the date as a date is breaking other tests, mysteriously.
95+ -- , "postDate" .= object [ "type" .= ("date" :: Text)
96+ -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
97+ , "message" .= object ["type" .= ("string" :: Text)]
98+ , "age" .= object ["type" .= ("integer" :: Text)]
99+ , "location" .= object ["type" .= ("geo_point" :: Text)]
100+ , "extra" .= object ["type" .= ("keyword" :: Text)]
101+ ]]]
102+
103+exampleTweet :: Tweet
104+exampleTweet = Tweet { user = "bitemyapp"
105+ , postDate = UTCTime
106+ (ModifiedJulianDay 55000)
107+ (secondsToDiffTime 10)
108+ , message = "Use haskell!"
109+ , age = 10000
110+ , location = Location 40.12 (-71.34)
111+ , extra = Nothing }
112+
113+one :: IO ()
114+one = do
115+ _ <- withTestEnv $ insertData
116+ let innerQuery = QueryMatchNoneQuery
117+ -- let innerQuery = QueryMatchQuery $ mkMatchQuery (FieldName "message") (QueryString "Use haskel")
118+ let phraseSuggester = mkPhraseSuggester (FieldName "message")
119+ let namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)
120+ let search' = mkSearch (Just innerQuery) Nothing
121+ let search = search' { suggestBody = Just namedSuggester }
122+ print $ encode search
123+ -- myTweet <- withTestEnv $ searchTweet search
124+ {- liftIO $
125+ myTweet `shouldBe` Right exampleTweet -}
126+ -- print myTweet
127+ resp <- withTestEnv $ searchByIndex testIndex search
128+ parsed <- parseEsResponse resp :: IO (Either EsError (SearchResult Tweet))
129+ print parsed
130+ return ()