diff --git a/examples/Calc.hs b/examples/Calc.hs --- a/examples/Calc.hs +++ b/examples/Calc.hs @@ -1,26 +1,28 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, MultiWayIf #-} + module Main where -import Control.Applicative -import Control.Arrow +import Control.Applicative +import Control.Arrow -import Control.Concurrent (MVar, newMVar, takeMVar, putMVar, threadDelay) -import Control.Monad (guard) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.State.Strict (StateT, get, modify, runStateT) +import Control.Concurrent (MVar, newMVar, takeMVar, putMVar, threadDelay) +import Control.Monad (guard) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State.Strict (StateT, get, modify, runStateT) -import Data.Char (isDigit) -import Data.List (isPrefixOf) -import Data.Monoid ((<>)) +import Data.Char (isDigit) +import Data.List (isPrefixOf) +import Data.Monoid ((<>)) import qualified Data.Text as T -import IHaskell.IPython.Kernel -import IHaskell.IPython.EasyKernel (installProfile, easyKernel, KernelConfig(..)) +import IHaskell.IPython.Kernel +import IHaskell.IPython.EasyKernel (installProfile, easyKernel, KernelConfig(..)) -import System.Environment (getArgs) -import System.FilePath (()) +import System.Environment (getArgs) +import System.FilePath (()) -import Text.Parsec (Parsec, ParseError, alphaNum, char, letter, oneOf, optionMaybe, runParser, ()) +import Text.Parsec (Parsec, ParseError, alphaNum, char, letter, oneOf, optionMaybe, + runParser, ()) import qualified Text.Parsec.Token as P import qualified Paths_ipython_kernel as Paths @@ -28,34 +30,29 @@ --------------------------------------------------------- -- Hutton's Razor, plus time delays, plus a global state --------------------------------------------------------- - --- | This language is Hutton's Razor with two added operations that --- are needed to demonstrate the kernel features: a global state, --- accessed and modified using Count, and a sleep operation. +-- +-- | This language is Hutton's Razor with two added operations that are needed to demonstrate the +-- kernel features: a global state, accessed and modified using Count, and a sleep operation. data Razor = I Integer | Plus Razor Razor | SleepThen Double Razor | Count deriving (Read, Show, Eq) - ---------- --- Parser ---------- - +-- ------- Parser ------- razorDef :: Monad m => P.GenLanguageDef String a m razorDef = P.LanguageDef - { P.commentStart = "(*" - , P.commentEnd = "*)" - , P.commentLine = "//" - , P.nestedComments = True - , P.identStart = letter <|> char '_' - , P.identLetter = alphaNum <|> char '_' - , P.opStart = oneOf "+" - , P.opLetter = oneOf "+" - , P.reservedNames = ["sleep", "then", "end", "count"] + { P.commentStart = "(*" + , P.commentEnd = "*)" + , P.commentLine = "//" + , P.nestedComments = True + , P.identStart = letter <|> char '_' + , P.identLetter = alphaNum <|> char '_' + , P.opStart = oneOf "+" + , P.opLetter = oneOf "+" + , P.reservedNames = ["sleep", "then", "end", "count"] , P.reservedOpNames = [] - , P.caseSensitive = True + , P.caseSensitive = True } lexer :: Monad m => P.GenTokenParser String a m @@ -83,39 +80,38 @@ literal = I <$> integer sleepThen :: Parsec String a Razor -sleepThen = do keyword "sleep" - delay <- float "seconds" - keyword "then" - body <- expr - keyword "end" "" - return $ SleepThen delay body +sleepThen = do + keyword "sleep" + delay <- float "seconds" + keyword "then" + body <- expr + keyword "end" "" + return $ SleepThen delay body count :: Parsec String a Razor count = keyword "count" >> return Count expr :: Parsec String a Razor -expr = do one <- parens expr <|> literal <|> sleepThen <|> count - rest <- optionMaybe (do op <- operator - guard (op == "+") - expr) - case rest of - Nothing -> return one - Just other -> return $ Plus one other +expr = do + one <- parens expr <|> literal <|> sleepThen <|> count + rest <- optionMaybe + (do + op <- operator + guard (op == "+") + expr) + case rest of + Nothing -> return one + Just other -> return $ Plus one other parse :: String -> Either ParseError Razor parse = runParser expr () "(input)" - ----------------------- --- Language operations ----------------------- - --- | Completion +-- -------------------- Language operations -------------------- | Completion langCompletion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text) langCompletion _code line col = let (before, _) = T.splitAt col line in fmap (\word -> (map T.pack . matchesFor $ T.unpack word, word, word)) - (lastMaybe (T.words before)) + (lastMaybe (T.words before)) where lastMaybe :: [a] -> Maybe a lastMaybe [] = Nothing @@ -123,43 +119,41 @@ lastMaybe (_:xs) = lastMaybe xs matchesFor :: String -> [String] matchesFor input = filter (isPrefixOf input) available - available = ["sleep", "then", "end", "count"] ++ map show [(-1000::Int)..1000] + available = ["sleep", "then", "end", "count"] ++ map show [(-1000 :: Int) .. 1000] -- | Documentation lookup langInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text) langInfo obj = - if | any (T.isPrefixOf obj) ["sleep", "then", "end"] -> - Just (obj, sleepDocs, sleepType) - | T.isPrefixOf obj "count" -> - Just (obj, countDocs, countType) + if | any (T.isPrefixOf obj) ["sleep", "then", "end"] -> Just (obj, sleepDocs, sleepType) + | T.isPrefixOf obj "count" -> Just (obj, countDocs, countType) | obj == "+" -> Just (obj, plusDocs, plusType) | T.all isDigit obj -> Just (obj, intDocs obj, intType) - | [x, y] <- T.splitOn "." obj, - T.all isDigit x, - T.all isDigit y -> Just (obj, floatDocs obj, floatType) + | [x, y] <- T.splitOn "." obj + , T.all isDigit x + , T.all isDigit y -> Just (obj, floatDocs obj, floatType) | otherwise -> Nothing where - sleepDocs = "sleep DURATION then VALUE end: sleep DURATION seconds, then eval VALUE" - sleepType = "sleep FLOAT then INT end" - plusDocs = "Perform addition" - plusType = "INT + INT" - intDocs i = "The integer " <> i - intType = "INT" - floatDocs f = "The floating point value " <> f - floatType = "FLOAT" - countDocs = "Increment and return the current counter" - countType = "INT" + sleepDocs = "sleep DURATION then VALUE end: sleep DURATION seconds, then eval VALUE" + sleepType = "sleep FLOAT then INT end" + plusDocs = "Perform addition" + plusType = "INT + INT" + intDocs i = "The integer " <> i + intType = "INT" + floatDocs f = "The floating point value " <> f + floatType = "FLOAT" + countDocs = "Increment and return the current counter" + countType = "INT" -- | Messages sent to the frontend during evaluation will be lists of trace elements data IntermediateEvalRes = Got Razor Integer | Waiting Double deriving Show --- | Cons for lists of trace elements - in this case, "sleeping" --- messages should replace old ones to create a countdown effect. +-- | Cons for lists of trace elements - in this case, "sleeping" messages should replace old ones to +-- create a countdown effect. consRes :: IntermediateEvalRes -> [IntermediateEvalRes] -> [IntermediateEvalRes] -consRes r@(Waiting _) (Waiting _ : s) = r:s -consRes r s = r:s +consRes r@(Waiting _) (Waiting _:s) = r : s +consRes r s = r : s -- | Execute an expression. execRazor :: MVar Integer -- ^ The global counter state @@ -168,53 +162,60 @@ -> ([IntermediateEvalRes] -> IO ()) -- ^ Callback for intermediate results -> StateT ([IntermediateEvalRes], T.Text) IO Integer execRazor _ x@(I i) _ _ = - modify (second (<> (T.pack (show x)))) >> return i + modify (second (<> T.pack (show x))) >> return i execRazor val tm@(Plus x y) clear send = - do modify (second (<> (T.pack (show tm)))) - x' <- execRazor val x clear send - modify (first $ consRes (Got x x')) - sendState - y' <- execRazor val y clear send - modify (first $ consRes (Got y y')) - sendState - let res = x' + y' - modify (first $ consRes (Got tm res)) - sendState - return res - where sendState = liftIO clear >> fst <$> get >>= liftIO . send + do + modify (second (<> T.pack (show tm))) + x' <- execRazor val x clear send + modify (first $ consRes (Got x x')) + sendState + y' <- execRazor val y clear send + modify (first $ consRes (Got y y')) + sendState + let res = x' + y' + modify (first $ consRes (Got tm res)) + sendState + return res + + where + sendState = liftIO clear >> fst <$> get >>= liftIO . send execRazor val (SleepThen delay body) clear send | delay <= 0.0 = execRazor val body clear send - | delay > 0.1 = do modify (first $ consRes (Waiting delay)) - sendState - liftIO $ threadDelay 100000 - execRazor val (SleepThen (delay - 0.1) body) clear send - | otherwise = do modify (first $ consRes (Waiting 0)) - sendState - liftIO $ threadDelay (floor (delay * 1000000)) - execRazor val body clear send - where sendState = liftIO clear >> fst <$> get >>= liftIO . send + | delay > 0.1 = do + modify (first $ consRes (Waiting delay)) + sendState + liftIO $ threadDelay 100000 + execRazor val (SleepThen (delay - 0.1) body) clear send + | otherwise = do + modify (first $ consRes (Waiting 0)) + sendState + liftIO $ threadDelay (floor (delay * 1000000)) + execRazor val body clear send + where + sendState = liftIO clear >> fst <$> get >>= liftIO . send execRazor val Count clear send = do i <- liftIO $ takeMVar val modify (first $ consRes (Got Count i)) sendState - liftIO $ putMVar val (i+1) + liftIO $ putMVar val (i + 1) return i - where sendState = liftIO clear >> fst <$> get >>= liftIO . send + where + sendState = liftIO clear >> fst <$> get >>= liftIO . send -- | Generate a language configuration for some initial state mkConfig :: MVar Integer -- ^ The internal state of the execution -> KernelConfig IO [IntermediateEvalRes] (Either ParseError Integer) mkConfig var = KernelConfig - { languageName = "expanded_huttons_razor" - , languageVersion = [0,1,0] - , profileSource = Just . ( "calc_profile.tar") <$> Paths.getDataDir - , displayResult = displayRes - , displayOutput = displayOut - , completion = langCompletion - , objectInfo = langInfo - , run = parseAndRun - , debug = False + { languageName = "expanded_huttons_razor" + , languageVersion = [0, 1, 0] + , profileSource = Just . ( "calc_profile.tar") <$> Paths.getDataDir + , displayResult = displayRes + , displayOutput = displayOut + , completion = langCompletion + , objectInfo = langInfo + , run = parseAndRun + , debug = False } where displayRes (Left err) = @@ -235,15 +236,17 @@ return (Right res, Ok, T.unpack pager) main :: IO () -main = do args <- getArgs - val <- newMVar 1 - case args of - ["kernel", profileFile] -> - easyKernel profileFile (mkConfig val) - ["setup"] -> do - putStrLn "Installing profile..." - installProfile (mkConfig val) - _ -> do - putStrLn "Usage:" - putStrLn "simple-calc-example setup -- set up the profile" - putStrLn "simple-calc-example kernel FILE -- run a kernel with FILE for communication with the frontend" +main = do + args <- getArgs + val <- newMVar 1 + case args of + ["kernel", profileFile] -> + easyKernel profileFile (mkConfig val) + ["setup"] -> do + putStrLn "Installing profile..." + installProfile (mkConfig val) + _ -> do + putStrLn "Usage:" + putStrLn "simple-calc-example setup -- set up the profile" + putStrLn + "simple-calc-example kernel FILE -- run a kernel with FILE for communication with the frontend" diff --git a/ipython-kernel.cabal b/ipython-kernel.cabal --- a/ipython-kernel.cabal +++ b/ipython-kernel.cabal @@ -1,5 +1,5 @@ name: ipython-kernel -version: 0.3.0.0 +version: 0.6.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. @@ -36,7 +36,7 @@ other-extensions: OverloadedStrings hs-source-dirs: src default-language: Haskell2010 - build-depends: base >=4.6 && < 4.8, + build-depends: base >=4.6 && < 4.9, aeson >=0.6 && < 0.9, bytestring >=0.10, cereal >=0.3, @@ -49,7 +49,8 @@ transformers >=0.3, unix >=2.6, uuid >=1.3, - zeromq4-haskell >=0.1 + zeromq4-haskell >=0.1, + SHA >=1.6 -- Example program @@ -57,7 +58,7 @@ hs-source-dirs: examples main-is: Calc.hs build-depends: ipython-kernel, - base >=4.6 && <4.8, + base >=4.6 && <4.9, filepath >=1.2, mtl >=2.1, parsec >=3.1, diff --git a/src/IHaskell/IPython/EasyKernel.hs b/src/IHaskell/IPython/EasyKernel.hs --- a/src/IHaskell/IPython/EasyKernel.hs +++ b/src/IHaskell/IPython/EasyKernel.hs @@ -1,32 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} --- | Description : Easy IPython kernels --- = Overview --- This module provides automation for writing simple IPython --- kernels. In particular, it provides a record type that defines --- configurations and a function that interprets a configuration as an --- action in some monad that can do IO. +-- | Description : Easy IPython kernels = Overview This module provides automation for writing +-- simple IPython kernels. In particular, it provides a record type that defines configurations and +-- a function that interprets a configuration as an action in some monad that can do IO. -- --- The configuration consists primarily of functions that implement --- the various features of a kernel, such as running code, looking up --- documentation, and performing completion. An example for a simple --- language that nevertheless has side effects, global state, and --- timing effects is included in the examples directory. +-- The configuration consists primarily of functions that implement the various features of a +-- kernel, such as running code, looking up documentation, and performing completion. An example for +-- a simple language that nevertheless has side effects, global state, and timing effects is +-- included in the examples directory. -- --- = Profiles --- To run your kernel, you will need an IPython profile that causes --- the frontend to run it. To generate a fresh profile, run the command +-- = Profiles To run your kernel, you will need an IPython profile that causes the frontend to run +-- it. To generate a fresh profile, run the command -- -- > ipython profile create NAME -- --- This will create a fresh IPython profile in @~\/.ipython\/profile_NAME@. --- This profile must be modified in two ways: +-- This will create a fresh IPython profile in @~\/.ipython\/profile_NAME@. This profile must be +-- modified in two ways: -- --- 1. It needs to run your kernel instead of the default ipython --- 2. It must have message signing turned off, because 'easyKernel' doesn't support it +-- 1. It needs to run your kernel instead of the default ipython 2. It must have message signing +-- turned off, because 'easyKernel' doesn't support it -- --- == Setting the executable --- To set the executable, modify the configuration object's +-- == Setting the executable To set the executable, modify the configuration object's -- @KernelManager.kernel_cmd@ property. For example: -- -- > c.KernelManager.kernel_cmd = ['my_kernel', '{connection_file}'] @@ -44,79 +38,73 @@ -- Consult the IPython documentation along with the generated profile -- source code for further configuration of the frontend, including -- syntax highlighting, logos, help text, and so forth. - module IHaskell.IPython.EasyKernel (easyKernel, installProfile, KernelConfig(..)) where -import Data.Aeson (decode) +import Data.Aeson (decode) import qualified Data.ByteString.Lazy as BL import qualified Codec.Archive.Tar as Tar -import Control.Concurrent (MVar, readChan, writeChan, newMVar, readMVar, modifyMVar_) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (forever, when) +import Control.Concurrent (MVar, readChan, writeChan, newMVar, readMVar, modifyMVar_) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad (forever, when, unless) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Text as T -import IHaskell.IPython.Kernel -import IHaskell.IPython.Message.UUID as UUID +import IHaskell.IPython.Kernel +import IHaskell.IPython.Message.UUID as UUID -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getHomeDirectory) -import System.FilePath (()) -import System.Exit (exitSuccess) -import System.IO (openFile, IOMode(ReadMode)) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, + getHomeDirectory) +import System.FilePath (()) +import System.Exit (exitSuccess) +import System.IO (openFile, IOMode(ReadMode)) --- | The kernel configuration specifies the behavior that is specific --- to your language. The type parameters provide the monad in which --- your kernel will run, the type of intermediate outputs from running --- cells, and the type of final results of cells, respectively. -data KernelConfig m output result = KernelConfig - { languageName :: String - -- ^ The name of the language. This field is used to calculate - -- the name of the profile, so it should contain characters that - -- are reasonable to have in file names. - , languageVersion :: [Int] -- ^ The version of the language - , profileSource :: IO (Maybe FilePath) - -- ^ Determine the source of a profile to install using - -- 'installProfile'. The source should be a tarball whose contents - -- will be unpacked directly into the profile directory. For - -- example, the file whose name is @ipython_config.py@ in the - -- tar file for a language named @lang@ will end up in - -- @~/.ipython/profile_lang/ipython_config.py@. - , displayOutput :: output -> [DisplayData] -- ^ How to render intermediate output - , displayResult :: result -> [DisplayData] -- ^ How to render final cell results - , completion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text) - -- ^ Perform completion. The returned tuple consists of the matches, - -- the matched text, and the completion text. The arguments are the - -- code in the cell, the current line as text, and the column at - -- which the cursor is placed. - , objectInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text) - -- ^ Return the information or documentation for its argument. The - -- returned tuple consists of the name, the documentation, and the - -- type, respectively. - , run :: T.Text -> IO () -> (output -> IO ()) -> m (result, ExecuteReplyStatus, String) - -- ^ Execute a cell. The arguments are the contents of the cell, an - -- IO action that will clear the current intermediate output, and an - -- IO action that will add a new item to the intermediate - -- output. The result consists of the actual result, the status to - -- be sent to IPython, and the contents of the pager. Return the - -- empty string to indicate that there is no pager output. Errors - -- should be handled by defining an appropriate error constructor in - -- your result type. - , debug :: Bool -- ^ Whether to print extra debugging information to - -- the console - } +-- | The kernel configuration specifies the behavior that is specific to your language. The type +-- parameters provide the monad in which your kernel will run, the type of intermediate outputs from +-- running cells, and the type of final results of cells, respectively. +data KernelConfig m output result = + KernelConfig + { + -- | The name of the language. This field is used to calculate the name of the profile, + -- so it should contain characters that are reasonable to have in file names. + languageName :: String + -- | The version of the language + , languageVersion :: [Int] + -- | Determine the source of a profile to install using 'installProfile'. The source should be a + -- tarball whose contents will be unpacked directly into the profile directory. For example, the + -- file whose name is @ipython_config.py@ in the tar file for a language named @lang@ will end up in + -- @~/.ipython/profile_lang/ipython_config.py@. + , profileSource :: IO (Maybe FilePath) + -- | How to render intermediate output + , displayOutput :: output -> [DisplayData] + -- | How to render final cell results + , displayResult :: result -> [DisplayData] + -- | Perform completion. The returned tuple consists of the matches, the matched text, and the + -- completion text. The arguments are the code in the cell, the current line as text, and the column + -- at which the cursor is placed. + , completion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text) + -- | Return the information or documentation for its argument. The returned tuple consists of the + -- name, the documentation, and the type, respectively. + , objectInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text) + -- | Execute a cell. The arguments are the contents of the cell, an IO action that will clear the + -- current intermediate output, and an IO action that will add a new item to the intermediate + -- output. The result consists of the actual result, the status to be sent to IPython, and the + -- contents of the pager. Return the empty string to indicate that there is no pager output. Errors + -- should be handled by defining an appropriate error constructor in your result type. + , run :: T.Text -> IO () -> (output -> IO ()) -> m (result, ExecuteReplyStatus, String) + , debug :: Bool -- ^ Whether to print extra debugging information to + } --- | Attempt to install the IPython profile from the .tar file --- indicated by the 'profileSource' field of the configuration, if it --- is not already installed. +-- the console | Attempt to install the IPython profile from the .tar file indicated by the +-- 'profileSource' field of the configuration, if it is not already installed. installProfile :: MonadIO m => KernelConfig m output result -> m () installProfile config = do installed <- isInstalled - when (not installed) $ do + unless installed $ do profSrc <- liftIO $ profileSource config case profSrc of Nothing -> liftIO (putStrLn "No IPython profile is installed or specified") @@ -124,10 +112,11 @@ profExists <- liftIO $ doesFileExist tar profTgt <- profDir if profExists - then do liftIO $ createDirectoryIfMissing True profTgt - liftIO $ Tar.extract profTgt tar - else liftIO . putStrLn $ - "The supplied profile source '" ++ tar ++ "' does not exist" + then do + liftIO $ createDirectoryIfMissing True profTgt + liftIO $ Tar.extract profTgt tar + else liftIO . putStrLn $ + "The supplied profile source '" ++ tar ++ "' does not exist" where profDir = do @@ -153,28 +142,29 @@ let repType = fromMaybe err (replyType $ msgType parent) err = error $ "No reply for message " ++ show (msgType parent) - return MessageHeader { - identifiers = identifiers parent, - parentHeader = Just parent, - metadata = Map.fromList [], - messageId = newMessageId, - sessionId = sessionId parent, - username = username parent, - msgType = 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. +-- | Execute an IPython kernel for a config. Your 'main' action should call this as the last thing +-- it does. easyKernel :: (MonadIO m) => FilePath -- ^ The connection file provided by the IPython frontend - -> KernelConfig m output result -- ^ The kernel configuration specifying how to react to messages + -> KernelConfig m output result -- ^ The kernel configuration specifying how to react to + -- messages -> m () easyKernel profileFile config = do prof <- liftIO $ getProfile profileFile - zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan) <- - liftIO $ serveProfile prof + zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan _) <- liftIO $ serveProfile + prof + False execCount <- liftIO $ newMVar 0 forever $ do req <- liftIO $ readChan shellReqChan @@ -183,7 +173,6 @@ reply <- replyTo config execCount zmq req repHeader liftIO $ writeChan shellRepChan reply - replyTo :: MonadIO m => KernelConfig m output result -> MVar Integer @@ -192,93 +181,79 @@ -> MessageHeader -> m Message replyTo config _ _ KernelInfoRequest{} replyHeader = - return KernelInfoReply - { header = replyHeader - , language = languageName config - , versionList = languageVersion config - } -replyTo config _ interface ShutdownRequest{restartPending=pending} replyHeader = do + return + KernelInfoReply + { header = replyHeader + , language = languageName config + , versionList = languageVersion config + } +replyTo config _ 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 - let send msg = writeChan (iopubChannel interface) msg + let send = writeChan (iopubChannel interface) busyHeader <- dupHeader replyHeader StatusMessage liftIO . send $ PublishStatus busyHeader Busy outputHeader <- dupHeader replyHeader DisplayDataMessage - (res, replyStatus, pagerOut) <- - let clearOutput = do - clearHeader <- dupHeader replyHeader ClearOutputMessage - send $ ClearOutput clearHeader False - sendOutput x = - send $ PublishDisplayData outputHeader (languageName config) - (displayOutput config x) - in run config code clearOutput sendOutput + (res, replyStatus, pagerOut) <- let clearOutput = do + clearHeader <- dupHeader replyHeader + ClearOutputMessage + send $ ClearOutput clearHeader False + sendOutput x = + send $ PublishDisplayData + outputHeader + (languageName config) + (displayOutput config x) + in run config code clearOutput sendOutput liftIO . send $ PublishDisplayData outputHeader (languageName config) (displayResult config res) idleHeader <- dupHeader replyHeader StatusMessage liftIO . send $ PublishStatus idleHeader Idle - liftIO $ modifyMVar_ execCount (return . (+1)) + liftIO $ modifyMVar_ execCount (return . (+ 1)) counter <- liftIO $ readMVar execCount - return ExecuteReply - { header = replyHeader - , pagerOutput = pagerOut - , executionCounter = fromIntegral counter - , status = replyStatus - } - -replyTo config _ _ req@CompleteRequest{} replyHeader = do - let code = getCode req - line = getCodeLine req - col = getCursorPos req + return + ExecuteReply + { header = replyHeader + , pagerOutput = pagerOut + , executionCounter = fromIntegral counter + , status = replyStatus + } - return $ case completion config code line col of - Nothing -> - CompleteReply - { header = replyHeader - , completionMatches = [] - , completionMatchedText = "" - , completionText = "" - , completionStatus = False - } - Just (matches, matchedText, cmplText) -> - CompleteReply - { header = replyHeader - , completionMatches = matches - , completionMatchedText = matchedText - , completionText = cmplText - , completionStatus = True - } +replyTo config _ _ req@CompleteRequest{} replyHeader = + -- TODO: FIX + error "Unimplemented in IPython 3.0" replyTo config _ _ ObjectInfoRequest { objectName = obj } replyHeader = - return $ case objectInfo config obj of - Just (name, docs, ty) -> ObjectInfoReply - { header = replyHeader - , objectName = obj - , objectFound = True - , objectTypeString = ty - , objectDocString = docs - } - Nothing -> ObjectInfoReply - { header = replyHeader - , objectName = obj - , objectFound = False - , objectTypeString = "" - , objectDocString = "" - } + return $ + case objectInfo config obj of + Just (name, docs, ty) -> ObjectInfoReply + { header = replyHeader + , objectName = obj + , objectFound = True + , objectTypeString = ty + , objectDocString = docs + } + Nothing -> ObjectInfoReply + { header = replyHeader + , objectName = obj + , objectFound = False + , objectTypeString = "" + , objectDocString = "" + } replyTo _ _ _ msg _ = do liftIO $ putStrLn "Unknown message: " liftIO $ print msg return msg - dupHeader :: MonadIO m => MessageHeader -> MessageType -> m MessageHeader dupHeader hdr mtype = - do uuid <- liftIO UUID.random - return hdr { messageId = uuid , msgType = mtype } + do + uuid <- liftIO UUID.random + return hdr { messageId = uuid, msgType = mtype } diff --git a/src/IHaskell/IPython/Kernel.hs b/src/IHaskell/IPython/Kernel.hs --- a/src/IHaskell/IPython/Kernel.hs +++ b/src/IHaskell/IPython/Kernel.hs @@ -1,16 +1,9 @@ --- | This module exports all the types and functions necessary to create an --- IPython language kernel that supports the @ipython console@ and @ipython --- notebook@ frontends. -module IHaskell.IPython.Kernel ( - module IHaskell.IPython.Types, - module IHaskell.IPython.Message.Writer, - module IHaskell.IPython.Message.Parser, - module IHaskell.IPython.Message.UUID, - module IHaskell.IPython.ZeroMQ, - ) where +-- | This module exports all the types and functions necessary to create an IPython language kernel +-- that supports the @ipython console@ and @ipython notebook@ frontends. +module IHaskell.IPython.Kernel (module X) where -import IHaskell.IPython.Types -import IHaskell.IPython.Message.Writer -import IHaskell.IPython.Message.Parser -import IHaskell.IPython.Message.UUID -import IHaskell.IPython.ZeroMQ +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/src/IHaskell/IPython/Message/Parser.hs b/src/IHaskell/IPython/Message/Parser.hs --- a/src/IHaskell/IPython/Message/Parser.hs +++ b/src/IHaskell/IPython/Message/Parser.hs @@ -1,191 +1,175 @@ {-# LANGUAGE OverloadedStrings #-} + -- | Description : Parsing messages received from IPython -- --- 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. +-- 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.IPython.Message.Parser (parseMessage) where -import Data.Aeson ((.:), decode, Result(..), Object) -import Control.Applicative ((<|>)) -import Data.Aeson.Types (parse) -import Data.ByteString -import Data.Map (Map) -import Data.Text (Text) - -import qualified Data.ByteString.Lazy as Lazy - -import IHaskell.IPython.Types +import Data.Aeson ((.:), decode, Result(..), Object) +import Control.Applicative ((<|>), (<$>), (<*>)) +import Data.Aeson.Types (parse) +import Data.ByteString +import Data.Map (Map) +import Data.Text (Text) +import qualified Data.ByteString.Lazy as Lazy +import IHaskell.IPython.Types type LByteString = Lazy.ByteString ------ External interface ----- - --- | Parse a message from its ByteString components into a Message. +-- --- 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 = + -> 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 - messageWithoutHeader = parser messageType $ Lazy.fromStrict content in - messageWithoutHeader { header = header } - ------ Module internals ----- + messageWithoutHeader = parser messageType $ Lazy.fromStrict content + in messageWithoutHeader { header = header } --- | Parse a header from its ByteString components into a MessageHeader. +-- --- 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 == "{}" +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) + 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 Text Text) + -- Get metadata as a simple map. + Just metadataMap = decode $ Lazy.fromStrict metadata :: Maybe (Map Text Text) noHeader :: MessageHeader noHeader = error "No header created" 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 KernelInfoRequestMessage = kernelInfoRequestParser -parser ExecuteRequestMessage = executeRequestParser -parser CompleteRequestMessage = completeRequestParser -parser ObjectInfoRequestMessage = objectInfoRequestParser -parser ShutdownRequestMessage = shutdownRequestParser -parser InputReplyMessage = inputReplyParser -parser CommOpenMessage = commOpenParser -parser CommDataMessage = commDataParser -parser CommCloseMessage = commCloseParser + -> LByteString -> Message -- ^ The parser that converts the body into a message. This message + -- should have an undefined header. +parser KernelInfoRequestMessage = kernelInfoRequestParser +parser ExecuteRequestMessage = executeRequestParser +parser CompleteRequestMessage = completeRequestParser +parser ObjectInfoRequestMessage = objectInfoRequestParser +parser ShutdownRequestMessage = shutdownRequestParser +parser InputReplyMessage = inputReplyParser +parser CommOpenMessage = commOpenParser +parser CommDataMessage = commDataParser +parser CommCloseMessage = commCloseParser +parser HistoryRequestMessage = historyRequestParser parser other = error $ "Unknown message type " ++ show other --- | Parse a kernel info request. --- A kernel info request has no auxiliary information, so ignore the body. +-- | Parse a kernel info request. A kernel info request has no auxiliary information, so ignore the +-- body. kernelInfoRequestParser :: LByteString -> Message kernelInfoRequestParser _ = KernelInfoRequest { header = noHeader } --- | Parse an execute request. --- Fields used are: +-- | 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 = +executeRequestParser content = let parser obj = do - code <- obj .: "code" - silent <- obj .: "silent" - storeHistory <- obj .: "store_history" - allowStdin <- obj .: "allow_stdin" + code <- obj .: "code" + silent <- obj .: "silent" + storeHistory <- obj .: "store_history" + allowStdin <- obj .: "allow_stdin" - return (code, silent, storeHistory, allowStdin) + return (code, silent, storeHistory, allowStdin) Just decoded = decode content - Success (code, silent, storeHistory, allowStdin) = parse parser decoded in - ExecuteRequest { - header = noHeader, - getCode = code, - getSilent = silent, - getAllowStdin = allowStdin, - getStoreHistory = storeHistory, - getUserVariables = [], - getUserExpressions = [] + Success (code, silent, storeHistory, allowStdin) = parse parser decoded + in ExecuteRequest + { header = noHeader + , getCode = code + , getSilent = silent + , getAllowStdin = allowStdin + , getStoreHistory = storeHistory + , getUserVariables = [] + , getUserExpressions = [] } -completeRequestParser :: LByteString -> Message -completeRequestParser content = parsed +requestParser parser content = parsed where - Success parsed = flip parse decoded $ \ obj -> do - code <- obj .: "block" <|> return "" - codeLine <- obj .: "line" - pos <- obj .: "cursor_pos" - return $ CompleteRequest noHeader code codeLine pos - - Just decoded = decode content + Success parsed = parse parser decoded + Just decoded = decode content -objectInfoRequestParser :: LByteString -> Message -objectInfoRequestParser content = parsed +historyRequestParser :: LByteString -> Message +historyRequestParser = requestParser $ \obj -> + HistoryRequest noHeader <$> obj .: "output" <*> obj .: "raw" <*> historyAccessType obj where - Success parsed = flip parse decoded $ \obj -> do - oname <- obj .: "oname" - dlevel <- obj .: "detail_level" - return $ ObjectInfoRequest noHeader oname dlevel + -- TODO: Implement full history access type parsing from message spec + historyAccessType obj = do + accessTypeStr <- obj .: "hist_access_type" + return $ + case accessTypeStr of + "range" -> HistoryRange + "tail" -> HistoryTail + "search" -> HistorySearch + str -> error $ "Unknown history access type: " ++ str - Just decoded = decode content +completeRequestParser :: LByteString -> Message +completeRequestParser = requestParser $ \obj -> do + code <- obj .: "code" + pos <- obj .: "cursor_pos" + return $ CompleteRequest noHeader code pos +objectInfoRequestParser :: LByteString -> Message +objectInfoRequestParser = requestParser $ \obj -> do + oname <- obj .: "oname" + dlevel <- obj .: "detail_level" + return $ ObjectInfoRequest noHeader oname dlevel shutdownRequestParser :: LByteString -> Message -shutdownRequestParser content = parsed - where - Success parsed = flip parse decoded $ \ obj -> do - code <- obj .: "restart" - return $ ShutdownRequest noHeader code - - Just decoded = decode content +shutdownRequestParser = requestParser $ \obj -> do + code <- obj .: "restart" + return $ ShutdownRequest noHeader code inputReplyParser :: LByteString -> Message -inputReplyParser content = parsed - where - Success parsed = flip parse decoded $ \ obj -> do - value <- obj .: "value" - return $ InputReply noHeader value - - Just decoded = decode content +inputReplyParser = requestParser $ \obj -> do + value <- obj .: "value" + return $ InputReply noHeader value commOpenParser :: LByteString -> Message -commOpenParser content = parsed - where - Success parsed = flip parse decoded $ \ obj -> do - uuid <- obj .: "comm_id" - name <- obj .: "target_name" - value <- obj .: "data" - return $ CommOpen noHeader name uuid value - - Just decoded = decode content +commOpenParser = requestParser $ \obj -> do + uuid <- obj .: "comm_id" + name <- obj .: "target_name" + value <- obj .: "data" + return $ CommOpen noHeader name uuid value commDataParser :: LByteString -> Message -commDataParser content = parsed - where - Success parsed = flip parse decoded $ \ obj -> do - uuid <- obj .: "comm_id" - value <- obj .: "data" - return $ CommData noHeader uuid value - - Just decoded = decode content +commDataParser = requestParser $ \obj -> do + uuid <- obj .: "comm_id" + value <- obj .: "data" + return $ CommData noHeader uuid value commCloseParser :: LByteString -> Message -commCloseParser content = parsed - where - Success parsed = flip parse decoded $ \ obj -> do - uuid <- obj .: "comm_id" - value <- obj .: "data" - return $ CommClose noHeader uuid value - - Just decoded = decode content +commCloseParser = requestParser $ \obj -> do + uuid <- obj .: "comm_id" + value <- obj .: "data" + return $ CommClose noHeader uuid value diff --git a/src/IHaskell/IPython/Message/UUID.hs b/src/IHaskell/IPython/Message/UUID.hs --- a/src/IHaskell/IPython/Message/UUID.hs +++ b/src/IHaskell/IPython/Message/UUID.hs @@ -1,26 +1,23 @@ -- | Description : UUID generator and data structure -- -- Generate, parse, and pretty print UUIDs for use with IPython. -module IHaskell.IPython.Message.UUID ( - UUID, - random, randoms, - ) where - -import Control.Monad (mzero, replicateM) -import Control.Applicative ((<$>)) -import Data.Text (pack) -import Data.Aeson -import Data.UUID.V4 (nextRandom) +module IHaskell.IPython.Message.UUID (UUID, random, randoms) where --- We use an internal string representation because for the purposes of --- IPython, it matters whether the letters are uppercase or lowercase and --- whether the dashes are present in the correct locations. For the --- purposes of new UUIDs, it does not matter, but IPython expects UUIDs --- passed to kernels to be returned unchanged, so we cannot actually parse --- them. +import Control.Monad (mzero, replicateM) +import Control.Applicative ((<$>)) +import Data.Text (pack) +import Data.Aeson +import Data.UUID.V4 (nextRandom) -- | A UUID (universally unique identifier). -data UUID = UUID String deriving (Show, Read, Eq, Ord) +data UUID = + -- We use an internal string representation because for the purposes of IPython, it + -- matters whether the letters are uppercase or lowercase and whether the dashes are + -- present in the correct locations. For the purposes of new UUIDs, it does not matter, + -- but IPython expects UUIDs passed to kernels to be returned unchanged, so we cannot + -- actually parse them. + UUID String + deriving (Show, Read, Eq, Ord) -- | Generate a list of random UUIDs. randoms :: Int -- ^ Number of UUIDs to generate. diff --git a/src/IHaskell/IPython/Message/Writer.hs b/src/IHaskell/IPython/Message/Writer.hs --- a/src/IHaskell/IPython/Message/Writer.hs +++ b/src/IHaskell/IPython/Message/Writer.hs @@ -1,129 +1,120 @@ {-# LANGUAGE OverloadedStrings #-} + -- | Description : @ToJSON@ for Messages -- -- This module contains the @ToJSON@ instance for @Message@. -module IHaskell.IPython.Message.Writer ( - ToJSON(..) -) where +module IHaskell.IPython.Message.Writer (ToJSON(..)) where -import Data.Aeson -import Data.Map (Map) -import Data.Text (Text, pack) -import Data.Monoid (mempty) +import Data.Aeson +import Data.Map (Map) +import Data.Text (Text, pack) +import Data.Monoid (mempty) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as B -import Data.Text.Encoding +import Data.Text.Encoding -import IHaskell.IPython.Types +import IHaskell.IPython.Types -- Convert message bodies into JSON. instance ToJSON Message where - toJSON KernelInfoReply{ versionList = vers, language = language } = object [ - "protocol_version" .= ints [4, 0], -- current protocol version, major and minor - "language_version" .= vers, - "language" .= language - ] + toJSON KernelInfoReply { versionList = vers, language = language } = + object ["protocol_version" .= string "5.0" -- current protocol version, major and minor + , "language_version" .= vers, "language" .= language] - toJSON ExecuteReply{ status = status, executionCounter = counter, pagerOutput = pager} = object [ - "status" .= show status, - "execution_count" .= counter, - "payload" .= - if null pager - then [] - else [object [ - "source" .= string "page", - "text" .= pager - ]], - "user_variables" .= emptyMap, - "user_expressions" .= emptyMap - ] - toJSON PublishStatus{ executionState = executionState } = object [ - "execution_state" .= executionState - ] - toJSON PublishStream{ streamType = streamType, streamContent = content } = object [ - "data" .= content, - "name" .= streamType - ] - toJSON PublishDisplayData{ source = src, displayData = datas } = object [ - "source" .= src, - "metadata" .= object [], - "data" .= object (map displayDataToJson datas) - ] + toJSON ExecuteReply { status = status, executionCounter = counter, pagerOutput = pager } = + object + [ "status" .= show status + , "execution_count" .= counter + , "payload" .= + if null pager + then [] + else [object ["source" .= string "page", "text" .= pager]] + , "user_variables" .= emptyMap + , "user_expressions" .= emptyMap + ] + toJSON PublishStatus { executionState = executionState } = + object ["execution_state" .= executionState] + toJSON PublishStream { streamType = streamType, streamContent = content } = + object ["data" .= content, "name" .= streamType] + toJSON PublishDisplayData { source = src, displayData = datas } = + object + ["source" .= src, "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 _ m mt t s) = object [ - "matches" .= m, - "matched_text" .= mt, - "text" .= t, - "status" .= if s then string "ok" else "error" - ] - toJSON o@ObjectInfoReply{} = object [ - "oname" .= objectName o, - "found" .= objectFound o, - "ismagic" .= False, - "isalias" .= False, - "type_name" .= objectTypeString o, - "docstring" .= objectDocString o - ] + 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 o@ObjectInfoReply{} = + object + [ "oname" .= + objectName o + , "found" .= objectFound o + , "ismagic" .= False + , "isalias" .= False + , "type_name" .= objectTypeString o + , "docstring" .= objectDocString o + ] - toJSON ShutdownReply{restartPending = restart} = object [ - "restart" .= restart - ] + toJSON ShutdownReply { restartPending = restart } = + object ["restart" .= restart] - toJSON ClearOutput{wait = wait} = object [ - "wait" .= wait - ] + toJSON ClearOutput { wait = wait } = + object ["wait" .= wait] - toJSON RequestInput{inputPrompt = prompt} = object [ - "prompt" .= prompt - ] + toJSON RequestInput { inputPrompt = prompt } = + object ["prompt" .= prompt] - toJSON req@CommOpen{} = object [ - "comm_id" .= commUuid req, - "target_name" .= commTargetName req, - "data" .= commData req - ] + toJSON req@CommOpen{} = + object ["comm_id" .= commUuid req, "target_name" .= commTargetName req, "data" .= commData req] - toJSON req@CommData{} = object [ - "comm_id" .= commUuid 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@CommClose{} = + object ["comm_id" .= commUuid req, "data" .= commData req] - toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body + toJSON req@HistoryReply{} = + object ["history" .= map tuplify (historyReply req)] + where + tuplify (HistoryReplyElement sess linum res) = (sess, linum, case res of + Left inp -> toJSON inp + Right (inp, out) -> toJSON out) + 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" + 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" + 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 -> (Text, Value) displayDataToJson (DisplayData mimeType dataStr) = - pack (show mimeType) .= String dataStr + pack (show mimeType) .= String dataStr ----- Constants ----- - emptyMap :: Map String String emptyMap = mempty diff --git a/src/IHaskell/IPython/Stdin.hs b/src/IHaskell/IPython/Stdin.hs --- a/src/IHaskell/IPython/Stdin.hs +++ b/src/IHaskell/IPython/Stdin.hs @@ -1,61 +1,50 @@ {-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-} --- | This module provides a way in which the Haskell standard input may be --- forwarded to the IPython frontend and thus allows the notebook to use --- the standard input. + +-- | This module provides a way in which the Haskell standard input may be forwarded to the IPython +-- frontend and thus allows the notebook to use the standard input. -- --- This relies on the implementation of file handles in GHC, and is --- generally unsafe and terrible. However, it is difficult to find another --- way to do it, as file handles are generally meant to point to streams --- and files, and not networked communication protocols. +-- This relies on the implementation of file handles in GHC, and is generally unsafe and terrible. +-- However, it is difficult to find another way to do it, as file handles are generally meant to +-- point to streams and files, and not networked communication protocols. -- --- In order to use this module, it must first be initialized with two --- things. First of all, in order to know how to communicate with the --- IPython frontend, it must know the kernel profile used for --- communication. For this, use @recordKernelProfile@ once the profile is --- known. Both this and @recordParentHeader@ take a directory name where --- they can store this data. +-- In order to use this module, it must first be initialized with two things. First of all, in order +-- to know how to communicate with the IPython frontend, it must know the kernel profile used for +-- communication. For this, use @recordKernelProfile@ once the profile is known. Both this and +-- @recordParentHeader@ take a directory name where they can store this data. -- --- Finally, the module must know what @execute_request@ message is --- currently being replied to (which will request the input). Thus, every --- time the language kernel receives an @execute_request@ message, it --- should inform this module via @recordParentHeader@, so that the module --- may generate messages with an appropriate parent header set. If this is --- not done, the IPython frontends will not recognize the target of the --- communication. +-- Finally, the module must know what @execute_request@ message is currently being replied to (which +-- will request the input). Thus, every time the language kernel receives an @execute_request@ +-- message, it should inform this module via @recordParentHeader@, so that the module may generate +-- messages with an appropriate parent header set. If this is not done, the IPython frontends will +-- not recognize the target of the communication. -- --- Finally, in order to activate this module, @fixStdin@ must be called --- once. It must be passed the same directory name as @recordParentHeader@ --- and @recordKernelProfile@. Note that if this is being used from within --- the GHC API, @fixStdin@ /must/ be called from within the GHC session --- not from the host code. -module IHaskell.IPython.Stdin ( - fixStdin, - recordParentHeader, - recordKernelProfile - ) where +-- Finally, in order to activate this module, @fixStdin@ must be called once. It must be passed the +-- same directory name as @recordParentHeader@ and @recordKernelProfile@. Note that if this is being +-- used from within the GHC API, @fixStdin@ /must/ be called from within the GHC session not from +-- the host code. +module IHaskell.IPython.Stdin (fixStdin, recordParentHeader, recordKernelProfile) where -import Control.Concurrent -import Control.Applicative ((<$>)) -import Control.Concurrent.Chan -import Control.Monad -import GHC.IO.Handle -import GHC.IO.Handle.Types -import System.IO -import System.Posix.IO -import System.IO.Unsafe -import qualified Data.Map as Map +import Control.Concurrent +import Control.Applicative ((<$>)) +import Control.Concurrent.Chan +import Control.Monad +import GHC.IO.Handle +import GHC.IO.Handle.Types +import System.IO +import System.Posix.IO +import System.IO.Unsafe +import qualified Data.Map as Map -import IHaskell.IPython.Types -import IHaskell.IPython.ZeroMQ -import IHaskell.IPython.Message.UUID as UUID +import IHaskell.IPython.Types +import IHaskell.IPython.ZeroMQ +import IHaskell.IPython.Message.UUID as UUID stdinInterface :: MVar ZeroMQStdin {-# NOINLINE stdinInterface #-} stdinInterface = unsafePerformIO newEmptyMVar --- | Manipulate standard input so that it is sourced from the IPython --- frontend. This function is build on layers of deep magical hackery, so --- be careful modifying it. +-- | Manipulate standard input so that it is sourced from the IPython frontend. This function is +-- build on layers of deep magical hackery, so be careful modifying it. fixStdin :: String -> IO () fixStdin dir = do -- Initialize the stdin interface. @@ -78,17 +67,18 @@ hDuplicateTo newStdin stdin loop stdinInput oldStdin newStdin + where loop stdinInput oldStdin newStdin = do let FileHandle _ mvar = stdin threadDelay $ 150 * 1000 empty <- isEmptyMVar mvar if not empty - then loop stdinInput oldStdin newStdin - else do - line <- getInputLine dir - hPutStr stdinInput $ line ++ "\n" - loop stdinInput oldStdin newStdin + then loop stdinInput oldStdin newStdin + else do + line <- getInputLine dir + hPutStr stdinInput $ line ++ "\n" + loop stdinInput oldStdin newStdin -- | Get a line of input from the IPython frontend. getInputLine :: String -> IO String @@ -98,15 +88,15 @@ -- Send a request for input. uuid <- UUID.random parentHeader <- read <$> readFile (dir ++ "/.last-req-header") - let header = MessageHeader { - username = username parentHeader, - identifiers = identifiers parentHeader, - parentHeader = Just parentHeader, - messageId = uuid, - sessionId = sessionId parentHeader, - metadata = Map.fromList [], - msgType = InputRequestMessage - } + let header = MessageHeader + { username = username parentHeader + , identifiers = identifiers parentHeader + , parentHeader = Just parentHeader + , messageId = uuid + , sessionId = sessionId parentHeader + , metadata = Map.fromList [] + , msgType = InputRequestMessage + } let msg = RequestInput header "" writeChan req msg diff --git a/src/IHaskell/IPython/Types.hs b/src/IHaskell/IPython/Types.hs --- a/src/IHaskell/IPython/Types.hs +++ b/src/IHaskell/IPython/Types.hs @@ -1,46 +1,52 @@ {-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-} --- | This module contains all types used to create an IPython language --- kernel. + +-- | This module contains all types used to create an IPython language kernel. module IHaskell.IPython.Types ( - -- * IPython kernel profile - Profile(..), - Transport(..), - Port(..), - IP(..), + -- * IPython kernel profile + Profile(..), + Transport(..), + Port(..), + IP(..), - -- * IPython messaging protocol - Message(..), - MessageHeader(..), - Username(..), - Metadata(..), - MessageType(..), - Width(..), Height(..), - StreamType(..), - ExecutionState(..), - ExecuteReplyStatus(..), - replyType, + -- * IPython kernelspecs + KernelSpec(..), - -- ** IPython display data message - DisplayData(..), - MimeType(..), - extractPlain - - ) where + -- * IPython messaging protocol + Message(..), + MessageHeader(..), + Username(..), + Metadata(..), + MessageType(..), + Width(..), + Height(..), + StreamType(..), + ExecutionState(..), + ExecuteReplyStatus(..), + HistoryAccessType(..), + HistoryReplyElement(..), + replyType, -import Data.Aeson -import Control.Applicative ((<$>), (<*>)) -import Data.ByteString (ByteString) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Text (Text) -import Data.Serialize -import IHaskell.IPython.Message.UUID -import GHC.Generics (Generic) -import Data.Typeable -import Data.List (find) -import Data.Map (Map) + -- ** IPython display data message + DisplayData(..), + MimeType(..), + extractPlain, + ) where --------------------- IPython Kernel Profile Types ---------------------- +import Data.Aeson +import Control.Applicative ((<$>), (<*>)) +import Data.ByteString (ByteString) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Text (Text) +import Data.Serialize +import IHaskell.IPython.Message.UUID +import GHC.Generics (Generic) +import Data.Typeable +import Data.List (find) +import Data.Map (Map) + +------------------ IPython Kernel Profile Types ---------------------- +-- -- | A TCP port. type Port = Int @@ -48,80 +54,108 @@ type IP = String -- | The transport mechanism used to communicate with the IPython frontend. -data Transport - = TCP -- ^ Default transport mechanism via TCP. - deriving (Show, Read) +data Transport = TCP -- ^ Default transport mechanism via TCP. + deriving (Show, Read) -- | A kernel profile, specifying how the kernel communicates. -data Profile = Profile { - ip :: IP, -- ^ The IP on which to listen. - transport :: Transport, -- ^ The transport mechanism. - stdinPort :: Port, -- ^ The stdin channel port. - controlPort :: Port, -- ^ The control channel port. - hbPort :: Port, -- ^ The heartbeat channel port. - shellPort :: Port, -- ^ The shell command port. - iopubPort :: Port, -- ^ The IOPub port. - key :: Text -- ^ The HMAC encryption key. - } deriving (Show, Read) +data Profile = + Profile + { ip :: IP -- ^ The IP on which to listen. + , transport :: Transport -- ^ The transport mechanism. + , stdinPort :: Port -- ^ The stdin channel port. + , controlPort :: Port -- ^ The control channel port. + , hbPort :: Port -- ^ The heartbeat channel port. + , shellPort :: Port -- ^ The shell command port. + , iopubPort :: Port -- ^ The IOPub port. + , signatureKey :: ByteString -- ^ The HMAC encryption key. + } + deriving (Show, Read) -- Convert the kernel profile to and from JSON. instance FromJSON Profile where - parseJSON (Object v) = - Profile <$> v .: "ip" - <*> v .: "transport" - <*> v .: "stdin_port" - <*> v .: "control_port" - <*> v .: "hb_port" - <*> v .: "shell_port" - <*> v .: "iopub_port" - <*> v .: "key" + parseJSON (Object v) = do + signatureScheme <- v .: "signature_scheme" + case signatureScheme of + "hmac-sha256" -> + Profile <$> v .: "ip" + <*> v .: "transport" + <*> v .: "stdin_port" + <*> v .: "control_port" + <*> v .: "hb_port" + <*> v .: "shell_port" + <*> v .: "iopub_port" + <*> (Text.encodeUtf8 <$> v .: "key") + sig -> error $ "Unexpected signature scheme: " ++ sig parseJSON _ = fail "Expecting JSON object." instance ToJSON Profile where - toJSON profile = object [ - "ip" .= ip profile, - "transport" .= transport profile, - "stdin_port" .= stdinPort profile, - "control_port".= controlPort profile, - "hb_port" .= hbPort profile, - "shell_port" .= shellPort profile, - "iopub_port" .= iopubPort profile, - "key" .= key profile - ] + toJSON profile = object + [ "ip" .= ip profile + , "transport" .= transport profile + , "stdin_port" .= stdinPort profile + , "control_port" .= controlPort profile + , "hb_port" .= hbPort profile + , "shell_port" .= shellPort profile + , "iopub_port" .= iopubPort profile + , "key" .= Text.decodeUtf8 (signatureKey profile) + ] instance FromJSON Transport where parseJSON (String mech) = case mech of "tcp" -> return TCP - _ -> fail $ "Unknown transport mechanism " ++ Text.unpack mech + _ -> fail $ "Unknown transport mechanism " ++ Text.unpack mech parseJSON _ = fail "Expected JSON string as transport." instance ToJSON Transport where toJSON TCP = String "tcp" +-------------------- 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") + , kernelLanguage :: String + -- | Command to run to start the kernel. One of the strings maybe @"{connection_file}"@, which will + -- be replaced by the path to a kernel profile file (see @Profile@) when the command is run. + , kernelCommand :: [String] + } + deriving (Eq, Show) --------------------- IPython Message Types ---------------------- +instance ToJSON KernelSpec where + toJSON kernelspec = object + [ "argv" .= kernelCommand kernelspec + , "display_name" .= kernelDisplayName kernelspec + , "language" .= kernelLanguage kernelspec + ] --- | 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. - } deriving (Show, Read) +------------------ IPython Message Types -------------------- +-- +-- | 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. + } + deriving (Show, Read) --- Convert a message header into the JSON field for the header. --- This field does not actually have all the record fields. +-- Convert a message header into the JSON field for the header. This field does not actually have +-- all the record fields. instance ToJSON MessageHeader where - toJSON header = object [ - "msg_id" .= messageId header, - "session" .= sessionId header, - "username" .= username header, - "msg_type" .= showMessageType (msgType header) - ] + toJSON header = object + [ "msg_id" .= messageId header + , "session" .= sessionId header + , "username" .= username header + , "version" .= ("5.0" :: String) + , "msg_type" .= showMessageType (msgType header) + ] -- | A username for the source of a message. type Username = Text @@ -151,203 +185,220 @@ | CommOpenMessage | CommDataMessage | CommCloseMessage - deriving (Show, Read, Eq) + | HistoryRequestMessage + | HistoryReplyMessage + deriving (Show, Read, Eq) showMessageType :: MessageType -> String -showMessageType KernelInfoReplyMessage = "kernel_info_reply" -showMessageType KernelInfoRequestMessage = "kernel_info_request" -showMessageType ExecuteReplyMessage = "execute_reply" -showMessageType ExecuteRequestMessage = "execute_request" -showMessageType StatusMessage = "status" -showMessageType StreamMessage = "stream" -showMessageType DisplayDataMessage = "display_data" -showMessageType OutputMessage = "pyout" -showMessageType InputMessage = "pyin" -showMessageType CompleteRequestMessage = "complete_request" -showMessageType CompleteReplyMessage = "complete_reply" -showMessageType ObjectInfoRequestMessage = "object_info_request" -showMessageType ObjectInfoReplyMessage = "object_info_reply" -showMessageType ShutdownRequestMessage = "shutdown_request" -showMessageType ShutdownReplyMessage = "shutdown_reply" -showMessageType ClearOutputMessage = "clear_output" -showMessageType InputRequestMessage = "input_request" -showMessageType InputReplyMessage = "input_reply" -showMessageType CommOpenMessage = "comm_open" -showMessageType CommDataMessage = "comm_msg" -showMessageType CommCloseMessage = "comm_close" +showMessageType KernelInfoReplyMessage = "kernel_info_reply" +showMessageType KernelInfoRequestMessage = "kernel_info_request" +showMessageType ExecuteReplyMessage = "execute_reply" +showMessageType ExecuteRequestMessage = "execute_request" +showMessageType StatusMessage = "status" +showMessageType StreamMessage = "stream" +showMessageType DisplayDataMessage = "display_data" +showMessageType OutputMessage = "pyout" +showMessageType InputMessage = "pyin" +showMessageType CompleteRequestMessage = "complete_request" +showMessageType CompleteReplyMessage = "complete_reply" +showMessageType ObjectInfoRequestMessage = "object_info_request" +showMessageType ObjectInfoReplyMessage = "object_info_reply" +showMessageType ShutdownRequestMessage = "shutdown_request" +showMessageType ShutdownReplyMessage = "shutdown_reply" +showMessageType ClearOutputMessage = "clear_output" +showMessageType InputRequestMessage = "input_request" +showMessageType InputReplyMessage = "input_reply" +showMessageType CommOpenMessage = "comm_open" +showMessageType CommDataMessage = "comm_msg" +showMessageType CommCloseMessage = "comm_close" +showMessageType HistoryRequestMessage = "history_request" +showMessageType HistoryReplyMessage = "history_reply" instance FromJSON MessageType where - parseJSON (String s) = case s of - "kernel_info_reply" -> return KernelInfoReplyMessage - "kernel_info_request" -> return KernelInfoRequestMessage - "execute_reply" -> return ExecuteReplyMessage - "execute_request" -> return ExecuteRequestMessage - "status" -> return StatusMessage - "stream" -> return StreamMessage - "display_data" -> return DisplayDataMessage - "pyout" -> return OutputMessage - "pyin" -> return InputMessage - "complete_request" -> return CompleteRequestMessage - "complete_reply" -> return CompleteReplyMessage - "object_info_request" -> return ObjectInfoRequestMessage - "object_info_reply" -> return ObjectInfoReplyMessage - "shutdown_request" -> return ShutdownRequestMessage - "shutdown_reply" -> return ShutdownReplyMessage - "clear_output" -> return ClearOutputMessage - "input_request" -> return InputRequestMessage - "input_reply" -> return InputReplyMessage - "comm_open" -> return CommOpenMessage - "comm_msg" -> return CommDataMessage - "comm_close" -> return CommCloseMessage + parseJSON (String s) = + case s of + "kernel_info_reply" -> return KernelInfoReplyMessage + "kernel_info_request" -> return KernelInfoRequestMessage + "execute_reply" -> return ExecuteReplyMessage + "execute_request" -> return ExecuteRequestMessage + "status" -> return StatusMessage + "stream" -> return StreamMessage + "display_data" -> return DisplayDataMessage + "pyout" -> return OutputMessage + "pyin" -> return InputMessage + "complete_request" -> return CompleteRequestMessage + "complete_reply" -> return CompleteReplyMessage + "object_info_request" -> return ObjectInfoRequestMessage + "object_info_reply" -> return ObjectInfoReplyMessage + "shutdown_request" -> return ShutdownRequestMessage + "shutdown_reply" -> return ShutdownReplyMessage + "clear_output" -> return ClearOutputMessage + "input_request" -> return InputRequestMessage + "input_reply" -> return InputReplyMessage + "comm_open" -> return CommOpenMessage + "comm_msg" -> return CommDataMessage + "comm_close" -> return CommCloseMessage + "history_request" -> return HistoryRequestMessage + "history_reply" -> return HistoryReplyMessage - _ -> fail ("Unknown message type: " ++ show s) + _ -> fail ("Unknown message type: " ++ show s) parseJSON _ = fail "Must be a string." - -- | A message used to communicate with the IPython frontend. -data Message - -- | A request from a frontend for information about the kernel. - = KernelInfoRequest { header :: MessageHeader } - -- | A response to a KernelInfoRequest. - | KernelInfoReply { - header :: MessageHeader, - versionList :: [Int], -- ^ The version of the language, e.g. [7, 6, 3] for GHC 7.6.3 - language :: String -- ^ The language name, e.g. "haskell" - } - - -- | A request from a frontend to execute some code. - | ExecuteRequest { - header :: MessageHeader, - getCode :: Text, -- ^ The code string. - getSilent :: Bool, -- ^ Whether this should be silently executed. - getStoreHistory :: Bool, -- ^ Whether to store this in history. - getAllowStdin :: Bool, -- ^ Whether this code can use stdin. - - getUserVariables :: [Text], -- ^ Unused. - getUserExpressions :: [Text] -- ^ Unused. - } - - -- | A reply to an execute request. - | ExecuteReply { - header :: MessageHeader, - status :: ExecuteReplyStatus, -- ^ The status of the output. - pagerOutput :: String, -- ^ The help string to show in the pager. - executionCounter :: Int -- ^ The execution count, i.e. which output this is. - } - - | PublishStatus { - header :: MessageHeader, - executionState :: ExecutionState -- ^ The execution state of the kernel. - } - - | PublishStream { - header :: MessageHeader, - streamType :: StreamType, -- ^ Which stream to publish to. - streamContent :: String -- ^ What to publish. - } - - | PublishDisplayData { - header :: MessageHeader, - source :: String, -- ^ The name of the data source. - displayData :: [DisplayData] -- ^ A list of data representations. - } - - | PublishOutput { - header :: MessageHeader, - reprText :: String, -- ^ Printed output text. - executionCount :: Int -- ^ Which output this is for. - } - - | PublishInput { - header :: MessageHeader, - inCode :: String, -- ^ Submitted input code. - executionCount :: Int -- ^ Which input this is. - } - - | CompleteRequest { - header :: MessageHeader, - getCode :: Text, {- ^ - The entire block of text where the line is. This may be useful in the +data Message = + -- | A request from a frontend for information about the kernel. + KernelInfoRequest { header :: MessageHeader } + | + -- | A response to a KernelInfoRequest. + KernelInfoReply + { header :: MessageHeader + , versionList :: [Int] -- ^ The version of the language, e.g. [7, 6, 3] for GHC + -- 7.6.3 + , language :: String -- ^ The language name, e.g. "haskell" + } + | + -- | A request from a frontend to execute some code. + ExecuteRequest + { header :: MessageHeader + , getCode :: Text -- ^ The code string. + , getSilent :: Bool -- ^ Whether this should be silently executed. + , getStoreHistory :: Bool -- ^ Whether to store this in history. + , getAllowStdin :: Bool -- ^ Whether this code can use stdin. + , getUserVariables :: [Text] -- ^ Unused. + , getUserExpressions :: [Text] -- ^ Unused. + } + | + -- | A reply to an execute request. + ExecuteReply + { header :: MessageHeader + , status :: ExecuteReplyStatus -- ^ The status of the output. + , pagerOutput :: String -- ^ The help string to show in the pager. + , executionCounter :: Int -- ^ The execution count, i.e. which output this is. + } + | + PublishStatus + { header :: MessageHeader + , executionState :: ExecutionState -- ^ The execution state of the kernel. + } + | + PublishStream + { header :: MessageHeader + , streamType :: StreamType -- ^ Which stream to publish to. + , streamContent :: String -- ^ What to publish. + } + | + PublishDisplayData + { header :: MessageHeader + , source :: String -- ^ The name of the data source. + , displayData :: [DisplayData] -- ^ A list of data representations. + } + | + PublishOutput + { header :: MessageHeader + , reprText :: String -- ^ Printed output text. + , executionCount :: Int -- ^ Which output this is for. + } + | + PublishInput + { header :: MessageHeader + , inCode :: String -- ^ Submitted input code. + , executionCount :: Int -- ^ Which input this is. + } + | + CompleteRequest + { header :: MessageHeader + , getCode :: Text {- ^ + The entire block of text where the line is. This may be useful in the case of multiline completions where more context may be needed. Note: if in practice this field proves unnecessary, remove it to lighten the - messages. json field @block@ -} - getCodeLine :: Text, -- ^ just the line with the cursor. json field @line@ - getCursorPos :: Int -- ^ position of the cursor (index into the line?). json field @cursor_pos@ - - } - - | CompleteReply { - header :: MessageHeader, - completionMatches :: [Text], - completionMatchedText :: Text, - completionText :: Text, - completionStatus :: Bool - } - - | ObjectInfoRequest { - header :: MessageHeader, - objectName :: Text, -- ^ Name of object being searched for. - detailLevel :: Int -- ^ Level of detail desired (defaults to 0). - -- 0 is equivalent to foo?, 1 is equivalent - -- to foo??. - } - - | ObjectInfoReply { - header :: MessageHeader, - objectName :: Text, -- ^ Name of object which was searched for. - objectFound :: Bool, -- ^ Whether the object was found. - objectTypeString :: Text, -- ^ Object type. - objectDocString :: Text - } - - | ShutdownRequest { - header :: MessageHeader, - restartPending :: Bool -- ^ Whether this shutdown precedes a restart. - } - | ShutdownReply { - header :: MessageHeader, - restartPending :: Bool -- ^ Whether this shutdown precedes a restart. - } - - | ClearOutput { - header :: MessageHeader, - wait :: Bool -- ^ Whether to wait to redraw until there is more output. - } - - | RequestInput { - header :: MessageHeader, - inputPrompt :: String - } - - | InputReply { - header :: MessageHeader, - inputValue :: String - } - - | CommOpen { - header :: MessageHeader, - commTargetName :: String, - commUuid :: UUID, - commData :: Value - } - - | CommData { - header :: MessageHeader, - commUuid :: UUID, - commData :: Value - } + messages. json field @code@ -} + , getCursorPos :: Int -- ^ Position of the cursor in unicode characters. json field + -- @cursor_pos@ + } + | + CompleteReply + { header :: MessageHeader + , completionMatches :: [Text] + , completionCursorStart :: Int + , completionCursorEnd :: Int + , completionMetadata :: Metadata + , completionStatus :: Bool + } + | + ObjectInfoRequest + { header :: MessageHeader + -- | Name of object being searched for. + , objectName :: Text + -- | Level of detail desired (defaults to 0). 0 is equivalent to foo?, 1 is equivalent to foo??. + , detailLevel :: Int + } + | + ObjectInfoReply + { header :: MessageHeader + , objectName :: Text -- ^ Name of object which was searched for. + , objectFound :: Bool -- ^ Whether the object was found. + , objectTypeString :: Text -- ^ Object type. + , objectDocString :: Text + } + | + ShutdownRequest + { header :: MessageHeader + , restartPending :: Bool -- ^ Whether this shutdown precedes a restart. + } + | + ShutdownReply + { header :: MessageHeader + , restartPending :: Bool -- ^ Whether this shutdown precedes a restart. + } + | + ClearOutput + { header :: MessageHeader + , wait :: Bool -- ^ Whether to wait to redraw until there is more output. + } + | RequestInput { header :: MessageHeader, inputPrompt :: String } + | InputReply { header :: MessageHeader, inputValue :: String } + | + CommOpen + { header :: MessageHeader + , commTargetName :: String + , commUuid :: UUID + , commData :: Value + } + | CommData { header :: MessageHeader, commUuid :: UUID, commData :: Value } + | CommClose { header :: MessageHeader, commUuid :: UUID, commData :: Value } + | + HistoryRequest + { header :: MessageHeader + , historyGetOutput :: Bool -- ^ If True, also return output history in the resulting + -- dict. + , historyRaw :: Bool -- ^ If True, return the raw input history, else the + -- transformed input. + , historyAccessType :: HistoryAccessType -- ^ What history is being requested. + } + | HistoryReply { header :: MessageHeader, historyReply :: [HistoryReplyElement] } + | SendNothing -- Dummy message; nothing is sent. + deriving Show - | CommClose { - header :: MessageHeader, - commUuid :: UUID, - commData :: Value - } +-- | Ways in which the frontend can request history. TODO: Implement fields as described in +-- messaging spec. +data HistoryAccessType = HistoryRange + | HistoryTail + | HistorySearch + deriving (Eq, Show) - | SendNothing -- Dummy message; nothing is sent. - deriving Show +-- | Reply to history requests. +data HistoryReplyElement = + HistoryReplyElement + { historyReplySession :: Int + , historyReplyLineNumber :: Int + , historyReplyContent :: Either String (String, String) + } + deriving (Eq, Show) -- | Possible statuses in the execution reply messages. -data ExecuteReplyStatus = Ok | Err | Abort +data ExecuteReplyStatus = Ok + | Err + | Abort instance Show ExecuteReplyStatus where show Ok = "ok" @@ -355,39 +406,49 @@ show Abort = "abort" -- | The execution state of the kernel. -data ExecutionState = Busy | Idle | Starting deriving Show +data ExecutionState = Busy + | Idle + | Starting + deriving Show -- | Input and output streams. -data StreamType = Stdin | Stdout deriving Show +data StreamType = Stdin + | Stdout + deriving Show -- | Get the reply message type for a request message type. replyType :: MessageType -> Maybe MessageType -replyType KernelInfoRequestMessage = Just KernelInfoReplyMessage -replyType ExecuteRequestMessage = Just ExecuteReplyMessage -replyType CompleteRequestMessage = Just CompleteReplyMessage -replyType ObjectInfoRequestMessage = Just ObjectInfoReplyMessage -replyType ShutdownRequestMessage = Just ShutdownReplyMessage +replyType KernelInfoRequestMessage = Just KernelInfoReplyMessage +replyType ExecuteRequestMessage = Just ExecuteReplyMessage +replyType CompleteRequestMessage = Just CompleteReplyMessage +replyType ObjectInfoRequestMessage = Just ObjectInfoReplyMessage +replyType ShutdownRequestMessage = Just ShutdownReplyMessage +replyType HistoryRequestMessage = Just HistoryReplyMessage replyType _ = Nothing -- | Data for display: a string with associated MIME type. -data DisplayData = DisplayData MimeType Text deriving (Typeable, Generic) +data DisplayData = DisplayData MimeType Text + deriving (Typeable, Generic) --- We can't print the actual data, otherwise this will be printed every --- time it gets computed because of the way the evaluator is structured. --- See how `displayExpr` is computed. +-- We can't print the actual data, otherwise this will be printed every time it gets computed +-- because of the way the evaluator is structured. See how `displayExpr` is computed. instance Show DisplayData where show _ = "DisplayData" -- Allow DisplayData serialization instance Serialize Text where - put str = put (Text.encodeUtf8 str) - get = Text.decodeUtf8 <$> get + put str = put (Text.encodeUtf8 str) + get = Text.decodeUtf8 <$> get + instance Serialize DisplayData + instance Serialize MimeType -- | Possible MIME types for the display data. type Width = Int + type Height = Int + data MimeType = PlainText | MimeHtml | MimePng Width Height @@ -395,22 +456,22 @@ | MimeSvg | MimeLatex | MimeJavascript - deriving (Eq, Typeable, Generic) + deriving (Eq, Typeable, Generic) -- Extract the plain text from a list of displays. extractPlain :: [DisplayData] -> String extractPlain disps = case find isPlain disps of - Nothing -> "" + Nothing -> "" Just (DisplayData PlainText bytestr) -> Text.unpack bytestr where isPlain (DisplayData mime _) = mime == PlainText instance Show MimeType where show PlainText = "text/plain" - show MimeHtml = "text/html" - show (MimePng _ _) = "image/png" - show (MimeJpg _ _) = "image/jpeg" - show MimeSvg = "image/svg+xml" + show MimeHtml = "text/html" + show (MimePng _ _) = "image/png" + show (MimeJpg _ _) = "image/jpeg" + show MimeSvg = "image/svg+xml" show MimeLatex = "text/latex" show MimeJavascript = "application/javascript" diff --git a/src/IHaskell/IPython/ZeroMQ.hs b/src/IHaskell/IPython/ZeroMQ.hs --- a/src/IHaskell/IPython/ZeroMQ.hs +++ b/src/IHaskell/IPython/ZeroMQ.hs @@ -1,53 +1,62 @@ {-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-} + -- | Description : Low-level ZeroMQ communication wrapper. -- --- The "ZeroMQ" module abstracts away the low-level 0MQ based interface with IPython, --- replacing it instead with a Haskell Channel based interface. The `serveProfile` function --- takes a IPython profile specification and returns the channel interface to use. -module IHaskell.IPython.ZeroMQ ( - ZeroMQInterface (..), - ZeroMQStdin(..), - serveProfile, - serveStdin, - ) where +-- The "ZeroMQ" module abstracts away the low-level 0MQ based interface with IPython, replacing it +-- instead with a Haskell Channel based interface. The `serveProfile` function takes a IPython +-- profile specification and returns the channel interface to use. +module IHaskell.IPython.ZeroMQ (ZeroMQInterface(..), ZeroMQStdin(..), serveProfile, serveStdin) where -import qualified Data.ByteString.Lazy as ByteString -import Data.ByteString (ByteString) -import Control.Concurrent -import Control.Monad -import System.IO.Unsafe -import Data.Aeson (encode) -import System.ZMQ4 hiding (stdin) +import qualified Data.ByteString.Lazy as LBS +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as Char +import Control.Concurrent +import Control.Monad +import System.IO.Unsafe +import Data.Aeson (encode) +import System.ZMQ4 hiding (stdin) +import Data.Digest.Pure.SHA as SHA +import Data.Monoid ((<>)) -import IHaskell.IPython.Types -import IHaskell.IPython.Message.Parser -import IHaskell.IPython.Message.Writer +import IHaskell.IPython.Types +import IHaskell.IPython.Message.Parser +import IHaskell.IPython.Message.Writer --- | The channel interface to the ZeroMQ sockets. All communication is done via --- Messages, which are encoded and decoded into a lower level form before being --- transmitted to IPython. These channels should functionally serve as --- high-level sockets which speak Messages instead of ByteStrings. -data ZeroMQInterface = Channels { - shellRequestChannel :: Chan Message, -- ^ A channel populated with requests from the frontend. - shellReplyChannel :: Chan Message, -- ^ Writing to this channel causes a reply to be sent to the frontend. - controlRequestChannel :: Chan Message, -- ^ This channel is a duplicate of the shell request channel, - -- ^ though using a different backend socket. - controlReplyChannel :: Chan Message, -- ^ This channel is a duplicate of the shell reply channel, - -- ^ though using a different backend socket. - iopubChannel :: Chan Message -- ^ Writing to this channel sends an iopub message to the frontend. - } +-- | The channel interface to the ZeroMQ sockets. All communication is done via Messages, which are +-- encoded and decoded into a lower level form before being transmitted to IPython. These channels +-- 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. + , shellReplyChannel :: Chan Message + -- | This channel is a duplicate of the shell request channel, though using a different backend + -- socket. + , controlRequestChannel :: Chan Message + -- | This channel is a duplicate of the shell reply channel, though using a different backend + -- socket. + , controlReplyChannel :: Chan Message + -- | Writing to this channel sends an iopub message to the frontend. + , iopubChannel :: Chan Message + -- | Key used to sign messages. + , hmacKey :: ByteString + } -data ZeroMQStdin = StdinChannel { - stdinRequestChannel :: Chan Message, - stdinReplyChannel :: Chan Message - } +data ZeroMQStdin = + StdinChannel + { stdinRequestChannel :: Chan Message + , stdinReplyChannel :: Chan Message + } --- | Start responding on all ZeroMQ channels used to communicate with IPython --- | via the provided profile. Return a set of channels which can be used to --- | communicate with IPython in a more structured manner. +-- | Start responding on all ZeroMQ channels used to communicate with IPython | via the provided +-- profile. Return a set of channels which can be used to | communicate with IPython in a more +-- structured manner. serveProfile :: Profile -- ^ The profile specifying which ports and transport mechanisms to use. + -> Bool -- ^ Print debug output -> IO ZeroMQInterface -- ^ The Message-channel based interface to the sockets. -serveProfile profile = do +serveProfile profile debug = do -- Create all channels which will be used for higher level communication. shellReqChan <- newChan shellRepChan <- newChan @@ -55,44 +64,43 @@ controlRepChan <- dupChan shellRepChan iopubChan <- newChan let channels = Channels shellReqChan shellRepChan controlReqChan controlRepChan iopubChan + (signatureKey profile) - -- Create the context in a separate thread that never finishes. If - -- withContext or withSocket complete, the context or socket become invalid. + -- 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 -- Serve on all sockets. - forkIO $ serveSocket context Rep (hbPort profile) $ heartbeat channels - forkIO $ serveSocket context Router (controlPort profile) $ control channels - forkIO $ serveSocket context Router (shellPort profile) $ shell channels + 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 - -- 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 used in other - -- threads. Thus, keep the last serveSocket in this thread. - serveSocket context Pub (iopubPort profile) $ iopub 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 + -- used in other threads. Thus, keep the last serveSocket in this thread. + serveSocket context Pub (iopubPort profile) $ iopub debug channels return channels -serveStdin :: Profile -> IO ZeroMQStdin +serveStdin :: Profile -> IO ZeroMQStdin serveStdin profile = do reqChannel <- newChan repChannel <- newChan - - -- Create the context in a separate thread that never finishes. If - -- withContext or withSocket complete, the context or socket become invalid. + + -- Create the context in a separate thread that never finishes. If withContext or withSocket + -- complete, the context or socket become invalid. forkIO $ withContext $ \context -> -- Serve on all sockets. serveSocket context Router (stdinPort profile) $ \socket -> do -- Read the request from the interface channel and send it. - readChan reqChannel >>= sendMessage socket + readChan reqChannel >>= sendMessage False (signatureKey profile) socket -- Receive a response and write it to the interface channel. - receiveMessage socket >>= writeChan repChannel + receiveMessage False socket >>= 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 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. serveSocket :: SocketType a => Context -> a -> Port -> (Socket a -> IO b) -> IO () serveSocket context socketType port action = void $ withSocket context socketType $ \socket -> do @@ -108,46 +116,45 @@ -- Send it back. send socket [] 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 :: ZeroMQInterface -> Socket Router -> IO () -shell channels socket = do +-- | 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 -- Receive a message and write it to the interface channel. - receiveMessage socket >>= writeChan requestChannel + receiveMessage debug socket >>= writeChan requestChannel -- Read the reply from the interface channel and send it. - readChan replyChannel >>= sendMessage socket + readChan replyChannel >>= sendMessage debug (hmacKey channels) socket where requestChannel = shellRequestChannel channels replyChannel = shellReplyChannel channels --- | 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. -control :: ZeroMQInterface -> Socket Router -> IO () -control channels socket = do +-- | 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. +control :: Bool -> ZeroMQInterface -> Socket Router -> IO () +control debug channels socket = do -- Receive a message and write it to the interface channel. - receiveMessage socket >>= writeChan requestChannel + receiveMessage debug socket >>= writeChan requestChannel -- Read the reply from the interface channel and send it. - readChan replyChannel >>= sendMessage socket + readChan replyChannel >>= sendMessage debug (hmacKey channels) socket where requestChannel = controlRequestChannel channels - replyChannel = controlReplyChannel channels + replyChannel = controlReplyChannel channels --- | Send messages via the iopub channel. --- | This reads messages from the ZeroMQ iopub interface channel --- | and then writes the messages to the socket. -iopub :: ZeroMQInterface -> Socket Pub -> IO () -iopub channels socket = - readChan (iopubChannel channels) >>= sendMessage socket +-- | 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 -- | Receive and parse a message from a socket. -receiveMessage :: Receiver a => Socket a -> IO Message -receiveMessage socket = do +receiveMessage :: Receiver a => Bool -> Socket a -> IO Message +receiveMessage debug socket = do -- Read all identifiers until the identifier/message delimiter. idents <- readUntil "" @@ -159,6 +166,12 @@ metadata <- next content <- next + when debug $ do + putStr "Header: " + Char.putStrLn headerData + putStr "Content: " + Char.putStrLn content + let message = parseMessage idents headerData parentHeader metadata content return message @@ -166,32 +179,27 @@ -- Receive the next piece of data from the socket. next = receive socket - -- Read data from the socket until we hit an ending string. - -- Return all data as a list, which does not include the ending string. + -- Read data from the socket until we hit an ending string. Return all data as a list, which does + -- not include the ending string. readUntil str = do line <- next if line /= str - then do - remaining <- readUntil str - return $ line : remaining - else return [] - --- | Encode a message in the IPython ZeroMQ communication protocol --- | and send it through the provided socket. -sendMessage :: Sender a => Socket a -> Message -> IO () -sendMessage _ SendNothing = return () -sendMessage socket message = do - let head = header message - parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head - idents = identifiers head - metadata = "{}" - content = encodeStrict message - headStr = encodeStrict head + then do + remaining <- readUntil str + return $ line : remaining + else return [] +-- | Encode a message in the IPython ZeroMQ communication protocol and send it through the provided +-- 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 + when debug $ print message + -- Send all pieces of the message. mapM_ sendPiece idents sendPiece "" - sendPiece "" + sendPiece signature sendPiece headStr sendPiece parentHeaderStr sendPiece metadata @@ -205,4 +213,20 @@ -- Encode to a strict bytestring. encodeStrict :: ToJSON a => a -> ByteString - encodeStrict = ByteString.toStrict . encode + encodeStrict = LBS.toStrict . encode + + -- Signature for the message using HMAC SHA-256. + signature :: ByteString + signature = hmac $ headStr <> parentHeaderStr <> metadata <> content + + -- Compute the HMAC SHA-256 signature of a bytestring message. + hmac :: ByteString -> ByteString + hmac = Char.pack . SHA.showDigest . SHA.hmacSha256 (LBS.fromStrict hmacKey) . LBS.fromStrict + + -- Pieces of the message. + head = header message + parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head + idents = identifiers head + metadata = "{}" + content = encodeStrict message + headStr = encodeStrict head