{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Web.RedHatBugzilla.Internal.Network
( BugzillaServer
, BugzillaApiKey (..)
, BugzillaSession (..)
, BugzillaException (..)
, QueryPart
, Request
, requestUrl
, newBzRequest
, sendBzRequest
) where
import Blaze.ByteString.Builder (toByteString)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Exception (Exception, throw)
import Control.Monad (mzero)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (runResourceT)
import Data.Aeson
import Data.Maybe (fromMaybe)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Typeable
import Network.HTTP.Simple (defaultRequest, httpLBS, parseRequest)
import Network.HTTP.Conduit (Request(..), Response(..), host, path, port,
queryString, requestHeaders, secure)
import Network.HTTP.Types.URI (QueryText, encodePathSegments, renderQueryText)
type BugzillaServer = T.Text
newtype BugzillaApiKey = BugzillaApiKey T.Text
data BugzillaSession = AnonymousSession BugzillaServer
| ApiKeySession BugzillaServer BugzillaApiKey
bzServer :: BugzillaSession -> BugzillaServer
bzServer :: BugzillaSession -> BugzillaServer
bzServer (AnonymousSession BugzillaServer
svr) = BugzillaServer
svr
bzServer (ApiKeySession BugzillaServer
svr BugzillaApiKey
_) = BugzillaServer
svr
data BugzillaException
= BugzillaJSONParseError String
| BugzillaAPIError Int String
| BugzillaUnexpectedValue String
deriving (Int -> BugzillaException -> ShowS
[BugzillaException] -> ShowS
BugzillaException -> String
(Int -> BugzillaException -> ShowS)
-> (BugzillaException -> String)
-> ([BugzillaException] -> ShowS)
-> Show BugzillaException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BugzillaException -> ShowS
showsPrec :: Int -> BugzillaException -> ShowS
$cshow :: BugzillaException -> String
show :: BugzillaException -> String
$cshowList :: [BugzillaException] -> ShowS
showList :: [BugzillaException] -> ShowS
Show, Typeable)
instance Exception BugzillaException
type QueryPart = (T.Text, Maybe T.Text)
requestUrl :: Request -> B.ByteString
requestUrl :: Request -> ByteString
requestUrl Request
req = ByteString
"https://" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
host Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
path Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
queryString Request
req
sslRequest :: Request
sslRequest :: Request
sslRequest =
Request
defaultRequest {
secure :: Bool
secure = Bool
True,
port :: Int
port = Int
443
}
newBzRequest :: BugzillaSession -> [T.Text] -> QueryText -> Request
newBzRequest :: BugzillaSession -> [BugzillaServer] -> QueryText -> Request
newBzRequest BugzillaSession
session [BugzillaServer]
methodParts QueryText
query =
let req :: Request
req =
Request
baseRequest {
path :: ByteString
path = Builder -> ByteString
toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [BugzillaServer] -> Builder
encodePathSegments ([BugzillaServer] -> Builder) -> [BugzillaServer] -> Builder
forall a b. (a -> b) -> a -> b
$ BugzillaServer
"rest" BugzillaServer -> [BugzillaServer] -> [BugzillaServer]
forall a. a -> [a] -> [a]
: [BugzillaServer]
methodParts,
queryString :: ByteString
queryString = Builder -> ByteString
toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> QueryText -> Builder
renderQueryText Bool
True QueryText
query
}
in case BugzillaSession
session of
ApiKeySession BugzillaServer
_ (BugzillaApiKey BugzillaServer
key) ->
Request
req { requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
"Authorization",
ByteString
"Bearer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> BugzillaServer -> ByteString
TE.encodeUtf8 BugzillaServer
key)] }
BugzillaSession
_ -> Request
req
where
baseRequest :: Request
baseRequest :: Request
baseRequest = Request -> Maybe Request -> Request
forall a. a -> Maybe a -> a
fromMaybe (Request
sslRequest { host :: ByteString
host = ByteString
serverBytes }) (String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
serverStr)
serverBytes :: ByteString
serverBytes = BugzillaServer -> ByteString
TE.encodeUtf8 BugzillaServer
serverTxt
serverStr :: String
serverStr = BugzillaServer -> String
T.unpack BugzillaServer
serverTxt
serverTxt :: BugzillaServer
serverTxt = BugzillaSession -> BugzillaServer
bzServer BugzillaSession
session
data BzError = BzError Int String
deriving (BzError -> BzError -> Bool
(BzError -> BzError -> Bool)
-> (BzError -> BzError -> Bool) -> Eq BzError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BzError -> BzError -> Bool
== :: BzError -> BzError -> Bool
$c/= :: BzError -> BzError -> Bool
/= :: BzError -> BzError -> Bool
Eq, Int -> BzError -> ShowS
[BzError] -> ShowS
BzError -> String
(Int -> BzError -> ShowS)
-> (BzError -> String) -> ([BzError] -> ShowS) -> Show BzError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BzError -> ShowS
showsPrec :: Int -> BzError -> ShowS
$cshow :: BzError -> String
show :: BzError -> String
$cshowList :: [BzError] -> ShowS
showList :: [BzError] -> ShowS
Show)
instance FromJSON BzError where
parseJSON :: Value -> Parser BzError
parseJSON (Object Object
v) = Int -> String -> BzError
BzError (Int -> String -> BzError)
-> Parser Int -> Parser (String -> BzError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"code"
Parser (String -> BzError) -> Parser String -> Parser BzError
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"
parseJSON Value
_ = Parser BzError
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
handleError :: String -> BL.ByteString -> IO b
handleError :: forall b. String -> ByteString -> IO b
handleError String
parseError ByteString
body = do
let mError :: Either String BzError
mError = ByteString -> Either String BzError
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body
case Either String BzError
mError of
Left String
_ -> BugzillaException -> IO b
forall a e. Exception e => e -> a
throw (BugzillaException -> IO b) -> BugzillaException -> IO b
forall a b. (a -> b) -> a -> b
$ String -> BugzillaException
BugzillaJSONParseError String
parseError
Right (BzError Int
code String
msg) -> BugzillaException -> IO b
forall a e. Exception e => e -> a
throw (BugzillaException -> IO b) -> BugzillaException -> IO b
forall a b. (a -> b) -> a -> b
$ Int -> String -> BugzillaException
BugzillaAPIError Int
code String
msg
sendBzRequest :: FromJSON a => Request -> IO a
sendBzRequest :: forall a. FromJSON a => Request -> IO a
sendBzRequest Request
req = ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO a -> IO a) -> ResourceT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
Response ByteString
response <- IO (Response ByteString) -> ResourceT IO (Response ByteString)
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> ResourceT IO (Response ByteString))
-> IO (Response ByteString) -> ResourceT IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS Request
req
let mResult :: Either String a
mResult = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String a) -> ByteString -> Either String a
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response
case Either String a
mResult of
Left String
msg -> IO a -> ResourceT IO a
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ResourceT IO a) -> IO a -> ResourceT IO a
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO a
forall b. String -> ByteString -> IO b
handleError String
msg (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response)
Right a
decoded -> a -> ResourceT IO a
forall a. a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
decoded