{-# 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

-- | A session for Bugzilla queries. Use 'anonymousSession' and
-- 'loginSession', as appropriate, to create one.
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
showList :: [BugzillaException] -> ShowS
$cshowList :: [BugzillaException] -> ShowS
show :: BugzillaException -> String
$cshow :: BugzillaException -> String
showsPrec :: Int -> BugzillaException -> ShowS
$cshowsPrec :: Int -> 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
    -- Try to parse the bzServer first, if it has a scheme then use it as the base request,
    -- otherwise force a secure ssl request.
    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
/= :: BzError -> BzError -> Bool
$c/= :: BzError -> BzError -> Bool
== :: BzError -> BzError -> Bool
$c== :: 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
showList :: [BzError] -> ShowS
$cshowList :: [BzError] -> ShowS
show :: BzError -> String
$cshow :: BzError -> String
showsPrec :: Int -> BzError -> ShowS
$cshowsPrec :: Int -> 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 -> BugzillaServer -> Parser Int
forall a. FromJSON a => Object -> BugzillaServer -> Parser a
.: BugzillaServer
"code"
                                 Parser (String -> BzError) -> Parser String -> Parser BzError
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> BugzillaServer -> Parser String
forall a. FromJSON a => Object -> BugzillaServer -> Parser a
.: BugzillaServer
"message"
  parseJSON Value
_          = Parser BzError
forall (m :: * -> *) a. MonadPlus m => m a
mzero

handleError :: String -> BL.ByteString -> IO b
handleError :: 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 :: 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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return a
decoded