diff --git a/alerta.cabal b/alerta.cabal --- a/alerta.cabal +++ b/alerta.cabal @@ -1,5 +1,5 @@ name: alerta -version: 0.1.0.5 +version: 0.1.0.6 synopsis: Bindings to the alerta REST API homepage: https://github.com/mjhopkins/alerta-client bug-reports: https://github.com/mjhopkins/alerta-client/issues @@ -22,6 +22,11 @@ . Built with . +flag servant-client-core + description: Use servant-client-core + default: True + manual: False + library hs-source-dirs: src exposed-modules: Alerta @@ -30,18 +35,27 @@ , Alerta.ServantExtras , Alerta.Types , Alerta.Util - build-depends: aeson >= 1.1 && < 1.3 - , aeson-pretty >= 0.8 && < 0.9 - , base >= 4.7 && < 5 - , containers >= 0.5 && < 0.6 - , data-default >= 0.7 && < 0.8 - , http-api-data >= 0.3 && < 0.4 - , http-client >= 0.5 && < 0.6 - , servant >= 0.10 && < 0.13 - , servant-client >= 0.10 && < 0.13 - , servant-server >= 0.10 && < 0.13 - , text >= 1.2.2 && < 1.3 - , time >= 1.6 && < 1.9 + build-depends: aeson >= 1.0.2.1 && < 1.3 + , aeson-pretty >= 0.8 && < 0.9 + , base >= 4.7 && < 5 + , containers >= 0.5 && < 0.6 + , data-default >= 0.7 && < 0.8 + , http-api-data >= 0.3 && < 0.4 + , http-client >= 0.5 && < 0.6 + , servant >= 0.10 && < 0.13 + , servant-client >= 0.10 && < 0.13 + , servant-server >= 0.10 && < 0.13 + , text >= 1.2.2 && < 1.3 + , time >= 1.6 && < 1.9 + + if flag(servant-client-core) + cpp-options: -DHAS_CLIENT_CORE=1 + build-depends: + servant-client-core >= 0.12 && < 0.13 + else + build-depends: + servant-client >= 0.10 && < 0.12 + ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Alerta/Auth.hs b/src/Alerta/Auth.hs --- a/src/Alerta/Auth.hs +++ b/src/Alerta/Auth.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -------------------------------------------------------------------------------- -- | @@ -17,34 +19,61 @@ , NeedApiKey ) where -import Alerta.Types (ApiKey (..)) +import Alerta.Types (ApiKey (..)) -import Data.Monoid ((<>)) -import Data.Proxy -import Data.Typeable (Typeable) -import Servant.API ((:>)) +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import Servant.API ((:>)) + +-- #if MIN_VERSION_servant_client(0,12,0) +#ifdef HAS_CLIENT_CORE +import Servant.Client.Core (AuthClientData, HasClient (..), Request, + addHeader) +#define REQ Request +#else import Servant.Client -import Servant.Common.Req (Req, addHeader) +import Servant.Common.Req (Req, addHeader) +#define REQ Req +#endif data NeedApiKey deriving Typeable data WithApiKey deriving Typeable -- | Authenticate a request using an API key -addApiKey :: ApiKey -> Req -> Req +addApiKey :: ApiKey -> REQ -> REQ addApiKey (ApiKey key) = addHeader "Authorization" ("Key " <> key) type instance AuthClientData NeedApiKey = ApiKey +-- #ifdef HAS_CLIENT_CORE +#if !MIN_VERSION_servant_client(0,12,0) instance HasClient api => HasClient (NeedApiKey :> api) where type Client (NeedApiKey :> api) = ApiKey -> Client api clientWithRoute _ req k = clientWithRoute (Proxy :: Proxy api) (addApiKey k req) +#else +instance HasClient m api => HasClient m (NeedApiKey :> api) where + type Client m (NeedApiKey :> api) = ApiKey -> Client m api + clientWithRoute m _ req k = + clientWithRoute m (Proxy :: Proxy api) (addApiKey k req) +#endif + type instance AuthClientData WithApiKey = Maybe ApiKey +-- #ifdef HAS_CLIENT_CORE +#if !MIN_VERSION_servant_client(0,12,0) instance HasClient api => HasClient (WithApiKey :> api) where type Client (WithApiKey :> api) = Maybe ApiKey -> Client api clientWithRoute _ req m = clientWithRoute (Proxy :: Proxy api) (maybe id addApiKey m req) +#else +instance HasClient m api => HasClient m (WithApiKey :> api) where + type Client m (WithApiKey :> api) = Maybe ApiKey -> Client m api + + clientWithRoute m _ req mk = + clientWithRoute m (Proxy :: Proxy api) (maybe id addApiKey mk req) +#endif diff --git a/src/Alerta/Helpers.hs b/src/Alerta/Helpers.hs --- a/src/Alerta/Helpers.hs +++ b/src/Alerta/Helpers.hs @@ -34,7 +34,7 @@ run :: (Show a, FromJSON a, ToJSON a) => ClientM a -> IO a run cl = do manager <- newManager defaultManagerSettings - res <- runClientM cl (clientEnv manager) + res <- runClientM cl (clientEnv manager) either handleError (\r -> prettyPrint r >> putStrLn "Success" >> return r) res -- | Run a Servant client function, pretty-printing the JSON returned, and @@ -43,14 +43,31 @@ run' = void . run handleError :: (FromJSON a, ToJSON a) => ServantError -> IO a -#if MIN_VERSION_servant_client(0,11,0) -handleError (FailureResponse _ status _ b) = either fail (\r -> putStrLn ("Failure response (status " ++ show status ++ ")") >> prettyPrint r >> return r) (eitherDecode b) -#else +-- really, these should all be servant_client. But CPP. +#if !MIN_VERSION_servant(0,11,0) handleError (FailureResponse status _ b) = either fail (\r -> putStrLn ("Failure response (status " ++ show status ++ ")") >> prettyPrint r >> return r) (eitherDecode b) +handleError (DecodeFailure e _ b) = fail ("decode failure\n\n" ++ e ++ "\n\n" ++ showUnescaped b) +handleError (InvalidContentTypeHeader h b) = fail ("unsupported content type type\n\n" ++ show h ++ "\n" ++ show b) #endif +#if MIN_VERSION_servant(0,11,0) && !MIN_VERSION_servant(0,12,0) +handleError (FailureResponse _ status _ b) = either fail (\r -> putStrLn ("Failure response (status " ++ show status ++ ")") >> prettyPrint r >> return r) (eitherDecode b) handleError (DecodeFailure e _ b) = fail ("decode failure\n\n" ++ e ++ "\n\n" ++ showUnescaped b) -handleError (UnsupportedContentType ct b) = fail ("unsupported content type\n\n" ++ show ct ++ "\n" ++ show b) handleError (InvalidContentTypeHeader h b) = fail ("unsupported content type type\n\n" ++ show h ++ "\n" ++ show b) +#endif +#if MIN_VERSION_servant(0,12,0) +handleError (FailureResponse r) = either fail (\r -> putStrLn ("Failure response (status " ++ show status ++ ")") >> prettyPrint r >> return r) (eitherDecode b) + where + status = responseStatusCode r + b = responseBody r +handleError (DecodeFailure e r) = fail ("decode failure\n\n" ++ T.unpack e ++ "\n\n" ++ showUnescaped b) + where + b = responseBody r +handleError (InvalidContentTypeHeader r) = fail ("unsupported content type type\n\n" ++ show h ++ "\n" ++ show b) + where + h = responseHeaders r + b = responseBody r +#endif +handleError (UnsupportedContentType ct b) = fail ("unsupported content type\n\n" ++ show ct ++ "\n" ++ show b) handleError (ConnectionError e) = fail ("connection error\n\n" ++ show e) showUnescaped :: Show a => a -> String @@ -62,10 +79,10 @@ replace :: [(String, String)] -> String -> String replace assocs s = T.unpack $ foldr replace' (T.pack s) assocs' where - assocs' :: [(Text, Text)] - assocs' = map (bimap T.pack T.pack) assocs - replace' :: (Text, Text) -> Text -> Text - replace' (a,b) = T.replace a b + assocs' :: [(Text, Text)] + assocs' = map (bimap T.pack T.pack) assocs + replace' :: (Text, Text) -> Text -> Text + replace' (a,b) = T.replace a b -- | Pretty-print the JSON encoding of the supplied value. prettyPrintEncoding :: ToJSON a => a -> IO () diff --git a/src/Alerta/ServantExtras.hs b/src/Alerta/ServantExtras.hs --- a/src/Alerta/ServantExtras.hs +++ b/src/Alerta/ServantExtras.hs @@ -1,10 +1,12 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -------------------------------------------------------------------------------- -- Module: Alerta.ServantExtras @@ -16,16 +18,22 @@ ( FieldQueries ) where -import Alerta.Types (FieldQuery, MatchType(..)) +import Alerta.Types (FieldQuery, MatchType (..)) import Data.List -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) import Data.Proxy -import qualified Data.Text as T - -import Servant.Common.Req (Req, appendToQueryString) +import qualified Data.Text as T +import Servant.API ((:>)) +#if MIN_VERSION_servant_client(0,12,0) +import Servant.Client.Core (HasClient (..), Request, + appendToQueryString) +#define REQ Request +#else import Servant.Client -import Servant.API ((:>)) +import Servant.Common.Req (Req, appendToQueryString) +#define REQ Req +#endif import Web.HttpApiData -- | We need this because Alerta for some reason requires `field` and `field!` @@ -36,17 +44,27 @@ data FieldQueries +#if !MIN_VERSION_servant_client(0,12,0) instance HasClient api => HasClient (FieldQueries :> api) where type Client (FieldQueries :> api) = [FieldQuery] -> Client api clientWithRoute Proxy req fqs = - clientWithRoute (Proxy :: Proxy api) $ foldl' (flip f) req fqs where + clientWithRoute (Proxy :: Proxy api) $ foldl' (flip applyFQ) req fqs - f :: FieldQuery -> Req -> Req - f (attr, txt, t, b) = appendToQueryString k (Just v) where - k = toUrlPiece attr <> suffix - v = prefix <> txt - suffix = if b then "" else "!" - prefix = case t of - Regex -> "~" - Literal -> "" +#else +instance HasClient m api => HasClient m (FieldQueries :> api) where + type Client m (FieldQueries :> api) = [FieldQuery] -> Client m api + + clientWithRoute m Proxy req fqs = + clientWithRoute m (Proxy :: Proxy api) $ foldl' (flip applyFQ) req fqs + +#endif + +applyFQ :: FieldQuery -> REQ -> REQ +applyFQ (attr, txt, t, b) = appendToQueryString k (Just v) where + k = toUrlPiece attr <> suffix + v = prefix <> txt + suffix = if b then "" else "!" + prefix = case t of + Regex -> "~" + Literal -> ""