Restructuring modules, ripping out Generic

Makefile

@@ -1,3 +1,5 @@
+stack = STACK_YAML='stack.yaml' stack
+
 build:
 	stack build
 
@@ -10,6 +12,9 @@ echo-warn:
 test: echo-warn
 	stack test
 
+ghcid:
+	ghcid -c "$(stack) ghci bloodhound:lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind' --main-is bloodhound:test:bloodhound-tests"
+
 7.8-build:
 	STACK_YAML="stack-7.8.yaml" stack build
 

bloodhound.cabal

@@ -31,18 +31,22 @@ Flag ES5
   Description: Run the test suite against an Elasticsearch 5.x server
   Default:     True
 
+-- Database.V1.Bloodhound
+-- Database.V1.Bloodhound.Client
+-- Database.V1.Bloodhound.Types
+-- Database.V1.Bloodhound.Types.Class
+-- Database.V1.Bloodhound.Types.Internal
+                       
 library
   ghc-options:         -Wall
-  exposed-modules:     Database.V1.Bloodhound
-                       Database.V1.Bloodhound.Client
-                       Database.V1.Bloodhound.Types
-                       Database.V1.Bloodhound.Types.Class
-                       Database.V1.Bloodhound.Types.Internal
-                       Database.V5.Bloodhound
+  exposed-modules:     Database.V5.Bloodhound
                        Database.V5.Bloodhound.Client
                        Database.V5.Bloodhound.Types
                        Database.V5.Bloodhound.Types.Class
                        Database.V5.Bloodhound.Types.Internal
+                       Database.V5.Bloodhound.Types.Internal.Analysis
+                       Database.V5.Bloodhound.Types.Internal.Client
+                       Database.V5.Bloodhound.Types.Internal.Query
   hs-source-dirs:      src
   build-depends:       base             >= 4.3     && <5,
                        bytestring       >= 0.10.0  && <0.11,
@@ -66,7 +70,7 @@ library
                        hashable
   default-language:    Haskell2010
 
-test-suite tests
+test-suite bloodhound-tests
   ghc-options: -Wall -fno-warn-orphans
   type: exitcode-stdio-1.0
   main-is: tests.hs

src/Bloodhound/Import.hs

@@ -0,0 +1,81 @@
+module Bloodhound.Import
+  ( module X
+  , LByteString
+  , Method
+  , parseReadText
+  , readMay
+  , showText
+  ) where
+
+import           Control.Applicative    as X (Alternative(..), optional)
+import           Control.Exception      as X (Exception)
+import           Control.Monad          as X ( MonadPlus(..)
+                                             , (<=<)
+                                             , forM
+                                             )
+import           Control.Monad.Fix      as X (MonadFix)
+import           Control.Monad.IO.Class as X (MonadIO(..))
+import           Control.Monad.Catch    as X ( MonadCatch
+                                             , MonadMask
+                                             , MonadThrow
+                                             )
+import           Control.Monad.Error    as X (MonadError)
+import           Control.Monad.Reader   as X ( MonadReader (..)
+                                             , MonadTrans (..)
+                                             , ReaderT (..)
+                                             )
+import           Control.Monad.State    as X (MonadState)
+import           Control.Monad.Writer   as X (MonadWriter)
+import           Data.Aeson             as X
+import           Data.Aeson.Types       as X ( Pair
+                                             , Parser
+                                             , emptyObject
+                                             , parseEither
+                                             , parseMaybe
+                                             , typeMismatch
+                                             )
+import           Data.Bifunctor         as X (first)
+import qualified Data.ByteString        as X (ByteString)
+import           Data.Char              as X (isNumber)
+import           Data.Hashable          as X (Hashable)
+import           Data.List              as X ( foldl'
+                                             , intercalate
+                                             , nub
+                                             )
+import           Data.List.NonEmpty     as X ( NonEmpty (..)
+                                             , toList
+                                             )
+import           Data.Maybe             as X ( catMaybes
+                                             , fromMaybe
+                                             , isNothing
+                                             , maybeToList
+                                             )
+import           Data.Scientific        as X (Scientific)
+import           Data.Semigroup         as X (Semigroup(..))
+import           Data.Text              as X (Text)
+import           Data.Time.Calendar     as X ( Day(..)
+                                             , showGregorian
+                                             )
+import           Data.Time.Clock        as X ( NominalDiffTime
+                                             , UTCTime
+                                             )
+import           Data.Time.Clock.POSIX  as X
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Network.HTTP.Types.Method as NHTM
+
+type LByteString = BL.ByteString
+
+type Method = NHTM.Method
+
+readMay :: Read a => String -> Maybe a
+readMay s = case reads s of
+              (a, ""):_ -> Just a
+              _         -> Nothing
+
+parseReadText :: Read a => Text -> Parser a
+parseReadText = maybe mzero return . readMay . T.unpack
+
+showText :: Show a => a -> Text
+showText = T.pack . show

