antiope-es (empty) → 7.4.4

raw patch · 8 files changed

+235/−0 lines, 8 filesdep +aesondep +amazonkadep +amazonka-coresetup-changed

Dependencies added: aeson, amazonka, amazonka-core, amazonka-elasticsearch, antiope-es, base, bytestring, hspec, json-stream, lens, thyme, unordered-containers, vector

Files

• ChangeLog.md +3/−0
• LICENSE +21/−0
• README.md +1/−0
• Setup.hs +2/−0
• antiope-es.cabal +58/−0
• src/Antiope/ES.hs +2/−0
• src/Antiope/ES/Sign.hs +147/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,3 @@+# Changelog for antiope-es++## Unreleased changes

@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2018-2019 Arbor Networks++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,1 @@+# antiope-es

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,58 @@+cabal-version: 2.4++name:                   antiope-es+version:                7.4.4+synopsis:               Please see the README on Github at <https://github.com/arbor/antiope#readme>+description:            Please see the README on Github at <https://github.com/arbor/antiope#readme>.+category:               Services+homepage:               https://github.com/arbor/antiope#readme+bug-reports:            https://github.com/arbor/antiope/issues+author:                 Arbor Networks+maintainer:             mayhem@arbor.net+copyright:              Arbor Networks+license:                MIT+license-file:           LICENSE+build-type:             Simple+extra-source-files:     README.md+                        ChangeLog.md++source-repository head+  type: git+  location: https://github.com/arbor/antiope++common base     { build-depends:  base      >= 4.7    && < 5 }++common config+  default-language:     Haskell2010+  ghc-options:          -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints++library+  import:               base, config+  exposed-modules:      Antiope.ES+                        Antiope.ES.Sign+  hs-source-dirs:       src+  default-extensions:   BangPatterns GeneralizedNewtypeDeriving OverloadedStrings TupleSections+  build-depends:+                        aeson+                      , amazonka               >= 1.6.0+                      , amazonka-core          >= 1.6.0+                      , amazonka-elasticsearch >= 1.6.0+                      , bytestring+                      , json-stream+                      , lens+                      , thyme+                      , unordered-containers+                      , vector++test-suite antiope-s3-test+  import:               base, config+  type:                 exitcode-stdio-1.0+  main-is:              Spec.hs+  hs-source-dirs:       test+  default-extensions:   BangPatterns GeneralizedNewtypeDeriving OverloadedStrings TupleSections+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:   hspec-discover:hspec-discover+  build-depends:        +                        antiope-es+                      , hspec+                      

@@ -0,0 +1,2 @@+module Antiope.ES where+

