{-# LANGUAGE NoImplicitPrelude, 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 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.
--
--
-- 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

import           IHaskellPrelude

import           Control.Concurrent
import           Control.Applicative ((<$>))
import           GHC.IO.Handle
import           GHC.IO.Handle.Types
import           System.FilePath ((</>))
import           System.Posix.IO
import           System.IO.Unsafe

import           IHaskell.IPython.Types
import           IHaskell.IPython.ZeroMQ
import           IHaskell.IPython.Message.UUID as UUID

stdinInterface :: MVar ZeroMQStdin
{-# NOINLINE stdinInterface #-}
stdinInterface :: MVar ZeroMQStdin
stdinInterface = forall a. IO a -> a
unsafePerformIO forall a. IO (MVar a)
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.
fixStdin :: String -> IO ()
fixStdin :: [Char] -> IO ()
fixStdin [Char]
dir = do
  -- Initialize the stdin interface.
  let fpath :: [Char]
fpath = [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
".kernel-profile"
  Profile
profile <- forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"fixStdin: Failed reading " forall a. [a] -> [a] -> [a]
++ [Char]
fpath)
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => [Char] -> Maybe a
readMay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile [Char]
fpath
  ZeroMQStdin
interface <- Profile -> IO ZeroMQStdin
serveStdin Profile
profile
  forall a. MVar a -> a -> IO ()
putMVar MVar ZeroMQStdin
stdinInterface ZeroMQStdin
interface
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
stdinOnce [Char]
dir

stdinOnce :: String -> IO ()
stdinOnce :: [Char] -> IO ()
stdinOnce [Char]
dir = do
  -- Create a pipe using and turn it into handles.
  (Fd
readEnd, Fd
writeEnd) <- IO (Fd, Fd)
createPipe
  Handle
newStdin <- Fd -> IO Handle
fdToHandle Fd
readEnd
  Handle
stdinInput <- Fd -> IO Handle
fdToHandle Fd
writeEnd
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
newStdin BufferMode
NoBuffering
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdinInput BufferMode
NoBuffering

  -- Store old stdin and swap in new stdin.
  Handle
oldStdin <- Handle -> IO Handle
hDuplicate Handle
stdin
  Handle -> Handle -> IO ()
hDuplicateTo Handle
newStdin Handle
stdin

  forall {t} {t} {b}. Handle -> t -> t -> IO b
loop Handle
stdinInput Handle
oldStdin Handle
newStdin

  where
    loop :: Handle -> t -> t -> IO b
loop Handle
stdinInput t
oldStdin t
newStdin = do
      let FileHandle [Char]
_ MVar Handle__
mvar = Handle
stdin
      Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
150 forall a. Num a => a -> a -> a
* Int
1000
      Bool
e <- forall a. MVar a -> IO Bool
isEmptyMVar MVar Handle__
mvar
      if Bool -> Bool
not Bool
e
        then Handle -> t -> t -> IO b
loop Handle
stdinInput t
oldStdin t
newStdin
        else do
          [Char]
line <- [Char] -> IO [Char]
getInputLine [Char]
dir
          Handle -> [Char] -> IO ()
hPutStr Handle
stdinInput forall a b. (a -> b) -> a -> b
$ [Char]
line forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
          Handle -> t -> t -> IO b
loop Handle
stdinInput t
oldStdin t
newStdin

-- | Get a line of input from the IPython frontend.
getInputLine :: String -> IO String
getInputLine :: [Char] -> IO [Char]
getInputLine [Char]
dir = do
  StdinChannel Chan Message
req Chan Message
rep <- forall a. MVar a -> IO a
readMVar MVar ZeroMQStdin
stdinInterface

  -- Send a request for input.
  UUID
uuid <- IO UUID
UUID.random
  let fpath :: [Char]
fpath = [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
".last-req-header"
  MessageHeader
parentHdr <- forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"getInputLine: Failed reading " forall a. [a] -> [a] -> [a]
++ [Char]
fpath)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => [Char] -> Maybe a
readMay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile [Char]
fpath
  let hdr :: MessageHeader
hdr = [ByteString]
-> Maybe MessageHeader
-> Metadata
-> UUID
-> UUID
-> Username
-> MessageType
-> [ByteString]
-> MessageHeader
MessageHeader (MessageHeader -> [ByteString]
mhIdentifiers MessageHeader
parentHdr) (forall a. a -> Maybe a
Just MessageHeader
parentHdr) forall a. Monoid a => a
mempty
              UUID
uuid (MessageHeader -> UUID
mhSessionId MessageHeader
parentHdr) (MessageHeader -> Username
mhUsername MessageHeader
parentHdr) MessageType
InputRequestMessage
              []
  let msg :: Message
msg = MessageHeader -> [Char] -> Message
RequestInput MessageHeader
hdr [Char]
""
  forall a. Chan a -> a -> IO ()
writeChan Chan Message
req Message
msg

  -- Get the reply.
  InputReply MessageHeader
_ [Char]
value <- forall a. Chan a -> IO a
readChan Chan Message
rep
  forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
value

recordParentHeader :: String -> MessageHeader -> IO ()
recordParentHeader :: [Char] -> MessageHeader -> IO ()
recordParentHeader [Char]
dir MessageHeader
hdr =
  [Char] -> [Char] -> IO ()
writeFile ([Char]
dir forall a. [a] -> [a] -> [a]
++ [Char]
"/.last-req-header") forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show MessageHeader
hdr

recordKernelProfile :: String -> Profile -> IO ()
recordKernelProfile :: [Char] -> Profile -> IO ()
recordKernelProfile [Char]
dir Profile
profile =
  [Char] -> [Char] -> IO ()
writeFile ([Char]
dir forall a. [a] -> [a] -> [a]
++ [Char]
"/.kernel-profile") forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Profile
profile