4269d27 · typeable/bloodhound

git.iko.soy/typeable/bloodhound

on master help sign in

Add date_range aggregation

4269d27Michael Xavier11 years ago

bloodhound.cabal+2−1

compare with master

unifiedsplit

@@ -71,7 +71,8 @@ test-suite tests

71 mtl,

72 quickcheck-properties,

73 derive,

74− quickcheck-instances

74+ quickcheck-instances,

75+ errors >= 2.0

75 default-language: Haskell2010

76 default-language: Haskell2010

77test-suite doctests

78test-suite doctests

src/Database/Bloodhound/Types.hs+107−2

@@ -225,6 +225,12 @@ module Database.Bloodhound.Types

225 , ValueCountAggregation(..)

226 , FilterAggregation(..)

227 , DateHistogramAggregation(..)

228+ , DateRangeAggregation(..)

229+ , DateRangeAggRange(..)

230+ , DateMathExpr(..)

231+ , DateMathAnchor(..)

232+ , DateMathModifier(..)

233+ , DateMathUnit(..)

228

234

229 , Highlights(..)

235 , Highlights(..)

230 , FieldHighlight(..)

236 , FieldHighlight(..)

@@ -240,6 +246,7 @@ module Database.Bloodhound.Types

240

246

241 , TermsResult(..)

247 , TermsResult(..)

242 , DateHistogramResult(..)

248 , DateHistogramResult(..)

249+ , DateRangeResult(..)

243 ) where

250 ) where

244

251

245import Control.Applicative

252import Control.Applicative

@@ -261,7 +268,9 @@ import qualified Data.Map.Strict as M

261import Data.Maybe

268import Data.Maybe

262import Data.Text (Text)

269import Data.Text (Text)

263import qualified Data.Text as T

270import qualified Data.Text as T

271+import Data.Time.Calendar

264import Data.Time.Clock (UTCTime)

272import Data.Time.Clock (UTCTime)

273+import Data.Time.Clock.POSIX

265import qualified Data.Traversable as DT

274import qualified Data.Traversable as DT

266import Data.Typeable (Typeable)

275import Data.Typeable (Typeable)

267import qualified Data.Vector as V

276import qualified Data.Vector as V

@@ -773,6 +782,9 @@ newtype PhraseSlop = PhraseSlop Int deriving (Eq, Show, Generic, ToJSO

773newtype MinDocFrequency = MinDocFrequency Int deriving (Eq, Show, Generic, ToJSON, FromJSON, Typeable)

782newtype MinDocFrequency = MinDocFrequency Int deriving (Eq, Show, Generic, ToJSON, FromJSON, Typeable)

774newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, Generic, ToJSON, FromJSON, Typeable)

783newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, Generic, ToJSON, FromJSON, Typeable)

775

784

785+-- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ

786+newtype POSIXMS = POSIXMS { posixMS :: UTCTime }

787+

776{-| 'unpackId' is a silly convenience function that gets used once.

788{-| 'unpackId' is a silly convenience function that gets used once.

777-}

789-}

778unpackId :: DocId -> Text

790unpackId :: DocId -> Text

@@ -1408,7 +1420,8 @@ data Interval = Year

1408data Aggregation = TermsAgg TermsAggregation

1420data Aggregation = TermsAgg TermsAggregation

1409 | DateHistogramAgg DateHistogramAggregation

1421 | DateHistogramAgg DateHistogramAggregation

1410 | ValueCountAgg ValueCountAggregation

1422 | ValueCountAgg ValueCountAggregation

1411− | FilterAgg FilterAggregation deriving (Eq, Show)

1423+ | FilterAgg FilterAggregation

1424+ | DateRangeAgg DateRangeAggregation deriving (Eq, Show)

1412

1425

1413

1426

