Initial commit

Setup.hs

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

package.yaml

@@ -0,0 +1,36 @@
+name:                escli
+version:             0.1.0.0
+github:              "DaveCTurner/escli"
+license:             BSD3
+author:              "David Turner"
+maintainer:          "[email protected]"
+copyright:           "2018 Author name here"
+
+dependencies:
+- base >= 4.7 && < 5
+- optparse-applicative
+- conduit
+- conduit-extra
+- bytestring
+- aeson
+- attoparsec
+- text
+- http-client
+- http-types
+- network-uri
+- aeson-pretty
+- iso8601-time
+- time
+
+executables:
+  escli:
+    main:                Main.hs
+    source-dirs:         src
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -Wall -Werror
+    other-modules:
+    - Config
+    - ESCommand

src/Config.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Config (Config(..), withConfig) where
+
+import Options.Applicative
+import Data.Monoid
+import Network.URI
+
+data Config = Config
+    { esBaseURI :: URI
+    } deriving (Show, Eq)
+
+configParser :: Parser Config
+configParser = Config
+    <$> option (maybeReader parseAbsoluteURI)
+        (  long "server"
+        <> help "Base HTTP URI of the Elasticsearch server"
+        <> showDefault
+        <> value URI
+                { uriScheme = "http:"
+                , uriAuthority = Just URIAuth
+                    { uriUserInfo = ""
+                    , uriRegName = "localhost"
+                    , uriPort    = ":9200"
+                    }
+                , uriPath = ""
+                , uriQuery = ""
+                , uriFragment = ""
+                }
+        <> metavar "ADDR")
+
+configParserInfo :: ParserInfo Config
+configParserInfo = info (configParser <**> helper)
+    (fullDesc
+        <> progDesc "Interact with Elasticsearch from the shell"
+        <> header "escli - Interact with Elasticsearch from the shell")
+
+withConfig :: (Config -> IO a) -> IO a
+withConfig go = go =<< execParser configParserInfo

src/ESCommand.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE LambdaCase #-}
+
+module ESCommand (ESCommand(..), esCommand) where
+
+import Control.Applicative
+import Control.Monad
+import qualified Data.Attoparsec.ByteString as AP
+import qualified Data.ByteString as B
+import Data.Aeson
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Encoding.Error as T
+
+data ESCommand = ESCommand
+    { httpVerb :: B.ByteString
+    , httpPath :: String
+    , cmdBody  :: [Value]
+    } deriving (Show, Eq)
+
+esCommand :: AP.Parser ESCommand
+esCommand = AP.skipMany skipNewline >> ESCommand
+    <$> AP.choice (map (AP.string . T.encodeUtf8 . T.pack) $ words "GET POST PUT DELETE")
+    <*  AP.takeWhile1 (== 0x20)
+    <*> (T.unpack . T.decodeUtf8With T.lenientDecode <$> AP.takeWhile1 (>= 0x20))
+    <*  skipNewline
+    <*> AP.sepBy jsonNotNewline skipNewline
+    <*  (skipNewline <|> AP.endOfInput)
+
+    where
+    skipNewline :: AP.Parser ()
+    skipNewline = void $ AP.word8 0x0a
+
+    jsonNotNewline :: AP.Parser Value
+    jsonNotNewline = AP.peekWord8 >>= \case
+        Just w | w >= 0x20 -> json
+        _                  -> fail "jsonNotNewline"