src/Database/V5/Bloodhound/Types/Internal.hs

@@ -1,57 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable         #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
--------------------------------------------------------------------------------
--- |
--- Module : Database.Bloodhound.Types.Internal
--- Copyright : (C) 2014 Chris Allen
--- License : BSD-style (see the file LICENSE)
--- Maintainer : Chris Allen <cma@bitemyapp.com>
--- Stability : provisional
--- Portability : DeriveGeneric, RecordWildCards
---
--- Internal data types for Bloodhound. These types may change without
--- notice so import at your own risk.
--------------------------------------------------------------------------------
-module Database.V5.Bloodhound.Types.Internal
-    ( BHEnv(..)
-    , Server(..)
-    , MonadBH(..)
-    ) where
-
-
-import           Control.Applicative  as A
-import           Control.Monad.Reader
-import           Data.Aeson
-import           Data.Text            (Text)
-import           Data.Typeable        (Typeable)
-import           GHC.Generics         (Generic)
-import           Network.HTTP.Client
-
-{-| Common environment for Elasticsearch calls. Connections will be
-    pipelined according to the provided HTTP connection manager.
--}
-data BHEnv = BHEnv { bhServer      :: Server
-                   , bhManager     :: Manager
-                   , bhRequestHook :: Request -> IO Request
-                   -- ^ Low-level hook that is run before every request is sent. Used to implement custom authentication strategies. Defaults to 'return' with 'mkBHEnv'.
-                   }
-
-instance (Functor m, Applicative m, MonadIO m) => MonadBH (ReaderT BHEnv m) where
-  getBHEnv = ask
-
-{-| 'Server' is used with the client functions to point at the ES instance
--}
-newtype Server = Server Text deriving (Eq, Show, Generic, Typeable, FromJSON)
-
-{-| All API calls to Elasticsearch operate within
-    MonadBH
-    . The idea is that it can be easily embedded in your
-    own monad transformer stack. A default instance for a ReaderT and
-    alias 'BH' is provided for the simple case.
--}
-class (Functor m, A.Applicative m, MonadIO m) => MonadBH m where
-  getBHEnv :: m BHEnv
-

src/Database/V5/Bloodhound/Types/Internal/Analysis.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+
+module Database.V5.Bloodhound.Types.Internal.Analysis where
+
+import           Data.Aeson
+import           Data.Aeson.Types ( Pair, Parser,
+                                    emptyObject,
+                                    parseEither, parseMaybe,
+                                    typeMismatch
+                                  )
+import qualified Data.Map.Strict as M
+import           Data.Maybe         (catMaybes)
+import           Data.Text          (Text)
+
+import           Database.V5.Bloodhound.Types.Internal.StringlyTyped
+
+data Analysis = Analysis
+  { analysisAnalyzer :: M.Map Text AnalyzerDefinition
+  , analysisTokenizer :: M.Map Text TokenizerDefinition
+  } deriving (Eq, Show)
+
+instance ToJSON Analysis where
+  toJSON (Analysis analyzer tokenizer) = object
+    [ "analyzer" .= analyzer
+    , "tokenizer" .= tokenizer
+    ]
+
+instance FromJSON Analysis where
+  parseJSON = withObject "Analysis" $ \m -> Analysis
+    <$> m .: "analyzer"
+    <*> m .: "tokenizer"
+
+newtype Tokenizer =
+  Tokenizer Text
+  deriving (Eq, Show, ToJSON, FromJSON)
+
+data AnalyzerDefinition = AnalyzerDefinition
+  { analyzerDefinitionTokenizer :: Maybe Tokenizer
+  } deriving (Eq,Show)
+
+instance ToJSON AnalyzerDefinition where
+  toJSON (AnalyzerDefinition tokenizer) = object $ catMaybes
+    [ fmap ("tokenizer" .=) tokenizer
+    ]
+
+instance FromJSON AnalyzerDefinition where
+  parseJSON = withObject "AnalyzerDefinition" $ \m -> AnalyzerDefinition
+    <$> m .:? "tokenizer"
+  
+
+data TokenizerDefinition
+  = TokenizerDefinitionNgram Ngram
+  deriving (Eq,Show)
+
+instance ToJSON TokenizerDefinition where
+  toJSON x = case x of
+    TokenizerDefinitionNgram (Ngram minGram maxGram tokenChars) -> object
+      [ "type" .= ("ngram" :: Text)
+      , "min_gram" .= minGram
+      , "max_gram" .= maxGram
+      , "token_chars" .= tokenChars
+      ]
+
+instance FromJSON TokenizerDefinition where
+  parseJSON = withObject "TokenizerDefinition" $ \m -> do
+    typ <- m .: "type" :: Parser Text
+    case typ of
+      "ngram" -> fmap TokenizerDefinitionNgram $ Ngram
+        <$> (fmap unStringlyTypedInt (m .: "min_gram"))
+        <*> (fmap unStringlyTypedInt (m .: "max_gram"))
+        <*> m .: "token_chars"
+      _ -> fail "invalid TokenizerDefinition"
+
+data Ngram = Ngram
+  { ngramMinGram :: Int
+  , ngramMaxGram :: Int
+  , ngramTokenChars :: [TokenChar]
+  } deriving (Eq,Show)
+
+data TokenChar =
+    TokenLetter
+  | TokenDigit
+  | TokenWhitespace
+  | TokenPunctuation
+  | TokenSymbol
+  deriving (Eq,Show)
+
+instance ToJSON TokenChar where
+  toJSON t = String $ case t of
+    TokenLetter -> "letter"
+    TokenDigit -> "digit"
+    TokenWhitespace -> "whitespace"
+    TokenPunctuation -> "punctuation"
+    TokenSymbol -> "symbol"
+
+instance FromJSON TokenChar where
+  parseJSON = withText "TokenChar" $ \t -> case t of
+    "letter" -> return TokenLetter
+    "digit" -> return TokenDigit
+    "whitespace" -> return TokenWhitespace
+    "punctuation" -> return TokenPunctuation
+    "symbol" -> return TokenSymbol
+    _ -> fail "invalid TokenChar"

