-- |
-- Module: Staversion.Internal.HTTP
-- Description: compatibility wrapper for http-client 
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- Every module in this package should use this module instead of
-- "Network.HTTP.Client".
--
-- __This is an internal module. End-users should not use it.__
{-# LANGUAGE CPP, DeriveDataTypeable #-}
module Staversion.Internal.HTTP
       ( Manager,
         OurHttpException,
         niceHTTPManager,
         fetchURL,
         asStatusFailureException
       ) where

import Control.Applicative ((<$>))
import Control.Exception (throwIO, Exception, SomeException, catch)
import Data.Typeable (Typeable)
import qualified Data.ByteString.Lazy as BSL
import qualified Network.HTTP.Client as H
import Network.HTTP.Client (Manager, HttpException)
import Network.HTTP.Types (statusIsSuccessful)
import Network.HTTP.Client.TLS (tlsManagerSettings)

data OurHttpException = ParseUrlException String SomeException
                      | StatusFailureException H.Request (H.Response ())
                      | OtherHttpException H.HttpException
                      deriving (Int -> OurHttpException -> ShowS
[OurHttpException] -> ShowS
OurHttpException -> String
(Int -> OurHttpException -> ShowS)
-> (OurHttpException -> String)
-> ([OurHttpException] -> ShowS)
-> Show OurHttpException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OurHttpException] -> ShowS
$cshowList :: [OurHttpException] -> ShowS
show :: OurHttpException -> String
$cshow :: OurHttpException -> String
showsPrec :: Int -> OurHttpException -> ShowS
$cshowsPrec :: Int -> OurHttpException -> ShowS
Show,Typeable)

instance Exception OurHttpException

niceHTTPManager :: IO Manager
niceHTTPManager :: IO Manager
niceHTTPManager = ManagerSettings -> IO Manager
H.newManager (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
H.managerSetProxy (Maybe Proxy -> ProxyOverride
H.proxyEnvironment Maybe Proxy
forall a. Maybe a
Nothing) (ManagerSettings -> ManagerSettings)
-> ManagerSettings -> ManagerSettings
forall a b. (a -> b) -> a -> b
$ ManagerSettings
tlsManagerSettings

makeRequest :: String -> Either SomeException H.Request
#if MIN_VERSION_http_client(0,4,30)
makeRequest :: String -> Either SomeException Request
makeRequest = String -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => String -> m Request
H.parseRequest
#else
makeRequest = fmap unCheck . H.parseUrl where
  unCheck req = req { H.checkStatus = \_ _ _ -> Nothing }
#endif

fetchURL :: Manager -> String -> IO BSL.ByteString
fetchURL :: Manager -> String -> IO ByteString
fetchURL Manager
man String
url = IO ByteString
doFetch IO ByteString -> (HttpException -> IO ByteString) -> IO ByteString
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` HttpException -> IO ByteString
forall a. HttpException -> IO a
rethrower where
  doFetch :: IO ByteString
doFetch = do
    Request
req <- (SomeException -> IO Request)
-> (Request -> IO Request)
-> Either SomeException Request
-> IO Request
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\SomeException
err -> OurHttpException -> IO Request
forall e a. Exception e => e -> IO a
throwIO (OurHttpException -> IO Request) -> OurHttpException -> IO Request
forall a b. (a -> b) -> a -> b
$ String -> SomeException -> OurHttpException
ParseUrlException String
url SomeException
err) Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Request -> IO Request)
-> Either SomeException Request -> IO Request
forall a b. (a -> b) -> a -> b
$ String -> Either SomeException Request
makeRequest String
url
    Response ByteString
res <- Request -> Manager -> IO (Response ByteString)
H.httpLbs Request
req Manager
man
    Response ByteString -> Request -> IO ()
forall b. Response b -> Request -> IO ()
checkResponseStatus Response ByteString
res Request
req
    ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
H.responseBody Response ByteString
res
  checkResponseStatus :: Response b -> Request -> IO ()
checkResponseStatus Response b
res Request
req =
    if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Status -> Bool
statusIsSuccessful (Status -> Bool) -> Status -> Bool
forall a b. (a -> b) -> a -> b
$ Response b -> Status
forall body. Response body -> Status
H.responseStatus Response b
res
    then OurHttpException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (OurHttpException -> IO ()) -> OurHttpException -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> Response () -> OurHttpException
StatusFailureException Request
req (() -> b -> ()
forall a b. a -> b -> a
const () (b -> ()) -> Response b -> Response ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response b
res)
    else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  rethrower :: H.HttpException -> IO a
  rethrower :: HttpException -> IO a
rethrower HttpException
e = OurHttpException -> IO a
forall e a. Exception e => e -> IO a
throwIO (OurHttpException -> IO a) -> OurHttpException -> IO a
forall a b. (a -> b) -> a -> b
$ HttpException -> OurHttpException
OtherHttpException HttpException
e

asStatusFailureException :: OurHttpException
                         -> Maybe Int -- ^ HTTP status code
asStatusFailureException :: OurHttpException -> Maybe Int
asStatusFailureException (StatusFailureException Request
_ Response ()
res) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
code
  where
    code :: Int
code = Status -> Int
forall a. Enum a => a -> Int
fromEnum (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
H.responseStatus Response ()
res
asStatusFailureException OurHttpException
_ = Maybe Int
forall a. Maybe a
Nothing