1414data TermsAggregation = TermsAggregation { term :: Either Text Text

1427data TermsAggregation = TermsAggregation { term :: Either Text Text

@@ -1434,6 +1447,36 @@ data DateHistogramAggregation = DateHistogramAggregation { dateField :: Fie

1434 , dateAggs :: Maybe Aggregations

1447 , dateAggs :: Maybe Aggregations

1435 } deriving (Eq, Show)

1448 } deriving (Eq, Show)

1436

1449

1450+

1451+data DateRangeAggregation = DateRangeAggregation { draField :: FieldName

1452+ , draFormat :: Maybe Text

1453+ , draRanges :: NonEmpty DateRangeAggRange

1454+ } deriving (Eq, Show)

1455+

1456+data DateRangeAggRange = DateRangeFrom DateMathExpr

1457+ | DateRangeTo DateMathExpr

1458+ | DateRangeFromAndTo DateMathExpr DateMathExpr deriving (Eq, Show)

1459+

1460+-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#date-math> for more information.

1461+data DateMathExpr = DateMathExpr DateMathAnchor [DateMathModifier] deriving (Eq, Show)

1462+

1463+

1464+-- | Starting point for a date range. This along with the 'DateMathModifiers' gets you the date ES will start from.

1465+data DateMathAnchor = DMNow

1466+ | DMDate Day deriving (Eq, Show)

1467+

1468+data DateMathModifier = AddTime Int DateMathUnit

1469+ | SubtractTime Int DateMathUnit

1470+ | RoundDownTo DateMathUnit deriving (Eq, Show)

1471+

1472+data DateMathUnit = DMYear

1473+ | DMMonth

1474+ | DMWeek

1475+ | DMDay

1476+ | DMHour

1477+ | DMMinute

1478+ | DMSecond deriving (Eq, Show)

1479+

1437-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-metrics-valuecount-aggregation.html> for more information.

1480-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-metrics-valuecount-aggregation.html> for more information.

1438data ValueCountAggregation = FieldValueCount FieldName

1481data ValueCountAggregation = FieldValueCount FieldName

1439 | ScriptValueCount Script deriving (Eq, Show)

1482 | ScriptValueCount Script deriving (Eq, Show)

@@ -1537,6 +1580,39 @@ instance ToJSON Aggregation where

1537 toJSON (FilterAgg (FilterAggregation filt ags)) =

1580 toJSON (FilterAgg (FilterAggregation filt ags)) =

1538 omitNulls [ "filter" .= filt

1581 omitNulls [ "filter" .= filt

1539 , "aggs" .= ags]

1582 , "aggs" .= ags]

1583+ toJSON (DateRangeAgg a) = object [ "date_range" .= a

1584+ ]

1585+

1586+instance ToJSON DateRangeAggregation where

1587+ toJSON DateRangeAggregation {..} =

1588+ omitNulls [ "field" .= draField

1589+ , "format" .= draFormat

1590+ , "ranges" .= toList draRanges

1591+ ]

1592+

1593+instance ToJSON DateRangeAggRange where

1594+ toJSON (DateRangeFrom e) = object [ "from" .= e ]

1595+ toJSON (DateRangeTo e) = object [ "to" .= e ]

1596+ toJSON (DateRangeFromAndTo f t) = object [ "from" .= f, "to" .= t ]

1597+

1598+instance ToJSON DateMathExpr where

1599+ toJSON (DateMathExpr a mods) = String (fmtA a <> mconcat (fmtMod <$> mods))

1600+ where fmtA DMNow = "now"

1601+ fmtA (DMDate date) = case toGregorian date of

1602+ (y,m,d) -> showText y <> "-" <>

1603+ showText m <> "-" <>

1604+ showText d <> "||"

1605+ fmtMod (AddTime n u) = "+" <> showText n <> fmtU u

1606+ fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u

1607+ fmtMod (RoundDownTo u) = "/" <> fmtU u

1608+ fmtU DMYear = "y"

1609+ fmtU DMMonth = "M"

1610+ fmtU DMWeek = "w"

1611+ fmtU DMDay = "d"

1612+ fmtU DMHour = "h"

1613+ fmtU DMMinute = "m"

1614+ fmtU DMSecond = "s"

1615+

1540

1616

1541type AggregationResults = M.Map Text Value

1617type AggregationResults = M.Map Text Value

1542

1618

@@ -1557,6 +1633,14 @@ data DateHistogramResult = DateHistogramResult { dateKey :: Int

1557 , dateDocCount :: Int

1633 , dateDocCount :: Int

1558 , dateHistogramAggs :: Maybe AggregationResults } deriving (Show)

1634 , dateHistogramAggs :: Maybe AggregationResults } deriving (Show)

