diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Michael Xavier (c) 2015 + +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 Michael Xavier 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,17 @@ +# bloodhound-amazonka-auth +[![Build Status](https://travis-ci.org/MichaelXavier/bloodhound-amazonka-auth.svg?branch=master)](https://travis-ci.org/MichaelXavier/bloodhound-amazonka-auth) + +Adds convenient Amazon ElasticSearch Service authentication to +Bloodhound. + + +# Usage + +```haskell +env <- newEnv region Discover +let auth = env ^. envAuth +let hook req = withAuth auth $ ae -> + either (liftIO . throwIO) return =<< amazonkaAuthHook ae region req +mgr <- newManager tlsManagerSettings +let bhe = (mkBHEnv server mgr) { bhRequestHook = hook } +``` 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/bloodhound-amazonka-auth.cabal b/bloodhound-amazonka-auth.cabal new file mode 100644 --- /dev/null +++ b/bloodhound-amazonka-auth.cabal @@ -0,0 +1,64 @@ +name: bloodhound-amazonka-auth +version: 0.1.0.0 +synopsis: Adds convenient Amazon ElasticSearch Service authentication to Bloodhound. +description: Please see README.md +homepage: http://github.com/MichaelXavier/bloodhound-amazonka-auth#readme +license: BSD3 +license-file: LICENSE +author: Michael Xavier +maintainer: michael@michaelxavier.net +copyright: 2015 Michael Xavier +category: Web +build-type: Simple +extra-source-files: README.md + , changelog.md +cabal-version: >=1.10 + +flag lib-Werror + default: False + manual: True + +library + hs-source-dirs: src + exposed-modules: Database.Bloodhound.Auth.Amazonka + Database.Bloodhound.Auth.Amazonka.Internal + build-depends: base >= 4.7 && < 5 + , bloodhound >= 0.11 + , http-client + , time + , amazonka-core >= 1.3.0 && < 1.4 + , amazonka-elasticsearch >= 1.3.6 && < 1.4 + , transformers + , http-types + , exceptions + , uri-bytestring + default-language: Haskell2010 + + if flag(lib-Werror) + ghc-options: -Werror + + ghc-options: -Wall + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: Haskell2010 + + build-depends: base + , bloodhound-amazonka-auth + , tasty + , tasty-hunit + , amazonka-core + , http-client + , time + + if flag(lib-Werror) + ghc-options: -Werror + + ghc-options: -Wall + + +source-repository head + type: git + location: https://github.com/MichaelXavier/bloodhound-amazonka-auth diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md diff --git a/src/Database/Bloodhound/Auth/Amazonka.hs b/src/Database/Bloodhound/Auth/Amazonka.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Auth/Amazonka.hs @@ -0,0 +1,9 @@ +module Database.Bloodhound.Auth.Amazonka + ( amazonkaAuthHook + , EsAmazonkaAuthError(..) + ) where + + +------------------------------------------------------------------------------- +import Database.Bloodhound.Auth.Amazonka.Internal +------------------------------------------------------------------------------- diff --git a/src/Database/Bloodhound/Auth/Amazonka/Internal.hs b/src/Database/Bloodhound/Auth/Amazonka/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Auth/Amazonka/Internal.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Database.Bloodhound.Auth.Amazonka.Internal where + + +------------------------------------------------------------------------------- +import Control.Exception +import Data.Bifunctor +import Data.Time.Clock +import Data.Typeable +import Database.Bloodhound.Types +import Network.AWS.Data.Body +import Network.AWS.Data.ByteString +import Network.AWS.Data.Path +import Network.AWS.Data.Query +import qualified Network.AWS.Data.Query as A +import Network.AWS.ElasticSearch (elasticSearch) +import Network.AWS.Types (AuthEnv, Region, sgRequest, + sgSign) +import qualified Network.AWS.Types as A +import Network.HTTP.Client +import Network.HTTP.Types.Method (parseMethod) +import URI.ByteString +------------------------------------------------------------------------------- + + +-- | Request hook to install into your 'BHEnv'. Does not handle +-- streaming request bodies, which should not be an issue for +-- Bloodhound. The exception cases handled by 'EsAmazonkaAuthError' +-- are truly exceptional and should probably be thrown. +-- +-- @ +-- env <- newEnv region Discover +-- let auth = env ^. envAuth +-- let hook req = withAuth auth $ \ae -> +-- either (liftIO . throwIO) return =<< amazonkaAuthHook ae region req +-- mgr <- newManager tlsManagerSettings +-- let bhe = (mkBHEnv server mgr) { bhRequestHook = hook } +-- @ +amazonkaAuthHook :: AuthEnv -> Region -> Request -> IO (Either EsAmazonkaAuthError Request) +amazonkaAuthHook ae reg req = amazonkaAuthHook' ae reg req <$> getCurrentTime + + +------------------------------------------------------------------------------- +amazonkaAuthHook' :: AuthEnv -> Region -> Request -> UTCTime -> Either EsAmazonkaAuthError Request +amazonkaAuthHook' ae reg req now = toReq <$> toAwsRequest req reg + where algo = sgSign (A._svcSigner elasticSearch) + toReq req' = sgRequest (algo req' ae reg now) + + +------------------------------------------------------------------------------- +toAwsRequest :: Request -> Region -> Either EsAmazonkaAuthError (A.Request a) +toAwsRequest r reg = do + meth <- first (const badMethod) (parseMethod bsMeth) + rqb <- toRQBody (requestBody r) + q <- toQS (queryString r) + return (A.Request { A._rqService = svc + , A._rqMethod = meth + , A._rqPath = rawPath (path r) + , A._rqQuery = q + , A._rqHeaders = requestHeaders r + , A._rqBody = rqb}) + where bsMeth = method r + badMethod = InvalidStdMethod bsMeth + svc = elasticSearch { A._svcEndpoint = const endpoint} + endpoint = requestEndpoint r reg + + +------------------------------------------------------------------------------- +toQS :: ByteString -> Either EsAmazonkaAuthError A.QueryString +toQS bs = case parseRelativeRef laxURIParserOptions bs of + Right rr -> Right (go (rrQuery rr)) + Left _ -> Left MalformedQueryString + where go q = QList [ QPair k (QValue (Just v)) | (k, v) <- queryPairs q] + +------------------------------------------------------------------------------- +requestEndpoint :: Request -> Region -> A.Endpoint +requestEndpoint r reg = A.Endpoint { A._endpointHost = host r + , A._endpointSecure = secure r + , A._endpointPort = port r + , A._endpointScope = toBS reg} + +------------------------------------------------------------------------------- +-- | These edge cases shouldn't come up in normal operation. The best +-- course of action is probably to throw these as an exception. +data EsAmazonkaAuthError = InvalidStdMethod Method + | StreamingBodyNotSupported + | MalformedQueryString deriving (Show, Eq, Typeable) + + +instance Exception EsAmazonkaAuthError + +------------------------------------------------------------------------------- +toRQBody :: RequestBody -> Either EsAmazonkaAuthError RqBody +toRQBody (RequestBodyLBS b) = Right (toBody b) +toRQBody (RequestBodyBS b) = Right (toBody b) +toRQBody _ = Left StreamingBodyNotSupported diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + + +------------------------------------------------------------------------------- +import Data.Time.Clock.POSIX +import Network.AWS.Types +import Network.HTTP.Client +import Test.Tasty +import Test.Tasty.HUnit +------------------------------------------------------------------------------- +import Database.Bloodhound.Auth.Amazonka.Internal +------------------------------------------------------------------------------- + + +main :: IO () +main = defaultMain tests + + +------------------------------------------------------------------------------- +tests :: TestTree +tests = testGroup "bloodhound-amazonka-auth" + [ + amazonkaAuthHookTests + ] + + +------------------------------------------------------------------------------- +amazonkaAuthHookTests :: TestTree +amazonkaAuthHookTests = testGroup "amazonkaAuthHook" + [ + testCase "does not mangle query parameters" $ do + req <- parseUrl "http://localhost:9200/foo/foo/_search?scroll=1m&search_type=scan" + let ae = AuthEnv (AccessKey "access key") (SecretKey "secret key") Nothing Nothing + let now = posixSecondsToUTCTime 0 + let Right res = amazonkaAuthHook' ae NorthVirginia req now + secure res @?= False + host res @?= "localhost" + port res @?= 9200 + path res @?= "/foo/foo/_search" + queryString res @?= "?scroll=1m&search_type=scan" + ]