{-# 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
$cshowsPrec :: Int -> OurHttpException -> ShowS
showsPrec :: Int -> OurHttpException -> ShowS
$cshow :: OurHttpException -> String
show :: OurHttpException -> String
$cshowList :: [OurHttpException] -> ShowS
showList :: [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 a. a -> IO a
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 {a}. Response a -> Request -> IO ()
checkResponseStatus Response ByteString
res Request
req
ByteString -> IO ByteString
forall a. a -> IO a
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 a -> Request -> IO ()
checkResponseStatus Response a
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 a -> Status
forall body. Response body -> Status
H.responseStatus Response a
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 (() -> a -> ()
forall a b. a -> b -> a
const () (a -> ()) -> Response a -> Response ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response a
res)
else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
rethrower :: H.HttpException -> IO a
rethrower :: forall a. 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
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