{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}

module Web.Bugzilla.Internal.Network
( BugzillaServer
, BugzillaContext (..)
, BugzillaToken (..)
, 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 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.Conduit (Manager, Request(..), Response(..), defaultRequest, host, httpLbs, path, queryString, secure)
import Network.HTTP.Types.URI (QueryText, encodePathSegments, renderQueryText)

type BugzillaServer  = T.Text

-- | Holds information about a 'BugzillaServer' and manages outgoing
-- connections. You can use 'newBugzillaContext' or
-- 'withBugzillaContext' to create one.
data BugzillaContext = BugzillaContext
  { BugzillaContext -> BugzillaServer
bzServer  :: BugzillaServer
  , BugzillaContext -> Manager
bzManager :: Manager
  }

newtype BugzillaToken = BugzillaToken T.Text

instance FromJSON BugzillaToken where
  parseJSON :: Value -> Parser BugzillaToken
parseJSON (Object v :: Object
v) = BugzillaServer -> BugzillaToken
BugzillaToken (BugzillaServer -> BugzillaToken)
-> Parser BugzillaServer -> Parser BugzillaToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> BugzillaServer -> Parser BugzillaServer
forall a. FromJSON a => Object -> BugzillaServer -> Parser a
.: "token"
  parseJSON _          = Parser BugzillaToken
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | A session for Bugzilla queries. Use 'anonymousSession' and
-- 'loginSession', as appropriate, to create one.
data BugzillaSession = AnonymousSession BugzillaContext
                     | LoginSession BugzillaContext BugzillaToken

bzContext :: BugzillaSession -> BugzillaContext
bzContext :: BugzillaSession -> BugzillaContext
bzContext (AnonymousSession ctx :: BugzillaContext
ctx) = BugzillaContext
ctx
bzContext (LoginSession ctx :: BugzillaContext
ctx _)   = BugzillaContext
ctx

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 req :: Request
req = "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   = 443
  }

newBzRequest :: BugzillaSession -> [T.Text] -> QueryText -> Request
newBzRequest :: BugzillaSession -> [BugzillaServer] -> QueryText -> Request
newBzRequest session :: BugzillaSession
session methodParts :: [BugzillaServer]
methodParts query :: QueryText
query =
    Request
sslRequest {
      host :: ByteString
host        = BugzillaServer -> ByteString
TE.encodeUtf8 (BugzillaServer -> ByteString)
-> (BugzillaSession -> BugzillaServer)
-> BugzillaSession
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BugzillaContext -> BugzillaServer
bzServer (BugzillaContext -> BugzillaServer)
-> (BugzillaSession -> BugzillaContext)
-> BugzillaSession
-> BugzillaServer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BugzillaSession -> BugzillaContext
bzContext (BugzillaSession -> ByteString) -> BugzillaSession -> ByteString
forall a b. (a -> b) -> a -> b
$ BugzillaSession
session,
      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
$ "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
queryWithToken
    }
  where
    queryWithToken :: QueryText
queryWithToken = case BugzillaSession
session of
                       AnonymousSession _                   -> QueryText
query
                       LoginSession _ (BugzillaToken token :: BugzillaServer
token) -> ("token", BugzillaServer -> Maybe BugzillaServer
forall a. a -> Maybe a
Just BugzillaServer
token) (BugzillaServer, Maybe BugzillaServer) -> QueryText -> QueryText
forall a. a -> [a] -> [a]
: QueryText
query

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 v :: 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
.: "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
.: "message"
  parseJSON _          = Parser BzError
forall (m :: * -> *) a. MonadPlus m => m a
mzero

handleError :: String -> BL.ByteString -> IO b
handleError :: String -> ByteString -> IO b
handleError parseError :: String
parseError body :: 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 _                   -> 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 code :: Int
code msg :: 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 => BugzillaSession -> Request -> IO a
sendBzRequest :: BugzillaSession -> Request -> IO a
sendBzRequest session :: BugzillaSession
session req :: 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 -> Manager -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req (Manager -> IO (Response ByteString))
-> (BugzillaSession -> Manager)
-> BugzillaSession
-> IO (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BugzillaContext -> Manager
bzManager (BugzillaContext -> Manager)
-> (BugzillaSession -> BugzillaContext)
-> BugzillaSession
-> Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BugzillaSession -> BugzillaContext
bzContext (BugzillaSession -> IO (Response ByteString))
-> BugzillaSession -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ BugzillaSession
session
  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 msg :: 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 decoded :: a
decoded -> a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
decoded