THRIFT-3580 THeader for Haskell

Client: hs

This closes #820
This closes #1423

4 files changed, 21 insertions, 5 deletions

diff --git a/test/hs/TestClient.hs b/test/hs/TestClient.hs
index d1ebb3cd0..93fb591b3 100644
--- a/test/hs/TestClient.hs
+++ b/test/hs/TestClient.hs
@@ -46,6 +46,7 @@ import Thrift.Transport.HttpClient
 import Thrift.Protocol
 import Thrift.Protocol.Binary
 import Thrift.Protocol.Compact
+import Thrift.Protocol.Header
 import Thrift.Protocol.JSON
 
 data Options = Options
@@ -85,12 +86,14 @@ getTransport t host port = do return (NoTransport $ "Unsupported transport: " ++
 data ProtocolType = Binary
                   | Compact
                   | JSON
+                  | Header
                   deriving (Show, Eq)
 
 getProtocol :: String -> ProtocolType
 getProtocol "binary"  = Binary
 getProtocol "compact" = Compact
 getProtocol "json"    = JSON
+getProtocol "header" = Header
 getProtocol p = error $ "Unsupported Protocol: " ++ p
 
 defaultOptions :: Options
@@ -104,7 +107,7 @@ defaultOptions = Options
   , testLoops    = 1
   }
 
-runClient :: (Protocol p, Transport t) => p t -> IO ()
+runClient :: Protocol p => p -> IO ()
 runClient p = do
   let prot = (p,p)
   putStrLn "Starting Tests"
@@ -266,6 +269,7 @@ main = do
                        Binary  -> runClient $ BinaryProtocol t
                        Compact -> runClient $ CompactProtocol t
                        JSON    -> runClient $ JSONProtocol t
+                       Header  -> createHeaderProtocol t t >>= runClient
     runTest loops p t = do
       let client = makeClient p t
       replicateM_ loops client
diff --git a/test/hs/TestServer.hs b/test/hs/TestServer.hs
index 4a88649b8..b7731ab1c 100644
--- a/test/hs/TestServer.hs
+++ b/test/hs/TestServer.hs
@@ -48,6 +48,7 @@ import Thrift.Transport.Framed
 import Thrift.Transport.Handle
 import Thrift.Protocol.Binary
 import Thrift.Protocol.Compact
+import Thrift.Protocol.Header
 import Thrift.Protocol.JSON
 
 data Options = Options
@@ -90,11 +91,13 @@ getTransport t = NoTransport $ "Unsupported transport: " ++ t
 data ProtocolType = Binary
                   | Compact
                   | JSON
+                  | Header
 
 getProtocol :: String -> ProtocolType
 getProtocol "binary"  = Binary
 getProtocol "compact" = Compact
 getProtocol "json"    = JSON
+getProtocol "header"  = Header
 getProtocol p = error $"Unsupported Protocol: " ++ p
 
 defaultOptions :: Options
@@ -261,13 +264,19 @@ main = do
           t <- f socket
           return (p t, p t)
 
+        headerAcceptor f socket = do
+          t <- f socket
+          p <- createHeaderProtocol1 t
+          return (p, p)
+
         doRunServer p f = do
           runThreadedServer (acceptor p f) TestHandler ThriftTest.process . PortNumber . fromIntegral
 
         runServer p f port = case p of
-          Binary  -> do doRunServer BinaryProtocol f port
-          Compact -> do doRunServer CompactProtocol f port
-          JSON    -> do doRunServer JSONProtocol f port
+          Binary  -> doRunServer BinaryProtocol f port
+          Compact -> doRunServer CompactProtocol f port
+          JSON    -> doRunServer JSONProtocol f port
+          Header  -> runThreadedServer (headerAcceptor f) TestHandler ThriftTest.process (PortNumber $ fromIntegral port)
 
 parseFlags :: [String] -> Options -> Maybe Options
 parseFlags (flag : flags) opts = do
diff --git a/test/known_failures_Linux.json b/test/known_failures_Linux.json
index c96198808..754535f12 100644
--- a/test/known_failures_Linux.json
+++ b/test/known_failures_Linux.json
@@ -229,6 +229,8 @@
   "go-java_json_http-ip",
   "go-java_json_http-ip-ssl",
   "go-nodejs_json_framed-ip",
+  "hs-csharp_binary_framed-ip",
+  "hs-csharp_compact_framed-ip",
   "hs-dart_binary_framed-ip",
   "hs-dart_compact_framed-ip",
   "hs-dart_json_framed-ip",
@@ -331,4 +333,4 @@
   "rs-dart_compact_framed-ip",
   "rs-dart_multi-binary_framed-ip",
   "rs-dart_multic-compact_framed-ip"
-]
\ No newline at end of file
+]
diff --git a/test/tests.json b/test/tests.json
index 35d0a6cc1..c4e07eefb 100644
--- a/test/tests.json
+++ b/test/tests.json
@@ -216,6 +216,7 @@
       "ip"
     ],
     "protocols": [
+      "header",
       "compact",
       "binary",
       "json"