module Data.IterIO.HttpClient (
simpleHttp, genSimpleHttp
, headRequest, getRequest, postRequest
, simpleGetHttp, simpleGetHttps
, simpleHeadHttp, simpleHeadHttps
, HttpClient(..)
, mkHttpClient
, httpConnect
, inumHttpClient
, HttpResponseHandler
, userAgent
, maxNrRedirects
, mkRequestToAbsUri
) where
import Prelude hiding (catch, head, div)
import Control.Monad (when, unless)
import Control.Exception
import Control.Monad.Trans
import Data.Maybe ( isNothing, fromJust)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Network.Socket as Net
import qualified Network.BSD as Net
import qualified OpenSSL.Session as SSL
import Data.IterIO
import Data.IterIO.Http
import Data.IterIO.SSL
import Data.Version (showVersion)
import Paths_iterIO (version)
import Data.IORef
type L = L.ByteString
type S = S.ByteString
lazyfy :: S -> L
lazyfy = L.pack . S.unpack
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO = catch
userAgent :: String
userAgent = "haskell-iterIO/" ++ showVersion version
data HttpClient = HttpClient {
hcSock :: !Net.Socket
, hcSockAddr :: !Net.SockAddr
, hcSslCtx :: !(Maybe SSL.SSLContext)
, hcIsHttps :: !Bool
}
maxNrRedirects :: Int
maxNrRedirects = 0
httpConnect :: MonadIO m => HttpClient -> IO (Iter L m (), Onum L m a)
httpConnect hc = do
let s = hcSock hc
isHttps = hcIsHttps hc
when (isHttps && isNothing (hcSslCtx hc)) $
throwIO (userError "Need SSL context for HTTPS")
Net.connect s (hcSockAddr hc)
if hcIsHttps hc
then iterSSL (fromJust $ hcSslCtx hc) s False
else iterStream s
mkHttpClient :: S
-> Int
-> Maybe SSL.SSLContext
-> Bool
-> IO HttpClient
mkHttpClient host port ctx isHttps = withSocket $ \s -> do
Net.setSocketOption s Net.KeepAlive 1
hostA <- getHostAddr (S8.unpack host)
let a = Net.SockAddrInet (toEnum port) hostA
return HttpClient { hcSock = s
, hcSockAddr = a
, hcSslCtx = ctx
, hcIsHttps = isHttps }
where withSocket action = do
s <- Net.socket Net.AF_INET Net.Stream 6
catchIO (action s) (\e -> Net.sClose s >> ioError e)
getHostAddr h =
catchIO (Net.inet_addr h) $ \_ -> do
h' <- getHostByName_safe h
case Net.hostAddresses h' of
[] -> err $ "No addresses in host entry for " ++ show h
(ha:_) -> return ha
getHostByName_safe h =
catchIO (Net.getHostByName h) $ \_ ->
err $ "Failed to lookup " ++ show h
err = throwIO . userError
simpleGetHttp :: MonadIO m
=> String
-> m (HttpResp m)
simpleGetHttp url = simpleHttp (getRequest url) L.empty Nothing
simpleGetHttps :: MonadIO m
=> String
-> SSL.SSLContext
-> m (HttpResp m)
simpleGetHttps url ctx = simpleHttp (getRequest url) L.empty (Just ctx)
simpleHeadHttp :: MonadIO m
=> String
-> m (HttpResp m)
simpleHeadHttp url = simpleHttp (headRequest url) L.empty Nothing
simpleHeadHttps :: MonadIO m
=> String
-> SSL.SSLContext
-> m (HttpResp m)
simpleHeadHttps url ctx = simpleHttp (headRequest url) L.empty (Just ctx)
simpleHttp :: MonadIO m
=> HttpReq ()
-> L
-> Maybe SSL.SSLContext
-> m (HttpResp m)
simpleHttp req body ctx = genSimpleHttp req body ctx maxNrRedirects True
genSimpleHttp :: MonadIO m
=> HttpReq ()
-> L
-> Maybe SSL.SSLContext
-> Int
-> Bool
-> m (HttpResp m)
genSimpleHttp req body ctx redirectCount passCookies = do
let scheme = reqScheme req
isHttps = scheme == (S8.pack "https")
port <- maybe (defaultPort scheme) return $ reqPort req
client <- liftIO $ mkHttpClient (reqHost req) port ctx isHttps
(sIter,sOnum) <- liftIO $ httpConnect client
refResp <- liftIO $ newIORef Nothing
count <- liftIO $ newIORef 0
sOnum |$ inumHttpClient (req, body) (handler count refResp) .| sIter
mresp <- liftIO $ readIORef refResp
maybe err return mresp
where handler countRef refResp resp = do
liftIO $ writeIORef refResp (Just resp)
count <- liftIO $ do c <- readIORef countRef
writeIORef countRef (c+1)
return c
if count < redirectCount
then handleRedirect (req, body) passCookies resp
else return Nothing
defaultPort s | s == S8.pack "http" = return 80
| s == S8.pack "https" = return 443
| otherwise = liftIO . throwIO . userError $
"Unrecognized scheme" ++ S8.unpack s
err = liftIO . throwIO . userError $ "Request failed"
handleRedirect :: MonadIO m
=> (HttpReq s, L )
-> Bool
-> HttpResp m
-> Iter L m (Maybe (HttpReq s, L))
handleRedirect (req, body) passCookies resp =
if (respStatus resp `notElem` s300s) || (reqMethod req `notElem` meths)
then return Nothing
else doRedirect $ lookup (S8.pack "location") $ respHeaders resp
where s300s = [stat301, stat302, stat303, stat307]
meths = [S8.pack "GET", S8.pack "HEAD"]
doRedirect Nothing = return Nothing
doRedirect (Just url) = do
newReq <- mkRequestToAbsUri (lazyfy url) (reqMethod req)
let req' = newReq { reqHeaders = reqHeaders req
, reqCookies = if passCookies
then reqCookies req
else []
, reqContentType = reqContentType req
, reqContentLength = reqContentLength req
, reqTransferEncoding = reqTransferEncoding req
, reqIfModifiedSince = reqIfModifiedSince req
, reqSession = reqSession req }
return $ Just (req', body)
headRequest :: String -> HttpReq ()
headRequest url = fromJust $ mkRequestToAbsUri (L8.pack url) $ S8.pack "HEAD"
getRequest :: String -> HttpReq ()
getRequest url = fromJust $ mkRequestToAbsUri (L8.pack url) $ S8.pack "GET"
postRequest :: String
-> String
-> L
-> HttpReq ()
postRequest url ct body =
let req = fromJust $ mkRequestToAbsUri (L8.pack url) $ S8.pack "POST"
in req { reqContentType = Just (S8.pack ct, [])
, reqContentLength = Just . fromIntegral . L8.length $ body }
mkRequestToAbsUri :: Monad m => L -> S -> m (HttpReq ())
mkRequestToAbsUri urlString method = do
(scheme, host, mport, path, query) <- enumPure urlString |$ absUri
return defaultHttpReq { reqScheme = scheme
, reqMethod = method
, reqPath = path
, reqPathLst = path2list path
, reqQuery = query
, reqHost = host
, reqPort = mport
, reqContentLength = Just 0
, reqVers = (1,1)
, reqHeaders = [hostHeader host, uaHeader]
}
where uaHeader = (S8.pack "User-Agent", S8.pack userAgent)
hostHeader host = (S8.pack "Host", host)
type HttpResponseHandler m s =
HttpResp m -> Iter L m (Maybe (HttpReq s, L))
inumHttpClient :: MonadIO m
=> (HttpReq s, L)
-> HttpResponseHandler m s -> Inum L L m a
inumHttpClient (req,body) respHandler = mkInumM $
tryI (irun $ enumHttpReq req body) >>=
either (fatal . fst) (const loop)
where loop = do eof <- atEOFI
unless eof doresp
doresp = do
resp <- liftI $ httpRespI
mreq <- catchI (liftI $ respHandler resp) errH
maybe (return ())
(\(req', body') ->
tryI (irun $ enumHttpReq req' body') >>=
either (fatal . fst) (const loop)) mreq
fatal (SomeException _) = return ()
errH (SomeException _) = return . return $ Nothing