Set the user-agent
This commit is contained in:
parent
b79fa52b25
commit
1e661fe3ca
@ -1,10 +1,11 @@
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Control.Monad.HTTP where
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.URL (URL (URL))
|
||||
import Control.Monad.Free.Church (F, liftF, foldF)
|
||||
import Network.HTTP.Client (Manager, httpLbs, parseRequest, responseBody)
|
||||
import Network.HTTP.Client (Manager, httpLbs, parseRequest, responseBody, Request (requestHeaders))
|
||||
import System.IO.Unsafe (unsafeInterleaveIO)
|
||||
|
||||
data OpsF f = Fetch URL (ByteString -> f)
|
||||
@ -28,10 +29,13 @@ fetch u = liftF (Fetch u id)
|
||||
--
|
||||
-- The requests are executed lazily, both as an atomic request and as
|
||||
-- a lazy bytestring. Be careful.
|
||||
--
|
||||
-- A custom user-agent is set for each request
|
||||
execute :: Manager -> FetchM a -> IO a
|
||||
execute manager = foldF $ \case
|
||||
Fetch (URL u) k -> k <$> unsafeInterleaveIO (fetchR u)
|
||||
where
|
||||
ua = ("User-Agent", "FeedMonad")
|
||||
fetchR u = do
|
||||
req <- parseRequest u
|
||||
responseBody <$> httpLbs req manager
|
||||
responseBody <$> httpLbs req{requestHeaders=[ua]} manager
|
||||
|
Loading…
Reference in New Issue
Block a user