From 196ccac96d6164637d830c7afc9c6dcb13b9db4b Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Sat, 1 Sep 2018 10:33:19 +1000 Subject: [PATCH] ipython-kernel: Switch on -Wall and fix all warnings Fixing these warnings required changes to the file names of the `MessageHeader` struct which makes this commit an API change. The version in the cabal file has been bumped accordingly. --- ipython-kernel/ipython-kernel.cabal | 6 +- .../src/IHaskell/IPython/EasyKernel.hs | 45 ++-- ipython-kernel/src/IHaskell/IPython/Kernel.hs | 1 - .../src/IHaskell/IPython/Message/Parser.hs | 21 +- .../src/IHaskell/IPython/Message/UUID.hs | 2 +- .../src/IHaskell/IPython/Message/Writer.hs | 199 --------------- ipython-kernel/src/IHaskell/IPython/Types.hs | 230 ++++++++++++++++-- ipython-kernel/src/IHaskell/IPython/ZeroMQ.hs | 124 +++++----- main/Main.hs | 20 +- src/IHaskell/IPython/Stdin.hs | 12 +- src/IHaskell/Types.hs | 4 +- 11 files changed, 306 insertions(+), 358 deletions(-) delete mode 100644 ipython-kernel/src/IHaskell/IPython/Message/Writer.hs diff --git a/ipython-kernel/ipython-kernel.cabal b/ipython-kernel/ipython-kernel.cabal index ed25dd09..a0e6e501 100644 --- a/ipython-kernel/ipython-kernel.cabal +++ b/ipython-kernel/ipython-kernel.cabal @@ -1,5 +1,5 @@ name: ipython-kernel -version: 0.9.1.0 +version: 0.10.0.0 synopsis: A library for creating kernels for IPython frontends description: ipython-kernel is a library for communicating with frontends for the interactive IPython framework. It is used extensively in IHaskell, the interactive Haskell environment. @@ -24,10 +24,11 @@ flag examples library + ghc-options: -Wall + exposed-modules: IHaskell.IPython.Kernel IHaskell.IPython.Types IHaskell.IPython.ZeroMQ - IHaskell.IPython.Message.Writer IHaskell.IPython.Message.Parser IHaskell.IPython.Message.UUID IHaskell.IPython.EasyKernel @@ -38,6 +39,7 @@ library aeson , bytestring , cereal , + cereal-text , containers , cryptonite , directory , diff --git a/ipython-kernel/src/IHaskell/IPython/EasyKernel.hs b/ipython-kernel/src/IHaskell/IPython/EasyKernel.hs index c50cb9d7..3c2cd044 100644 --- a/ipython-kernel/src/IHaskell/IPython/EasyKernel.hs +++ b/ipython-kernel/src/IHaskell/IPython/EasyKernel.hs @@ -23,7 +23,7 @@ -- logos, help text, and so forth. module IHaskell.IPython.EasyKernel (easyKernel, installKernelspec, KernelConfig(..)) where -import Data.Aeson (decode, encode) +import Data.Aeson (decode, encode, toJSON) import qualified Data.ByteString.Lazy as BL @@ -32,7 +32,7 @@ import System.Process (rawSystem) import Control.Concurrent (MVar, readChan, writeChan, newMVar, readMVar, modifyMVar_) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (forever, when, unless, void) +import Control.Monad (forever, when, void) import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -40,10 +40,8 @@ import qualified Data.Text as T import IHaskell.IPython.Kernel import IHaskell.IPython.Message.UUID as UUID -import IHaskell.IPython.Types -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, - getHomeDirectory, getTemporaryDirectory) +import System.Directory (createDirectoryIfMissing, getTemporaryDirectory) import System.FilePath (()) import System.Exit (exitSuccess) import System.IO (openFile, IOMode(ReadMode)) @@ -53,7 +51,7 @@ import System.IO (openFile, IOMode(ReadMode)) -- running cells, and the type of final results of cells, respectively. data KernelConfig m output result = KernelConfig - { + { -- | Info on the language of the kernel. kernelLanguageInfo :: LanguageInfo -- | Write all the files into the kernel directory, including `kernel.js`, `logo-64x64.svg`, and any @@ -122,19 +120,12 @@ createReplyHeader :: MonadIO m => MessageHeader -> m MessageHeader createReplyHeader parent = do -- Generate a new message UUID. newMessageId <- liftIO UUID.random - let repType = fromMaybe err (replyType $ msgType parent) - err = error $ "No reply for message " ++ show (msgType parent) + let repType = fromMaybe err (replyType $ mhMsgType parent) + err = error $ "No reply for message " ++ show (mhMsgType parent) + + return $ MessageHeader (mhIdentifiers parent) (Just parent) (Map.fromList []) + newMessageId (mhSessionId parent) (mhUsername parent) repType - return - MessageHeader - { identifiers = identifiers parent - , parentHeader = Just parent - , metadata = Map.fromList [] - , messageId = newMessageId - , sessionId = sessionId parent - , username = username parent - , msgType = repType - } -- | Execute an IPython kernel for a config. Your 'main' action should call this as the last thing -- it does. @@ -145,16 +136,14 @@ easyKernel :: MonadIO m -> m () easyKernel profileFile config = do prof <- liftIO $ getProfile profileFile - zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan _) <- liftIO $ serveProfile - prof - False + zmq <- liftIO $ serveProfile prof False execCount <- liftIO $ newMVar 0 forever $ do - req <- liftIO $ readChan shellReqChan + req <- liftIO $ readChan (shellRequestChannel zmq) repHeader <- createReplyHeader (header req) when (debug config) . liftIO $ print req reply <- replyTo config execCount zmq req repHeader - liftIO $ writeChan shellRepChan reply + liftIO $ writeChan (shellRequestChannel zmq) reply replyTo :: MonadIO m => KernelConfig m output result @@ -180,17 +169,17 @@ replyTo config _ interface KernelInfoRequest{} replyHeader = do , status = Ok } -replyTo config _ _ CommInfoRequest{} replyHeader = +replyTo _ _ _ CommInfoRequest{} replyHeader = return CommInfoReply { header = replyHeader , commInfo = Map.empty } -replyTo config _ interface ShutdownRequest { restartPending = pending } replyHeader = do +replyTo _ _ interface ShutdownRequest { restartPending = pending } replyHeader = do liftIO $ writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader pending liftIO exitSuccess -replyTo config execCount interface req@ExecuteRequest { getCode = code } replyHeader = do +replyTo config execCount interface req@ExecuteRequest{} replyHeader = do let send = writeChan (iopubChannel interface) busyHeader <- dupHeader replyHeader StatusMessage @@ -205,7 +194,7 @@ replyTo config execCount interface req@ExecuteRequest { getCode = code } replyHe send $ PublishDisplayData outputHeader (displayOutput config x) - in run config code clearOutput sendOutput + in run config (getCode req) clearOutput sendOutput liftIO . send $ PublishDisplayData outputHeader (displayResult config res) @@ -254,4 +243,4 @@ dupHeader :: MonadIO m => MessageHeader -> MessageType -> m MessageHeader dupHeader hdr mtype = do uuid <- liftIO UUID.random - return hdr { messageId = uuid, msgType = mtype } + return hdr { mhMessageId = uuid, mhMsgType = mtype } diff --git a/ipython-kernel/src/IHaskell/IPython/Kernel.hs b/ipython-kernel/src/IHaskell/IPython/Kernel.hs index 97e35e9b..a680dd8f 100644 --- a/ipython-kernel/src/IHaskell/IPython/Kernel.hs +++ b/ipython-kernel/src/IHaskell/IPython/Kernel.hs @@ -3,7 +3,6 @@ module IHaskell.IPython.Kernel (module X) where import IHaskell.IPython.Types as X -import IHaskell.IPython.Message.Writer as X import IHaskell.IPython.Message.Parser as X import IHaskell.IPython.Message.UUID as X import IHaskell.IPython.ZeroMQ as X diff --git a/ipython-kernel/src/IHaskell/IPython/Message/Parser.hs b/ipython-kernel/src/IHaskell/IPython/Message/Parser.hs index 69f27d79..6aa949d1 100644 --- a/ipython-kernel/src/IHaskell/IPython/Message/Parser.hs +++ b/ipython-kernel/src/IHaskell/IPython/Message/Parser.hs @@ -8,15 +8,14 @@ -- the low-level 0MQ interface. module IHaskell.IPython.Message.Parser (parseMessage) where -import Control.Applicative ((<|>), (<$>), (<*>)) -import Data.Aeson ((.:), (.:?), (.!=), decode, Result(..), Object, Value(..)) -import Data.Aeson.Types (parse, parseEither) +import Control.Applicative ((<$>), (<*>)) +import Data.Aeson ((.:), (.:?), (.!=), decode, FromJSON, Result(..), Object, Value(..)) +import Data.Aeson.Types (Parser, parse, parseEither) import Data.ByteString hiding (unpack) import qualified Data.ByteString.Lazy as Lazy import Data.HashMap.Strict as HM import Data.Map (Map) import Data.Maybe (fromMaybe) -import Data.Text (Text) import Data.Text (Text, unpack) import Debug.Trace import IHaskell.IPython.Types @@ -32,7 +31,7 @@ parseMessage :: [ByteString] -- ^ The list of identifiers sent with the message. -> Message -- ^ A parsed message. parseMessage idents headerData parentHeader metadata content = let header = parseHeader idents headerData parentHeader metadata - messageType = msgType header + messageType = mhMsgType header messageWithoutHeader = parser messageType $ Lazy.fromStrict content in messageWithoutHeader { header = header } @@ -43,15 +42,7 @@ parseHeader :: [ByteString] -- ^ The list of identifiers. -> 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 - } + MessageHeader idents parentResult metadataMap messageUUID sessionUUID username 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. @@ -180,6 +171,7 @@ displayDataParser = requestParser $ \obj -> do let displayDatas = makeDisplayDatas dataDict return $ PublishDisplayData noHeader displayDatas +requestParser :: FromJSON a => (a -> Parser Message) -> LByteString -> Message requestParser parser content = case parseEither parser decoded of Right parsed -> parsed @@ -218,6 +210,7 @@ inputMessageParser = requestParser $ \obj -> do executionCount <- obj .: "execution_count" return $ Input noHeader code executionCount +getDisplayDatas :: Maybe Object -> [DisplayData] getDisplayDatas Nothing = [] getDisplayDatas (Just dataDict) = makeDisplayDatas dataDict diff --git a/ipython-kernel/src/IHaskell/IPython/Message/UUID.hs b/ipython-kernel/src/IHaskell/IPython/Message/UUID.hs index d45ad291..b4e7a734 100644 --- a/ipython-kernel/src/IHaskell/IPython/Message/UUID.hs +++ b/ipython-kernel/src/IHaskell/IPython/Message/UUID.hs @@ -3,7 +3,7 @@ -- Generate, parse, and pretty print UUIDs for use with IPython. module IHaskell.IPython.Message.UUID (UUID, random, randoms, uuidToString) where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>)) import Control.Monad (mzero, replicateM) import Data.Aeson import Data.Text (pack) diff --git a/ipython-kernel/src/IHaskell/IPython/Message/Writer.hs b/ipython-kernel/src/IHaskell/IPython/Message/Writer.hs deleted file mode 100644 index 42a99743..00000000 --- a/ipython-kernel/src/IHaskell/IPython/Message/Writer.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing -fno-warn-unused-matches #-} - --- | Description : @ToJSON@ for Messages --- --- This module contains the @ToJSON@ instance for @Message@. -module IHaskell.IPython.Message.Writer (ToJSON(..)) where - -import Data.Aeson -import Data.Aeson.Types (Pair) -import Data.Aeson.Parser (json) -import Data.Map (Map) -import Data.Monoid (mempty) -import Data.Text (Text, pack) -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Map as Map -import IHaskell.IPython.Types -import Data.Maybe (fromMaybe) - -instance ToJSON LanguageInfo where - toJSON info = object - [ "name" .= languageName info - , "version" .= languageVersion info - , "file_extension" .= languageFileExtension info - , "codemirror_mode" .= languageCodeMirrorMode info - , "pygments_lexer" .= languagePygmentsLexer info - ] - --- Convert message bodies into JSON. -instance ToJSON Message where - toJSON rep@KernelInfoReply{} = - object - [ "protocol_version" .= protocolVersion rep - , "banner" .= banner rep - , "implementation" .= implementation rep - , "implementation_version" .= implementationVersion rep - , "language_info" .= languageInfo rep - , "status" .= show (status rep) - ] - - toJSON CommInfoReply - { header = header - , commInfo = commInfo - } = - object - [ "comms" .= Map.map (\comm -> object ["target_name" .= comm]) commInfo - , "status" .= string "ok" - ] - - toJSON ExecuteRequest - { getCode = code - , getSilent = silent - , getStoreHistory = storeHistory - , getAllowStdin = allowStdin - , getUserExpressions = userExpressions - } = - object - [ "code" .= code - , "silent" .= silent - , "store_history" .= storeHistory - , "allow_stdin" .= allowStdin - , "user_expressions" .= userExpressions - ] - - toJSON ExecuteReply { status = status, executionCounter = counter, pagerOutput = pager } = - object - [ "status" .= show status - , "execution_count" .= counter - , "payload" .= - if null pager - then [] - else mkPayload pager - , "user_expressions" .= emptyMap - ] - where - mkPayload o = [ object - [ "source" .= string "page" - , "start" .= Number 0 - , "data" .= object (map displayDataToJson o) - ] - ] - toJSON PublishStatus { executionState = executionState } = - object ["execution_state" .= executionState] - toJSON PublishStream { streamType = streamType, streamContent = content } = - object ["data" .= content, "name" .= streamType] - toJSON PublishDisplayData { displayData = datas } = - object - ["metadata" .= object [], "data" .= object (map displayDataToJson datas)] - - toJSON PublishOutput { executionCount = execCount, reprText = reprText } = - object - [ "data" .= object ["text/plain" .= reprText] - , "execution_count" .= execCount - , "metadata" .= object [] - ] - toJSON PublishInput { executionCount = execCount, inCode = code } = - object ["execution_count" .= execCount, "code" .= code] - toJSON (CompleteReply _ matches start end metadata status) = - object - [ "matches" .= matches - , "cursor_start" .= start - , "cursor_end" .= end - , "metadata" .= metadata - , "status" .= if status - then string "ok" - else "error" - ] - toJSON i@InspectReply{} = - object - [ "status" .= if inspectStatus i - then string "ok" - else "error" - , "data" .= object (map displayDataToJson . inspectData $ i) - , "metadata" .= object [] - , "found" .= inspectStatus i - ] - - toJSON ShutdownReply { restartPending = restart } = - object ["restart" .= restart - , "status" .= string "ok" - ] - - toJSON ClearOutput { wait = wait } = - object ["wait" .= wait] - - toJSON RequestInput { inputPrompt = prompt } = - object ["prompt" .= prompt] - - toJSON req@CommOpen{} = - object - [ "comm_id" .= commUuid req - , "target_name" .= commTargetName req - , "target_module" .= commTargetModule req - , "data" .= commData req - ] - - toJSON req@CommData{} = - object ["comm_id" .= commUuid req, "data" .= commData req] - - toJSON req@CommClose{} = - object ["comm_id" .= commUuid req, "data" .= commData req] - - toJSON req@HistoryReply{} = - object ["history" .= map tuplify (historyReply req) - , "status" .= string "ok" - ] - where - tuplify (HistoryReplyElement sess linum res) = (sess, linum, case res of - Left inp -> toJSON inp - Right (inp, out) -> toJSON out) - - toJSON req@IsCompleteReply{} = - object pairs - where - pairs = - case reviewResult req of - CodeComplete -> status "complete" - CodeIncomplete ind -> status "incomplete" ++ indent ind - CodeInvalid -> status "invalid" - CodeUnknown -> status "unknown" - status x = ["status" .= pack x] - indent x = ["indent" .= pack x] - - toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body - --- | Print an execution state as "busy", "idle", or "starting". -instance ToJSON ExecutionState where - toJSON Busy = String "busy" - toJSON Idle = String "idle" - toJSON Starting = String "starting" - --- | Print a stream as "stdin" or "stdout" strings. -instance ToJSON StreamType where - toJSON Stdin = String "stdin" - toJSON Stdout = String "stdout" - --- | Convert a MIME type and value into a JSON dictionary pair. -displayDataToJson :: DisplayData -> (Text, Value) -displayDataToJson (DisplayData MimeJson dataStr) = - pack (show MimeJson) .= fromMaybe (String "") (decodeStrict (encodeUtf8 dataStr) :: Maybe Value) -displayDataToJson (DisplayData MimeVegalite dataStr) = - pack (show MimeVegalite) .= fromMaybe (String "") (decodeStrict (encodeUtf8 dataStr) :: Maybe Value) -displayDataToJson (DisplayData MimeVega dataStr) = - pack (show MimeVega) .= fromMaybe (String "") (decodeStrict (encodeUtf8 dataStr) :: Maybe Value) -displayDataToJson (DisplayData mimeType dataStr) = - pack (show mimeType) .= String dataStr - ------ Constants ----- -emptyMap :: Map String String -emptyMap = mempty - -emptyList :: [Int] -emptyList = [] - -ints :: [Int] -> [Int] -ints = id - -string :: String -> String -string = id diff --git a/ipython-kernel/src/IHaskell/IPython/Types.hs b/ipython-kernel/src/IHaskell/IPython/Types.hs index 3e21d3ac..353abb1c 100644 --- a/ipython-kernel/src/IHaskell/IPython/Types.hs +++ b/ipython-kernel/src/IHaskell/IPython/Types.hs @@ -6,8 +6,8 @@ module IHaskell.IPython.Types ( -- * IPython kernel profile Profile(..), Transport(..), - Port(..), - IP(..), + Port, + IP, -- * IPython kernelspecs KernelSpec(..), @@ -15,12 +15,12 @@ module IHaskell.IPython.Types ( -- * IPython messaging protocol Message(..), MessageHeader(..), - Username(..), - Metadata(..), + Username, + Metadata, MessageType(..), CodeReview(..), - Width(..), - Height(..), + Width, + Height, StreamType(..), ExecutionState(..), ExecuteReplyStatus(..), @@ -38,11 +38,15 @@ module IHaskell.IPython.Types ( import Control.Applicative ((<$>), (<*>)) import Data.Aeson +import Data.Aeson.Types (typeMismatch) import Data.ByteString (ByteString) import Data.List (find) import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import Data.Serialize -import Data.Text (Text) +import Data.Serialize.Text () +import Data.Text (Text, pack) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Typeable @@ -117,7 +121,7 @@ instance ToJSON Transport where -------------------- IPython Kernelspec Types ---------------------- data KernelSpec = KernelSpec - { + { -- | Name shown to users to describe this kernel (e.g. "Haskell") kernelDisplayName :: String -- | Name for the kernel; unique kernel identifier (e.g. "haskell") @@ -140,13 +144,13 @@ instance ToJSON KernelSpec where -- | A message header with some metadata. data MessageHeader = MessageHeader - { identifiers :: [ByteString] -- ^ The identifiers sent with the message. - , parentHeader :: Maybe MessageHeader -- ^ The parent header, if present. - , metadata :: Metadata -- ^ A dict of metadata. - , messageId :: UUID -- ^ A unique message UUID. - , sessionId :: UUID -- ^ A unique session UUID. - , username :: Username -- ^ The user who sent this message. - , msgType :: MessageType -- ^ The message type. + { mhIdentifiers :: [ByteString] -- ^ The identifiers sent with the message. + , mhParentHeader :: Maybe MessageHeader -- ^ The parent header, if present. + , mhMetadata :: Metadata -- ^ A dict of metadata. + , mhMessageId :: UUID -- ^ A unique message UUID. + , mhSessionId :: UUID -- ^ A unique session UUID. + , mhUsername :: Username -- ^ The user who sent this message. + , mhMsgType :: MessageType -- ^ The message type. } deriving (Show, Read) @@ -154,11 +158,11 @@ data MessageHeader = -- all the record fields. instance ToJSON MessageHeader where toJSON header = object - [ "msg_id" .= messageId header - , "session" .= sessionId header - , "username" .= username header + [ "msg_id" .= mhMessageId header + , "session" .= mhSessionId header + , "username" .= mhUsername header , "version" .= ("5.0" :: String) - , "msg_type" .= showMessageType (msgType header) + , "msg_type" .= showMessageType (mhMsgType header) ] -- | A username for the source of a message. @@ -280,6 +284,15 @@ data LanguageInfo = } deriving (Show, Eq) +instance ToJSON LanguageInfo where + toJSON info = object + [ "name" .= languageName info + , "version" .= languageVersion info + , "file_extension" .= languageFileExtension info + , "codemirror_mode" .= languageCodeMirrorMode info + , "pygments_lexer" .= languagePygmentsLexer info + ] + data CodeReview = CodeComplete | CodeIncomplete String -- ^ String to be used to indent next line of input | CodeInvalid @@ -472,6 +485,146 @@ data Message = | SendNothing -- Dummy message; nothing is sent. deriving Show +-- Convert message bodies into JSON. +instance ToJSON Message where + toJSON rep@KernelInfoReply{} = + object + [ "protocol_version" .= protocolVersion rep + , "banner" .= banner rep + , "implementation" .= implementation rep + , "implementation_version" .= implementationVersion rep + , "language_info" .= languageInfo rep + , "status" .= show (status rep) + ] + + toJSON CommInfoReply + { header = header + , commInfo = commInfo + } = + object + [ "comms" .= Map.map (\comm -> object ["target_name" .= comm]) commInfo + , "status" .= string "ok" + ] + + toJSON ExecuteRequest + { getCode = code + , getSilent = silent + , getStoreHistory = storeHistory + , getAllowStdin = allowStdin + , getUserExpressions = userExpressions + } = + object + [ "code" .= code + , "silent" .= silent + , "store_history" .= storeHistory + , "allow_stdin" .= allowStdin + , "user_expressions" .= userExpressions + ] + + toJSON ExecuteReply { status = status, executionCounter = counter, pagerOutput = pager } = + object + [ "status" .= show status + , "execution_count" .= counter + , "payload" .= + if null pager + then [] + else mkPayload pager + , "user_expressions" .= emptyMap + ] + where + mkPayload o = [ object + [ "source" .= string "page" + , "start" .= Number 0 + , "data" .= object (map displayDataToJson o) + ] + ] + toJSON PublishStatus { executionState = executionState } = + object ["execution_state" .= executionState] + toJSON PublishStream { streamType = streamType, streamContent = content } = + object ["data" .= content, "name" .= streamType] + toJSON PublishDisplayData { displayData = datas } = + object + ["metadata" .= object [], "data" .= object (map displayDataToJson datas)] + + toJSON PublishOutput { executionCount = execCount, reprText = reprText } = + object + [ "data" .= object ["text/plain" .= reprText] + , "execution_count" .= execCount + , "metadata" .= object [] + ] + toJSON PublishInput { executionCount = execCount, inCode = code } = + object ["execution_count" .= execCount, "code" .= code] + toJSON (CompleteReply _ matches start end metadata status) = + object + [ "matches" .= matches + , "cursor_start" .= start + , "cursor_end" .= end + , "metadata" .= metadata + , "status" .= if status + then string "ok" + else "error" + ] + toJSON i@InspectReply{} = + object + [ "status" .= if inspectStatus i + then string "ok" + else "error" + , "data" .= object (map displayDataToJson . inspectData $ i) + , "metadata" .= object [] + , "found" .= inspectStatus i + ] + + toJSON ShutdownReply { restartPending = restart } = + object ["restart" .= restart + , "status" .= string "ok" + ] + + toJSON ClearOutput { wait = wait } = + object ["wait" .= wait] + + toJSON RequestInput { inputPrompt = prompt } = + object ["prompt" .= prompt] + + toJSON req@CommOpen{} = + object + [ "comm_id" .= commUuid req + , "target_name" .= commTargetName req + , "target_module" .= commTargetModule req + , "data" .= commData req + ] + + toJSON req@CommData{} = + object ["comm_id" .= commUuid req, "data" .= commData req] + + toJSON req@CommClose{} = + object ["comm_id" .= commUuid req, "data" .= commData req] + + toJSON req@HistoryReply{} = + object ["history" .= map tuplify (historyReply req) + , "status" .= string "ok" + ] + where + tuplify (HistoryReplyElement sess linum res) = (sess, linum, case res of + Left inp -> toJSON inp + Right (inp, out) -> toJSON out) + + toJSON req@IsCompleteReply{} = + object pairs + where + pairs = + case reviewResult req of + CodeComplete -> status "complete" + CodeIncomplete ind -> status "incomplete" ++ indent ind + CodeInvalid -> status "invalid" + CodeUnknown -> status "unknown" + status x = ["status" .= pack x] + indent x = ["indent" .= pack x] + + toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body + + + + -- | Ways in which the frontend can request history. TODO: Implement fields as described in -- messaging spec. data HistoryAccessType = HistoryRange @@ -497,6 +650,7 @@ instance FromJSON ExecuteReplyStatus where parseJSON (String "ok") = return Ok parseJSON (String "error") = return Err parseJSON (String "abort") = return Abort + parseJSON invalid = typeMismatch "ExecuteReplyStatus" invalid instance Show ExecuteReplyStatus where show Ok = "ok" @@ -513,6 +667,13 @@ instance FromJSON ExecutionState where parseJSON (String "busy") = return Busy parseJSON (String "idle") = return Idle parseJSON (String "starting") = return Starting + parseJSON invalid = typeMismatch "ExecutionState" invalid + +-- | Print an execution state as "busy", "idle", or "starting". +instance ToJSON ExecutionState where + toJSON Busy = String "busy" + toJSON Idle = String "idle" + toJSON Starting = String "starting" -- | Input and output streams. data StreamType = Stdin @@ -524,6 +685,13 @@ instance FromJSON StreamType where parseJSON (String "stdin") = return Stdin parseJSON (String "stdout") = return Stdout parseJSON (String "stderr") = return Stderr + parseJSON invalid = typeMismatch "StreamType" invalid + +-- | Print a stream as "stdin" or "stdout" strings. +instance ToJSON StreamType where + toJSON Stdin = String "stdin" + toJSON Stdout = String "stdout" + toJSON Stderr = String "stderr" -- | Get the reply message type for a request message type. replyType :: MessageType -> Maybe MessageType @@ -547,11 +715,6 @@ data DisplayData = DisplayData MimeType Text instance Show DisplayData where show _ = "DisplayData" --- Allow DisplayData serialization -instance Serialize Text where - put str = put (Text.encodeUtf8 str) - get = Text.decodeUtf8 <$> get - instance Serialize DisplayData instance Serialize MimeType @@ -583,6 +746,7 @@ extractPlain disps = case find isPlain disps of Nothing -> "" Just (DisplayData PlainText bytestr) -> Text.unpack bytestr + Just _ -> "" where isPlain (DisplayData mime _) = mime == PlainText @@ -617,3 +781,21 @@ instance Read MimeType where readsPrec _ "application/vnd.vega.v2+json" = [(MimeVega, "")] readsPrec _ "application/vnd.vegalite.v1+json" = [(MimeVegalite, "")] readsPrec _ "application/vdom.v1+json" = [(MimeVdom, "")] + readsPrec _ _ = [] + +-- | Convert a MIME type and value into a JSON dictionary pair. +displayDataToJson :: DisplayData -> (Text, Value) +displayDataToJson (DisplayData MimeJson dataStr) = + pack (show MimeJson) .= fromMaybe (String "") (decodeStrict (Text.encodeUtf8 dataStr) :: Maybe Value) +displayDataToJson (DisplayData MimeVegalite dataStr) = + pack (show MimeVegalite) .= fromMaybe (String "") (decodeStrict (Text.encodeUtf8 dataStr) :: Maybe Value) +displayDataToJson (DisplayData MimeVega dataStr) = + pack (show MimeVega) .= fromMaybe (String "") (decodeStrict (Text.encodeUtf8 dataStr) :: Maybe Value) +displayDataToJson (DisplayData mimeType dataStr) = + pack (show mimeType) .= String dataStr + +string :: String -> String +string = id + +emptyMap :: Map String String +emptyMap = mempty diff --git a/ipython-kernel/src/IHaskell/IPython/ZeroMQ.hs b/ipython-kernel/src/IHaskell/IPython/ZeroMQ.hs index 6b29894b..afb985ad 100644 --- a/ipython-kernel/src/IHaskell/IPython/ZeroMQ.hs +++ b/ipython-kernel/src/IHaskell/IPython/ZeroMQ.hs @@ -27,11 +27,10 @@ import qualified Data.ByteString.Lazy as LBS import Data.Char import Data.Monoid ((<>)) import qualified Data.Text.Encoding as Text -import System.ZMQ4 as ZMQ4 hiding (stdin) +import System.ZMQ4 as ZMQ4 import Text.Read (readMaybe) import IHaskell.IPython.Message.Parser -import IHaskell.IPython.Message.Writer () import IHaskell.IPython.Types -- | The channel interface to the ZeroMQ sockets. All communication is done via Messages, which are @@ -39,7 +38,7 @@ import IHaskell.IPython.Types -- should functionally serve as high-level sockets which speak Messages instead of ByteStrings. data ZeroMQInterface = Channels - { + { -- | A channel populated with requests from the frontend. shellRequestChannel :: Chan Message -- | Writing to this channel causes a reply to be sent to the frontend. @@ -90,16 +89,16 @@ serveProfile profile debug = do -- Create the context in a separate thread that never finishes. If withContext or withSocket -- complete, the context or socket become invalid. - forkIO $ withContext $ \context -> do + _ <- forkIO $ withContext $ \ctxt -> do -- Serve on all sockets. - forkIO $ serveSocket context Rep (hbPort profile) $ heartbeat channels - forkIO $ serveSocket context Router (controlPort profile) $ control debug channels - forkIO $ serveSocket context Router (shellPort profile) $ shell debug channels + _ <- forkIO $ serveSocket ctxt Rep (hbPort profile) $ heartbeat channels + _ <- forkIO $ serveSocket ctxt Router (controlPort profile) $ control debug channels + _ <- forkIO $ serveSocket ctxt Router (shellPort profile) $ shell debug channels - -- The context is reference counted in this thread only. Thus, the last serveSocket cannot be - -- asynchronous, because otherwise context would be garbage collectable - since it would only be + -- The ctxt is reference counted in this thread only. Thus, the last serveSocket cannot be + -- asynchronous, because otherwise ctxt would be garbage collectable - since it would only be -- used in other threads. Thus, keep the last serveSocket in this thread. - serveSocket context Pub (iopubPort profile) $ iopub debug channels + serveSocket ctxt Pub (iopubPort profile) $ iopub debug channels return channels @@ -132,9 +131,9 @@ parsePort s = readMaybe num num = reverse (takeWhile isNumber (reverse s)) bindLocalEphemeralPort :: Socket a -> IO Int -bindLocalEphemeralPort socket = do - bind socket $ "tcp://127.0.0.1:*" - endpointString <- lastEndpoint socket +bindLocalEphemeralPort sock = do + bind sock $ "tcp://127.0.0.1:*" + endpointString <- lastEndpoint sock case parsePort endpointString of Nothing -> fail $ "internalError: IHaskell.IPython.ZeroMQ.bindLocalEphemeralPort encountered a port index that could not be interpreted as an int." @@ -152,19 +151,19 @@ withEphemeralPorts :: ByteString -- ^ HMAC encryption key withEphemeralPorts key debug callback = do channels <- newZeroMQInterface key -- Create the ZMQ4 context - withContext $ \context -> do + withContext $ \ctxt -> do -- Create the sockets to communicate with. - withSocket context Rep $ \heartbeatSocket -> do - withSocket context Router $ \controlportSocket -> do - withSocket context Router $ \shellportSocket -> do - withSocket context Pub $ \iopubSocket -> do + withSocket ctxt Rep $ \heartbeatSocket -> do + withSocket ctxt Router $ \controlportSocket -> do + withSocket ctxt Router $ \shellportSocket -> do + withSocket ctxt Pub $ \iopubSocket -> do -- Bind each socket to a local port, getting the port chosen. - hbPort <- bindLocalEphemeralPort heartbeatSocket - controlPort <- bindLocalEphemeralPort controlportSocket - shellPort <- bindLocalEphemeralPort shellportSocket - iopubPort <- bindLocalEphemeralPort iopubSocket + hbPt <- bindLocalEphemeralPort heartbeatSocket + controlPt <- bindLocalEphemeralPort controlportSocket + shellPt <- bindLocalEphemeralPort shellportSocket + iopubPt <- bindLocalEphemeralPort iopubSocket -- Create object to store ephemeral ports - let ports = ZeroMQEphemeralPorts { ephHbPort = hbPort, ephControlPort = controlPort, ephShellPort = shellPort, ephIOPubPort = iopubPort, ephSignatureKey = key } + let ports = ZeroMQEphemeralPorts hbPt controlPt shellPt iopubPt key -- Launch actions to listen to communicate between channels and cockets. _ <- forkIO $ forever $ heartbeat channels heartbeatSocket _ <- forkIO $ forever $ control debug channels controlportSocket @@ -180,44 +179,44 @@ serveStdin profile = do -- Create the context in a separate thread that never finishes. If withContext or withSocket -- complete, the context or socket become invalid. - forkIO $ withContext $ \context -> + _ <- forkIO $ withContext $ \ctxt -> -- Serve on all sockets. - serveSocket context Router (stdinPort profile) $ \socket -> do + serveSocket ctxt Router (stdinPort profile) $ \sock -> do -- Read the request from the interface channel and send it. - readChan reqChannel >>= sendMessage False (signatureKey profile) socket + readChan reqChannel >>= sendMessage False (signatureKey profile) sock -- Receive a response and write it to the interface channel. - receiveMessage False socket >>= writeChan repChannel + receiveMessage False sock >>= writeChan repChannel return $ StdinChannel reqChannel repChannel --- | Serve on a given socket in a separate thread. Bind the socket in the | given context and then --- loop the provided action, which should listen | on the socket and respond to any events. +-- | Serve on a given sock in a separate thread. Bind the sock in the | given context and then +-- loop the provided action, which should listen | on the sock and respond to any events. serveSocket :: SocketType a => Context -> a -> Port -> (Socket a -> IO b) -> IO () -serveSocket context socketType port action = void $ - withSocket context socketType $ \socket -> do - bind socket $ "tcp://127.0.0.1:" ++ show port - forever $ action socket +serveSocket ctxt socketType port action = void $ + withSocket ctxt socketType $ \sock -> do + bind sock $ "tcp://127.0.0.1:" ++ show port + forever $ action sock -- | Listener on the heartbeat port. Echoes back any data it was sent. heartbeat :: ZeroMQInterface -> Socket Rep -> IO () -heartbeat _ socket = do +heartbeat _ sock = do -- Read some data. - request <- receive socket + request <- receive sock -- Send it back. - send socket [] request + send sock [] request -- | Listener on the shell port. Reads messages and writes them to | the shell request channel. For -- each message, reads a response from the | shell reply channel of the interface and sends it back -- to the frontend. shell :: Bool -> ZeroMQInterface -> Socket Router -> IO () -shell debug channels socket = do +shell debug channels sock = do -- Receive a message and write it to the interface channel. - receiveMessage debug socket >>= writeChan requestChannel + receiveMessage debug sock >>= writeChan requestChannel -- Read the reply from the interface channel and send it. - readChan replyChannel >>= sendMessage debug (hmacKey channels) socket + readChan replyChannel >>= sendMessage debug (hmacKey channels) sock where requestChannel = shellRequestChannel channels @@ -227,12 +226,12 @@ shell debug channels socket = do -- each message, reads a response from the | shell reply channel of the interface and sends it back -- to the frontend. control :: Bool -> ZeroMQInterface -> Socket Router -> IO () -control debug channels socket = do +control debug channels sock = do -- Receive a message and write it to the interface channel. - receiveMessage debug socket >>= writeChan requestChannel + receiveMessage debug sock >>= writeChan requestChannel -- Read the reply from the interface channel and send it. - readChan replyChannel >>= sendMessage debug (hmacKey channels) socket + readChan replyChannel >>= sendMessage debug (hmacKey channels) sock where requestChannel = controlRequestChannel channels @@ -241,33 +240,33 @@ control debug channels socket = do -- | Send messages via the iopub channel. | This reads messages from the ZeroMQ iopub interface -- channel | and then writes the messages to the socket. iopub :: Bool -> ZeroMQInterface -> Socket Pub -> IO () -iopub debug channels socket = - readChan (iopubChannel channels) >>= sendMessage debug (hmacKey channels) socket +iopub debug channels sock = + readChan (iopubChannel channels) >>= sendMessage debug (hmacKey channels) sock -- | Attempt to send a message along the socket, returning true if successful. trySendMessage :: Sender a => String -> Bool -> ByteString -> Socket a -> Message -> IO Bool -trySendMessage nm debug hmacKey socket message = do +trySendMessage _ debug hmackey sock msg = do let zmqErrorHandler :: ZMQError -> IO Bool zmqErrorHandler e -- Ignore errors if we cannot send. We may want to forward this to the thread that tried put the -- message in the Chan initially. | errno e == 38 = return False | otherwise = throwIO e - (sendMessage debug hmacKey socket message >> return True) `catch` zmqErrorHandler + (sendMessage debug hmackey sock msg >> return True) `catch` zmqErrorHandler -- | Send messages via the iopub channel. This reads messages from the ZeroMQ iopub interface -- channel and then writes the messages to the socket. This is a checked implementation which will -- stop if the socket is closed. checkedIOpub :: Bool -> ZeroMQInterface -> Socket Pub -> IO () -checkedIOpub debug channels socket = do +checkedIOpub debug channels sock = do msg <- readChan (iopubChannel channels) - cont <- trySendMessage "io" debug (hmacKey channels) socket msg + cont <- trySendMessage "io" debug (hmacKey channels) sock msg when cont $ - checkedIOpub debug channels socket + checkedIOpub debug channels sock -- | Receive and parse a message from a socket. receiveMessage :: Receiver a => Bool -> Socket a -> IO Message -receiveMessage debug socket = do +receiveMessage debug sock = do -- Read all identifiers until the identifier/message delimiter. idents <- readUntil "" @@ -285,12 +284,11 @@ receiveMessage debug socket = do putStr "Content: " Char.putStrLn content - let message = parseMessage idents headerData parentHeader metadata content - return message + return $ parseMessage idents headerData parentHeader metadata content where -- Receive the next piece of data from the socket. - next = receive socket + next = receive sock -- Read data from the socket until we hit an ending string. Return all data as a list, which does -- not include the ending string. @@ -306,10 +304,10 @@ receiveMessage debug socket = do -- socket. Sign it using HMAC with SHA-256 using the provided key. sendMessage :: Sender a => Bool -> ByteString -> Socket a -> Message -> IO () sendMessage _ _ _ SendNothing = return () -sendMessage debug hmacKey socket message = do +sendMessage debug hmackey sock msg = do when debug $ do putStr "Message: " - print message + print msg putStr "Sent: " print content @@ -325,8 +323,8 @@ sendMessage debug hmacKey socket message = do sendLast content where - sendPiece = send socket [SendMore] - sendLast = send socket [] + sendPiece = send sock [SendMore] + sendLast = send sock [] -- Encode to a strict bytestring. encodeStrict :: ToJSON a => a -> ByteString @@ -338,12 +336,12 @@ sendMessage debug hmacKey socket message = do -- Compute the HMAC SHA-256 signature of a bytestring message. hmac :: ByteString -> ByteString - hmac = Char.pack . show . (HMAC.hmacGetDigest :: HMAC.HMAC SHA256 -> Hash.Digest SHA256) . HMAC.hmac hmacKey + hmac = Char.pack . show . (HMAC.hmacGetDigest :: HMAC.HMAC SHA256 -> Hash.Digest SHA256) . HMAC.hmac hmackey -- Pieces of the message. - head = header message - parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head - idents = identifiers head + hdr = header msg + parentHeaderStr = maybe "{}" encodeStrict $ mhParentHeader hdr + idents = mhIdentifiers hdr metadata = "{}" - content = encodeStrict message - headStr = encodeStrict head + content = encodeStrict msg + headStr = encodeStrict hdr diff --git a/main/Main.hs b/main/Main.hs index bdeaae49..28c341b6 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -195,7 +195,7 @@ runKernel kOpts profileSrc = do installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.") Nothing - isCommMessage req = msgType (header req) `elem` [CommDataMessage, CommCloseMessage] + isCommMessage req = mhMsgType (header req) `elem` [CommDataMessage, CommCloseMessage] -- Initial kernel state. initialKernelState :: IO (MVar KernelState) @@ -206,19 +206,11 @@ createReplyHeader :: MessageHeader -> Interpreter MessageHeader createReplyHeader parent = do -- Generate a new message UUID. newMessageId <- liftIO UUID.random - let repType = fromMaybe err (replyType $ msgType parent) - err = error $ "No reply for message " ++ show (msgType parent) + let repType = fromMaybe err (replyType $ mhMsgType parent) + err = error $ "No reply for message " ++ show (mhMsgType parent) - return - MessageHeader - { identifiers = identifiers parent - , parentHeader = Just parent - , metadata = Map.fromList [] - , messageId = newMessageId - , sessionId = sessionId parent - , username = username parent - , msgType = repType - } + return $ MessageHeader (mhIdentifiers parent) (Just parent) mempty + newMessageId (mhSessionId parent) (mhUsername parent) repType -- | Compute a reply to a message. replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message) @@ -432,7 +424,7 @@ handleComm send kernelState req replyHeader = do newState <- case Map.lookup uuid widgets of Nothing -> return kernelState Just (Widget widget) -> - case msgType $ header req of + case mhMsgType $ header req of CommDataMessage -> do disp <- run $ comm widget dat communicate pgrOut <- liftIO $ readMVar pOut diff --git a/src/IHaskell/IPython/Stdin.hs b/src/IHaskell/IPython/Stdin.hs index 71a9178d..b7e15c5b 100644 --- a/src/IHaskell/IPython/Stdin.hs +++ b/src/IHaskell/IPython/Stdin.hs @@ -33,7 +33,6 @@ import GHC.IO.Handle import GHC.IO.Handle.Types import System.Posix.IO import System.IO.Unsafe -import qualified Data.Map as Map import IHaskell.IPython.Types import IHaskell.IPython.ZeroMQ @@ -88,15 +87,8 @@ getInputLine dir = do -- Send a request for input. uuid <- UUID.random parentHdr <- fromJust . readMay <$> readFile (dir ++ "/.last-req-header") - let hdr = MessageHeader - { username = username parentHdr - , identifiers = identifiers parentHdr - , parentHeader = Just parentHdr - , messageId = uuid - , sessionId = sessionId parentHdr - , metadata = Map.fromList [] - , msgType = InputRequestMessage - } + let hdr = MessageHeader (mhIdentifiers parentHdr) (Just parentHdr) mempty + uuid (mhSessionId parentHdr) (mhUsername parentHdr) InputRequestMessage let msg = RequestInput hdr "" writeChan req msg diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs index e57eac8f..74bc3aef 100644 --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -39,7 +39,7 @@ module IHaskell.Types ( import IHaskellPrelude -import Data.Aeson (ToJSON, Value, (.=), object) +import Data.Aeson (ToJSON (..), Value, (.=), object) import Data.Function (on) import Data.Serialize import GHC.Generics @@ -268,4 +268,4 @@ dupHeader :: MessageHeader -> MessageType -> IO MessageHeader dupHeader hdr messageType = do uuid <- liftIO random - return hdr { messageId = uuid, msgType = messageType } + return hdr { mhMessageId = uuid, mhMsgType = messageType }