adding message directory

IHaskell/Message/BodyParser.hs

@@ -0,0 +1,46 @@
+-- | This module provides parsers for message bodies for
+-- @IHaskell.Message.Parser@, and should not be used elsewhere. The
+-- 'header' field on all these messages is initialized to 'undefined' and
+-- is inserted afterwards.
+module IHaskell.Message.BodyParser (
+  kernelInfoRequestParser,
+  executeRequestParser
+)  where
+
+import BasicPrelude
+import Data.Aeson
+import Data.Aeson.Types (parse)
+
+import IHaskell.Types
+
+-- | Parse a kernel info request.
+-- A kernel info request has no auxiliary information, so ignore the body.
+kernelInfoRequestParser :: LByteString -> Message
+kernelInfoRequestParser _ = KernelInfoRequest { header = undefined }
+
+-- | Parse an execute request.
+-- Fields used are:
+--  1. "code": the code to execute.
+--  2. "silent": whether to execute silently.
+--  3. "store_history": whether to include this in history.
+--  4. "allow_stdin": whether to allow reading from stdin for this code.
+executeRequestParser :: LByteString -> Message
+executeRequestParser content = 
+  let parser obj = do
+        code <- obj .: "code"
+        silent <- obj .: "silent"
+        storeHistory <- obj .: "store_history"
+        allowStdin <- obj .: "allow_stdin"
+
+        return (code, silent, storeHistory, allowStdin)
+      Just decoded = decode content
+      Success (code, silent, storeHistory, allowStdin) = parse parser decoded in
+    ExecuteRequest {
+      header = undefined,
+      getCode = code,
+      getSilent = silent,
+      getAllowStdin = allowStdin,
+      getStoreHistory = storeHistory,
+      getUserVariables = [],
+      getUserExpressions = []
+    }

IHaskell/Message/Parser.hs

@@ -0,0 +1,72 @@
+-- | This module is responsible for converting from low-level ByteStrings
+-- | obtained from the 0MQ sockets into Messages. The only exposed function is
+-- | `parseMessage`, which should only be used in the low-level 0MQ interface.
+module IHaskell.Message.Parser (parseMessage) where
+
+import BasicPrelude
+import Data.Aeson ((.:), decode, Result(..), Object)
+import Data.Aeson.Types (parse)
+
+import qualified Data.ByteString.Lazy as Lazy
+
+import IHaskell.Types
+import IHaskell.Message.BodyParser
+
+----- External interface -----
+
+-- | Parse a message from its ByteString components into a Message.
+parseMessage :: [ByteString] -- ^ The list of identifiers sent with the message.
+             -> ByteString   -- ^ The header data.
+             -> ByteString   -- ^ The parent header, which is just "{}" if there is no header.
+             -> ByteString   -- ^ The metadata map, also "{}" for an empty map.
+             -> ByteString   -- ^ The message content.
+             -> Message      -- ^ A parsed message.
+parseMessage idents headerData parentHeader metadata content = 
+  let header = parseHeader idents headerData parentHeader metadata
+      messageType = msgType header in
+    (parser messageType $ Lazy.fromStrict content) {
+      header = header                      
+    }
+
+----- Module internals -----
+
+-- | Parse a header from its ByteString components into a MessageHeader.
+parseHeader :: [ByteString]  -- ^ The list of identifiers.
+            -> ByteString    -- ^ The header data.
+            -> ByteString    -- ^ The parent header, or "{}" for Nothing.
+            -> ByteString    -- ^ The metadata, or "{}" for an empty map.
+            -> MessageHeader -- The resulting message header.
+parseHeader idents headerData parentHeader metadata = MessageHeader {
+  identifiers = idents,
+  parentHeader = parentResult,
+  metadata = metadataMap,
+  messageId = messageUUID,
+  sessionId = sessionUUID,
+  username = username,
+  msgType = messageType
+  } where
+      -- Decode the header data and the parent header data into JSON objects.
+      -- If the parent header data is absent, just have Nothing instead.
+      Just result = decode $ Lazy.fromStrict headerData :: Maybe Object
+      parentResult = if parentHeader == "{}"
+                     then Nothing
+                     else Just $ parseHeader idents parentHeader "{}" metadata
+
+      -- Get the basic fields from the header.
+      Success (messageType, username, messageUUID, sessionUUID) = flip parse result $ \obj -> do 
+        messType <- obj .: "msg_type"
+        username <- obj .: "username"
+        message <- obj .: "msg_id"
+        session <- obj .: "session"
+        return (messType, username, message, session)
+
+      -- Get metadata as a simple map.
+      Just metadataMap = decode $ Lazy.fromStrict metadata :: Maybe (Map ByteString ByteString)
+
+parser :: MessageType            -- ^ The message type being parsed.
+      -> LByteString -> Message   -- The parser that converts the body into a message.
+                                -- This message should have an undefined
+                                -- header.
+parser "kernel_info_request"  = kernelInfoRequestParser
+parser "execute_request"      = executeRequestParser
+parser other = error $ "Unknown message type " ++ textToString (show other)

IHaskell/Message/Writer.hs

@@ -0,0 +1,50 @@
+-- | This module contains the @ToJSON@ instance for @Message@.
+module IHaskell.Message.Writer (
+  ToJSON(..)
+)  where
+
+import BasicPrelude
+import Data.Aeson
+import Data.Map (fromList)
+
+import IHaskell.Types
+
+-- Convert message bodies into JSON.
+instance ToJSON Message where
+  toJSON KernelInfoReply{} = object [
+                             "protocol_version" .= ints [4, 0], -- current protocol version, major and minor
+                             "language_version" .= ints [7, 6, 2],
+                             "language" .= string "haskell"
+                           ]
+
+  toJSON ExecuteReply{ status = status, executionCounter = counter} = object [
+                             "status" .= status,
+                             "execution_count" .= counter,
+                             "payload" .= emptyList,
+                             "user_variables" .= emptyMap,
+                             "user_expressions" .= emptyMap
+                           ]
+  toJSON IopubStatus{ executionState = executionState } = object [
+                             "execution_state" .= executionState
+                           ]
+
+  toJSON body = error $ "Do not know how to convert to JSON for message " ++ textToString (show body)
+
+instance ToJSON ExecutionState where
+    toJSON Busy = String "busy"
+    toJSON Idle = String "idle"
+    toJSON Starting = String "starting"
+
+----- Constants -----
+
+emptyMap :: Map String String
+emptyMap = fromList []
+
+emptyList :: [Int]
+emptyList = []
+
+ints :: [Int] -> [Int]
+ints = id
+
+string :: String -> String
+string = id