1559

1635

1636+data DateRangeResult = DateRangeResult { dateRangeKey :: Text

1637+ , dateRangeFrom :: Maybe UTCTime

1638+ , dateRangeFromAsString :: Maybe Text

1639+ , dateRangeTo :: Maybe UTCTime

1640+ , dateRangeToAsString :: Maybe Text

1641+ , dateRangeDocCount :: Int

1642+ , dateRangeAggs :: Maybe AggregationResults } deriving (Show, Eq)

1643+

1560toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)

1644toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)

1561toTerms t a = M.lookup t a >>= deserialize

1645toTerms t a = M.lookup t a >>= deserialize

1562 where deserialize = parseMaybe parseJSON

1646 where deserialize = parseMaybe parseJSON

@@ -1575,6 +1659,11 @@ instance BucketAggregation DateHistogramResult where

1575 docCount = dateDocCount

1659 docCount = dateDocCount

1576 aggs = dateHistogramAggs

1660 aggs = dateHistogramAggs

1577

1661

1662+instance BucketAggregation DateRangeResult where

1663+ key = dateRangeKey

1664+ docCount = dateRangeDocCount

1665+ aggs = dateRangeAggs

1666+

1578instance (FromJSON a, BucketAggregation a) => FromJSON (Bucket a) where

1667instance (FromJSON a, BucketAggregation a) => FromJSON (Bucket a) where

1579 parseJSON (Object v) = Bucket <$>

1668 parseJSON (Object v) = Bucket <$>

1580 v .: "buckets"

1669 v .: "buckets"

@@ -1595,6 +1684,22 @@ instance FromJSON DateHistogramResult where

1595 v .:? "aggregations"

1684 v .:? "aggregations"

1596 parseJSON _ = mempty

1685 parseJSON _ = mempty

1597

1686

1687+instance FromJSON DateRangeResult where

1688+ parseJSON = withObject "DateRangeResult" parse

1689+ where parse v = DateRangeResult <$>

1690+ v .: "key" <*>

1691+ (fmap posixMS <$> v .:? "from") <*>

1692+ v .:? "from_as_string" <*>

1693+ (fmap posixMS <$> v .:? "to") <*>

1694+ v .:? "to_as_string" <*>

1695+ v .: "doc_count" <*>

1696+ v .:? "aggregations"

1697+

1698+instance FromJSON POSIXMS where

1699+ parseJSON = withScientific "POSIXMS" (return . parse)

1700+ where parse n = let n' = truncate n :: Integer

