diff --git a/FeedMonad/src/Control/Monad/HTTP.hs b/FeedMonad/src/Control/Monad/HTTP.hs index a885b44..e7dca3f 100644 --- a/FeedMonad/src/Control/Monad/HTTP.hs +++ b/FeedMonad/src/Control/Monad/HTTP.hs @@ -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