{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide, not-home #-}
module Network.Http.Connection (
Connection (..),
makeConnection,
withConnection,
openConnection,
openConnectionSSL,
openConnectionUnix,
closeConnection,
getHostname,
getRequestHeaders,
getHeadersFull,
sendRequest,
receiveResponse,
receiveResponseRaw,
unsafeReceiveResponse,
UnexpectedCompression,
emptyBody,
simpleBody,
fileBody,
inputStreamBody,
debugHandler,
simpleHandler,
concatHandler,
) where
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Builder (
flush,
fromByteString,
toByteString,
)
import qualified Blaze.ByteString.Builder.HTTP as Builder (chunkedTransferEncoding, chunkedTransferTerminator)
import Control.Exception (bracket)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S
import Network.Socket
import OpenSSL (withOpenSSL)
import OpenSSL.Session (SSL, SSLContext)
import qualified OpenSSL.Session as SSL
import System.IO.Streams (InputStream, OutputStream, stdout)
import qualified System.IO.Streams as Streams
import qualified System.IO.Streams.SSL as Streams hiding (connect)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mappend, mempty)
#endif
import Network.Http.Internal
import Network.Http.ResponseParser
data Connection = Connection
{
Connection -> ByteString
cHost :: ByteString
,
Connection -> IO ()
cClose :: IO ()
, Connection -> OutputStream Builder
cOut :: OutputStream Builder
, Connection -> InputStream ByteString
cIn :: InputStream ByteString
}
instance Show Connection where
show :: Connection -> String
show Connection
c =
{-# SCC "Connection.show" #-}
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Host: "
, ByteString -> String
S.unpack forall a b. (a -> b) -> a -> b
$ Connection -> ByteString
cHost Connection
c
, String
"\n"
]
makeConnection ::
ByteString ->
IO () ->
OutputStream ByteString ->
InputStream ByteString ->
IO Connection
makeConnection :: ByteString
-> IO ()
-> OutputStream ByteString
-> InputStream ByteString
-> IO Connection
makeConnection ByteString
h IO ()
c OutputStream ByteString
o1 InputStream ByteString
i = do
OutputStream Builder
o2 <- OutputStream ByteString -> IO (OutputStream Builder)
Streams.builderStream OutputStream ByteString
o1
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString
-> IO ()
-> OutputStream Builder
-> InputStream ByteString
-> Connection
Connection ByteString
h IO ()
c OutputStream Builder
o2 InputStream ByteString
i
withConnection :: IO Connection -> (Connection -> IO γ) -> IO γ
withConnection :: forall γ. IO Connection -> (Connection -> IO γ) -> IO γ
withConnection IO Connection
mkC =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Connection
mkC Connection -> IO ()
closeConnection
openConnection :: Hostname -> Port -> IO Connection
openConnection :: ByteString -> Port -> IO Connection
openConnection ByteString
h1' Port
p = do
[AddrInfo]
is <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (forall a. a -> Maybe a
Just AddrInfo
hints) (forall a. a -> Maybe a
Just String
h1) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Port
p)
let addr :: AddrInfo
addr = forall a. [a] -> a
head [AddrInfo]
is
let a :: SockAddr
a = AddrInfo -> SockAddr
addrAddress AddrInfo
addr
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) SocketType
Stream ProtocolNumber
defaultProtocol
Socket -> SockAddr -> IO ()
connect Socket
s SockAddr
a
(InputStream ByteString
i, OutputStream ByteString
o1) <- Socket -> IO (InputStream ByteString, OutputStream ByteString)
Streams.socketToStreams Socket
s
OutputStream Builder
o2 <- OutputStream ByteString -> IO (OutputStream Builder)
Streams.builderStream OutputStream ByteString
o1
forall (m :: * -> *) a. Monad m => a -> m a
return
Connection
{ cHost :: ByteString
cHost = ByteString
h2'
, cClose :: IO ()
cClose = Socket -> IO ()
close Socket
s
, cOut :: OutputStream Builder
cOut = OutputStream Builder
o2
, cIn :: InputStream ByteString
cIn = InputStream ByteString
i
}
where
hints :: AddrInfo
hints =
AddrInfo
defaultHints
{ addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_NUMERICSERV]
, addrSocketType :: SocketType
addrSocketType = SocketType
Stream
}
h2' :: ByteString
h2' =
if Port
p forall a. Eq a => a -> a -> Bool
== Port
80
then ByteString
h1'
else [ByteString] -> ByteString
S.concat [ByteString
h1', ByteString
":", String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Port
p]
h1 :: String
h1 = ByteString -> String
S.unpack ByteString
h1'
openConnectionSSL :: SSLContext -> Hostname -> Port -> IO Connection
openConnectionSSL :: SSLContext -> ByteString -> Port -> IO Connection
openConnectionSSL SSLContext
ctx ByteString
h1' Port
p = forall a. IO a -> IO a
withOpenSSL forall a b. (a -> b) -> a -> b
$ do
[AddrInfo]
is <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
h1) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Port
p)
let a :: SockAddr
a = AddrInfo -> SockAddr
addrAddress forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [AddrInfo]
is
f :: Family
f = AddrInfo -> Family
addrFamily forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [AddrInfo]
is
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
f SocketType
Stream ProtocolNumber
defaultProtocol
Socket -> SockAddr -> IO ()
connect Socket
s SockAddr
a
SSL
ssl <- SSLContext -> Socket -> IO SSL
SSL.connection SSLContext
ctx Socket
s
SSL -> String -> IO ()
SSL.setTlsextHostName SSL
ssl String
h1
SSL -> IO ()
SSL.connect SSL
ssl
(InputStream ByteString
i, OutputStream ByteString
o1) <- SSL -> IO (InputStream ByteString, OutputStream ByteString)
Streams.sslToStreams SSL
ssl
OutputStream Builder
o2 <- OutputStream ByteString -> IO (OutputStream Builder)
Streams.builderStream OutputStream ByteString
o1
forall (m :: * -> *) a. Monad m => a -> m a
return
Connection
{ cHost :: ByteString
cHost = ByteString
h2'
, cClose :: IO ()
cClose = Socket -> SSL -> IO ()
closeSSL Socket
s SSL
ssl
, cOut :: OutputStream Builder
cOut = OutputStream Builder
o2
, cIn :: InputStream ByteString
cIn = InputStream ByteString
i
}
where
h2' :: ByteString
h2' :: ByteString
h2' =
if Port
p forall a. Eq a => a -> a -> Bool
== Port
443
then ByteString
h1'
else [ByteString] -> ByteString
S.concat [ByteString
h1', ByteString
":", String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Port
p]
h1 :: String
h1 = ByteString -> String
S.unpack ByteString
h1'
closeSSL :: Socket -> SSL -> IO ()
closeSSL :: Socket -> SSL -> IO ()
closeSSL Socket
s SSL
ssl = do
SSL -> ShutdownType -> IO ()
SSL.shutdown SSL
ssl ShutdownType
SSL.Unidirectional
Socket -> IO ()
close Socket
s
openConnectionUnix :: FilePath -> IO Connection
openConnectionUnix :: String -> IO Connection
openConnectionUnix String
path = do
let a :: SockAddr
a = String -> SockAddr
SockAddrUnix String
path
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
defaultProtocol
Socket -> SockAddr -> IO ()
connect Socket
s SockAddr
a
(InputStream ByteString
i, OutputStream ByteString
o1) <- Socket -> IO (InputStream ByteString, OutputStream ByteString)
Streams.socketToStreams Socket
s
OutputStream Builder
o2 <- OutputStream ByteString -> IO (OutputStream Builder)
Streams.builderStream OutputStream ByteString
o1
forall (m :: * -> *) a. Monad m => a -> m a
return
Connection
{ cHost :: ByteString
cHost = ByteString
path'
, cClose :: IO ()
cClose = Socket -> IO ()
close Socket
s
, cOut :: OutputStream Builder
cOut = OutputStream Builder
o2
, cIn :: InputStream ByteString
cIn = InputStream ByteString
i
}
where
path' :: ByteString
path' = String -> ByteString
S.pack String
path
sendRequest :: Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
sendRequest :: forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
sendRequest Connection
c Request
q OutputStream Builder -> IO α
handler = do
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
msg) OutputStream Builder
o2
EntityBody
e2 <- case ExpectMode
t of
ExpectMode
Normal -> do
forall (m :: * -> *) a. Monad m => a -> m a
return EntityBody
e
ExpectMode
Continue -> do
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
Builder.flush) OutputStream Builder
o2
Response
p <- InputStream ByteString -> IO Response
readResponseHeader InputStream ByteString
i
case Response -> Int
getStatusCode Response
p of
Int
100 -> do
forall (m :: * -> *) a. Monad m => a -> m a
return EntityBody
e
Int
_ -> do
forall a. a -> InputStream a -> IO ()
Streams.unRead (Response -> ByteString
rsp Response
p) InputStream ByteString
i
forall (m :: * -> *) a. Monad m => a -> m a
return EntityBody
Empty
α
x <- case EntityBody
e2 of
EntityBody
Empty -> do
OutputStream Builder
o3 <- forall a. IO (OutputStream a)
Streams.nullOutput
α
y <- OutputStream Builder -> IO α
handler OutputStream Builder
o3
forall (m :: * -> *) a. Monad m => a -> m a
return α
y
EntityBody
Chunking -> do
OutputStream Builder
o3 <- forall a b. (a -> b) -> OutputStream b -> IO (OutputStream a)
Streams.contramap Builder -> Builder
Builder.chunkedTransferEncoding OutputStream Builder
o2
α
y <- OutputStream Builder -> IO α
handler OutputStream Builder
o3
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
Builder.chunkedTransferTerminator) OutputStream Builder
o2
forall (m :: * -> *) a. Monad m => a -> m a
return α
y
(Static Int64
_) -> do
α
y <- OutputStream Builder -> IO α
handler OutputStream Builder
o2
forall (m :: * -> *) a. Monad m => a -> m a
return α
y
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
Builder.flush) OutputStream Builder
o2
forall (m :: * -> *) a. Monad m => a -> m a
return α
x
where
o2 :: OutputStream Builder
o2 = Connection -> OutputStream Builder
cOut Connection
c
e :: EntityBody
e = Request -> EntityBody
qBody Request
q
t :: ExpectMode
t = Request -> ExpectMode
qExpect Request
q
msg :: Builder
msg = Request -> ByteString -> Builder
composeRequestBytes Request
q ByteString
h'
h' :: ByteString
h' = Connection -> ByteString
cHost Connection
c
i :: InputStream ByteString
i = Connection -> InputStream ByteString
cIn Connection
c
rsp :: Response -> ByteString
rsp Response
p = Builder -> ByteString
Builder.toByteString forall a b. (a -> b) -> a -> b
$ Response -> Builder
composeResponseBytes Response
p
getHostname :: Connection -> Request -> ByteString
getHostname :: Connection -> Request -> ByteString
getHostname Connection
c Request
q =
case Request -> Maybe ByteString
qHost Request
q of
Just ByteString
h' -> ByteString
h'
Maybe ByteString
Nothing -> Connection -> ByteString
cHost Connection
c
{-# DEPRECATED getRequestHeaders "use retrieveHeaders . getHeadersFull instead" #-}
getRequestHeaders :: Connection -> Request -> [(ByteString, ByteString)]
Connection
c Request
q =
(ByteString
"Host", Connection -> Request -> ByteString
getHostname Connection
c Request
q) forall a. a -> [a] -> [a]
: [(ByteString, ByteString)]
kvs
where
h :: Headers
h = Request -> Headers
qHeaders Request
q
kvs :: [(ByteString, ByteString)]
kvs = Headers -> [(ByteString, ByteString)]
retrieveHeaders Headers
h
getHeadersFull :: Connection -> Request -> Headers
Connection
c Request
q =
Headers
h'
where
h :: Headers
h = Request -> Headers
qHeaders Request
q
h' :: Headers
h' = Headers -> ByteString -> ByteString -> Headers
updateHeader Headers
h ByteString
"Host" (Connection -> Request -> ByteString
getHostname Connection
c Request
q)
receiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse :: forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c Response -> InputStream ByteString -> IO β
handler = do
Response
p <- InputStream ByteString -> IO Response
readResponseHeader InputStream ByteString
i
InputStream ByteString
i' <- Response -> InputStream ByteString -> IO (InputStream ByteString)
readResponseBody Response
p InputStream ByteString
i
β
x <- Response -> InputStream ByteString -> IO β
handler Response
p InputStream ByteString
i'
forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
i'
forall (m :: * -> *) a. Monad m => a -> m a
return β
x
where
i :: InputStream ByteString
i = Connection -> InputStream ByteString
cIn Connection
c
receiveResponseRaw :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponseRaw :: forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponseRaw Connection
c Response -> InputStream ByteString -> IO β
handler = do
Response
p <- InputStream ByteString -> IO Response
readResponseHeader InputStream ByteString
i
let p' :: Response
p' =
Response
p
{ pContentEncoding :: ContentEncoding
pContentEncoding = ContentEncoding
Identity
}
InputStream ByteString
i' <- Response -> InputStream ByteString -> IO (InputStream ByteString)
readResponseBody Response
p' InputStream ByteString
i
β
x <- Response -> InputStream ByteString -> IO β
handler Response
p InputStream ByteString
i'
forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
i'
forall (m :: * -> *) a. Monad m => a -> m a
return β
x
where
i :: InputStream ByteString
i = Connection -> InputStream ByteString
cIn Connection
c
unsafeReceiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
unsafeReceiveResponse :: forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
unsafeReceiveResponse Connection
c Response -> InputStream ByteString -> IO β
handler = do
Response
p <- InputStream ByteString -> IO Response
readResponseHeader InputStream ByteString
i
InputStream ByteString
i' <- Response -> InputStream ByteString -> IO (InputStream ByteString)
readResponseBody Response
p InputStream ByteString
i
Response -> InputStream ByteString -> IO β
handler Response
p InputStream ByteString
i'
where
i :: InputStream ByteString
i = Connection -> InputStream ByteString
cIn Connection
c
emptyBody :: OutputStream Builder -> IO ()
emptyBody :: OutputStream Builder -> IO ()
emptyBody OutputStream Builder
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
simpleBody :: ByteString -> OutputStream Builder -> IO ()
simpleBody :: ByteString -> OutputStream Builder -> IO ()
simpleBody ByteString
x' OutputStream Builder
o = do
let b :: Builder
b = ByteString -> Builder
Builder.fromByteString ByteString
x'
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
b) OutputStream Builder
o
fileBody :: FilePath -> OutputStream Builder -> IO ()
fileBody :: String -> OutputStream Builder -> IO ()
fileBody String
p OutputStream Builder
o = do
forall a. String -> (InputStream ByteString -> IO a) -> IO a
Streams.withFileAsInput String
p (\InputStream ByteString
i -> InputStream ByteString -> OutputStream Builder -> IO ()
inputStreamBody InputStream ByteString
i OutputStream Builder
o)
inputStreamBody :: InputStream ByteString -> OutputStream Builder -> IO ()
inputStreamBody :: InputStream ByteString -> OutputStream Builder -> IO ()
inputStreamBody InputStream ByteString
i1 OutputStream Builder
o = do
InputStream Builder
i2 <- forall a b. (a -> b) -> InputStream a -> IO (InputStream b)
Streams.map ByteString -> Builder
Builder.fromByteString InputStream ByteString
i1
forall a. InputStream a -> OutputStream a -> IO ()
Streams.supply InputStream Builder
i2 OutputStream Builder
o
debugHandler :: Response -> InputStream ByteString -> IO ()
debugHandler :: Response -> InputStream ByteString -> IO ()
debugHandler Response
p InputStream ByteString
i = do
ByteString -> IO ()
S.putStr forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
S.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r') forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toByteString forall a b. (a -> b) -> a -> b
$ Response -> Builder
composeResponseBytes Response
p
forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream ByteString
i OutputStream ByteString
stdout
simpleHandler :: Response -> InputStream ByteString -> IO ByteString
simpleHandler :: Response -> InputStream ByteString -> IO ByteString
simpleHandler Response
_ InputStream ByteString
i1 = do
InputStream Builder
i2 <- forall a b. (a -> b) -> InputStream a -> IO (InputStream b)
Streams.map ByteString -> Builder
Builder.fromByteString InputStream ByteString
i1
Builder
x <- forall s a. (s -> a -> s) -> s -> InputStream a -> IO s
Streams.fold forall a. Monoid a => a -> a -> a
mappend forall a. Monoid a => a
mempty InputStream Builder
i2
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toByteString Builder
x
concatHandler :: Response -> InputStream ByteString -> IO ByteString
concatHandler :: Response -> InputStream ByteString -> IO ByteString
concatHandler = Response -> InputStream ByteString -> IO ByteString
simpleHandler
{-# DEPRECATED concatHandler "Use simpleHandler instead" #-}
closeConnection :: Connection -> IO ()
closeConnection :: Connection -> IO ()
closeConnection Connection
c = Connection -> IO ()
cClose Connection
c