module Thrift.Transport.HttpClient
( module Thrift.Transport
, HttpClient (..)
, openHttpClient
) where
import Thrift.Transport
import Network.URI
import Network.HTTP hiding (port, host)
import Control.Monad (liftM)
import Data.Maybe (fromJust)
import Data.Monoid (mappend, mempty)
import Control.Exception (throw)
import Control.Concurrent.MVar
import qualified Data.Binary.Builder as B
import qualified Data.ByteString.Lazy as LBS
data HttpClient =
HttpClient {
hstream :: HandleStream LBS.ByteString,
uri :: URI,
writeBuffer :: WriteBuffer,
readBuffer :: ReadBuffer
}
uriAuth :: URI -> URIAuth
uriAuth = fromJust . uriAuthority
host :: URI -> String
host = uriRegName . uriAuth
port :: URI -> Int
port uri_ =
if portStr == mempty then
httpPort
else
read portStr
where
portStr = dropWhile (== ':') $ uriPort $ uriAuth uri_
httpPort = 80
openHttpClient :: URI -> IO HttpClient
openHttpClient uri_ = do
stream <- openTCPConnection (host uri_) (port uri_)
wbuf <- newWriteBuffer
rbuf <- newReadBuffer
return $ HttpClient stream uri_ wbuf rbuf
instance Transport HttpClient where
tClose = close . hstream
tRead hclient n = readBuf (readBuffer hclient) n
tWrite hclient = writeBuf (writeBuffer hclient)
tFlush hclient = do
body <- flushBuf $ writeBuffer hclient
let request = Request {
rqURI = uri hclient,
rqHeaders = [
mkHeader HdrContentType "application/x-thrift",
mkHeader HdrContentLength $ show $ LBS.length body],
rqMethod = POST,
rqBody = body
}
res <- sendHTTP (hstream hclient) request
case res of
Right response -> do
fillBuf (readBuffer hclient) (rspBody response)
Left _ -> do
throw $ TransportExn "THttpConnection: HTTP failure from server" TE_UNKNOWN
return ()
tIsOpen _ = return True
type WriteBuffer = MVar (B.Builder)
newWriteBuffer :: IO WriteBuffer
newWriteBuffer = newMVar mempty
writeBuf :: WriteBuffer -> LBS.ByteString -> IO ()
writeBuf w s = modifyMVar_ w $ return . (\builder ->
builder `mappend` (B.fromLazyByteString s))
flushBuf :: WriteBuffer -> IO (LBS.ByteString)
flushBuf w = B.toLazyByteString `liftM` swapMVar w mempty
type ReadBuffer = MVar (LBS.ByteString)
newReadBuffer :: IO ReadBuffer
newReadBuffer = newMVar mempty
fillBuf :: ReadBuffer -> LBS.ByteString -> IO ()
fillBuf r s = swapMVar r s >> return ()
readBuf :: ReadBuffer -> Int -> IO (LBS.ByteString)
readBuf r n = modifyMVar r $ return . flipPair . LBS.splitAt (fromIntegral n)
where flipPair (a, b) = (b, a)