packages feed

ipython-kernel 0.3.0.0 → 0.6.0.0

raw patch · 10 files changed

+1015/−996 lines, 10 filesdep +SHAdep ~base

Dependencies added: SHA

Dependency ranges changed: base

Files

examples/Calc.hs view
@@ -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"
ipython-kernel.cabal view
@@ -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,
src/IHaskell/IPython/EasyKernel.hs view
@@ -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 }
src/IHaskell/IPython/Kernel.hs view
@@ -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
src/IHaskell/IPython/Message/Parser.hs view
@@ -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
src/IHaskell/IPython/Message/UUID.hs view
@@ -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.
src/IHaskell/IPython/Message/Writer.hs view
@@ -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
src/IHaskell/IPython/Stdin.hs view
@@ -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
src/IHaskell/IPython/Types.hs view
@@ -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"
src/IHaskell/IPython/ZeroMQ.hs view
@@ -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 "<IDS|MSG>" @@ -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 "<IDS|MSG>"-  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