module Network.HTTP.Client.Types where
import Data.Typeable
import Network.HTTP.Types
import Control.Exception (Exception, IOException, SomeException)
import Data.Word (Word64)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Blaze.ByteString.Builder (Builder, fromLazyByteString, fromByteString, toLazyByteString)
import Data.Int (Int64)
import Data.Default
import Data.Monoid
import Data.Time (UTCTime)
import qualified Data.List as DL
import Network.Socket (HostAddress)
import Data.IORef
data Connection = Connection
{ connectionRead :: !(IO S.ByteString)
, connectionUnread :: !(S.ByteString -> IO ())
, connectionWrite :: !(S.ByteString -> IO ())
, connectionClose :: !(IO ())
}
data StatusHeaders = StatusHeaders !Status !HttpVersion !RequestHeaders
deriving (Show, Eq, Ord)
data HttpException = StatusCodeException Status ResponseHeaders CookieJar
| InvalidUrlException String String
| TooManyRedirects [Response L.ByteString]
| UnparseableRedirect (Response L.ByteString)
| TooManyRetries
| HttpParserException String
| HandshakeFailed
| OverlongHeaders
| ResponseTimeout
| FailedConnectionException String Int
| ExpectedBlankAfter100Continue
| InvalidStatusLine S.ByteString
| InvalidHeader S.ByteString
| InternalIOException IOException
| ProxyConnectException S.ByteString Int (Either S.ByteString HttpException)
| NoResponseDataReceived
| TlsException SomeException
| TlsNotSupported
| ResponseBodyTooShort Word64 Word64
| InvalidChunkHeaders
| IncompleteHeaders
deriving (Show, Typeable)
instance Exception HttpException
data Cookie = Cookie
{ cookie_name :: S.ByteString
, cookie_value :: S.ByteString
, cookie_expiry_time :: UTCTime
, cookie_domain :: S.ByteString
, cookie_path :: S.ByteString
, cookie_creation_time :: UTCTime
, cookie_last_access_time :: UTCTime
, cookie_persistent :: Bool
, cookie_host_only :: Bool
, cookie_secure_only :: Bool
, cookie_http_only :: Bool
}
deriving (Read, Show)
newtype CookieJar = CJ { expose :: [Cookie] }
deriving (Read, Show)
instance Eq Cookie where
(==) a b = name_matches && domain_matches && path_matches
where name_matches = cookie_name a == cookie_name b
domain_matches = cookie_domain a == cookie_domain b
path_matches = cookie_path a == cookie_path b
instance Ord Cookie where
compare c1 c2
| S.length (cookie_path c1) > S.length (cookie_path c2) = LT
| S.length (cookie_path c1) < S.length (cookie_path c2) = GT
| cookie_creation_time c1 > cookie_creation_time c2 = GT
| otherwise = LT
instance Default CookieJar where
def = CJ []
instance Eq CookieJar where
(==) cj1 cj2 = (DL.sort $ expose cj1) == (DL.sort $ expose cj2)
instance Monoid CookieJar where
mempty = def
(CJ a) `mappend` (CJ b) = CJ (DL.nub $ DL.sortBy compare' $ a `mappend` b)
where compare' c1 c2 =
if cookie_creation_time c1 > cookie_creation_time c2
then LT
else GT
data Proxy = Proxy
{ proxyHost :: S.ByteString
, proxyPort :: Int
}
deriving (Show, Read, Eq, Ord, Typeable)
data RequestBody
= RequestBodyLBS !L.ByteString
| RequestBodyBS !S.ByteString
| RequestBodyBuilder !Int64 !Builder
| RequestBodyStream !Int64 !(GivesPopper ())
| RequestBodyStreamChunked !(GivesPopper ())
instance Monoid RequestBody where
mempty = RequestBodyBS S.empty
mappend x0 y0 =
case (simplify x0, simplify y0) of
(Left (i, x), Left (j, y)) -> RequestBodyBuilder (i + j) (x `mappend` y)
(Left x, Right y) -> combine (builderToStream x) y
(Right x, Left y) -> combine x (builderToStream y)
(Right x, Right y) -> combine x y
where
combine (Just i, x) (Just j, y) = RequestBodyStream (i + j) (combine' x y)
combine (_, x) (_, y) = RequestBodyStreamChunked (combine' x y)
combine' :: GivesPopper () -> GivesPopper () -> GivesPopper ()
combine' x y f = x $ \x' -> y $ \y' -> combine'' x' y' f
combine'' :: Popper -> Popper -> NeedsPopper () -> IO ()
combine'' x y f = do
istate <- newIORef $ Left (x, y)
f $ go istate
go istate = do
state <- readIORef istate
case state of
Left (x, y) -> do
bs <- x
if S.null bs
then do
writeIORef istate $ Right y
y
else return bs
Right y -> y
simplify :: RequestBody -> Either (Int64, Builder) (Maybe Int64, GivesPopper ())
simplify (RequestBodyLBS lbs) = Left (L.length lbs, fromLazyByteString lbs)
simplify (RequestBodyBS bs) = Left (fromIntegral $ S.length bs, fromByteString bs)
simplify (RequestBodyBuilder len b) = Left (len, b)
simplify (RequestBodyStream i gp) = Right (Just i, gp)
simplify (RequestBodyStreamChunked gp) = Right (Nothing, gp)
builderToStream :: (Int64, Builder) -> (Maybe Int64, GivesPopper ())
builderToStream (len, builder) =
(Just len, gp)
where
gp np = do
ibss <- newIORef $ L.toChunks $ toLazyByteString builder
np $ do
bss <- readIORef ibss
case bss of
[] -> return S.empty
bs:bss' -> do
writeIORef ibss bss'
return bs
type Popper = IO S.ByteString
type NeedsPopper a = Popper -> IO a
type GivesPopper a = NeedsPopper a -> IO a
data Request = Request
{ method :: Method
, secure :: Bool
, host :: S.ByteString
, port :: Int
, path :: S.ByteString
, queryString :: S.ByteString
, requestHeaders :: RequestHeaders
, requestBody :: RequestBody
, proxy :: Maybe Proxy
, hostAddress :: Maybe HostAddress
, rawBody :: Bool
, decompress :: ContentType -> Bool
, redirectCount :: Int
, checkStatus :: Status -> ResponseHeaders -> CookieJar -> Maybe SomeException
, responseTimeout :: Maybe Int
, getConnectionWrapper :: Maybe Int
-> HttpException
-> IO (ConnRelease, Connection, ManagedConn)
-> IO (Maybe Int, (ConnRelease, Connection, ManagedConn))
, cookieJar :: Maybe CookieJar
}
type ContentType = S.ByteString
data ConnReuse = Reuse | DontReuse
type ConnRelease = ConnReuse -> IO ()
data ManagedConn = Fresh | Reused
data Response body = Response
{ responseStatus :: !Status
, responseVersion :: !HttpVersion
, responseHeaders :: !ResponseHeaders
, responseBody :: !body
, responseCookieJar :: !CookieJar
, responseClose' :: !ResponseClose
}
deriving (Show, Eq, Typeable, Functor)
responseClose :: Response a -> IO ()
responseClose = runResponseClose . responseClose'
newtype ResponseClose = ResponseClose { runResponseClose :: IO () }
deriving Typeable
instance Show ResponseClose where
show _ = "ResponseClose"
instance Eq ResponseClose where
_ == _ = True