Merge pull request #154 from krdlab/feature/add-haskell-rpc-example

michaelklishin · web-flow · commit a2da52fbdbe5 · 2018-01-23T08:32:36.000+03:00
Add Haskell RPC example
diff --git a/haskell/README.md b/haskell/README.md
@@ -43,6 +43,7 @@ Code examples are executed via `runhaskell`:
 
 [Tutorial six: RPC](http://www.rabbitmq.com/tutorial-six-python.html)
 
-    TBD
+    runhaskell rpcServer.hs
+    runhaskell rpcClient.hs
 
 To learn more, see [Network.AMQP](https://github.com/hreinhardt/amqp).
diff --git a/haskell/rpcClient.hs b/haskell/rpcClient.hs
@@ -0,0 +1,57 @@
+#!/usr/bin/env stack
+-- stack --install-ghc runghc --package bytestring --package text --package amqp --package uuid
+{-# LANGUAGE OverloadedStrings #-}
+
+import           Control.Concurrent         (MVar, newEmptyMVar, putMVar,
+                                             takeMVar)
+import           Control.Monad              (when)
+import qualified Data.ByteString.Lazy.Char8 as BL
+import           Data.Maybe                 (fromJust)
+import           Data.Text                  (Text)
+import           Data.UUID                  (toText)
+import           Data.UUID.V4               (nextRandom)
+import           Network.AMQP
+
+type QueueName = Text
+
+main :: IO ()
+main = do
+    conn <- openConnection "127.0.0.1" "/" "guest" "guest"
+    ch   <- openChannel conn
+
+    putStrLn " [x] Requesting fib(30)"
+    res <- callFib ch rpcQueue 30
+    putStrLn $ " [.] Got '" ++ show res ++ "'"
+
+    closeConnection conn
+  where
+    rpcQueue = "rpc_queue"
+
+callFib :: Channel -> QueueName -> Int -> IO Int
+callFib ch queue n = do
+    cid <- genCorrelationId
+    rqn <- declareReplyQueue
+
+    let body = BL.pack . show $ n
+    let message = newMsg {msgCorrelationID = Just cid, msgReplyTo = Just rqn, msgBody = body}
+    publishMsg ch "" queue message
+
+    m <- newEmptyMVar
+    consumeMsgs ch rqn Ack $ handleResponse cid m
+
+    res <- takeMVar m
+    return res
+  where
+    genCorrelationId = toText <$> nextRandom
+    declareReplyQueue = do
+        let opts = newQueue {queueAutoDelete = True, queueExclusive = True}
+        (rqn, _, _) <- declareQueue ch opts
+        return rqn
+
+handleResponse :: Text -> MVar Int -> (Message, Envelope) -> IO ()
+handleResponse corrId m (msg, envelope) = do
+    let msgCorrId = fromJust (msgCorrelationID msg)
+    when (msgCorrId == corrId) $ do
+        res <- readIO (BL.unpack . msgBody $ msg)
+        putMVar m res
+        ackEnv envelope
diff --git a/haskell/rpcServer.hs b/haskell/rpcServer.hs
@@ -0,0 +1,47 @@
+#!/usr/bin/env stack
+-- stack --install-ghc runghc --package bytestring --package text --package amqp
+{-# LANGUAGE OverloadedStrings #-}
+
+import           Control.Concurrent         (MVar, newEmptyMVar, putMVar,
+                                             takeMVar)
+import qualified Data.ByteString.Lazy.Char8 as BL
+import           Data.Maybe                 (fromJust)
+import           Network.AMQP
+
+main :: IO ()
+main = do
+    conn  <- openConnection "127.0.0.1" "/" "guest" "guest"
+    ch    <- openChannel conn
+
+    qos ch 0 1 False
+    declareQueue ch newQueue {queueName = rpcQueue}
+
+    m <- newEmptyMVar
+    consumeMsgs ch rpcQueue Ack $ handleRequest ch m
+    putStrLn " [x] Awaiting RPC requests"
+    takeMVar m
+
+    closeConnection conn
+  where
+    rpcQueue = "rpc_queue"
+
+handleRequest :: Channel -> MVar () -> (Message, Envelope) -> IO ()
+handleRequest ch m (msg, envelope) = do
+    n <- readIO . BL.unpack . msgBody $ msg
+    putStrLn $ " [.] fib(" ++ show n ++ ")"
+
+    let result = fib n
+    let response = newMsg { msgCorrelationID = msgCorrelationID msg
+                          , msgBody = BL.pack . show $ result
+                          }
+    publishMsg ch "" replyTo response
+    ackEnv envelope
+    putMVar m ()
+  where
+    replyTo = fromJust $ msgReplyTo msg
+
+fib :: Int -> Int
+fib n
+    | n >= 2    = fib (n - 1) + fib (n - 2)
+    | n == 1    = 1
+    | otherwise = 0