src/Database/V5/Bloodhound/Types/Internal/Newtypes.hs

@@ -0,0 +1,195 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+
+module Database.V5.Bloodhound.Types.Internal.Newtypes where
+
+import           Bloodhound.Import
+
+{-| 'MappingName' is part of mappings which are how ES describes and schematizes
+    the data in the indices.
+-}
+newtype MappingName =
+  MappingName Text
+  deriving (Eq, Show, ToJSON, FromJSON)
+
+newtype ShardId = ShardId { shardId :: Int }
+                deriving (Eq, Show, FromJSON)
+
+{-| 'DocId' is a generic wrapper value for expressing unique Document IDs.
+    Can be set by the user or created by ES itself. Often used in client
+    functions for poking at specific documents.
+-}
+newtype DocId =
+  DocId Text
+  deriving (Eq, Show, ToJSON, FromJSON)
+
+{-| 'FieldName' is used all over the place wherever a specific field within
+     a document needs to be specified, usually in 'Query's or 'Filter's.
+-}
+newtype FieldName =
+  FieldName Text
+  deriving (Eq, Read, Show, ToJSON, FromJSON)
+
+newtype TypeName =
+  TypeName Text
+  deriving (Eq, Show, ToJSON, FromJSON)
+
+{-| 'QueryString' is used to wrap query text bodies, be they human written or not.
+-}
+newtype QueryString =
+  QueryString Text
+  deriving (Eq, Show, ToJSON, FromJSON)
+
+
+{-| 'Script' is often used in place of 'FieldName' to specify more
+complex ways of extracting a value from a document.
+-}
+newtype Script =
+  Script { scriptText :: Text }
+  deriving (Eq, Show)
+
+{-| 'CacheName' is used in 'RegexpFilter' for describing the
+    'CacheKey' keyed caching behavior.
+-}
+newtype CacheName =
+  CacheName Text
+  deriving (Eq, Show, FromJSON, ToJSON)
+
+{-| 'CacheKey' is used in 'RegexpFilter' to key regex caching.
+-}
+newtype CacheKey =
+  CacheKey Text deriving (Eq, Show, FromJSON, ToJSON)
+newtype Existence =
+  Existence Bool deriving (Eq, Show, FromJSON, ToJSON)
+newtype NullValue =
+  NullValue Bool deriving (Eq, Show, FromJSON, ToJSON)
+newtype CutoffFrequency =
+  CutoffFrequency Double deriving (Eq, Show, FromJSON, ToJSON)
+newtype Analyzer =
+  Analyzer Text deriving (Eq, Show, FromJSON, ToJSON)
+newtype MaxExpansions =
+  MaxExpansions Int deriving (Eq, Show, FromJSON, ToJSON)
+
+{-| 'Lenient', if set to true, will cause format based failures to be
+    ignored. I don't know what the bloody default is, Elasticsearch
+    documentation didn't say what it was. Let me know if you figure it out.
+-}
+newtype Lenient =
+  Lenient Bool deriving (Eq, Show, FromJSON, ToJSON)
+newtype Tiebreaker =
+  Tiebreaker Double deriving (Eq, Show, FromJSON, ToJSON)
+
+{-| 'MinimumMatch' controls how many should clauses in the bool query should
+     match. Can be an absolute value (2) or a percentage (30%) or a
+     combination of both.
+-}
+newtype MinimumMatch =
+  MinimumMatch Int deriving (Eq, Show, FromJSON, ToJSON)
+newtype DisableCoord =
+  DisableCoord Bool deriving (Eq, Show, FromJSON, ToJSON)
+newtype IgnoreTermFrequency =
+  IgnoreTermFrequency Bool deriving (Eq, Show, FromJSON, ToJSON)
+newtype MinimumTermFrequency =
+  MinimumTermFrequency Int deriving (Eq, Show, FromJSON, ToJSON)
+newtype MaxQueryTerms =
+  MaxQueryTerms Int deriving (Eq, Show, FromJSON, ToJSON)
+newtype Fuzziness =
+  Fuzziness Double deriving (Eq, Show, FromJSON, ToJSON)
+
+{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -}
+newtype PrefixLength =
+  PrefixLength Int deriving (Eq, Show, FromJSON, ToJSON)
+newtype PercentMatch =
+  PercentMatch Double deriving (Eq, Show, FromJSON, ToJSON)
+newtype StopWord =
+  StopWord Text deriving (Eq, Show, FromJSON, ToJSON)
+newtype QueryPath =
+  QueryPath Text deriving (Eq, Show, FromJSON, ToJSON)
+
+{-| Allowing a wildcard at the beginning of a word (eg "*ing") is particularly
+    heavy, because all terms in the index need to be examined, just in case
+    they match. Leading wildcards can be disabled by setting
+    'AllowLeadingWildcard' to false. -}
+newtype AllowLeadingWildcard =
+  AllowLeadingWildcard     Bool deriving (Eq, Show, FromJSON, ToJSON)
+newtype LowercaseExpanded =
+  LowercaseExpanded        Bool deriving (Eq, Show, FromJSON, ToJSON)
+newtype EnablePositionIncrements =
+  EnablePositionIncrements Bool deriving (Eq, Show, FromJSON, ToJSON)
+
+{-| By default, wildcard terms in a query are not analyzed.
+    Setting 'AnalyzeWildcard' to true enables best-effort analysis.
+-}
+newtype AnalyzeWildcard = AnalyzeWildcard Bool deriving (Eq, Show, FromJSON, ToJSON)
+
+{-| 'GeneratePhraseQueries' defaults to false.
+-}
+newtype GeneratePhraseQueries =
+  GeneratePhraseQueries Bool deriving (Eq, Show, FromJSON, ToJSON)
+
+{-| 'Locale' is used for string conversions - defaults to ROOT.
+-}
+newtype Locale        = Locale        Text deriving (Eq, Show, FromJSON, ToJSON)
+newtype MaxWordLength = MaxWordLength Int  deriving (Eq, Show, FromJSON, ToJSON)
+newtype MinWordLength = MinWordLength Int  deriving (Eq, Show, FromJSON, ToJSON)
+
+{-| 'PhraseSlop' sets the default slop for phrases, 0 means exact
+     phrase matches. Default is 0.
+-}
+newtype PhraseSlop      = PhraseSlop      Int deriving (Eq, Show, FromJSON, ToJSON)
+newtype MinDocFrequency = MinDocFrequency Int deriving (Eq, Show, FromJSON, ToJSON)
+newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, FromJSON, ToJSON)
+
+-- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ
+newtype POSIXMS = POSIXMS { posixMS :: UTCTime }
+
+newtype Boost =
+  Boost Double
+  deriving (Eq, Show, ToJSON, FromJSON)
+
+newtype BoostTerms =
+  BoostTerms Double
+  deriving (Eq, Show, ToJSON, FromJSON)
+
+{-| 'ShardCount' is part of 'IndexSettings' -}
+newtype ShardCount =
+  ShardCount Int
+  deriving (Eq, Show, ToJSON)
+
+{-| 'ReplicaCount' is part of 'IndexSettings' -}
+newtype ReplicaCount =
+  ReplicaCount Int
+  deriving (Eq, Show, ToJSON)
+
+{-| 'IndexName' is used to describe which index to query/create/delete -}
+newtype IndexName =
+  IndexName Text
+  deriving (Eq, Show, ToJSON, FromJSON)
+
+newtype IndexAliasName =
+  IndexAliasName { indexAliasName :: IndexName }
+  deriving (Eq, Show, ToJSON)
+
+newtype MaybeNA a = MaybeNA { unMaybeNA :: Maybe a }
+  deriving (Show, Eq)
+
+instance FromJSON a => FromJSON (MaybeNA a) where
+  parseJSON (String "NA") = pure $ MaybeNA Nothing
+  parseJSON o             = MaybeNA . Just <$> parseJSON o
+
+newtype SnapshotName =
+  SnapshotName { snapshotName :: Text }
+  deriving (Eq, Show, ToJSON, FromJSON)
+
+-- | Milliseconds
+newtype MS = MS NominalDiffTime
+
+-- keeps the unexported constructor warnings at bay
+unMS :: MS -> NominalDiffTime
+unMS (MS t) = t
+
+
+instance FromJSON MS where
+  parseJSON = withScientific "MS" (return . MS . parse)
+    where
+      parse n = fromInteger ((truncate n) * 1000)