src/Main.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import System.IO
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Conduit
+import Data.Conduit.Binary
+import Config
+import ESCommand
+import Data.Conduit.Attoparsec
+import Network.URI
+import Data.Maybe
+import Network.HTTP.Client
+import Network.HTTP.Types.Header
+import Data.Aeson
+import qualified Data.ByteString.Builder as B
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.ByteString.Lazy as BL
+import Data.Monoid
+import Data.Int
+import qualified Data.Aeson.Encode.Pretty
+import Data.Time
+import Data.Time.ISO8601
+import Network.HTTP.Types.Status
+
+main :: IO ()
+main = withConfig $ \config -> do
+
+    putStrLn $ "Base URI: " ++ show (esBaseURI config)
+    manager <- newManager defaultManagerSettings
+
+    runConduit
+         $  sourceHandle stdin
+        =$= conduitParser esCommand
+        =$= awaitForever (liftIO . runCommand config manager . snd)
+
+prettyStringFromJson :: ToJSON a => a -> String
+prettyStringFromJson v
+    = T.unpack $ T.decodeUtf8 $ BL.toStrict
+        $ Data.Aeson.Encode.Pretty.encodePretty' aesonPrettyConfig v
+    where
+    aesonPrettyConfig = Data.Aeson.Encode.Pretty.defConfig
+        { Data.Aeson.Encode.Pretty.confIndent = Data.Aeson.Encode.Pretty.Spaces 2 }
+
+runCommand :: Config -> Manager -> ESCommand -> IO ()
+runCommand Config{..} manager ESCommand{..} = do
+    let initReq = fromMaybe (error "Bad URI") $ do
+            uriRef <- parseURIReference httpPath
+            let absUri = uriRef `relativeTo` esBaseURI
+            parseRequest $ show absUri
+
+        BuilderWithLength bodyBuilder bodyLength = builderFromBody cmdBody
+
+        req = initReq
+            { method = httpVerb
+            , requestHeaders = case cmdBody of
+                []  -> []
+                [_] -> [(hContentType, "application/json")]
+                _   -> [(hContentType, "application/x-ndjson")]
+            , requestBody = RequestBodyBuilder bodyLength bodyBuilder
+            }
+
+        httpVerbString = T.unpack $ T.decodeUtf8 httpVerb
+        resolvedUriString = getUri req `relativeFrom` esBaseURI
+
+    putStrLn "# Request: "
+    putStrLn $ httpVerbString <> " " <> show resolvedUriString
+    forM_ cmdBody $ \v -> putStrLn $ prettyStringFromJson v
+    before <- getCurrentTime
+    putStrLn $ "# at " ++ formatISO8601Millis before
+    putStrLn ""
+
+    response <- httpLbs req manager
+    after <- getCurrentTime
+    putStrLn "# Response: "
+    putStrLn $ "# " ++ show (statusCode    $ responseStatus response)
+            ++ " "  ++ T.unpack (T.decodeUtf8 $ statusMessage $ responseStatus response)
+    let Just bodyValue = decode $ responseBody response :: Maybe Value
+    forM_ (Prelude.lines $ prettyStringFromJson bodyValue) $ \l
+        -> putStrLn $ "# " ++ l
+    putStrLn $ "# at " ++ formatISO8601Millis after
+    putStrLn $ "# (" ++ show (diffUTCTime after before) ++ " elapsed)"
+    putStrLn ""
+
+data BuilderWithLength = BuilderWithLength B.Builder !Int64
+
+instance Monoid BuilderWithLength where
+    mempty = BuilderWithLength mempty 0
+    mappend (BuilderWithLength b1 l1) (BuilderWithLength b2 l2)
+        = BuilderWithLength (b1 <> b2) (l1 + l2)
+
+jsonWithLength :: ToJSON a => a -> BuilderWithLength
+jsonWithLength v = BuilderWithLength (B.lazyByteString bs) (BL.length bs)
+  where bs = encode v
+
+newlineWithLength :: BuilderWithLength
+newlineWithLength = BuilderWithLength (B.word8 0x0a) 1
+
+builderFromBody :: [Value] -> BuilderWithLength
+builderFromBody []  = mempty
+builderFromBody [v] = jsonWithLength v
+builderFromBody vs  = mconcat $ map ((<> newlineWithLength) . jsonWithLength) vs

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-9.21
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.6"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor