MasseR
/
FeedMonad
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Set the user-agent

This commit is contained in:
Mats Rauhala 2021-11-11 22:37:18 +02:00
parent b79fa52b25
commit 1e661fe3ca
1 changed files with 6 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
FeedMonad/src/Control/Monad/HTTP.hs
View File

@ -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