{-# LANGUAGE CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-}
module GHCi.Server
  ( serv
  , defaultServer
  )
where

import Prelude
import GHCi.Run
import GHCi.TH
import GHCi.Message
import GHCi.Signals
import GHCi.Utils

import Control.DeepSeq
import Control.Exception
import Control.Monad
import Control.Concurrent (threadDelay)
import Data.Binary
import Data.IORef

import Text.Printf
import System.Environment (getProgName, getArgs)
import System.Exit

type MessageHook = Msg -> IO Msg

trace :: String -> IO ()
trace :: String -> IO ()
trace String
s = IO String
getProgName IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> String -> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"[%20s] %s\n" String
name String
s

serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
serv :: Bool -> MessageHook -> Pipe -> (forall a. IO a -> IO a) -> IO ()
serv Bool
verbose MessageHook
hook Pipe
pipe forall a. IO a -> IO a
restore = IO ()
loop
 where
  loop :: IO ()
loop = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"reading pipe..."
    Msg Message a
msg <- Pipe -> Get Msg -> IO Msg
forall a. Pipe -> Get a -> IO a
readPipe Pipe
pipe Get Msg
getMessage IO Msg -> MessageHook -> IO Msg
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageHook
hook

    IO ()
discardCtrlC

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace (String
"msg: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Message a -> String
forall a. Show a => a -> String
show Message a
msg))
    case Message a
msg of
      Message a
Shutdown -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      RunTH RemoteRef (IORef QState)
st HValueRef
q THResultType
ty Maybe Loc
loc -> IO ByteString -> IO ()
forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Pipe
-> RemoteRef (IORef QState)
-> HValueRef
-> THResultType
-> Maybe Loc
-> IO ByteString
runTH Pipe
pipe RemoteRef (IORef QState)
st HValueRef
q THResultType
ty Maybe Loc
loc
      RunModFinalizers RemoteRef (IORef QState)
st [RemoteRef (Q ())]
qrefs -> IO () -> IO ()
forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Pipe -> RemoteRef (IORef QState) -> [RemoteRef (Q ())] -> IO ()
runModFinalizerRefs Pipe
pipe RemoteRef (IORef QState)
st [RemoteRef (Q ())]
qrefs
      Message a
