THRIFT-560. haskell: Add THttpClient
git-svn-id: https://svn.apache.org/repos/asf/incubator/thrift/trunk@898013 13f79535-47bb-0310-9956-ffa450edef68
diff --git a/lib/hs/src/Thrift/Transport/HttpClient.hs b/lib/hs/src/Thrift/Transport/HttpClient.hs
new file mode 100644
index 0000000..2268261
--- /dev/null
+++ b/lib/hs/src/Thrift/Transport/HttpClient.hs
@@ -0,0 +1,124 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you under the Apache License, Version 2.0 (the
+-- "License"); you may not use this file except in compliance
+-- with the License. You may obtain a copy of the License at
+--
+-- http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing,
+-- software distributed under the License is distributed on an
+-- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+-- KIND, either express or implied. See the License for the
+-- specific language governing permissions and limitations
+-- under the License.
+--
+
+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
+
+
+-- | 'HttpClient', or THttpClient implements the Thrift Transport
+-- | Layer over http or https.
+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
+
+-- | Use 'openHttpClient' to create an HttpClient connected to @uri@
+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
+-- Mini IO buffers
+
+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)