module Network.MiniHTTP.Client
( fetchBasic
, connection
, transport
, request
) where
import Control.Monad (when)
import Control.Concurrent.STM
import Control.Exception (handle, throwIO)
import qualified Data.Binary.Put as P
import qualified Data.ByteString as B
import Data.ByteString.Internal (w2c)
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (isNothing)
import Data.String
import qualified Network.Connection as C
import qualified Network.DNS.Client as DNS
import qualified Network.DNS.Types as DNS
import Network.MiniHTTP.Marshal
import Network.MiniHTTP.HTTPConnection
import qualified Network.MiniHTTP.URL as URL
import Network.Socket
import System.IO.Unsafe (unsafePerformIO)
import qualified OpenSSL.Session as SSL
import qualified OpenSSL.X509 as X509
readReply :: C.Connection -> IO (Maybe (Reply, Maybe Source))
readReply conn = do
r <- readIG conn 256 4096 parseReply
case r of
Nothing -> return Nothing
Just reply ->
case httpContentLength $ replyHeaders reply of
Nothing ->
if "chunked" `elem` (httpTransferEncoding $ replyHeaders reply)
then do
source <- connChunkedSource conn
return $ Just (reply, Just source)
else do
source <- connEOFSource conn
return $ Just (reply, Just source)
Just n -> do
source <- connSource n B.empty conn
return $ Just (reply, Just source)
request :: C.Connection
-> Request
-> Maybe Source
-> IO (Maybe (Reply, Maybe Source))
request conn req msource = do
let requestBytes = B.concat $ BL.toChunks $ P.runPut $ putRequest req
atomically $ C.write conn requestBytes
let lowWater = 32 * 1024
case msource of
(Just source) -> do
success <- if isNothing $ httpContentLength $ reqHeaders req
then streamSourceChunked lowWater conn source
else streamSource lowWater conn source
if not success
then return Nothing
else readReply conn
Nothing -> readReply conn
globalOpenSSLClientContext :: SSL.SSLContext
globalOpenSSLClientContext = unsafePerformIO $ do
ctx <- SSL.context
SSL.contextSetDefaultCiphers ctx
SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer False False
SSL.contextSetCAFile ctx "/etc/ssl/cert.pem"
return ctx
connection :: URL.URL
-> IO Socket
connection (URL.URL { URL.urlHost = URL.IPv4Literal host, URL.urlPort = port }) = do
sock <- socket AF_INET Stream 0
connect sock $ SockAddrInet (fromIntegral port) host
return sock
connection (URL.URL { URL.urlHost = URL.IPv6Literal host, URL.urlPort = port }) = do
sock <- socket AF_INET6 Stream 0
connect sock $ SockAddrInet6 (fromIntegral port) 0 host 0
return sock
connection (URL.URL { URL.urlHost = URL.Hostname hostname, URL.urlPort = port }) = do
r <- DNS.resolve DNS.A $ map w2c $ B.unpack hostname
case r of
Left error -> fail $ show error
Right [] -> fail "DNS returned no A records"
Right (((_, DNS.RRA (haddr:_))):_) -> do
sock <- socket AF_INET Stream 0
connect sock $ SockAddrInet (fromIntegral port) haddr
return sock
transport :: URL.URL -> Socket -> IO C.Connection
transport (URL.URL { URL.urlScheme = URL.HTTP }) sock =
C.new (return ()) $ C.baseConnectionFromSocket sock
transport (URL.URL { URL.urlScheme = URL.HTTPS, URL.urlHost = URL.Hostname hostname }) sock = do
ssl <- SSL.connection globalOpenSSLClientContext sock
SSL.connect ssl
verified <- SSL.getVerifyResult ssl
when (not verified) $ fail "Failed to verify SSL server certificate"
mcert <- SSL.getPeerCertificate ssl
case mcert of
Nothing -> fail "No server certificate"
Just cert -> do
subjects <- X509.getSubjectName cert True
case "commonName" `lookup` subjects of
Nothing -> fail "No hostname in certificate"
Just h -> do
when (fromString h /= hostname) $ fail $
"Hostname doesn't match certificate (" ++
h ++ " vs " ++ show hostname ++ ")"
conn <- C.new (return ()) $ sslToBaseConnection ssl
return conn
transport _ _ = fail "Cannot create HTTPS connection to an IP address (cannot check certificate)"
fetchBasic :: Headers
-> URL.URL
-> IO (C.Connection, Reply, Maybe Source)
fetchBasic headers url = do
sock <- connection url
handle (\e -> sClose sock >> throwIO e) $ do
conn <- transport url sock
let headers' = case URL.urlHost url of
URL.Hostname h -> headers { httpHost = Just h }
_ -> headers
r <- request conn (Request GET (URL.toRelative url) 1 1 headers') Nothing
case r of
Nothing -> C.close conn >> fail "HTTP parse error"
(Just (reply, msource)) -> return (conn, reply, msource)