-- | Implementation of 'HttpClient' using the HTTP package
module Hackage.Security.Client.Repository.HttpLib.HTTP (
    withClient
    -- ** Additional operations
  , setOutHandler
  , setErrHandler
  , setProxy
  , request
    -- ** Low-level API
  , Browser -- opaque
  , withBrowser
    -- * Exception types
  , UnexpectedResponse(..)
  , InvalidProxy(..)
  ) where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.List (intercalate)
import Data.Typeable (Typeable)
import Network.URI
import qualified Data.ByteString.Lazy as BS.L
import qualified Control.Monad.State  as State
import qualified Network.Browser      as HTTP
import qualified Network.HTTP         as HTTP
import qualified Network.HTTP.Proxy   as HTTP

import Hackage.Security.Client
import Hackage.Security.Client.Repository.HttpLib
import Hackage.Security.Util.Checked
import Hackage.Security.Util.Pretty

{-------------------------------------------------------------------------------
  Top-level API
-------------------------------------------------------------------------------}

-- | Initialize the client
--
-- TODO: This currently uses the lazy bytestring API offered by the HTTP
-- library. Unfortunately this provides no way of closing the connection when
-- the callback decides it doesn't require any further input. It seems
-- impossible however to implement a proper streaming API.
-- See <https://github.com/haskell/HTTP/issues/86>.
withClient :: (Browser -> HttpLib -> IO a) -> IO a
withClient :: forall a. (Browser -> HttpLib -> IO a) -> IO a
withClient Browser -> HttpLib -> IO a
callback =
    IO Browser -> (Browser -> IO ()) -> (Browser -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Browser
browserInit Browser -> IO ()
browserCleanup ((Browser -> IO a) -> IO a) -> (Browser -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Browser
browser ->
      Browser -> HttpLib -> IO a
callback Browser
browser HttpLib {
          httpGet :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
httpGet      = Browser
-> [HttpRequestHeader]
-> URI
-> ([HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
forall a.
Throws SomeRemoteError =>
Browser
-> [HttpRequestHeader]
-> URI
-> ([HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
get      Browser
browser
        , httpGetRange :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
httpGetRange = Browser
-> [HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
forall a.
Throws SomeRemoteError =>
Browser
-> [HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
getRange Browser
browser
        }

{-------------------------------------------------------------------------------
  Individual methods
-------------------------------------------------------------------------------}

get :: Throws SomeRemoteError
    => Browser
    -> [HttpRequestHeader] -> URI
    -> ([HttpResponseHeader] -> BodyReader -> IO a)
    -> IO a
get :: forall a.
Throws SomeRemoteError =>
Browser
-> [HttpRequestHeader]
-> URI
-> ([HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
get Browser
browser [HttpRequestHeader]
reqHeaders URI
uri [HttpResponseHeader] -> BodyReader -> IO a
callback = ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
forall a.
((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
wrapCustomEx (((Throws UnexpectedResponse, Throws IOException) => IO a)
 -> Throws SomeRemoteError => IO a)
-> ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
forall a b. (a -> b) -> a -> b
$ do
    Response ByteString
response <- Throws IOException =>
Browser -> Request ByteString -> IO (Response ByteString)
Browser -> Request ByteString -> IO (Response ByteString)
request Browser
browser
      (Request ByteString -> IO (Response ByteString))
-> Request ByteString -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ [HttpRequestHeader] -> Request ByteString -> Request ByteString
forall a. HasHeaders a => [HttpRequestHeader] -> a -> a
addRequestHeaders [HttpRequestHeader]
reqHeaders
      -- avoid silly `Content-Length: 0` header inserted by `mkRequest`
      (Request ByteString -> Request ByteString)
-> Request ByteString -> Request ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> Request ByteString -> Request ByteString
forall a. HasHeaders a => HeaderName -> a -> a
removeHeader HeaderName
HTTP.HdrContentLength
      (Request ByteString -> Request ByteString)
-> Request ByteString -> Request ByteString
forall a b. (a -> b) -> a -> b
$ RequestMethod -> URI -> Request ByteString
forall ty. BufferType ty => RequestMethod -> URI -> Request ty
HTTP.mkRequest RequestMethod
HTTP.GET URI
uri
    case Response ByteString -> ResponseCode
forall a. Response a -> ResponseCode
HTTP.rspCode Response ByteString
response of
      (Int
2, Int
0, Int
0) -> Response ByteString
-> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
forall a.
Throws SomeRemoteError =>
Response ByteString
-> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
withResponse Response ByteString
response [HttpResponseHeader] -> BodyReader -> IO a
callback
      ResponseCode
otherCode -> UnexpectedResponse -> IO a
forall e a. (Exception e, Throws e) => e -> IO a
throwChecked (UnexpectedResponse -> IO a) -> UnexpectedResponse -> IO a
forall a b. (a -> b) -> a -> b
$ URI -> ResponseCode -> UnexpectedResponse
UnexpectedResponse URI
uri ResponseCode
otherCode

getRange :: Throws SomeRemoteError
         => Browser
         -> [HttpRequestHeader] -> URI -> (Int, Int)
         -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
         -> IO a
getRange :: forall a.
Throws SomeRemoteError =>
Browser
-> [HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
getRange Browser
browser [HttpRequestHeader]
reqHeaders URI
uri (Int
from, Int
to) HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback = ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
forall a.
((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
wrapCustomEx (((Throws UnexpectedResponse, Throws IOException) => IO a)
 -> Throws SomeRemoteError => IO a)
-> ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
forall a b. (a -> b) -> a -> b
$ do
    Response ByteString
response <- Throws IOException =>
Browser -> Request ByteString -> IO (Response ByteString)
Browser -> Request ByteString -> IO (Response ByteString)
request Browser
browser
      (Request ByteString -> IO (Response ByteString))
-> Request ByteString -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Request ByteString -> Request ByteString
forall a. HasHeaders a => Int -> Int -> a -> a
setRange Int
from Int
to
      (Request ByteString -> Request ByteString)
-> Request ByteString -> Request ByteString
forall a b. (a -> b) -> a -> b
$ [HttpRequestHeader] -> Request ByteString -> Request ByteString
forall a. HasHeaders a => [HttpRequestHeader] -> a -> a
addRequestHeaders [HttpRequestHeader]
reqHeaders
      -- avoid silly `Content-Length: 0` header inserted by `mkRequest`
      (Request ByteString -> Request ByteString)
-> Request ByteString -> Request ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> Request ByteString -> Request ByteString
forall a. HasHeaders a => HeaderName -> a -> a
removeHeader HeaderName
HTTP.HdrContentLength
      (Request ByteString -> Request ByteString)
-> Request ByteString -> Request ByteString
forall a b. (a -> b) -> a -> b
$ RequestMethod -> URI -> Request ByteString
forall ty. BufferType ty => RequestMethod -> URI -> Request ty
HTTP.mkRequest RequestMethod
HTTP.GET URI
uri
    case Response ByteString -> ResponseCode
forall a. Response a -> ResponseCode
HTTP.rspCode Response ByteString
response of
      (Int
2, Int
0, Int
0) -> Response ByteString
-> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
forall a.
Throws SomeRemoteError =>
Response ByteString
-> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
withResponse Response ByteString
response (([HttpResponseHeader] -> BodyReader -> IO a) -> IO a)
-> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback HttpStatus
HttpStatus200OK
      (Int
2, Int
0, Int
6) -> Response ByteString
-> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
forall a.
Throws SomeRemoteError =>
Response ByteString
-> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
withResponse Response ByteString
response (([HttpResponseHeader] -> BodyReader -> IO a) -> IO a)
-> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback HttpStatus
HttpStatus206PartialContent
      ResponseCode
otherCode -> UnexpectedResponse -> IO a
forall e a. (Exception e, Throws e) => e -> IO a
throwChecked (UnexpectedResponse -> IO a) -> UnexpectedResponse -> IO a
forall a b. (a -> b) -> a -> b
$ URI -> ResponseCode -> UnexpectedResponse
UnexpectedResponse URI
uri ResponseCode
otherCode

removeHeader :: HTTP.HasHeaders a => HTTP.HeaderName -> a -> a
removeHeader :: forall a. HasHeaders a => HeaderName -> a -> a
removeHeader HeaderName
name a
h = a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
HTTP.setHeaders a
h [Header]
newHeaders
  where
    newHeaders :: [Header]
newHeaders = [ Header
x | x :: Header
x@(HTTP.Header HeaderName
n String
_) <- a -> [Header]
forall x. HasHeaders x => x -> [Header]
HTTP.getHeaders a
h, HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
n ]

{-------------------------------------------------------------------------------
  Auxiliary methods used to implement the HttpClient interface
-------------------------------------------------------------------------------}

withResponse :: Throws SomeRemoteError
             => HTTP.Response BS.L.ByteString
             -> ([HttpResponseHeader] -> BodyReader -> IO a)
             -> IO a
withResponse :: forall a.
Throws SomeRemoteError =>
Response ByteString
-> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
withResponse Response ByteString
response [HttpResponseHeader] -> BodyReader -> IO a
callback = ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
forall a.
((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
wrapCustomEx (((Throws UnexpectedResponse, Throws IOException) => IO a)
 -> Throws SomeRemoteError => IO a)
-> ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
forall a b. (a -> b) -> a -> b
$ do
    BodyReader
br <- ByteString -> IO BodyReader
bodyReaderFromBS (ByteString -> IO BodyReader) -> ByteString -> IO BodyReader
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall a. Response a -> a
HTTP.rspBody Response ByteString
response
    [HttpResponseHeader] -> BodyReader -> IO a
callback [HttpResponseHeader]
responseHeaders (BodyReader -> IO a) -> BodyReader -> IO a
forall a b. (a -> b) -> a -> b
$ ((Throws UnexpectedResponse, Throws IOException) => BodyReader)
-> Throws SomeRemoteError => BodyReader
forall a.
((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
wrapCustomEx BodyReader
(Throws UnexpectedResponse, Throws IOException) => BodyReader
br
  where
    responseHeaders :: [HttpResponseHeader]
responseHeaders = Response ByteString -> [HttpResponseHeader]
forall a. Response a -> [HttpResponseHeader]
getResponseHeaders Response ByteString
response

{-------------------------------------------------------------------------------
  Custom exception types
-------------------------------------------------------------------------------}

wrapCustomEx :: ( ( Throws UnexpectedResponse
                  , Throws IOException
                  ) => IO a)
             -> (Throws SomeRemoteError => IO a)
wrapCustomEx :: forall a.
((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
wrapCustomEx (Throws UnexpectedResponse, Throws IOException) => IO a
act = (UnexpectedResponse -> IO a)
-> (Throws UnexpectedResponse => IO a) -> IO a
forall e a.
Exception e =>
(e -> IO a) -> (Throws e => IO a) -> IO a
handleChecked (\(UnexpectedResponse
ex :: UnexpectedResponse) -> UnexpectedResponse -> IO a
forall {e} {a}. Exception e => e -> IO a
go UnexpectedResponse
ex)
                 ((Throws UnexpectedResponse => IO a) -> IO a)
-> (Throws UnexpectedResponse => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ (IOException -> IO a) -> (Throws IOException => IO a) -> IO a
forall e a.
Exception e =>
(e -> IO a) -> (Throws e => IO a) -> IO a
handleChecked (\(IOException
ex :: IOException)        -> IOException -> IO a
forall {e} {a}. Exception e => e -> IO a
go IOException
ex)
                 ((Throws IOException => IO a) -> IO a)
-> (Throws IOException => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a
Throws IOException => IO a
(Throws UnexpectedResponse, Throws IOException) => IO a
act
  where
    go :: e -> IO a
go e
ex = SomeRemoteError -> IO a
forall e a. (Exception e, Throws e) => e -> IO a
throwChecked (e -> SomeRemoteError
forall e. Exception e => e -> SomeRemoteError
SomeRemoteError e
ex)

data UnexpectedResponse = UnexpectedResponse URI (Int, Int, Int)
  deriving (Typeable)

data InvalidProxy = InvalidProxy String
  deriving (Typeable)

instance Pretty UnexpectedResponse where
  pretty :: UnexpectedResponse -> String
pretty (UnexpectedResponse URI
uri ResponseCode
code) = String
"Unexpected response " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ResponseCode -> String
forall a. Show a => a -> String
show ResponseCode
code
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
uri

instance Pretty InvalidProxy where
  pretty :: InvalidProxy -> String
pretty (InvalidProxy String
p) = String
"Invalid proxy " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
p

deriving instance Show UnexpectedResponse
deriving instance Show InvalidProxy
instance Exception UnexpectedResponse where displayException :: UnexpectedResponse -> String
displayException = UnexpectedResponse -> String
forall a. Pretty a => a -> String
pretty
instance Exception InvalidProxy where displayException :: InvalidProxy -> String
displayException = InvalidProxy -> String
forall a. Pretty a => a -> String
pretty

{-------------------------------------------------------------------------------
  Additional operations
-------------------------------------------------------------------------------}

setProxy :: Browser -> ProxyConfig String -> IO ()
setProxy :: Browser -> ProxyConfig String -> IO ()
setProxy Browser
browser ProxyConfig String
proxyConfig = do
    Proxy
proxy <- case ProxyConfig String
proxyConfig of
      ProxyConfig String
ProxyConfigNone  -> Proxy -> IO Proxy
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
HTTP.NoProxy
      ProxyConfig String
ProxyConfigAuto  -> Bool -> IO Proxy
HTTP.fetchProxy Bool
True
      ProxyConfigUse String
p -> case String -> Maybe Proxy
HTTP.parseProxy String
p of
                             Maybe Proxy
Nothing -> InvalidProxy -> IO Proxy
forall {e} {a}. Exception e => e -> IO a
throwUnchecked (InvalidProxy -> IO Proxy) -> InvalidProxy -> IO Proxy
forall a b. (a -> b) -> a -> b
$ String -> InvalidProxy
InvalidProxy String
p
                             Just Proxy
p' -> Proxy -> IO Proxy
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
p'
    Browser -> BrowserAction LazyStream () -> IO ()
forall a. Browser -> BrowserAction LazyStream a -> IO a
withBrowser Browser
browser (BrowserAction LazyStream () -> IO ())
-> BrowserAction LazyStream () -> IO ()
forall a b. (a -> b) -> a -> b
$ Proxy -> BrowserAction LazyStream ()
forall t. Proxy -> BrowserAction t ()
HTTP.setProxy (Proxy -> Proxy
emptyAsNone Proxy
proxy)
  where
    emptyAsNone :: HTTP.Proxy -> HTTP.Proxy
    emptyAsNone :: Proxy -> Proxy
emptyAsNone (HTTP.Proxy String
uri Maybe Authority
_) | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uri = Proxy
HTTP.NoProxy
    emptyAsNone Proxy
p = Proxy
p

setOutHandler :: Browser -> (String -> IO ()) -> IO ()
setOutHandler :: Browser -> (String -> IO ()) -> IO ()
setOutHandler Browser
browser = Browser -> BrowserAction LazyStream () -> IO ()
forall a. Browser -> BrowserAction LazyStream a -> IO a
withBrowser Browser
browser (BrowserAction LazyStream () -> IO ())
-> ((String -> IO ()) -> BrowserAction LazyStream ())
-> (String -> IO ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ()) -> BrowserAction LazyStream ()
forall t. (String -> IO ()) -> BrowserAction t ()
HTTP.setOutHandler

setErrHandler :: Browser -> (String -> IO ()) -> IO ()
setErrHandler :: Browser -> (String -> IO ()) -> IO ()
setErrHandler Browser
browser = Browser -> BrowserAction LazyStream () -> IO ()
forall a. Browser -> BrowserAction LazyStream a -> IO a
withBrowser Browser
browser (BrowserAction LazyStream () -> IO ())
-> ((String -> IO ()) -> BrowserAction LazyStream ())
-> (String -> IO ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ()) -> BrowserAction LazyStream ()
forall t. (String -> IO ()) -> BrowserAction t ()
HTTP.setErrHandler

-- | Execute a single request
request :: Throws IOException
        => Browser
        -> HTTP.Request BS.L.ByteString
        -> IO (HTTP.Response BS.L.ByteString)
request :: Throws IOException =>
Browser -> Request ByteString -> IO (Response ByteString)
request Browser
browser = IO (Response ByteString) -> IO (Response ByteString)
forall a. Throws IOException => IO a -> IO a
checkIO (IO (Response ByteString) -> IO (Response ByteString))
-> (Request ByteString -> IO (Response ByteString))
-> Request ByteString
-> IO (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((URI, Response ByteString) -> Response ByteString)
-> IO (URI, Response ByteString) -> IO (Response ByteString)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (URI, Response ByteString) -> Response ByteString
forall a b. (a, b) -> b
snd (IO (URI, Response ByteString) -> IO (Response ByteString))
-> (Request ByteString -> IO (URI, Response ByteString))
-> Request ByteString
-> IO (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Browser
-> BrowserAction LazyStream (URI, Response ByteString)
-> IO (URI, Response ByteString)
forall a. Browser -> BrowserAction LazyStream a -> IO a
withBrowser Browser
browser (BrowserAction LazyStream (URI, Response ByteString)
 -> IO (URI, Response ByteString))
-> (Request ByteString
    -> BrowserAction LazyStream (URI, Response ByteString))
-> Request ByteString
-> IO (URI, Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request ByteString
-> BrowserAction LazyStream (URI, Response ByteString)
forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
HTTP.request

{-------------------------------------------------------------------------------
  Browser state
-------------------------------------------------------------------------------}

type LazyStream = HTTP.HandleStream BS.L.ByteString

data Browser = Browser {
    Browser -> MVar (BrowserState LazyStream)
browserState :: MVar (HTTP.BrowserState LazyStream)
  }

-- | Run a browser action
--
-- IMPLEMENTATION NOTE: the 'browse' action doesn't itself create any
-- connections, they are created on demand; we just need to make sure to carry
-- this state from one invocation of 'browse' to another.
withBrowser :: forall a. Browser -> HTTP.BrowserAction LazyStream a -> IO a
withBrowser :: forall a. Browser -> BrowserAction LazyStream a -> IO a
withBrowser Browser{MVar (BrowserState LazyStream)
browserState :: Browser -> MVar (BrowserState LazyStream)
browserState :: MVar (BrowserState LazyStream)
..} BrowserAction LazyStream a
act = MVar (BrowserState LazyStream)
-> (BrowserState LazyStream -> IO (BrowserState LazyStream, a))
-> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (BrowserState LazyStream)
browserState ((BrowserState LazyStream -> IO (BrowserState LazyStream, a))
 -> IO a)
-> (BrowserState LazyStream -> IO (BrowserState LazyStream, a))
-> IO a
forall a b. (a -> b) -> a -> b
$ \BrowserState LazyStream
bst -> BrowserAction LazyStream (BrowserState LazyStream, a)
-> IO (BrowserState LazyStream, a)
forall conn a. BrowserAction conn a -> IO a
HTTP.browse (BrowserAction LazyStream (BrowserState LazyStream, a)
 -> IO (BrowserState LazyStream, a))
-> BrowserAction LazyStream (BrowserState LazyStream, a)
-> IO (BrowserState LazyStream, a)
forall a b. (a -> b) -> a -> b
$ do
    BrowserState LazyStream -> BrowserAction LazyStream ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put BrowserState LazyStream
bst
    a
result <- BrowserAction LazyStream a
act
    BrowserState LazyStream
bst'   <- BrowserAction LazyStream (BrowserState LazyStream)
forall s (m :: * -> *). MonadState s m => m s
State.get
    (BrowserState LazyStream, a)
-> BrowserAction LazyStream (BrowserState LazyStream, a)
forall a. a -> BrowserAction LazyStream a
forall (m :: * -> *) a. Monad m => a -> m a
return (BrowserState LazyStream
bst', a
result)

-- | Initial browser state
--
-- Throws an 'InvalidProxy' exception if the proxy definition is invalid.
--
-- TODO: If the proxy configuration is automatic, the _only_ way that we can
-- find out from the @HTTP@ library is to pass @True@ as the argument to
-- 'fetchProxy'; but this prints to standard error when the proxy is invalid,
-- rather than throwing an exception :-O
browserInit :: IO Browser
browserInit :: IO Browser
browserInit = do
    MVar (BrowserState LazyStream)
browserState <- BrowserState LazyStream -> IO (MVar (BrowserState LazyStream))
forall a. a -> IO (MVar a)
newMVar (BrowserState LazyStream -> IO (MVar (BrowserState LazyStream)))
-> IO (BrowserState LazyStream)
-> IO (MVar (BrowserState LazyStream))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BrowserAction LazyStream (BrowserState LazyStream)
-> IO (BrowserState LazyStream)
forall conn a. BrowserAction conn a -> IO a
HTTP.browse BrowserAction LazyStream (BrowserState LazyStream)
forall s (m :: * -> *). MonadState s m => m s
State.get
    Browser -> IO Browser
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Browser{MVar (BrowserState LazyStream)
browserState :: MVar (BrowserState LazyStream)
browserState :: MVar (BrowserState LazyStream)
..}

-- | Cleanup browser state
--
-- NOTE: Calling 'withBrowser' after 'browserCleanup' will result in deadlock.
--
-- IMPLEMENTATION NOTE: "HTTP" does not provide any explicit API for resource
-- cleanup, so we can only rely on the garbage collector to do for us.
browserCleanup :: Browser -> IO ()
browserCleanup :: Browser -> IO ()
browserCleanup Browser{MVar (BrowserState LazyStream)
browserState :: Browser -> MVar (BrowserState LazyStream)
browserState :: MVar (BrowserState LazyStream)
..} = IO (BrowserState LazyStream) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (BrowserState LazyStream) -> IO ())
-> IO (BrowserState LazyStream) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (BrowserState LazyStream) -> IO (BrowserState LazyStream)
forall a. MVar a -> IO a
takeMVar MVar (BrowserState LazyStream)
browserState

{-------------------------------------------------------------------------------
  HTTP auxiliary
-------------------------------------------------------------------------------}

hAcceptRanges :: HTTP.HeaderName
hAcceptRanges :: HeaderName
hAcceptRanges = String -> HeaderName
HTTP.HdrCustom String
"Accept-Ranges"

setRange :: HTTP.HasHeaders a => Int -> Int -> a -> a
setRange :: forall a. HasHeaders a => Int -> Int -> a -> a
setRange Int
from Int
to = HeaderSetter a
forall a. HasHeaders a => HeaderSetter a
HTTP.insertHeader HeaderName
HTTP.HdrRange String
rangeHeader
  where
    -- Content-Range header uses inclusive rather than exclusive bounds
    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>
    rangeHeader :: String
rangeHeader = String
"bytes=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
from String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

addRequestHeaders :: HTTP.HasHeaders a => [HttpRequestHeader] -> a -> a
addRequestHeaders :: forall a. HasHeaders a => [HttpRequestHeader] -> a -> a
addRequestHeaders =
    ((a -> a) -> (a -> a) -> a -> a) -> (a -> a) -> [a -> a] -> a -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) a -> a
forall a. a -> a
id ([a -> a] -> a -> a)
-> ([HttpRequestHeader] -> [a -> a])
-> [HttpRequestHeader]
-> a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, String) -> a -> a)
-> [(HeaderName, String)] -> [a -> a]
forall a b. (a -> b) -> [a] -> [b]
map ((HeaderName -> String -> a -> a) -> (HeaderName, String) -> a -> a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HeaderName -> String -> a -> a
forall a. HasHeaders a => HeaderSetter a
HTTP.insertHeader) ([(HeaderName, String)] -> [a -> a])
-> ([HttpRequestHeader] -> [(HeaderName, String)])
-> [HttpRequestHeader]
-> [a -> a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(HeaderName, [String])]
-> [HttpRequestHeader] -> [(HeaderName, String)]
trOpt []
  where
    trOpt :: [(HTTP.HeaderName, [String])]
          -> [HttpRequestHeader]
          -> [(HTTP.HeaderName, String)]
    trOpt :: [(HeaderName, [String])]
-> [HttpRequestHeader] -> [(HeaderName, String)]
trOpt [(HeaderName, [String])]
acc [] =
      ((HeaderName, [String]) -> [(HeaderName, String)])
-> [(HeaderName, [String])] -> [(HeaderName, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HeaderName, [String]) -> [(HeaderName, String)]
finalizeHeader [(HeaderName, [String])]
acc
    trOpt [(HeaderName, [String])]
acc (HttpRequestHeader
HttpRequestMaxAge0:[HttpRequestHeader]
os) =
      [(HeaderName, [String])]
-> [HttpRequestHeader] -> [(HeaderName, String)]
trOpt (HeaderName
-> [String] -> [(HeaderName, [String])] -> [(HeaderName, [String])]
forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert HeaderName
HTTP.HdrCacheControl [String
"max-age=0"] [(HeaderName, [String])]
acc) [HttpRequestHeader]
os
    trOpt [(HeaderName, [String])]
acc (HttpRequestHeader
HttpRequestNoTransform:[HttpRequestHeader]
os) =
      [(HeaderName, [String])]
-> [HttpRequestHeader] -> [(HeaderName, String)]
trOpt (HeaderName
-> [String] -> [(HeaderName, [String])] -> [(HeaderName, [String])]
forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert HeaderName
HTTP.HdrCacheControl [String
"no-transform"] [(HeaderName, [String])]
acc) [HttpRequestHeader]
os

    -- Some headers are comma-separated, others need multiple headers for
    -- multiple options.
    --
    -- TODO: Right we we just comma-separate all of them.
    finalizeHeader :: (HTTP.HeaderName, [String]) -> [(HTTP.HeaderName, String)]
    finalizeHeader :: (HeaderName, [String]) -> [(HeaderName, String)]
finalizeHeader (HeaderName
name, [String]
strs) = [(HeaderName
name, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
strs))]

    insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
    insert :: forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert a
x [b]
y = a -> ([b] -> [b]) -> [(a, [b])] -> [(a, [b])]
forall a b. Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]
modifyAssocList a
x ([b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b]
y)

    -- modify the first maching element
    modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]
    modifyAssocList :: forall a b. Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]
modifyAssocList a
a b -> b
f = [(a, b)] -> [(a, b)]
go where
        go :: [(a, b)] -> [(a, b)]
go []                         = []
        go (p :: (a, b)
p@(a
a', b
b) : [(a, b)]
xs) | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a'   = (a
a', b -> b
f b
b) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
xs
                            | Bool
otherwise = (a, b)
p         (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, b)]
go [(a, b)]
xs

getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader]
getResponseHeaders :: forall a. Response a -> [HttpResponseHeader]
getResponseHeaders Response a
response = [[HttpResponseHeader]] -> [HttpResponseHeader]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
    -- Check the @Accept-Ranges@ header.
    --
    -- @Accept-Ranges@ takes a _single_ argument, but there might potentially
    -- be more than one of them (although the spec does not explicitly say so).

    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.5>
    -- and <http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.12>
    [ HttpResponseHeader
HttpResponseAcceptRangesBytes
    | String
"bytes" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Header -> String) -> [Header] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Header -> String
HTTP.hdrValue (HeaderName -> Response a -> [Header]
forall a. HasHeaders a => HeaderName -> a -> [Header]
HTTP.retrieveHeaders HeaderName
hAcceptRanges Response a
response)
    ]
  ]