diff --git a/IHaskell/Message/BodyParser.hs b/IHaskell/Message/BodyParser.hs new file mode 100644 index 00000000..bc60e086 --- /dev/null +++ b/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 = [] + } diff --git a/IHaskell/Message/Parser.hs b/IHaskell/Message/Parser.hs new file mode 100644 index 00000000..6d8ef894 --- /dev/null +++ b/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) diff --git a/IHaskell/Message/Writer.hs b/IHaskell/Message/Writer.hs new file mode 100644 index 00000000..a5adb2fb --- /dev/null +++ b/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