b5cf74d · typeable/bloodhound

README.md+1−1

compare with master

unifiedsplit

@@ -60,7 +60,7 @@ import Data.Time.Calendar (Day(..))

60import Data.Time.Clock (secondsToDiffTime, UTCTime(..))

61import Data.Text (Text)

62import GHC.Generics (Generic)

63−import Network.HTTP.Conduit

63+import Network.HTTP.Client

64import qualified Network.HTTP.Types.Status as NHTS

65

66-- no trailing slashes in servers, library handles building the path.

Setup.hs+51−2

@@ -1,2 +1,51 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Main (main) where

3+

4+import Data.List ( nub )

5+import Data.Version ( showVersion )

6+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )

7+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )

1−import Distribution.Simple

8+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )

2−main = defaultMain

9+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )

10+import Distribution.Simple.BuildPaths ( autogenModulesDir )

11+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))

12+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )

13+import Distribution.Text ( display )

14+import Distribution.Verbosity ( Verbosity, normal )

15+import System.FilePath ( (</>) )

16+

17+main :: IO ()

18+main = defaultMainWithHooks simpleUserHooks

19+ { buildHook = \pkg lbi hooks flags -> do

20+ generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi

21+ buildHook simpleUserHooks pkg lbi hooks flags

22+ , postHaddock = \args flags pkg lbi -> do

23+ copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")]

24+ postHaddock simpleUserHooks args flags pkg lbi

25+ }

26+

27+haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath

28+haddockOutputDir flags pkg = destDir where

29+ baseDir = case haddockDistPref flags of

30+ NoFlag -> "."

31+ Flag x -> x

32+ destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)

33+

34+generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()

35+generateBuildModule verbosity pkg lbi = do

36+ let dir = autogenModulesDir lbi

37+ createDirectoryIfMissingVerbose verbosity True dir

38+ withLibLBI pkg lbi $ \_ libcfg -> do

39+ withTestLBI pkg lbi $ \suite suitecfg -> do

40+ rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines

41+ [ "module Build_" ++ testName suite ++ " where"

42+ , "deps :: [String]"

43+ , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))

44+ ]

45+ where

46+ formatdeps = map (formatone . snd)

47+ formatone p = case packageName p of

48+ PackageName n -> n ++ "-" ++ showVersion (packageVersion p)

49+

50+testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]

51+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys

bloodhound.cabal+23

@@ -57,3 +57,26 @@ test-suite tests

57 vector,

58 unordered-containers >= 0.2.5.0 && <0.3

59 default-language: Haskell2010

60+

61+test-suite doctests

62+ default-language: Haskell2010

63+ default-extensions: OverloadedStrings

64+ type: exitcode-stdio-1.0

65+ main-is: doctests.hs

66+ hs-source-dirs: tests

67+ build-depends: base,

68+ doctest,

69+ doctest-prop,

70+ directory,

71+ filepath

72+

73+-- test-suite doctests

74+-- type: exitcode-stdio-1.0

75+-- ghc-options: -threaded

76+-- main-is: doctest-driver.hs

77+-- hs-source-dirs: tests

78+-- build-depends: base >4 && <5

79+-- , doctest

80+-- , doctest-discover

81+-- , doctest-prop

82+-- default-language: Haskell2010

src/Database/Bloodhound/Client.hs+37−5

@@ -1,3 +1,22 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+

3+-------------------------------------------------------------------------------

4+-- |

5+-- Module : Database.Bloodhound.Types

7+-- License : BSD-style (see the file LICENSE)

8+-- Maintainer : Chris Allen <cma@bitemyapp.com

9+-- Stability : provisional

10+-- Portability : DeriveGeneric, RecordWildCards

11+--

12+-- Data types for describing actions and data structures performed to interact

13+-- with Elasticsearch. The two main buckets your queries against Elasticsearch

14+-- will fall into are 'Query's and 'Filter's. 'Filter's are more like

15+-- traditional database constraints and often have preferable performance

16+-- properties. 'Query's support human-written textual queries, such as fuzzy

17+-- queries.

18+-------------------------------------------------------------------------------

19+

1module Database.Bloodhound.Client

20module Database.Bloodhound.Client

