diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,51 @@ -import Distribution.Simple -main = defaultMain +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.List ( nub ) +import Data.Version ( showVersion ) +import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) +import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) +import Distribution.Text ( display ) +import Distribution.Verbosity ( Verbosity, normal ) +import System.FilePath ( () ) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + , postHaddock = \args flags pkg lbi -> do + -- copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")] + postHaddock simpleUserHooks args flags pkg lbi + } + +haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath +haddockOutputDir flags pkg = destDir where + baseDir = case haddockDistPref flags of + NoFlag -> "." + Flag x -> x + destDir = baseDir "doc" "html" display (packageName pkg) + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys diff --git a/bloodhound.cabal b/bloodhound.cabal --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -1,5 +1,5 @@ name: bloodhound -version: 0.4.0.2 +version: 0.5.0.0 synopsis: ElasticSearch client library for Haskell description: ElasticSearch made awesome for Haskell hackers homepage: https://github.com/bitemyapp/bloodhound @@ -9,7 +9,7 @@ maintainer: cma@bitemyapp.com copyright: 2014, Chris Allen category: Database, Search -build-type: Simple +build-type: Custom cabal-version: >=1.10 source-repository head @@ -18,14 +18,13 @@ library ghc-options: -Wall - default-extensions: OverloadedStrings exposed-modules: Database.Bloodhound Database.Bloodhound.Client Database.Bloodhound.Types Database.Bloodhound.Types.Class hs-source-dirs: src build-depends: base >= 4.3 && <5, - bytestring >= 0.10.2 && <0.11, + bytestring >= 0.10.0 && <0.11, containers >= 0.5.0.0 && <0.6, aeson >= 0.7 && <0.9, conduit >= 1.0 && <1.3, @@ -34,12 +33,11 @@ time >= 1.4 && <1.6, text >= 0.11 && <1.3, http-types >= 0.8 && <0.9, - vector >= 0.10.9 && <0.11 + vector >= 0.10.9 && <0.11 default-language: Haskell2010 test-suite tests - ghc-options: -Wall - default-extensions: OverloadedStrings + ghc-options: -Wall -fno-warn-orphans type: exitcode-stdio-1.0 main-is: tests.hs hs-source-dirs: tests @@ -57,3 +55,14 @@ vector, unordered-containers >= 0.2.5.0 && <0.3 default-language: Haskell2010 + +test-suite doctests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: tests + build-depends: base, + directory, + doctest, + doctest-prop, + filepath diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -1,5 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Database.Bloodhound.Client +-- Copyright : (C) 2014 Chris Allen +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Chris Allen >> :set -XOverloadedStrings +-- >>> :set -XDeriveGeneric +-- >>> import Database.Bloodhound +-- >>> import Test.DocTest.Prop (assert) +-- >>> let testServer = (Server "http://localhost:9200") +-- >>> let testIndex = IndexName "twitter" +-- >>> let testMapping = MappingName "tweet" +-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) +-- >>> data TweetMapping = TweetMapping deriving (Eq, Show) +-- >>> _ <- deleteIndex testServer testIndex +-- >>> _ <- deleteMapping testServer testIndex testMapping +-- >>> import GHC.Generics +-- >>> import Data.Time.Calendar (Day (..)) +-- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime) +-- >>> :{ +--instance ToJSON TweetMapping where +-- toJSON TweetMapping = +-- object ["tweet" .= +-- object ["properties" .= +-- object ["location" .= +-- object ["type" .= ("geo_point" :: Text)]]]] +--data Location = Location { lat :: Double +-- , lon :: Double } deriving (Eq, Generic, Show) +--data Tweet = Tweet { user :: Text +-- , postDate :: UTCTime +-- , message :: Text +-- , age :: Int +-- , location :: Location } deriving (Eq, Generic, Show) +--exampleTweet = Tweet { user = "bitemyapp" +-- , postDate = UTCTime +-- (ModifiedJulianDay 55000) +-- (secondsToDiffTime 10) +-- , message = "Use haskell!" +-- , age = 10000 +-- , location = Location 40.12 (-71.34) } +--instance ToJSON Tweet +--instance FromJSON Tweet +--instance ToJSON Location +--instance FromJSON Location +--data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show) +--instance FromJSON BulkTest +--instance ToJSON BulkTest +-- :} +-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount' +-- which rejects 'Int' values below 1 and above 1000. +-- +-- >>> mkShardCount 10 +-- Just (ShardCount 10) mkShardCount :: Int -> Maybe ShardCount mkShardCount n | n < 1 = Nothing - | n > 1000 = Nothing -- seriously, what the fuck? + | n > 1000 = Nothing | otherwise = Just (ShardCount n) +-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount' +-- which rejects 'Int' values below 1 and above 1000. +-- +-- >>> mkReplicaCount 10 +-- Just (ReplicaCount 10) mkReplicaCount :: Int -> Maybe ReplicaCount mkReplicaCount n | n < 1 = Nothing @@ -90,36 +162,67 @@ -- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html -- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs +-- | 'getStatus' fetches the 'Status' of a 'Server' +-- +-- >>> getStatus testServer +-- Just (Status {ok = Nothing, status = 200, name = "Arena", version = Version {number = "1.4.1", build_hash = "89d3241d670db65f994242c8e8383b169779e2d4", build_timestamp = 2014-11-26 15:49:29 UTC, build_snapshot = False, lucene_version = "4.10.2"}, tagline = "You Know, for Search"}) getStatus :: Server -> IO (Maybe Status) getStatus (Server server) = do request <- parseUrl $ joinPath [server] response <- withManager defaultManagerSettings $ httpLbs request return $ decode (responseBody response) +-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'. +-- +-- >>> response <- createIndex testServer defaultIndexSettings (IndexName "didimakeanindex") +-- >>> respIsTwoHunna response +-- True +-- >>> indexExists testServer (IndexName "didimakeanindex") +-- True createIndex :: Server -> IndexSettings -> IndexName -> IO Reply createIndex (Server server) indexSettings (IndexName indexName) = put url body where url = joinPath [server, indexName] body = Just $ encode indexSettings +-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'. +-- +-- >>> response <- createIndex testServer defaultIndexSettings (IndexName "didimakeanindex") +-- >>> response <- deleteIndex testServer (IndexName "didimakeanindex") +-- >>> respIsTwoHunna response +-- True +-- >>> indexExists testServer testIndex +-- False deleteIndex :: Server -> IndexName -> IO Reply deleteIndex (Server server) (IndexName indexName) = delete $ joinPath [server, indexName] +statusCodeIs :: Int -> Reply -> Bool +statusCodeIs n resp = NHTS.statusCode (responseStatus resp) == n + respIsTwoHunna :: Reply -> Bool -respIsTwoHunna resp = NHTS.statusCode (responseStatus resp) == 200 +respIsTwoHunna = statusCodeIs 200 existentialQuery :: String -> IO (Reply, Bool) existentialQuery url = do reply <- head url return (reply, respIsTwoHunna reply) +-- | 'indexExists' enables you to check if an index exists. Returns 'Bool' +-- in IO +-- +-- >>> exists <- indexExists testServer testIndex indexExists :: Server -> IndexName -> IO Bool indexExists (Server server) (IndexName indexName) = do (_, exists) <- existentialQuery url return exists where url = joinPath [server, indexName] +-- | 'refreshIndex' will force a refresh on an index. You must +-- do this if you want to read what you wrote. +-- +-- >>> _ <- createIndex testServer defaultIndexSettings testIndex +-- >>> _ <- refreshIndex testServer testIndex refreshIndex :: Server -> IndexName -> IO Reply refreshIndex (Server server) (IndexName indexName) = post url Nothing @@ -136,15 +239,27 @@ where ociString = stringifyOCIndex oci url = joinPath [server, indexName, ociString] +-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at +-- http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html +-- +-- >>> reply <- openIndex testServer testIndex openIndex :: Server -> IndexName -> IO Reply openIndex = openOrCloseIndexes OpenIndex +-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at +-- http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html +-- +-- >>> reply <- closeIndex testServer testIndex closeIndex :: Server -> IndexName -> IO Reply closeIndex = openOrCloseIndexes CloseIndex -{-| putMapping is an HTTP PUT and has upsert semantics. Mappings are schemas - for documents in indexes. --} +-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas +-- for documents in indexes. +-- +-- >>> _ <- createIndex testServer defaultIndexSettings testIndex +-- >>> resp <- putMapping testServer testIndex testMapping TweetMapping +-- >>> print resp +-- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("Content-Type","application/json; charset=UTF-8"),("Content-Length","21")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} putMapping :: ToJSON a => Server -> IndexName -> MappingName -> a -> IO Reply putMapping (Server server) (IndexName indexName) (MappingName mappingName) mapping = @@ -152,11 +267,27 @@ where url = joinPath [server, indexName, mappingName, "_mapping"] body = Just $ encode mapping +-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index. +-- Mappings are schemas for documents in indexes. +-- +-- >>> _ <- createIndex testServer defaultIndexSettings testIndex +-- >>> _ <- putMapping testServer testIndex testMapping TweetMapping +-- >>> resp <- deleteMapping testServer testIndex testMapping +-- >>> print resp +-- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("Content-Type","application/json; charset=UTF-8"),("Content-Length","21")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} deleteMapping :: Server -> IndexName -> MappingName -> IO Reply deleteMapping (Server server) (IndexName indexName) (MappingName mappingName) = delete $ joinPath [server, indexName, mappingName, "_mapping"] +-- | 'indexDocument' is the primary way to save a single document in +-- Elasticsearch. The document itself is simply something we can +-- convert into a JSON 'Value'. The 'DocId' will function as the +-- primary key for the document. +-- +-- >>> resp <- indexDocument testServer testIndex testMapping exampleTweet (DocId "1") +-- >>> print resp +-- Response {responseStatus = Status {statusCode = 201, statusMessage = "Created"}, responseVersion = HTTP/1.1, responseHeaders = [("Content-Type","application/json; charset=UTF-8"),("Content-Length","74")], responseBody = "{\"_index\":\"twitter\",\"_type\":\"tweet\",\"_id\":\"1\",\"_version\":1,\"created\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} indexDocument :: ToJSON doc => Server -> IndexName -> MappingName -> doc -> DocId -> IO Reply indexDocument (Server server) (IndexName indexName) @@ -165,17 +296,36 @@ where url = joinPath [server, indexName, mappingName, docId] body = Just (encode document) +-- | 'deleteDocument' is the primary way to delete a single document. +-- +-- >>> _ <- deleteDocument testServer testIndex testMapping (DocId "1") deleteDocument :: Server -> IndexName -> MappingName -> DocId -> IO Reply deleteDocument (Server server) (IndexName indexName) (MappingName mappingName) (DocId docId) = delete $ joinPath [server, indexName, mappingName, docId] +-- | 'bulk' uses Elasticsearch's bulk API at +-- http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html +-- to perform bulk operations. The 'BulkOperation' data type encodes the +-- index/update/delete/create operations. You pass a 'V.Vector' of 'BulkOperation's +-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch +-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead. +-- +-- >>> let stream = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))] +-- >>> _ <- bulk testServer stream +-- >>> _ <- refreshIndex testServer testIndex bulk :: Server -> V.Vector BulkOperation -> IO Reply bulk (Server server) bulkOps = post url body where url = joinPath [server, "_bulk"] body = Just $ encodeBulkOperations bulkOps +-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation' +-- into an 'L.ByteString' +-- +-- >>> let bulkOps = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))] +-- >>> encodeBulkOperations bulkOps +-- "\n{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n" encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString encodeBulkOperations stream = collapsed where blobs = fmap encodeBulkOperation stream @@ -183,7 +333,7 @@ collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n") mash :: Builder -> V.Vector L.ByteString -> Builder -mash = V.foldl' (\b x -> b `mappend` "\n" `mappend` (lazyByteString x)) +mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x)) mkBulkStreamValue :: Text -> String -> String -> String -> Value mkBulkStreamValue operation indexName mappingName docId = @@ -192,6 +342,12 @@ , "_type" .= mappingName , "_id" .= docId]] +-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation' +-- into an 'L.ByteString' +-- +-- >>> let bulkOp = BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah")) +-- >>> encodeBulkOperation bulkOp +-- "{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}" encodeBulkOperation :: BulkOperation -> L.ByteString encodeBulkOperation (BulkIndex (IndexName indexName) (MappingName mappingName) @@ -218,13 +374,21 @@ doc = object ["doc" .= value] blob = encode metadata `mappend` "\n" `mappend` encode doc - +-- | 'getDocument' is a straight-forward way to fetch a single document from +-- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'. +-- The 'DocId' is the primary key for your Elasticsearch document. +-- +-- >>> yourDoc <- getDocument testServer testIndex testMapping (DocId "1") getDocument :: Server -> IndexName -> MappingName -> DocId -> IO Reply getDocument (Server server) (IndexName indexName) (MappingName mappingName) (DocId docId) = get $ joinPath [server, indexName, mappingName, docId] +-- | 'documentExists' enables you to check if a document exists. Returns 'Bool' +-- in IO +-- +-- >>> exists <- documentExists testServer testIndex testMapping (DocId "1") documentExists :: Server -> IndexName -> MappingName -> DocId -> IO Bool documentExists (Server server) (IndexName indexName) @@ -236,27 +400,75 @@ dispatchSearch :: String -> Search -> IO Reply dispatchSearch url search = post url (Just (encode search)) +-- | 'searchAll', given a 'Search', will perform that search against all indexes +-- on an Elasticsearch server. Try to avoid doing this if it can be helped. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> let search = mkSearch (Just query) Nothing +-- >>> reply <- searchAll testServer search searchAll :: Server -> Search -> IO Reply searchAll (Server server) = dispatchSearch url where url = joinPath [server, "_search"] +-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search +-- against all mappings within an index on an Elasticsearch server. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> let search = mkSearch (Just query) Nothing +-- >>> reply <- searchByIndex testServer testIndex search searchByIndex :: Server -> IndexName -> Search -> IO Reply searchByIndex (Server server) (IndexName indexName) = dispatchSearch url where url = joinPath [server, indexName, "_search"] +-- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that +-- search against a specific mapping within an index on an Elasticsearch server. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> let search = mkSearch (Just query) Nothing +-- >>> reply <- searchByType testServer testIndex testMapping search searchByType :: Server -> IndexName -> MappingName -> Search -> IO Reply searchByType (Server server) (IndexName indexName) (MappingName mappingName) = dispatchSearch url where url = joinPath [server, indexName, mappingName, "_search"] +-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search' +-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update +-- syntax if you want to add things like aggregations or highlights while still using +-- this helper function. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> mkSearch (Just query) Nothing +-- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = 0, size = 10} mkSearch :: Maybe Query -> Maybe Filter -> Search mkSearch query filter = Search query filter Nothing Nothing Nothing False 0 10 +-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for +-- the 'Query' and the 'Aggregation'. +-- +-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst } +-- >>> terms +-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing}) +-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms mkAggregateSearch :: Maybe Query -> Aggregations -> Search mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False 0 0 +-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for +-- the 'Query' and the 'Aggregation'. +-- +-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") +-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing] +-- >>> let search = mkHighlightSearch (Just query) testHighlight mkHighlightSearch :: Maybe Query -> Highlights -> Search mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False 0 10 +-- | 'pageSearch' is a helper function that takes a search and assigns the page from and to +-- fields for the search. +-- +-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") +-- >>> let search = mkSearch (Just query) Nothing +-- >>> search +-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = 0, size = 10} +-- >>> pageSearch 10 100 search +-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = 10, size = 100} pageSearch :: Int -> Int -> Search -> Search pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize } diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -1,14 +1,26 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-| Data types for describing actions and data structures performed to interact - with Elasticsearch. The two main buckets your queries against Elasticsearch - will fall into are 'Query's and 'Filter's. 'Filter's are more like - traditional database constraints and often have preferable performance - properties. 'Query's support human-written textual queries, such as fuzzy - queries. --} +------------------------------------------------------------------------------- +-- | +-- Module : Database.Bloodhound.Types +-- Copyright : (C) 2014 Chris Allen +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Chris Allen >> :set -XOverloadedStrings +-- >>> import Database.Bloodhound +-- >>> let testServer = (Server "http://localhost:9200") +-- >>> let testIndex = IndexName "twitter" +-- >>> let testMapping = MappingName "tweet" +-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) +-- defaultIndexSettings is exported by Database.Bloodhound as well +-- no trailing slashes in servers, library handles building the path. + {-| 'Version' is embedded in 'Status' -} data Version = Version { number :: Text , build_hash :: Text @@ -576,7 +598,7 @@ data Query = TermQuery Term (Maybe Boost) - | TermsQuery [Term] MinimumMatch + | TermsQuery (NonEmpty Term) | QueryMatchQuery MatchQuery | QueryMultiMatchQuery MultiMatchQuery | QueryBoolQuery BoolQuery @@ -1007,7 +1029,7 @@ DistanceRange { distanceFrom :: Distance , distanceTo :: Distance } deriving (Eq, Show) -data (FromJSON a) => SearchResult a = +data SearchResult a = SearchResult { took :: Int , timedOut :: Bool , shards :: ShardResult @@ -1016,12 +1038,12 @@ type Score = Double -data (FromJSON a) => SearchHits a = +data SearchHits a = SearchHits { hitsTotal :: Int , maxScore :: Score , hits :: [Hit a] } deriving (Eq, Show) -data (FromJSON a) => Hit a = +data Hit a = Hit { hitIndex :: IndexName , hitType :: MappingName , hitDocId :: DocId @@ -1186,7 +1208,7 @@ aggs :: a -> Maybe AggregationResults -data (FromJSON a, BucketAggregation a) => Bucket a = Bucket { buckets :: [a]} deriving (Show) +data Bucket a = Bucket { buckets :: [a]} deriving (Show) data TermsResult = TermsResult { termKey :: Text , termsDocCount :: Int @@ -1358,12 +1380,12 @@ boosted = maybe [] (return . ("boost" .=)) boost merged = mappend base boosted - toJSON (TermsQuery terms termsQueryMinimumMatch) = + toJSON (TermsQuery terms) = object [ "terms" .= object conjoined ] - where conjoined = - [ "tags" .= fmap toJSON terms - , "minimum_should_match" .= toJSON termsQueryMinimumMatch ] - + where conjoined = [ getTermsField terms .= + fmap (toJSON . getTermValue) (toList terms)] + getTermsField ((Term f _ ) :| _) = f + getTermValue (Term _ v) = v toJSON (IdsQuery idsQueryMappingName docIds) = object [ "ids" .= object conjoined ] where conjoined = [ "type" .= toJSON idsQueryMappingName diff --git a/tests/doctests.hsc b/tests/doctests.hsc new file mode 100644 --- /dev/null +++ b/tests/doctests.hsc @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Main (doctests) +-- Copyright : (C) 2014 Chris Allen +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Chris Allen +-- Stability : provisional +-- Portability : portable +-- +-- This module provides doctests for a project based on the actual versions +-- of the packages it was built with. It requires a corresponding Setup.lhs +-- to be added to the project +----------------------------------------------------------------------------- + +module Main where + +import Build_doctests (deps) +import Control.Applicative +import Control.Monad +import Data.List +import System.Directory +import System.FilePath +import Test.DocTest + +##if defined(mingw32_HOST_OS) +##if defined(i386_HOST_ARCH) +##define USE_CP +import Control.Applicative +import Control.Exception +import Foreign.C.Types +foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool +foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt +##elif defined(x86_64_HOST_ARCH) +##define USE_CP +import Control.Applicative +import Control.Exception +import Foreign.C.Types +foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool +foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt +##endif +##endif + +-- | Run in a modified codepage where we can print UTF-8 values on Windows. +withUnicode :: IO a -> IO a +##ifdef USE_CP +withUnicode m = do + cp <- c_GetConsoleCP + (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp +##else +withUnicode m = m +##endif + +main :: IO () +main = withUnicode $ getSources >>= \sources -> doctest $ + "-isrc" + : "-idist/build/autogen" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : "-hide-all-packages" + : map ("-package="++) deps ++ sources + +getSources :: IO [FilePath] +getSources = filter (isSuffixOf ".hs") <$> go "src" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -6,9 +7,10 @@ import Control.Applicative import Control.Monad import Data.Aeson -import Data.HashMap.Strict (fromList) +import qualified Data.HashMap.Strict as HM import Data.List (nub) import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import Data.Text (Text) import qualified Data.Text as T @@ -268,6 +270,14 @@ myTweet <- searchTweet search myTweet `shouldBe` Right exampleTweet + it "returns document for terms query and identity filter" $ do + _ <- insertData + let query = TermsQuery (NE.fromList [(Term "user" "bitemyapp")]) + let filter = IdentityFilter <&&> IdentityFilter + let search = mkSearch (Just query) (Just filter) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + it "returns document for match query" $ do _ <- insertData let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp") @@ -499,9 +509,9 @@ _ <- insertData _ <- insertOther let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") - let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing] + let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing] - let search = mkHighlightSearch (Just query) highlight + let search = mkHighlightSearch (Just query) testHighlight myHighlight <- searchTweetHighlight search myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use haskell!"])])) @@ -509,9 +519,9 @@ _ <- insertData _ <- insertOther let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") - let highlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing] + let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing] - let search = mkHighlightSearch (Just query) highlight + let search = mkHighlightSearch (Just query) testHighlight myHighlight <- searchTweetHighlight search myHighlight `shouldBe` Right Nothing @@ -541,19 +551,19 @@ it "checks that omitNulls drops list elements when it should" $ let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int])) , "test2" .= (toJSON ("some value" :: Text))] - in dropped `shouldBe` Object (fromList [("test2", String "some value")]) + in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")]) it "checks that omitNulls doesn't drop list elements when it shouldn't" $ let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int])) , "test2" .= (toJSON ("some value" :: Text))] - in notDropped `shouldBe` Object (fromList [ ("test1", Array (V.fromList [Number 1.0])) + in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0])) , ("test2", String "some value")]) it "checks that omitNulls drops non list elements when it should" $ let dropped = omitNulls $ [ "test1" .= (toJSON Null) , "test2" .= (toJSON ("some value" :: Text))] - in dropped `shouldBe` Object (fromList [("test2", String "some value")]) + in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")]) it "checks that omitNulls doesn't drop non list elements when it shouldn't" $ let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int)) , "test2" .= (toJSON ("some value" :: Text))] - in notDropped `shouldBe` Object (fromList [ ("test1", Number 1.0) + in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0) , ("test2", String "some value")])