1{-# LANGUAGE FlexibleInstances #-} 2-- 3-- Licensed to the Apache Software Foundation (ASF) under one 4-- or more contributor license agreements. See the NOTICE file 5-- distributed with this work for additional information 6-- regarding copyright ownership. The ASF licenses this file 7-- to you under the Apache License, Version 2.0 (the 8-- "License"); you may not use this file except in compliance 9-- with the License. You may obtain a copy of the License at 10-- 11-- http://www.apache.org/licenses/LICENSE-2.0 12-- 13-- Unless required by applicable law or agreed to in writing, 14-- software distributed under the License is distributed on an 15-- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 16-- KIND, either express or implied. See the License for the 17-- specific language governing permissions and limitations 18-- under the License. 19-- 20 21module Thrift.Transport.HttpClient 22 ( module Thrift.Transport 23 , HttpClient (..) 24 , openHttpClient 25) where 26 27import Thrift.Transport 28import Thrift.Transport.IOBuffer 29import Network.URI 30import Network.HTTP hiding (port, host) 31 32import Data.Maybe (fromJust) 33import Data.Monoid (mempty) 34import Control.Exception (throw) 35import qualified Data.ByteString.Lazy as LBS 36 37 38-- | 'HttpClient', or THttpClient implements the Thrift Transport 39-- | Layer over http or https. 40data HttpClient = 41 HttpClient { 42 hstream :: HandleStream LBS.ByteString, 43 uri :: URI, 44 writeBuffer :: WriteBuffer, 45 readBuffer :: ReadBuffer 46 } 47 48uriAuth :: URI -> URIAuth 49uriAuth = fromJust . uriAuthority 50 51host :: URI -> String 52host = uriRegName . uriAuth 53 54port :: URI -> Int 55port uri_ = 56 if portStr == mempty then 57 httpPort 58 else 59 read portStr 60 where 61 portStr = dropWhile (== ':') $ uriPort $ uriAuth uri_ 62 httpPort = 80 63 64-- | Use 'openHttpClient' to create an HttpClient connected to @uri@ 65openHttpClient :: URI -> IO HttpClient 66openHttpClient uri_ = do 67 stream <- openTCPConnection (host uri_) (port uri_) 68 wbuf <- newWriteBuffer 69 rbuf <- newReadBuffer 70 return $ HttpClient stream uri_ wbuf rbuf 71 72instance Transport HttpClient where 73 74 tClose = close . hstream 75 76 tPeek = peekBuf . readBuffer 77 78 tRead = readBuf . readBuffer 79 80 tWrite = writeBuf . writeBuffer 81 82 tFlush hclient = do 83 body <- flushBuf $ writeBuffer hclient 84 let request = Request { 85 rqURI = uri hclient, 86 rqHeaders = [ 87 mkHeader HdrContentType "application/x-thrift", 88 mkHeader HdrContentLength $ show $ LBS.length body], 89 rqMethod = POST, 90 rqBody = body 91 } 92 93 res <- sendHTTP (hstream hclient) request 94 case res of 95 Right response -> 96 fillBuf (readBuffer hclient) (rspBody response) 97 Left _ -> 98 throw $ TransportExn "THttpConnection: HTTP failure from server" TE_UNKNOWN 99 return () 100 101 tIsOpen _ = return True 102