2 ( createIndex

21 ( createIndex

3 , deleteIndex

22 , deleteIndex

@@ -41,15 +60,22 @@ import Prelude hiding (filter, head)

41

60

42import Database.Bloodhound.Types

61import Database.Bloodhound.Types

43

62

44−-- find way to avoid destructuring Servers and Indexes?

63+-- $setup

45−-- make get, post, put, delete helpers.

64+-- >>> :set -XOverloadedStrings

46−-- make dispatch take URL last for better variance and

65+-- >>> import Database.Bloodhound

47−-- utilization of partial application

66+-- >>> import Test.DocTest.Prop (assert)

67+-- >>> error "blah"

68+-- no trailing slashes in servers, library handles building the path.

69+-- >>> let testServer = (Server "http://localhost:9200")

70+-- >>> let testIndex = IndexName "twitter"

71+-- >>> let testMapping = MappingName "tweet"

72+-- defaultIndexSettings is exported by Database.Bloodhound as well

73+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)

48

74

49mkShardCount :: Int -> Maybe ShardCount

75mkShardCount :: Int -> Maybe ShardCount

50mkShardCount n

76mkShardCount n

51 | n < 1 = Nothing

77 | n < 1 = Nothing

52− | n > 1000 = Nothing -- seriously, what the fuck?

78+ | n > 1000 = Nothing

53 | otherwise = Just (ShardCount n)

79 | otherwise = Just (ShardCount n)

54

80

55mkReplicaCount :: Int -> Maybe ReplicaCount

81mkReplicaCount :: Int -> Maybe ReplicaCount

@@ -96,6 +122,12 @@ getStatus (Server server) = do

96 response <- withManager defaultManagerSettings $ httpLbs request

122 response <- withManager defaultManagerSettings $ httpLbs request

97 return $ decode (responseBody response)

123 return $ decode (responseBody response)

98

124

125+-- | createIndex will create an index given a 'Server',

126+-- 'IndexSettings', and an 'IndexName'

127+

128+-- >>> response <- createIndex testServer defaultIndexSettings testIndex

129+-- >>> assert $ respIsTwoHunna response

130+-- >>> assert False

99createIndex :: Server -> IndexSettings -> IndexName -> IO Reply

131createIndex :: Server -> IndexSettings -> IndexName -> IO Reply

100createIndex (Server server) indexSettings (IndexName indexName) =

132createIndex (Server server) indexSettings (IndexName indexName) =

101 put url body

133 put url body

src/Database/Bloodhound/Types.hs+33−11

@@ -1,13 +1,25 @@

1{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

3

4

5+-------------------------------------------------------------------------------

6+-- |

7+-- Module : Database.Bloodhound.Types

9+-- License : BSD-style (see the file LICENSE)

10+-- Maintainer : Chris Allen <cma@bitemyapp.com

11+-- Stability : provisional

12+-- Portability : DeriveGeneric, RecordWildCards

13+--

4−{-| Data types for describing actions and data structures performed to interact

14+-- Data types for describing actions and data structures performed to interact

5− with Elasticsearch. The two main buckets your queries against Elasticsearch

15+-- with Elasticsearch. The two main buckets your queries against Elasticsearch

6− will fall into are 'Query's and 'Filter's. 'Filter's are more like

16+-- will fall into are 'Query's and 'Filter's. 'Filter's are more like

7− traditional database constraints and often have preferable performance

17+-- traditional database constraints and often have preferable performance

8− properties. 'Query's support human-written textual queries, such as fuzzy

18+-- properties. 'Query's support human-written textual queries, such as fuzzy

9− queries.

19+-- queries.

10−-}

20+-------------------------------------------------------------------------------

21+

22+

11

23

12module Database.Bloodhound.Types

24module Database.Bloodhound.Types

13 ( defaultCache

25 ( defaultCache

@@ -197,6 +209,16 @@ import qualified Network.HTTP.Types.Method as NHTM

197

209

198import Database.Bloodhound.Types.Class

210import Database.Bloodhound.Types.Class

199

211

212+-- $setup

213+-- >>> :set -XOverloadedStrings

214+-- >>> import Database.Bloodhound

215+-- no trailing slashes in servers, library handles building the path.

216+-- >>> let testServer = (Server "http://localhost:9200")

217+-- >>> let testIndex = IndexName "twitter"

218+-- >>> let testMapping = MappingName "tweet"

219+

220+-- defaultIndexSettings is exported by Database.Bloodhound as well

221+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)

200

222

201{-| 'Version' is embedded in 'Status' -}

223{-| 'Version' is embedded in 'Status' -}

202data Version = Version { number :: Text

224data Version = Version { number :: Text

@@ -1007,7 +1029,7 @@ data DistanceRange =

1007 DistanceRange { distanceFrom :: Distance

1029 DistanceRange { distanceFrom :: Distance

1008 , distanceTo :: Distance } deriving (Eq, Show)

1030 , distanceTo :: Distance } deriving (Eq, Show)

1009

1031

1010−data (FromJSON a) => SearchResult a =

1032+data SearchResult a =

1011 SearchResult { took :: Int

1033 SearchResult { took :: Int

1012 , timedOut :: Bool

1034 , timedOut :: Bool

1013 , shards :: ShardResult

1035 , shards :: ShardResult

@@ -1016,12 +1038,12 @@ data (FromJSON a) => SearchResult a =

1016

1038

1017type Score = Double

1039type Score = Double

1018

1040

1019−data (FromJSON a) => SearchHits a =

1041+data SearchHits a =

1020 SearchHits { hitsTotal :: Int

1042 SearchHits { hitsTotal :: Int

1021 , maxScore :: Score

1043 , maxScore :: Score

1022 , hits :: [Hit a] } deriving (Eq, Show)

1044 , hits :: [Hit a] } deriving (Eq, Show)

1023

1045

1024−data (FromJSON a) => Hit a =

1046+data Hit a =

1025 Hit { hitIndex :: IndexName

1047 Hit { hitIndex :: IndexName

1026 , hitType :: MappingName

1048 , hitType :: MappingName

1027 , hitDocId :: DocId

1049 , hitDocId :: DocId

@@ -1186,7 +1208,7 @@ class BucketAggregation a where

1186 aggs :: a -> Maybe AggregationResults

1208 aggs :: a -> Maybe AggregationResults

1187

1209

1188

1210

1189−data (FromJSON a, BucketAggregation a) => Bucket a = Bucket { buckets :: [a]} deriving (Show)

1211+data Bucket a = Bucket { buckets :: [a]} deriving (Show)

1190

1212

1191data TermsResult = TermsResult { termKey :: Text

1213data TermsResult = TermsResult { termKey :: Text

1192 , termsDocCount :: Int

1214 , termsDocCount :: Int

tests/doctests.hscnew file+74

@@ -0,0 +1,74 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ForeignFunctionInterface #-}

3+-----------------------------------------------------------------------------

4+-- |

5+-- Module : Main (doctests)

7+-- License : BSD-style (see the file LICENSE)

8+-- Maintainer : Chris Allen <cma@bitemyapp.com>

9+-- Stability : provisional

10+-- Portability : portable

11+--

12+-- This module provides doctests for a project based on the actual versions

13+-- of the packages it was built with. It requires a corresponding Setup.lhs

14+-- to be added to the project

15+-----------------------------------------------------------------------------

16+

17+module Main where

18+

19+import Build_doctests (deps)

20+import Control.Applicative

21+import Control.Monad

22+import Data.List

23+import System.Directory

24+import System.FilePath

25+import Test.DocTest

26+

27+##if defined(mingw32_HOST_OS)

28+##if defined(i386_HOST_ARCH)

29+##define USE_CP

30+import Control.Applicative

31+import Control.Exception

32+import Foreign.C.Types

33+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool

34+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt

35+##elif defined(x86_64_HOST_ARCH)

36+##define USE_CP

37+import Control.Applicative

38+import Control.Exception

39+import Foreign.C.Types

40+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool

41+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt

42+##endif

43+##endif

44+

45+-- | Run in a modified codepage where we can print UTF-8 values on Windows.

46+withUnicode :: IO a -> IO a

47+##ifdef USE_CP

48+withUnicode m = do

49+ cp <- c_GetConsoleCP

50+ (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp

51+##else

52+withUnicode m = m

53+##endif

54+

55+main :: IO ()

56+main = withUnicode $ getSources >>= \sources -> doctest $

57+ "-isrc"

58+ : "-idist/build/autogen"

59+ : "-optP-include"

60+ : "-optPdist/build/autogen/cabal_macros.h"

61+ : "-hide-all-packages"

62+ : map ("-package="++) deps ++ sources

63+

64+getSources :: IO [FilePath]

65+getSources = filter (isSuffixOf ".hs") <$> go "src"

66+ where

67+ go dir = do

68+ (dirs, files) <- getFilesAndDirectories dir

69+ (files ++) . concat <$> mapM go dirs

70+

71+getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])

72+getFilesAndDirectories dir = do

73+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir

74+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c

tests/tests.hs+4−4

@@ -499,9 +499,9 @@ main = hspec $ do

499 _ <- insertData

500 _ <- insertOther

501 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")

502− let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]

502+ let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]

503

504− let search = mkHighlightSearch (Just query) highlight

504+ let search = mkHighlightSearch (Just query) testHighlight

505 myHighlight <- searchTweetHighlight search

506 myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))

507

@@ -509,9 +509,9 @@ main = hspec $ do

509 _ <- insertData

510 _ <- insertOther

511 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")

512− let highlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]

512+ let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]

513

514− let search = mkHighlightSearch (Just query) highlight

514+ let search = mkHighlightSearch (Just query) testHighlight

515 myHighlight <- searchTweetHighlight search

516 myHighlight `shouldBe` Right Nothing

517