1701+ in POSIXMS (posixSecondsToUTCTime (fromInteger (n' `div` 1000)))

1702+

1598instance Monoid Filter where

1703instance Monoid Filter where

1599 mempty = IdentityFilter

1704 mempty = IdentityFilter

1600 mappend a b = AndFilter [a, b] defaultCache

1705 mappend a b = AndFilter [a, b] defaultCache

@@ -1890,7 +1995,7 @@ instance FromJSON Query where

1890 <|> idsQuery `taggedWith` "ids"

1995 <|> idsQuery `taggedWith` "ids"

1891 <|> queryQueryStringQuery `taggedWith` "query_string"

1996 <|> queryQueryStringQuery `taggedWith` "query_string"

1892 <|> queryMatchQuery `taggedWith` "match"

1997 <|> queryMatchQuery `taggedWith` "match"

1893− <|> queryMultiMatchQuery --TODO: is this a precedence issue?

1998+ <|> queryMultiMatchQuery

1894 <|> queryBoolQuery `taggedWith` "bool"

1999 <|> queryBoolQuery `taggedWith` "bool"

1895 <|> queryBoostingQuery `taggedWith` "boosting"

2000 <|> queryBoostingQuery `taggedWith` "boosting"

1896 <|> queryCommonTermsQuery `taggedWith` "common"

2001 <|> queryCommonTermsQuery `taggedWith` "common"

tests/tests.hs+39−1

@@ -7,6 +7,7 @@

7module Main where

9import Control.Applicative

10+import Control.Error

10import Control.Exception

11import Control.Exception

11import Control.Monad

12import Control.Monad

12import Control.Monad.Reader

13import Control.Monad.Reader

@@ -23,7 +24,7 @@ import Data.Monoid

23import Data.Proxy

24import Data.Proxy

24import Data.Text (Text)

25import Data.Text (Text)

25import qualified Data.Text as T

26import qualified Data.Text as T

26−import Data.Time.Calendar (Day (..))

27+import Data.Time.Calendar (Day (..), fromGregorian)

27import Data.Time.Clock (UTCTime (..),

28import Data.Time.Clock (UTCTime (..),

28 secondsToDiffTime)

29 secondsToDiffTime)

29import Data.Typeable

30import Data.Typeable

@@ -917,6 +918,43 @@ main = hspec $ do

917 fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "bitemyapps" 1

918 fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "bitemyapps" 1

918 , docCountPair "notmyapps" 1

919 , docCountPair "notmyapps" 1

919 ]))

920 ]))

921+ it "can execute date_range aggregations" $ withTestEnv $ do

922+ let now = fromGregorian 2015 3 14

923+ let ltAMonthAgo = UTCTime (fromGregorian 2015 3 1) 0

924+ let ltAWeekAgo = UTCTime (fromGregorian 2015 3 10) 0

925+ let oldDoc = exampleTweet { postDate = ltAMonthAgo }

926+ let newDoc = exampleTweet { postDate = ltAWeekAgo }

927+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings oldDoc (DocId "1")

928+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings newDoc (DocId "2")

929+ _ <- refreshIndex testIndex

930+ let thisMonth = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMMonth])

931+ let thisWeek = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMWeek])

932+ let agg = DateRangeAggregation (FieldName "postDate") Nothing (thisMonth :| [thisWeek])

933+ let ags = mkAggregations "date_ranges" (DateRangeAgg agg)

934+ let search = mkAggregateSearch Nothing ags

935+ res <- searchTweets search

936+ liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right 2

937+ let bucks = do magrs <- fmapL show (aggregations <$> res)

938+ agrs <- note "no aggregations returned" magrs

939+ rawBucks <- note "no date_ranges aggregation" $ M.lookup "date_ranges" agrs

940+ parseEither parseJSON rawBucks

941+ let fromMonthT = UTCTime (fromGregorian 2015 2 14) 0

942+ let fromWeekT = UTCTime (fromGregorian 2015 3 7) 0

943+ liftIO $ buckets <$> bucks `shouldBe` Right [ DateRangeResult "2015-02-14T00:00:00.000Z-*"

944+ (Just fromMonthT)

945+ (Just "2015-02-14T00:00:00.000Z")

946+ Nothing

947+ Nothing

948+ 2

949+ Nothing

950+ , DateRangeResult "2015-03-07T00:00:00.000Z-*"

951+ (Just fromWeekT)

952+ (Just "2015-03-07T00:00:00.000Z")

953+ Nothing

954+ Nothing

955+ 1

956+ Nothing

957+ ]

920

958

921 it "returns date histogram aggregation results" $ withTestEnv $ do

959 it "returns date histogram aggregation results" $ withTestEnv $ do

922 _ <- insertData

960 _ <- insertData