src/Database/V5/Bloodhound/Types/Internal/StringlyTyped.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Database.V5.Bloodhound.Types.Internal.StringlyTyped where
+
+import           Control.Monad    (MonadPlus(..))
+import           Data.Aeson
+import           Data.Aeson.Types ( Pair, Parser,
+                                    emptyObject,
+                                    parseEither, parseMaybe,
+                                    typeMismatch
+                                  )
+import           Data.Text        (Text)
+import qualified Data.Text     as T
+
+import           Bloodhound.Import
+
+-- This whole module is a sin bucket to deal with Elasticsearch badness.
+newtype StringlyTypedDouble = StringlyTypedDouble
+  { unStringlyTypedDouble :: Double }
+
+instance FromJSON StringlyTypedDouble where
+  parseJSON =
+      fmap StringlyTypedDouble
+    . parseJSON
+    . unStringlyTypeJSON
+
+newtype StringlyTypedInt = StringlyTypedInt
+  { unStringlyTypedInt :: Int }
+
+instance FromJSON StringlyTypedInt where
+  parseJSON =
+      fmap StringlyTypedInt
+    . parseJSON
+    . unStringlyTypeJSON
+
+-- | For some reason in several settings APIs, all leaf values get returned
+-- as strings. This function attepmts to recover from this for all
+-- non-recursive JSON types. If nothing can be done, the value is left alone.
+unStringlyTypeJSON :: Value -> Value
+unStringlyTypeJSON (String "true") =
+  Bool True
+unStringlyTypeJSON (String "false") =
+  Bool False
+unStringlyTypeJSON (String "null") =
+  Null
+unStringlyTypeJSON v@(String t) =
+  case readMay (T.unpack t) of
+    Just n  -> Number n
+    Nothing -> v
+unStringlyTypeJSON v = v