@@ -0,0 +1,147 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE TypeFamilies       #-}++module Antiope.ES.Sign where++import Control.Lens              (Lens', lens, (&), (.~), (<&>))+import Data.Aeson+import Data.JsonStream.Parser    (objectWithKey, parseByteString)+import Data.Vector               (Vector)+import Network.AWS.ElasticSearch (elasticSearch)+import Network.AWS.Prelude+import Network.AWS.Request       (postBody)+import Network.AWS.Response      (receiveBytes)+import Network.AWS.Sign.V4       (v4)++import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.HashMap.Strict        as HMap+import qualified Data.JsonStream.Parser     as JP+import qualified Data.Vector                as Vector++esService :: Service+esService = Service+  { _svcAbbrev    = "ElasticSearchClient"+  , _svcSigner    = v4+  , _svcPrefix    = "es"+  , _svcVersion   = _svcVersion elasticSearch+  , _svcEndpoint  = defaultEndpoint esService <&> endpointHost .~ error "ElasticSearch Service endpoint is not configured. example: 'let env2 = configure (setEndpoint True <hostname> 443 esService) env'"+  , _svcTimeout   = _svcTimeout elasticSearch+  , _svcCheck     = _svcCheck elasticSearch+  , _svcError     = _svcError elasticSearch+  , _svcRetry     = _svcRetry elasticSearch+  }++data SendBulk a = SendBulk+  { _pbOps           :: Vector a+    -- This is here as opposed to in a class in order to avoid forcing orphan+    -- instances when we integrate with Bloodhound.+  , _encodeEsRequest :: Vector a -> L.ByteString+  } deriving (Typeable, Generic)++sendBulk :: Vector a -> (Vector a -> L.ByteString) -> SendBulk a+sendBulk = SendBulk++sendBulk' :: [a] -> (Vector a -> L.ByteString) -> SendBulk a+sendBulk' = SendBulk . Vector.fromList++bulkOps :: Lens' (SendBulk a) (Vector a)+bulkOps = lens _pbOps (\s a -> s{_pbOps = a})++bulkEncode :: Lens' (SendBulk a) (Vector a -> L.ByteString)+bulkEncode = lens _encodeEsRequest (\s a -> s{_encodeEsRequest = a})++instance ToPath (SendBulk a) where+  toPath = const "_bulk"++instance ToQuery (SendBulk a) where+  toQuery = const mempty++instance ToHeaders (SendBulk a) where+  toHeaders = const [(hContentType, "application/json")]++instance AWSRequest (SendBulk a) where+  type Rs (SendBulk a) = SendBulkResponse+  request = postBody esService+  response = receiveBytes $ \_ _ x ->+    -- ES returns JSON which contains an array of elements, one per an item in a batch.+    -- Parsing this massive response is expensive (it takes ~15%-20% of the runtime)+    -- and it is only needed in case of errors.+    -- As an optimisation, we can first look at the "errors" field, and if it is set+    -- to False we can avoid parsing the rest of the response+    let+      -- We could use '(,) <$> objectWithKey "errors" <*> objectWithKey "took"'+      -- and it works, except that somehow it forces JSON Parser to traverse+      -- the whole response, which we want to avoid.+      -- Looks like it is a property of the Applicative instance for the Parser.+      errors = parseByteString (objectWithKey "errors" JP.bool) x & listToMaybe+      took'  = parseByteString (objectWithKey "took" JP.number) x & listToMaybe+    in case (,) <$> took' <*> errors of+      Just (time, False) -> Right $ SendBulkResponse (round time) False []+      _                  -> JP.eitherDecodeStrict x++instance ToBody (SendBulk a) where+  toBody a = toBody $ _encodeEsRequest a $ _pbOps a++data SendBulkResponse = SendBulkResponse+  { took       :: !Int+  , hasErrors  :: !Bool+  , operations :: ![SendBulkResponseOperation]+  } deriving (Eq, Show, Typeable, Generic)++data SendBulkResponseOperation = SendBulkResponseOperation+  { action :: !Text+  , item   :: !SendBulkResponseItem+  } deriving (Eq, Show, Typeable, Generic)++data SendBulkResponseItem = SendBulkResponseItem+  { index     :: !Text+  , mapping   :: !Text+  , itemId    :: !Text+  , status    :: !Int+  , errorJson :: !(Maybe Value)+  } deriving (Eq, Show, Typeable, Generic)++instance FromJSON SendBulkResponseItem where+  parseJSON =+    withObject "SendBulkResponseItem" $ \obj -> SendBulkResponseItem+      <$> obj .: "_index"+      <*> obj .: "_type"+      <*> obj .: "_id"+      <*> obj .: "status"+      <*> obj .:? "error"++instance ToJSON SendBulkResponseItem where+  toJSON a = object+    [ "_index" .= index a+    , "_type"  .= mapping a+    , "_id"    .= itemId a+    , "status" .= status a+    , "error"  .= errorJson a+    ]++instance FromJSON SendBulkResponseOperation where+  parseJSON =+    withObject "SendBulkResponseOperation" $ \obj ->+      case HMap.keys obj of+        [actionName] -> SendBulkResponseOperation actionName <$> obj .: actionName+        _            -> fail "Unable to parse bulk response item action"++instance ToJSON SendBulkResponseOperation where+  toJSON a = object [ action a .= item a]++instance FromJSON SendBulkResponse where+  parseJSON =+    withObject "SendBulkResponse" $ \obj -> SendBulkResponse+      <$> obj .: "took"+      <*> obj .: "errors"+      <*> obj .: "items"++instance ToJSON SendBulkResponse where+  toJSON a = object+    [ "took"    .= took a+    , "errors"  .= hasErrors a+    , "items"   .= operations a+    ]

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}