diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for elasticsearch-interchange + +## 0.1.0.0 -- 2022-12-08 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021, Layer 3 Communications + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Layer 3 Communications nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/elasticsearch-interchange.cabal b/elasticsearch-interchange.cabal new file mode 100644 --- /dev/null +++ b/elasticsearch-interchange.cabal @@ -0,0 +1,66 @@ +cabal-version: 3.0 +name: elasticsearch-interchange +version: 0.1.0.0 +synopsis: Serialization of Elasticsearch requests and responses +description: + This library provides data types for communicating with elasticsearch. It + also includes serialization and deserialization functions for these data + types. This library does not include machinery for transport. The user is + responsible for using an http client forming the complete requests + (e.g. setting the Content-Type header). +bug-reports: https://github.com/layer-3-communications/elasticsearch-interchange +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: amartin@layer3com.com +copyright: 2021 Layer 3 Communications +category: Data +build-type: Simple +extra-source-files: + CHANGELOG.md + samples/bulk/request/001/*.json + samples/bulk/response/001/*.json + samples/search/response/001/*.json + samples/cat/aliases/response/001/*.json + samples/cat/indices/response/001/*.json + +library + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -O2 + exposed-modules: + Elasticsearch.Bulk.Request + Elasticsearch.Bulk.Response + Elasticsearch.Search.Response + Elasticsearch.Cat.Indices.Response + Elasticsearch.Cat.Aliases.Response + Elasticsearch.Aliases.Request + build-depends: + , base >=4.13 && <5 + , bytebuild >=0.3.7 && <0.4 + , json-query >=0.2.1 && <0.3 + , json-syntax >=0.2 && <0.3 + , primitive >=0.7.1 && <0.8 + , text-short >=0.1.3 && <0.2 + , unpacked-maybe-text >=0.1 && <0.2 + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -Wall -O2 + build-depends: + , base >=4.11.1 && <5 + , bytebuild + , byteslice + , bytestring + , elasticsearch-interchange + , json-query + , json-syntax + , primitive + , tasty + , tasty-golden + , text-short + , unpacked-maybe-text + , pretty-show >=1.10 diff --git a/samples/bulk/request/001/output.json b/samples/bulk/request/001/output.json new file mode 100644 --- /dev/null +++ b/samples/bulk/request/001/output.json @@ -0,0 +1,4 @@ +{"index":{"_index":"person-2018.09.28","_id":"5bc6d38e-8b30-11eb-8dcd-0242ac130003"}} +{} +{"create":{"_index":"person-2018.09.29","_id":"3cd512c8-8b31-11eb-8dcd-0242ac130003"}} +{"name":"Xavier"} diff --git a/samples/bulk/response/001/input.json b/samples/bulk/response/001/input.json new file mode 100644 --- /dev/null +++ b/samples/bulk/response/001/input.json @@ -0,0 +1,40 @@ +{ + "took": 30, + "errors": false, + "items": [ + { + "index": { + "_index": "test", + "_type": "_doc", + "_id": "1", + "_version": 1, + "result": "created", + "_shards": { + "total": 2, + "successful": 1, + "failed": 0 + }, + "status": 201, + "_seq_no" : 0, + "_primary_term": 1 + } + }, + { + "delete": { + "_index": "test", + "_type": "_doc", + "_id": "2", + "_version": 1, + "result": "not_found", + "_shards": { + "total": 2, + "successful": 1, + "failed": 0 + }, + "status": 404, + "_seq_no" : 1, + "_primary_term" : 2 + } + } + ] +} diff --git a/samples/cat/aliases/response/001/input.json b/samples/cat/aliases/response/001/input.json new file mode 100644 --- /dev/null +++ b/samples/cat/aliases/response/001/input.json @@ -0,0 +1,26 @@ +[ + { + "alias": "widgets", + "index": "widgets-2022.09.21", + "filter": "-", + "routing.index": "-", + "routing.search": "-", + "is_write_index": "-" + }, + { + "alias": "widgets", + "index": "widgets-2022.09.22", + "filter": "-", + "routing.index": "-", + "routing.search": "-", + "is_write_index": "-" + }, + { + "alias": "gadgets", + "index": "gadgets-2022.09.21", + "filter": "-", + "routing.index": "-", + "routing.search": "-", + "is_write_index": "-" + } +] diff --git a/samples/cat/indices/response/001/input.json b/samples/cat/indices/response/001/input.json new file mode 100644 --- /dev/null +++ b/samples/cat/indices/response/001/input.json @@ -0,0 +1,38 @@ +[ + { + "health": "green", + "status": "open", + "index": "example-alpha", + "uuid": "L_ObHO__R32Mn5ef_HEuFQ", + "pri": "1", + "rep": "1", + "docs.count": "6728", + "docs.deleted": "152", + "store.size": "2254044", + "pri.store.size": "1121907" + }, + { + "health": "green", + "status": "closed", + "index": "example-beta", + "uuid": "KlgRurzNRRanrldo06OFog", + "pri": "1", + "rep": "1", + "docs.count": "85", + "docs.deleted": "0", + "store.size": "286823", + "pri.store.size": "143410" + }, + { + "health": "yellow", + "status": "open", + "index": "example-gamma", + "uuid": "bcqcIRUPRoklp-GW_l1gYg", + "pri": "1", + "rep": "1", + "docs.count": "22517", + "docs.deleted": "6019", + "store.size": "164020888", + "pri.store.size": "82609812" + } +] diff --git a/samples/search/response/001/input.json b/samples/search/response/001/input.json new file mode 100644 --- /dev/null +++ b/samples/search/response/001/input.json @@ -0,0 +1,49 @@ + + +{ + "took": 5, + "timed_out": false, + "_shards": { + "total": 1, + "successful": 1, + "skipped": 0, + "failed": 0 + }, + "hits": { + "total": { + "value": 20, + "relation": "eq" + }, + "max_score": 1.3862942, + "hits": [ + { + "_index": "my-index-000001", + "_type" : "_doc", + "_id": "0", + "_score": 1.3862942, + "_source": { + "@timestamp": "2099-11-15T14:12:12", + "http": { + "request": { + "method": "get" + }, + "response": { + "status_code": 200, + "bytes": 1070000 + }, + "version": "1.1" + }, + "source": { + "ip": "127.0.0.1" + }, + "message": "GET /search HTTP/1.1 200 1070000", + "user": { + "id": "kimchy" + } + } + } + ] + } +} + + diff --git a/src/Elasticsearch/Aliases/Request.hs b/src/Elasticsearch/Aliases/Request.hs new file mode 100644 --- /dev/null +++ b/src/Elasticsearch/Aliases/Request.hs @@ -0,0 +1,60 @@ +{-# language BangPatterns #-} +{-# language DuplicateRecordFields #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language PatternSynonyms #-} + +module Elasticsearch.Aliases.Request + ( Action(..) + , AddAttributes(..) + , RemoveAttributes(..) + , encode + ) where + +import Data.Primitive (SmallArray) +import Data.Text.Short (ShortText) +import Json (pattern (:->)) + +import qualified Json + +-- | The action to be taken with the document. +data Action + = Add AddAttributes + -- ^ Add an index to an alias + | Remove RemoveAttributes + -- ^ Remove an index from an alias + deriving (Show) + +data AddAttributes = AddAttributes + { alias :: !ShortText + , index :: !ShortText + , isWriteIndex :: !Bool + } deriving (Show) + +data RemoveAttributes = RemoveAttributes + { alias :: !ShortText + , index :: !ShortText + } deriving (Show) + +encode :: SmallArray Action -> Json.Value +encode !xs = Json.object1 ("actions" :-> Json.Array (fmap encodeAction xs)) + +encodeAction :: Action -> Json.Value +encodeAction = \case + Add x -> encodeAdd x + Remove x -> encodeRemove x + +encodeAdd :: AddAttributes -> Json.Value +encodeAdd AddAttributes{alias,index,isWriteIndex} = + Json.object1 $ "add" :-> Json.object3 + ("alias" :-> Json.String alias) + ("index" :-> Json.String index) + ("is_write_index" :-> (if isWriteIndex then Json.True else Json.False)) + +encodeRemove :: RemoveAttributes -> Json.Value +encodeRemove RemoveAttributes{alias,index} = + Json.object1 $ "remove" :-> Json.object2 + ("alias" :-> Json.String alias) + ("index" :-> Json.String index) diff --git a/src/Elasticsearch/Bulk/Request.hs b/src/Elasticsearch/Bulk/Request.hs new file mode 100644 --- /dev/null +++ b/src/Elasticsearch/Bulk/Request.hs @@ -0,0 +1,138 @@ +{-# language BangPatterns #-} +{-# language DuplicateRecordFields #-} +{-# language MagicHash #-} +{-# language NamedFieldPuns #-} + +module Elasticsearch.Bulk.Request + ( Operation(..) + , Action(..) + , encode + , encodeSmile + ) where + +import Data.Bytes.Builder (Builder) +import Data.Primitive (SmallArray) +import Data.Text.Short (ShortText) +import GHC.Exts (Ptr(Ptr)) + +import qualified Data.Maybe.Unpacked.Text.Short as M +import qualified Data.Bytes.Builder as Builder +import qualified Json +import qualified Json.Smile + +-- | A single operation in a bulk request. +data Operation = Operation + { action :: !Action + -- ^ The action to take. Usually 'Create' or 'Index'. + , index :: {-# UNPACK #-} !ShortText + -- ^ Index name, required + , id_ :: {-# UNPACK #-} !M.MaybeShortText + -- ^ Document ID, optional but strongly recommended. + , document :: !Json.Value + -- ^ Document + } deriving (Show) + +-- | The action to be taken with the document. +data Action + = Create + -- ^ Create a new document. Fails if document with ID already exists. + | Index + -- ^ Create or update a document. + | Delete + -- ^ Delete a document. Note: Currently broken. Results in + -- malformed request. + | Update + -- ^ Update a document. Fails if document with ID does not exist. + deriving (Show) + +-- | Encode returns a builder, not a JSON value, because the body of +-- an Elasticsearch bulk requests is not JSON. Technically, it is +-- , but since there is no common type for +-- that, this module just converts it straight to a builder. +encode :: SmallArray Operation -> Builder +encode !xs = foldMap encodeOne xs + +encodeOne :: Operation -> Builder +encodeOne Operation{action,index,id_,document} = + encodePreamble action + <> Builder.shortTextJsonString index + <> M.maybe mempty + (\t -> Builder.ascii7 ',' '"' '_' 'i' 'd' '"' ':' + <> Builder.shortTextJsonString t + ) id_ + <> Builder.ascii3 '}' '}' '\n' + <> Json.encode document + <> Builder.ascii '\n' + +-- When we encode the first part of the operation, we are trying to +-- build something like this: +-- {"index":{"_index":"test","_id":"1"}} +-- {"index":{"_index":"test"} +-- {"create":{"_index":"test","_id":"1"}} +-- This function encodes just the beginning part. For example: +-- {"index":{"_index": +-- {"create":{"_index": +encodePreamble :: Action -> Builder +encodePreamble x = case x of + Create -> Builder.cstring (Ptr "{\"create\":{\"_index\":"# ) + Index -> Builder.cstring (Ptr "{\"index\":{\"_index\":"# ) + Delete -> Builder.cstring (Ptr "{\"delete\":{\"_index\":"# ) + Update -> Builder.cstring (Ptr "{\"update\":{\"_index\":"# ) + +-- | Encode with SMILE. This does not use backreferences. +encodeSmile :: SmallArray Operation -> Builder +{-# noinline encodeSmile #-} +encodeSmile !xs = foldMap encodeSmileOne xs + +encodeSmileAction :: Action -> ShortText -> ShortText -> Builder +{-# inline encodeSmileAction #-} +encodeSmileAction x !indexName !docId = + ( case x of + Create -> + -- Breakdown: + -- [0-3]: four-byte prefix, smiley face + -- [4]: object (0xfa) + -- [5]: key, length 6 + -- [6-11]: "create" + -- [12]: object (0xfa) + -- [13]: key, length 6 + -- [14-19]: "_index" + Builder.cstring (Ptr "\x3a\x29\x0a\x00\xfa\x85\x63\x72\x65\x61\x74\x65\xfa\x85\x5f\x69\x6e\x64\x65\x78"#) + Index -> + -- Nearly the same as create but with the action key different + Builder.cstring (Ptr "\x3a\x29\x0a\x00\xfa\x84\x69\x6e\x64\x65\x78\xfa\x85\x5f\x69\x6e\x64\x65\x78"#) + _ -> errorWithoutStackTrace "Elasticsearch.Bulk.Request[encodeSmileAction]: write Update and Delete cases" + ) + <> + Json.Smile.encodeString indexName + <> + Builder.cstring (Ptr "\x82\x5f\x69\x64"#) -- the "_id" key + <> + Json.Smile.encodeString docId + <> + Builder.cstring (Ptr "\xfb\xfb\xff"#) -- close objects and stream separator 0xFF + +encodeSmileActionWithoutDocId :: Action -> ShortText -> Builder +{-# inline encodeSmileActionWithoutDocId #-} +encodeSmileActionWithoutDocId x !indexName = + ( case x of + Create -> + Builder.cstring (Ptr "\x3a\x29\x0a\x00\xfa\x85\x63\x72\x65\x61\x74\x65\xfa\x85\x5f\x69\x6e\x64\x65\x78"#) + Index -> + -- Nearly the same as create but with the action key different + Builder.cstring (Ptr "\x3a\x29\x0a\x00\xfa\x84\x69\x6e\x64\x65\x78\xfa\x85\x5f\x69\x6e\x64\x65\x78"#) + _ -> errorWithoutStackTrace "Elasticsearch.Bulk.Request[encodeSmileAction]: write Update and Delete cases" + ) + <> + Json.Smile.encodeString indexName + <> + Builder.cstring (Ptr "\xfb\xfb\xff"#) -- close objects and stream separator 0xFF + +encodeSmileOne :: Operation -> Builder +encodeSmileOne Operation{action,index,id_,document} = + M.maybe + (encodeSmileActionWithoutDocId action index) + (encodeSmileAction action index) + id_ + <> Json.Smile.encode document + <> Builder.word8 0xFF diff --git a/src/Elasticsearch/Bulk/Response.hs b/src/Elasticsearch/Bulk/Response.hs new file mode 100644 --- /dev/null +++ b/src/Elasticsearch/Bulk/Response.hs @@ -0,0 +1,245 @@ +{-# language ApplicativeDo #-} +{-# language BangPatterns #-} +{-# language DuplicateRecordFields #-} +{-# language MagicHash #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language UnboxedTuples #-} + +-- | Response to @/_bulk@ request. +module Elasticsearch.Bulk.Response + ( -- * Types + Response(..) + , Action(..) + , Item(..) + , ConcurrencyControl(..) + , Error(..) + , Details(..) + -- * Response Parser + , parser + -- * Example Data + -- $example + ) where + +import Prelude hiding (id) + +import Control.Monad ((>=>)) +import Data.Foldable (find) +import Data.Primitive (SmallArray) +import Data.Text.Short (ShortText) +import Data.Word (Word64,Word16) +import Elasticsearch.Bulk.Request (Action(Update,Create,Delete,Index)) +import Json (Member(Member)) +import Json.Parser (Parser,MemberParser) +import Json.Context (Context(Key)) + +import qualified Data.Primitive as PM +import qualified Json as J +import qualified Json.Parser as P + +data Response = Response + { took :: !Word64 + -- ^ How many milliseconds did the operation take? + , errors :: !Bool + -- ^ Did anything go wrong? + , items :: !(SmallArray Item) + -- ^ Individual responses for each operation. + } deriving (Show) + +-- | The _type field is omitted because it is always _doc in Elasticsearch 7+. +-- Some other fields are omitted because they are only present when an operation +-- succeeds. +data Item = Item + { action :: !Action + , index :: !ShortText + -- ^ @_index@ + , id :: !ShortText + -- ^ @_id@ + , status :: !Word16 + -- ^ @status@ + , details :: !Details + -- ^ No single field dictates the details. + } deriving (Show) + +-- | An item has different fields depending on whether the operation +-- was considered to have succeeded. +data Details + = Success !ConcurrencyControl + | Failure !Error + deriving (Show) + +data ConcurrencyControl = ConcurrencyControl + { version :: !Word64 + -- ^ @_version@ + , sequenceNumber :: !Word64 + -- ^ @_seq_no@ + } deriving (Show) + +data Error = Error + { type_ :: !ShortText + , reason :: !ShortText + } deriving (Show) + +-- | Decode the JSON response to a bulk request. +parser :: J.Value -> Parser Response +parser v = do + mbrs <- P.object v + P.members + ( do took <- P.key "took" (P.number >=> P.word64) + errors <- P.key "errors" P.boolean + items <- P.key "items" (P.array >=> P.smallArray itemParser) + pure Response{took,errors,items} + ) mbrs + +itemParser :: J.Value -> Parser Item +itemParser v = do + mbrsTop <- P.object v + case PM.sizeofSmallArray mbrsTop of + 1 -> do + let !(# Member{key=keyAction,value=valueAction} #) = PM.indexSmallArray## mbrsTop 0 + action <- case keyAction of + "update" -> pure Update + "create" -> pure Create + "delete" -> pure Delete + "index" -> pure Index + _ -> P.fail "expected one of: update, create, delete, index" + P.contextually (Key keyAction) $ do + mbrsProps <- P.object valueAction + case find (\Member{key=keyProp} -> keyProp == "error") mbrsProps of + Nothing -> P.members -- item indicates a success + ( do index <- P.key "_index" P.string + id <- P.key "_id" P.string + status <- P.key "status" (P.number >=> P.word16) + version <- P.key "_version" (P.number >=> P.word64) + sequenceNumber <- P.key "_seq_no" (P.number >=> P.word64) + pure Item + { action,index,id,status + , details=Success ConcurrencyControl{version,sequenceNumber} + } + ) mbrsProps + Just Member{value=errorValue} -> do -- item indicates a failure + mbrsError <- P.object errorValue + err <- P.contextually (Key "error") (P.members errorMemberParser mbrsError) + P.members + ( do index <- P.key "_index" P.string + id <- P.key "_id" P.string + status <- P.key "status" (P.number >=> P.word16) + pure Item + { action,index,id,status + , details=Failure err + } + ) mbrsProps + _ -> P.fail "expected object with single member" + +errorMemberParser :: MemberParser Error +errorMemberParser = do + type_ <- P.key "type" P.string + reason <- P.key "reason" P.string + pure Error{type_,reason} + + +-- $example +-- +-- Example responses from Elasticsearch documentation with additional +-- commentary. This one does not include any detailed error messages: +-- +-- > { +-- > "took": 30, +-- > "errors": false, +-- > "items": [ +-- > { +-- > "index": { +-- > "_index": "test", +-- > "_type": "_doc", +-- > "_id": "1", +-- > "_version": 1, +-- > "result": "created", +-- > "_shards": { +-- > "total": 2, +-- > "successful": 1, +-- > "failed": 0 +-- > }, +-- > "status": 201, +-- > "_seq_no" : 0, +-- > "_primary_term": 1 +-- > } +-- > }, +-- > { +-- > "delete": { +-- > "_index": "test", +-- > "_type": "_doc", +-- > "_id": "2", +-- > "_version": 1, +-- > "result": "not_found", +-- > "_shards": { +-- > "total": 2, +-- > "successful": 1, +-- > "failed": 0 +-- > }, +-- > "status": 404, +-- > "_seq_no" : 1, +-- > "_primary_term" : 2 +-- > } +-- > } +-- > ] +-- > } +-- +-- This one does have detailed error messages in it: +-- +-- > { +-- > "took": 486, +-- > "errors": true, +-- > "items": [ +-- > { +-- > "update": { +-- > "_index": "index1", +-- > "_type" : "_doc", +-- > "_id": "5", +-- > "status": 404, +-- > "error": { +-- > "type": "document_missing_exception", +-- > "reason": "[_doc][5]: document missing", +-- > "index_uuid": "aAsFqTI0Tc2W0LCWgPNrOA", +-- > "shard": "0", +-- > "index": "index1" +-- > } +-- > } +-- > }, +-- > { +-- > "update": { +-- > "_index": "index1", +-- > "_type" : "_doc", +-- > "_id": "6", +-- > "status": 404, +-- > "error": { +-- > "type": "document_missing_exception", +-- > "reason": "[_doc][6]: document missing", +-- > "index_uuid": "aAsFqTI0Tc2W0LCWgPNrOA", +-- > "shard": "0", +-- > "index": "index1" +-- > } +-- > } +-- > }, +-- > { +-- > "create": { +-- > "_index": "index1", +-- > "_type" : "_doc", +-- > "_id": "7", +-- > "_version": 1, +-- > "result": "created", +-- > "_shards": { +-- > "total": 2, +-- > "successful": 1, +-- > "failed": 0 +-- > }, +-- > "_seq_no": 0, +-- > "_primary_term": 1, +-- > "status": 201 +-- > } +-- > } +-- > ] +-- > } +-- +-- Even though the documentation shows an @index_uuid@ field in the +-- error details, Elasticsearch 7.10 does not always populate this field. +-- It is not terribly useful, so it is omitted from the 'Error' type. diff --git a/src/Elasticsearch/Cat/Aliases/Response.hs b/src/Elasticsearch/Cat/Aliases/Response.hs new file mode 100644 --- /dev/null +++ b/src/Elasticsearch/Cat/Aliases/Response.hs @@ -0,0 +1,44 @@ +{-# language ApplicativeDo #-} +{-# language BangPatterns #-} +{-# language DuplicateRecordFields #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language UnboxedTuples #-} + +-- | Response to @/_cat/aliases@ request. +module Elasticsearch.Cat.Aliases.Response + ( Response(..) + , Alias(..) + -- * Response Parser + , parser + ) where + +import Data.Primitive (SmallArray) +import Data.Text.Short (ShortText) +import Json.Parser (Parser) + +import qualified Json as J +import qualified Json.Parser as P + +newtype Response = Response + { indices :: SmallArray Alias + } deriving (Show) + +data Alias = Alias + { alias :: !ShortText + , index :: !ShortText + } deriving (Show) + +parser :: J.Value -> Parser Response +parser v = fmap Response (P.array v >>= P.smallArray aliasParser) + +aliasParser :: J.Value -> Parser Alias +aliasParser v = do + mbrs <- P.object v + P.members + ( do alias <- P.key "alias" P.string + index <- P.key "index" P.string + pure Alias{alias,index} + ) mbrs diff --git a/src/Elasticsearch/Cat/Indices/Response.hs b/src/Elasticsearch/Cat/Indices/Response.hs new file mode 100644 --- /dev/null +++ b/src/Elasticsearch/Cat/Indices/Response.hs @@ -0,0 +1,72 @@ +{-# language ApplicativeDo #-} +{-# language BangPatterns #-} +{-# language DuplicateRecordFields #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language UnboxedTuples #-} + +-- | Response to @/_cat/indices@ request. Make sure to set these query string +-- parameters: @format=json&bytes=b@. +module Elasticsearch.Cat.Indices.Response + ( Response(..) + , Index(..) + , Health(..) + , Status(..) + -- * Response Parser + , parser + ) where + +import Control.Monad ((>=>)) +import Data.Primitive (SmallArray) +import Data.Text.Short (ShortText) +import Json.Parser (Parser) + +import qualified Json as J +import qualified Json.Parser as P + +newtype Response = Response + { indices :: SmallArray Index + } deriving (Show) + +data Index = Index + { health :: !Health + -- ^ Health: green, yellow, red (@health@) + , status :: !Status + -- ^ Status: open or closed (@status@) + , index :: !ShortText + -- ^ The name of the index (@index@) + } deriving (Show) + +data Health = Green | Yellow | Red + deriving (Show) + +data Status = Open | Closed + deriving (Show) + +parser :: J.Value -> Parser Response +parser v = fmap Response (P.array v >>= P.smallArray indexParser) + +indexParser :: J.Value -> Parser Index +indexParser v = do + mbrs <- P.object v + P.members + ( do health <- P.key "health" (P.string >=> healthParser) + status <- P.key "status" (P.string >=> statusParser) + index <- P.key "index" P.string + pure Index{health,status,index} + ) mbrs + +healthParser :: ShortText -> Parser Health +healthParser = \case + "red" -> pure Red + "yellow" -> pure Yellow + "green" -> pure Green + _ -> P.fail "expected one of: red, yellow, green" + +statusParser :: ShortText -> Parser Status +statusParser = \case + "open" -> pure Open + "closed" -> pure Closed + _ -> P.fail "expected one of: open, closed" diff --git a/src/Elasticsearch/Search/Response.hs b/src/Elasticsearch/Search/Response.hs new file mode 100644 --- /dev/null +++ b/src/Elasticsearch/Search/Response.hs @@ -0,0 +1,146 @@ +{-# language ApplicativeDo #-} +{-# language BangPatterns #-} +{-# language DuplicateRecordFields #-} +{-# language MagicHash #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language UnboxedTuples #-} + +-- | Responses from Search API (@http:\/\/elasticsearch.example.com\/{index}\/_search@) +module Elasticsearch.Search.Response + ( -- * Types + Response(..) + , Hits(..) + , Hit(..) + , Total(..) + -- * Response Parser + , parser + -- * Example Data + -- $example + ) where + +import Prelude hiding (id) + +import Control.Monad ((>=>)) +import Data.Primitive (SmallArray) +import Data.Text.Short (ShortText) +import Data.Word (Word64) +import Json.Parser (Parser,MemberParser) + +import qualified Json as J +import qualified Json.Parser as P + +-- | A response from a search. +-- +-- One strange thing about the organization of the response is that there +-- is a @hits@ field with another @hits@ field inside of it. This is how +-- elasticsearch presents this information, and that unusual structure is +-- simply mirrored by these types. +data Response = Response + { took :: !Word64 + -- ^ How many milliseconds did the operation take? + , hits :: !Hits + -- ^ A hits object + } deriving (Show) + +data Hits = Hits + { total :: !Total + -- ^ Information about the total number of documents that matched + , hits :: !(SmallArray Hit) + -- ^ Array of hits + } deriving (Show) + +-- | A document that matched the search criteria +data Hit = Hit + { index :: !ShortText + -- ^ Index name + , id :: !ShortText + -- ^ Document id + , source :: !J.Value + -- ^ Source document + } deriving (Show) + +data Total = Total + { value :: !Word64 + , relation :: !ShortText + } deriving (Show) + +-- | Decode the JSON response to a bulk request. +parser :: J.Value -> Parser Response +parser v = do + mbrs <- P.object v + P.members + ( do took <- P.key "took" (P.number >=> P.word64) + hits <- P.key "hits" (P.object >=> P.members hitsParser) + pure Response{took,hits} + ) mbrs + +hitsParser :: MemberParser Hits +hitsParser = do + total <- P.key "total" (P.object >=> P.members totalParser) + hits <- P.key "hits" + (P.array >=> P.smallArray (P.object >=> P.members hitParser)) + pure Hits{total,hits} + +totalParser :: MemberParser Total +totalParser = do + value <- P.key "value" (P.number >=> P.word64) + relation <- P.key "relation" P.string + pure Total{value,relation} + +hitParser :: MemberParser Hit +hitParser = do + index <- P.key "_index" P.string + id <- P.key "_id" P.string + source <- P.key "_source" pure + pure Hit{index,id,source} + +-- $example +-- +-- Example response from Elasticsearch documentation: +-- +-- > { +-- > "took": 5, +-- > "timed_out": false, +-- > "_shards": { +-- > "total": 1, +-- > "successful": 1, +-- > "skipped": 0, +-- > "failed": 0 +-- > }, +-- > "hits": { +-- > "total": { +-- > "value": 20, +-- > "relation": "eq" +-- > }, +-- > "max_score": 1.3862942, +-- > "hits": [ +-- > { +-- > "_index": "my-index-000001", +-- > "_type" : "_doc", +-- > "_id": "0", +-- > "_score": 1.3862942, +-- > "_source": { +-- > "@timestamp": "2099-11-15T14:12:12", +-- > "http": { +-- > "request": { +-- > "method": "get" +-- > }, +-- > "response": { +-- > "status_code": 200, +-- > "bytes": 1070000 +-- > }, +-- > "version": "1.1" +-- > }, +-- > "source": { +-- > "ip": "127.0.0.1" +-- > }, +-- > "message": "GET /search HTTP/1.1 200 1070000", +-- > "user": { +-- > "id": "kimchy" +-- > } +-- > } +-- > } +-- > ] +-- > } +-- > } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,127 @@ +{-# language BangPatterns #-} +{-# language DuplicateRecordFields #-} +{-# language MultiWayIf #-} +{-# language NumDecimals #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language PatternSynonyms #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +import Test.Tasty (defaultMain,testGroup,TestTree) +import Test.Tasty.Golden (goldenVsString) +import Elasticsearch.Bulk.Request (Operation(Operation),Action(Index,Create)) +import Text.Show.Pretty (ppShow) +import Json (pattern (:->)) + +import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Chunks as Chunks +import qualified Data.Bytes.Builder as Builder +import qualified Data.List as List +import qualified Data.Maybe.Unpacked.Text.Short as M +import qualified GHC.Exts as Exts +import qualified Elasticsearch.Bulk.Request as Bulk.Request +import qualified Elasticsearch.Bulk.Response as Bulk.Response +import qualified Elasticsearch.Search.Response as Search.Response +import qualified Elasticsearch.Cat.Indices.Response as Cat.Indices.Response +import qualified Elasticsearch.Cat.Aliases.Response as Cat.Aliases.Response +import qualified Elasticsearch.Aliases.Request as Aliases.Request +import qualified Json +import qualified Json.Errors as Errors +import qualified Json.Parser as Parser +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBC8 +import qualified Data.Text.Short as TS + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Elasticsearch" + [ testGroup "Search" + [ testGroup "Response" + [ goldenVsString "001" "samples/search/response/001/output.txt" $ do + prepare "samples/search/response/001/input.json" Search.Response.parser + ] + ] + , testGroup "CatAliases" + [ testGroup "Response" + [ goldenVsString "001" "samples/cat/aliases/response/001/output.txt" $ do + prepare "samples/cat/aliases/response/001/input.json" Cat.Aliases.Response.parser + ] + ] + , testGroup "CatIndices" + [ testGroup "Response" + [ goldenVsString "001" "samples/cat/indices/response/001/output.txt" $ do + prepare "samples/cat/indices/response/001/input.json" Cat.Indices.Response.parser + ] + ] + , testGroup "Aliases" + [ testGroup "Request" + [ goldenVsString "001" "samples/aliases/request/001/output.json" + $ pure + $ LBS.fromStrict + $ Chunks.concatByteString + $ Builder.run 64 + $ Json.encode + $ Aliases.Request.encode + $ Exts.fromList + [ Aliases.Request.Add Aliases.Request.AddAttributes + { alias = "person-2018" + , index = "person-2018.09.28" + , isWriteIndex = False + } + , Aliases.Request.Remove Aliases.Request.RemoveAttributes + { alias = "person-2018" + , index = "person-2018.09.27" + } + ] + ] + ] + , testGroup "Bulk" + [ testGroup "Request" + [ goldenVsString "001" "samples/bulk/request/001/output.json" + $ pure + $ LBS.fromStrict + $ Chunks.concatByteString + $ Builder.run 64 + $ Bulk.Request.encode + $ Exts.fromList + [ Operation + { action = Index + , index = "person-2018.09.28" + , id_ = M.just "5bc6d38e-8b30-11eb-8dcd-0242ac130003" + , document = Json.emptyObject + } + , Operation + { action = Create + , index = "person-2018.09.29" + , id_ = M.just "3cd512c8-8b31-11eb-8dcd-0242ac130003" + , document = Json.Object + (Exts.fromList ["name" :-> Json.String "Xavier"]) + } + ] + ] + , testGroup "Response" + [ goldenVsString "001" "samples/bulk/response/001/output.txt" $ do + prepare "samples/bulk/response/001/input.json" Bulk.Response.parser + ] + ] + ] + +prepare :: Show a + => String -- path to json + -> (Json.Value -> Parser.Parser a) + -> IO LBC8.ByteString +prepare path parse = do + c <- Bytes.readFile path + case Json.decode c of + Left _ -> fail "input file was not JSON" + Right v -> do + case Parser.run (parse v) of + Left errs -> fail ("parse error at: " ++ TS.unpack (Errors.encode errs)) + Right response -> do + let raw = ppShow response + let clean = if List.isSuffixOf "\n" raw then raw else raw ++ "\n" + pure (LBC8.pack clean)