tests/V5/tests.hs

@@ -44,7 +44,7 @@ import           Data.Typeable
 import qualified Data.Vector                     as V
 import qualified Data.Version                    as Vers
 import           Database.V5.Bloodhound
-import           GHC.Generics                    as G
+-- import           GHC.Generics                    as G
 import           Network.HTTP.Client             hiding (Proxy)
 import qualified Network.HTTP.Types.Method       as NHTM
 import qualified Network.HTTP.Types.Status       as NHTS
@@ -164,7 +164,7 @@ propJSON _ = prop testName $ \(a :: a) ->
         ty = typeOf (undefined :: a)
 
 data Location = Location { lat :: Double
-                         , lon :: Double } deriving (Eq, Generic, Show)
+                         , lon :: Double } deriving (Eq, Show)
 
 data Tweet = Tweet { user     :: Text
                    , postDate :: UTCTime
@@ -172,7 +172,7 @@ data Tweet = Tweet { user     :: Text
                    , age      :: Int
                    , location :: Location
                    , extra    :: Maybe Text }
-           deriving (Eq, Generic, Show)
+           deriving (Eq, Show)
 
 instance ToJSON   Tweet where
   toJSON = genericToJSON defaultOptions
@@ -433,7 +433,7 @@ withSnapshot srn sn = bracket_ alloc free
 
 
 
-data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
+data BulkTest = BulkTest { name :: Text } deriving (Eq, Show)
 instance FromJSON BulkTest where
   parseJSON = genericParseJSON defaultOptions
 instance ToJSON BulkTest where