module Thrift.Transport.HttpClient
( module Thrift.Transport
, HttpClient (..)
, openHttpClient
) where
import Thrift.Transport
import Network.URI
import Network.HTTP hiding (port, host)
import Network.TCP
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.Char8 as LBS
data HttpClient =
HttpClient {
hstream :: HandleStream LBS.ByteString,
uri :: URI,
writeBuffer :: WriteBuffer,
readBuffer :: ReadBuffer
}
uriAuth = fromJust . uriAuthority
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 res -> do
fillBuf (readBuffer hclient) (rspBody res)
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)