1 {-# LANGUAGE MultiWayIf, OverloadedStrings, TupleSections #-} 2 module Databrary.HTTP.Client 3 ( HTTPClient 4 , initHTTPClient 5 , checkContentOk 6 , CookiesT 7 , runCookiesT 8 , withCookies 9 , withResponseCookies 10 , requestAcceptContent 11 , httpParse 12 , httpMaybe 13 , httpRequestJSON 14 ) where 15 16 import Control.Arrow ((&&&)) 17 import Control.Exception.Lifted (handle) 18 import Control.Monad.IO.Class (MonadIO) 19 import Control.Monad.Trans.Control (MonadBaseControl) 20 import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) 21 import Data.Function (on) 22 import Data.Monoid ((<>)) 23 import Network.HTTP.Client.TLS (tlsManagerSettings) 24 import Network.HTTP.Types (hAccept, hContentType, statusIsSuccessful) 25 import qualified Data.Aeson as JSON 26 import qualified Data.Attoparsec.ByteString as P 27 import qualified Data.ByteString as BS 28 import qualified Data.ByteString.Char8 as BSC 29 import qualified Network.HTTP.Client as HC 30 31 import Databrary.Has 32 33 type HTTPClient = HC.Manager 34 35 initHTTPClient :: IO HTTPClient 36 initHTTPClient = HC.newManager tlsManagerSettings 37 { HC.managerConnCount = 4 38 , HC.managerIdleConnectionCount = 8 39 } 40 41 type CookiesT m a = StateT HC.CookieJar m a 42 43 runCookiesT :: Monad m => CookiesT m a -> m a 44 runCookiesT f = evalStateT f mempty 45 46 withCookies :: (MonadIO m, MonadHas HTTPClient c m) => (HC.Request -> HC.Manager -> IO (HC.Response a)) -> HC.Request -> CookiesT m (HC.Response a) 47 withCookies f r = StateT $ \c -> focusIO $ \m -> 48 (id &&& HC.responseCookieJar) <$> f r{ HC.cookieJar = HC.cookieJar r <> Just c } m 49 50 withResponseCookies :: (MonadIO m, MonadHas HTTPClient c m) => HC.Request -> (HC.Response HC.BodyReader -> IO a) -> CookiesT m a 51 withResponseCookies q f = StateT $ \c -> focusIO $ \m -> 52 HC.withResponse q{ HC.cookieJar = HC.cookieJar q <> Just c } m $ \r -> (, HC.responseCookieJar r) <$> f r 53 54 contentTypeEq :: BS.ByteString -> BS.ByteString -> Bool 55 contentTypeEq = (==) `on` f where 56 f s 57 | Just i <- BSC.elemIndex ';' s = BS.take i s 58 | otherwise = s 59 60 checkContentOk :: BS.ByteString -> HC.Request -> HC.Response HC.BodyReader -> IO () 61 checkContentOk ct _ rsp = do 62 if | not $ statusIsSuccessful $ HC.responseStatus rsp -> fail "checkContentOk: status unsuccessful" 63 | not $ any (contentTypeEq ct) ht -> fail "checkContentOk: bad content type" 64 | otherwise -> return () 65 where ht = lookup hContentType $ HC.responseHeaders rsp 66 67 requestAcceptContent :: BS.ByteString -> HC.Request -> HC.Request 68 requestAcceptContent ct req = req 69 { HC.requestHeaders = (hAccept, ct) : HC.requestHeaders req 70 , HC.checkResponse = checkContentOk ct 71 } 72 73 httpParse :: P.Parser a -> HC.Response HC.BodyReader -> IO (P.Result a) 74 httpParse p r = P.parseWith (HC.responseBody r) p BS.empty 75 76 httpMaybe :: MonadBaseControl IO m => m (Maybe a) -> m (Maybe a) 77 httpMaybe = handle (return . fail . (show :: HC.HttpException -> String)) 78 79 httpRequestJSON :: HC.Request -> HTTPClient -> IO (Maybe JSON.Value) 80 httpRequestJSON r m = httpMaybe $ 81 HC.withResponse (requestAcceptContent "application/json" r) m (fmap P.maybeResult . httpParse JSON.json)