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