Thrift 0.1.0 → 0.1.1

raw patch · 9 files changed

+175/−26 lines, 9 filesdep +HTTPdep +binarydep +bytestringsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: HTTP, binary, bytestring

API changes (from Hackage documentation)

Files

• Setup.hs +0/−3
• Thrift.cabal +25/−5
• import +0/−0
• main +0/−0
• src/Thrift.hs +0/−1
• src/Thrift/Protocol/Binary.hs +13/−8
• src/Thrift/Transport.hs +8/−6
• src/Thrift/Transport/Handle.hs +5/−3
• src/Thrift/Transport/HttpClient.hs +124/−0

@@ -1,3 +0,0 @@--import Distribution.Simple-main = defaultMain

@@ -1,6 +1,25 @@+--+-- 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.+--+ Name:           Thrift-Version:        0.1.0-Cabal-Version:  >= 1.4+Version:        0.1.1+Cabal-Version:  >= 1.2.3 License:        OtherLicense  Category:       Foreign Build-Type:     Simple@@ -8,18 +27,19 @@ homepage:       http://incubator.apache.org/thrift maintainer:     thrift-user-subscribe@incubator.apache.org  description:-  The Thrift Haskell package that shipped with Thrift v.0.2.0, released under the Apache 2.0 license.+  The Thrift Haskell package that shipped with Thrift v.0.3.0, released under the Apache 2.0 license.  + Library   Hs-Source-Dirs:     src   Build-Depends:-    base >= 4 && < 5, network, ghc-prim+    base >=4 && < 5, network, ghc-prim, binary, bytestring, HTTP   ghc-options:     -fglasgow-exts   Extensions:     DeriveDataTypeable   Exposed-Modules:     Thrift, Thrift.Protocol, Thrift.Transport, Thrift.Protocol.Binary-    Thrift.Transport.Handle, Thrift.Server+    Thrift.Transport.Handle, Thrift.Transport.HttpClient,  Thrift.Server

@@ -90,7 +90,6 @@     readStructEnd pt     return r -readAppExnFields :: (Protocol p, Transport t) => p t -> AppExn -> IO AppExn readAppExnFields pt r = do     (n, ft, id) <- readFieldBegin pt     if ft == T_STOP

@@ -23,6 +23,7 @@     ) where  import Control.Exception ( throw )+import Control.Monad ( liftM )  import Data.Bits import Data.Int@@ -34,6 +35,7 @@ import Thrift.Protocol import Thrift.Transport +import qualified Data.ByteString.Lazy.Char8 as LBS  version_mask = 0xffff0000 version_1    = 0x80010000@@ -62,13 +64,13 @@     writeSetBegin p (t, n) = writeType p t >> writeI32 p n     writeSetEnd _ = return () -    writeBool p b = tWrite (getTransport p) [toEnum $ if b then 1 else 0]+    writeBool p b = tWrite (getTransport p) $ LBS.singleton $ toEnum $ if b then 1 else 0     writeByte p b = tWrite (getTransport p) (getBytes b 1)     writeI16 p b = tWrite (getTransport p) (getBytes b 2)     writeI32 p b = tWrite (getTransport p) (getBytes b 4)     writeI64 p b = tWrite (getTransport p) (getBytes b 8)     writeDouble p d = writeI64 p (fromIntegral $ floatBits d)-    writeString p s = writeI32 p (length s) >> tWrite (getTransport p) s+    writeString p s = writeI32 p (length s) >> tWrite (getTransport p) (LBS.pack s)     writeBinary = writeString      readMessageBegin p = do@@ -116,7 +118,10 @@     readDouble p = do         bs <- readI64 p         return $ floatOfBits $ fromIntegral bs-    readString p = readI32 p >>= tReadAll (getTransport p)+    readString p = do+        i <- readI32 p+        LBS.unpack `liftM` tReadAll (getTransport p) i+     readBinary = readString  @@ -128,16 +133,16 @@ readType :: (Protocol p, Transport t) => p t -> IO ThriftType readType p = toEnum `fmap` readByte p -composeBytes :: (Bits b, Enum t) => [t] -> b-composeBytes = (foldl' fn 0) . (map $ fromIntegral . fromEnum)+composeBytes :: (Bits b) => LBS.ByteString -> b+composeBytes = (foldl' fn 0) . (map (fromIntegral . fromEnum)) . LBS.unpack     where fn acc b = (acc `shiftL` 8) .|. b  getByte :: Bits a => a -> Int -> a getByte i n = 255 .&. (i `shiftR` (8 * n)) -getBytes :: (Bits a, Integral a) => a -> Int -> String-getBytes i 0 = []-getBytes i n = (toEnum $ fromIntegral $ getByte i (n-1)):(getBytes i (n-1))+getBytes :: (Bits a, Integral a) => a -> Int -> LBS.ByteString+getBytes i 0 = LBS.empty+getBytes i n = (toEnum $ fromIntegral $ getByte i (n-1)) `LBS.cons` (getBytes i (n-1))  floatBits :: Double -> Word64 floatBits (D# d#) = W64# (unsafeCoerce# d#)

@@ -28,23 +28,25 @@  import Data.Typeable ( Typeable ) +import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Monoid  class Transport a where     tIsOpen :: a -> IO Bool     tClose  :: a -> IO ()-    tRead   :: a -> Int -> IO String-    tWrite  :: a -> String ->IO ()+    tRead   :: a -> Int -> IO LBS.ByteString+    tWrite  :: a -> LBS.ByteString -> IO ()     tFlush  :: a -> IO ()-    tReadAll :: a -> Int -> IO String+    tReadAll :: a -> Int -> IO LBS.ByteString -    tReadAll a 0 = return []+    tReadAll a 0 = return mempty     tReadAll a len = do         result <- tRead a len-        let rlen = length result+        let rlen = fromIntegral $ LBS.length result         when (rlen == 0) (throw $ TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN)         if len <= rlen             then return result-            else (result ++) `fmap` (tReadAll a (len - rlen))+            else (result `mappend`) `fmap` (tReadAll a (len - rlen))  data TransportExn = TransportExn String TransportExnType   deriving ( Show, Typeable )

@@ -32,12 +32,14 @@  import Thrift.Transport +import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Monoid  instance Transport Handle where     tIsOpen = hIsOpen     tClose h    = hClose h-    tRead  h n  = replicateM n (hGetChar h) `catch` handleEOF-    tWrite h s  = mapM_ (hPutChar h) s+    tRead  h n  = LBS.hGet h n `catch` handleEOF+    tWrite h s  = LBS.hPut h s     tFlush = hFlush  @@ -54,5 +56,5 @@   handleEOF e = if isEOFError e-    then return []+    then return mempty     else throw $ TransportExn "TChannelTransport: Could not read" TE_UNKNOWN

@@ -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)