_other -> Message a -> IO a
forall a. Message a -> IO a
run Message a
msg IO a -> (a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply

  reply :: forall a. (Binary a, Show a) => a -> IO ()
  reply :: forall a. (Binary a, Show a) => a -> IO ()
reply a
r = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace (String
"writing pipe: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
r)
    Pipe -> Put -> IO ()
writePipe Pipe
pipe (a -> Put
forall t. Binary t => t -> Put
put a
r)
    IO ()
loop

  -- Run some TH code, which may interact with GHC by sending
  -- THMessage requests, and then finally send RunTHDone followed by a
  -- QResult.  For an overview of how TH works with Remote GHCi, see
  -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
  wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
  wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH IO a
io = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"wrapRunTH..."
    Either SomeException a
r <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"wrapRunTH done."
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"writing RunTHDone."
    Pipe -> Put -> IO ()
writePipe Pipe
pipe (THMessage () -> Put
forall a. THMessage a -> Put
putTHMessage THMessage ()
RunTHDone)
    case Either SomeException a
r of
      Left SomeException
e
        | Just (GHCiQException QState
_ String
err) <- SomeException -> Maybe GHCiQException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e  -> do
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace (String
"QFail " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
err)
           QResult a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply (String -> QResult a
forall a. String -> QResult a
QFail String
err :: QResult a)
        | Bool
otherwise -> do
           String
str <- SomeException -> IO String
showException SomeException
e
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace (String
"QException " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)
           QResult a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply (String -> QResult a
forall a. String -> QResult a
QException String
str :: QResult a)
      Right a
a -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"QDone"
        QResult a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply (a -> QResult a
forall a. a -> QResult a
QDone a
a)

  -- carefully when showing an exception, there might be other exceptions
  -- lurking inside it.  If so, we return the inner exception instead.
  showException :: SomeException -> IO String
  showException :: SomeException -> IO String
showException SomeException
e0 = do
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"showException"
     Either SomeException String
r <- IO String -> IO (Either SomeException String)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO String -> IO (Either SomeException String))
-> IO String -> IO (Either SomeException String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
evaluate (String -> String
forall a. NFData a => a -> a
force (SomeException -> String
forall a. Show a => a -> String
show (SomeException
e0::SomeException)))
     case Either SomeException String
r of
       Left SomeException
e -> SomeException -> IO String
showException SomeException
e
       Right String
str -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
str

  -- throw away any pending ^C exceptions while we're not running
  -- interpreted code.  GHC will also get the ^C, and either ignore it
  -- (if this is GHCi), or tell us to quit with a Shutdown message.
  discardCtrlC :: IO ()
discardCtrlC = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"discardCtrlC"
    Either AsyncException ()
r <- IO () -> IO (Either AsyncException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either AsyncException ()))
-> IO () -> IO (Either AsyncException ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case Either AsyncException ()
r of
      Left AsyncException
UserInterrupt -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
discardCtrlC
      Left AsyncException
e -> AsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO AsyncException
e
      Either AsyncException ()
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Default server
defaultServer :: IO ()
defaultServer :: IO ()
defaultServer = do
  [String]
args <- IO [String]
getArgs
  (Handle
outh, Handle
inh, [String]
rest) <-
      case [String]
args of
        String
arg0:String
arg1:[String]
rest -> do
            Handle
inh  <- String -> IO Handle
readGhcHandle String
arg1
            Handle
outh <- String -> IO Handle
readGhcHandle String
arg0
            (Handle, Handle, [String]) -> IO (Handle, Handle, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
outh, Handle
inh, [String]
rest)
        [String]
_ -> IO (Handle, Handle, [String])
forall a. IO a
dieWithUsage

  (Bool
verbose, [String]
rest') <- case [String]
rest of
    String
"-v":[String]
rest' -> (Bool, [String]) -> IO (Bool, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [String]
rest')
    [String]
_ -> (Bool, [String]) -> IO (Bool, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [String]
rest)

  (Bool
wait, [String]
rest'') <- case [String]
rest' of
    String
"-wait":[String]
rest'' -> (Bool, [String]) -> IO (Bool, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [String]
rest'')
    [String]
_ -> (Bool, [String]) -> IO (Bool, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [String]
rest')

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
rest'') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO ()
forall a. IO a
dieWithUsage

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"GHC iserv starting (in: %s; out: %s)\n" (Handle -> String
forall a. Show a => a -> String
show Handle
inh) (Handle -> String
forall a. Show a => a -> String
show Handle
outh)
  IO ()
installSignalHandlers
  IORef (Maybe ByteString)
lo_ref <- Maybe ByteString -> IO (IORef (Maybe ByteString))
forall a. a -> IO (IORef a)
newIORef Maybe ByteString
forall a. Maybe a
Nothing
  let pipe :: Pipe
pipe = Pipe{pipeRead :: Handle
pipeRead = Handle
inh, pipeWrite :: Handle
pipeWrite = Handle
outh, pipeLeftovers :: IORef (Maybe ByteString)
pipeLeftovers = IORef (Maybe ByteString)
lo_ref}

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wait (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
putStrLn String
"Waiting 3s"
    Int -> IO ()
threadDelay Int
3000000

  ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> MessageHook -> Pipe -> (forall a. IO a -> IO a) -> IO ()
serv Bool
verbose MessageHook
forall a. a -> IO a
hook Pipe
pipe

  where hook :: a -> IO a
hook = a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return -- empty hook
    -- we cannot allow any async exceptions while communicating, because
    -- we will lose sync in the protocol, hence uninterruptibleMask.

dieWithUsage :: IO a
dieWithUsage :: forall a. IO a
dieWithUsage = do
    String
prog <- IO String
getProgName
    String -> IO a
forall a. String -> IO a
die (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
prog String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
  where
#if defined(WINDOWS)
    msg = "usage: iserv <write-handle> <read-handle> [-v]"
#else
    msg :: String
msg = String
"usage: iserv <write-fd> <read-fd> [-v]"
#endif