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)