{-# 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 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

    discardCtrlC

    when verbose $ trace ("msg: " ++ (show msg))
    case 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..."
    r <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io
    when verbose $ trace "wrapRunTH done."
    when verbose $ trace "writing RunTHDone."
    writePipe pipe (putTHMessage RunTHDone)
    case 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
           str <- SomeException -> IO String
showException SomeException
e
           when verbose $ trace ("QException " ++ str)
           reply (QException 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"
     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 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"
    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 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. (HasCallStack, 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
  args <- IO [String]
getArgs
  (outh, inh, rest) <-
      case args of
        String
arg0:String
arg1:[String]
rest -> do
            inh  <- String -> IO Handle
readGhcHandle String
arg1
            outh <- readGhcHandle arg0
            return (outh, inh, rest)
        [String]
_ -> IO (Handle, Handle, [String])
forall a. IO a
dieWithUsage

  (verbose, rest') <- case 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)

  (wait, rest'') <- case 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')

  unless (null rest'') $
    dieWithUsage

  when verbose $
    printf "GHC iserv starting (in: %s; out: %s)\n" (show inh) (show outh)
  installSignalHandlers
  lo_ref <- newIORef Nothing
  let pipe = Pipe{pipeRead :: Handle
pipeRead = Handle
inh, pipeWrite :: Handle
pipeWrite = Handle
outh, pipeLeftovers :: IORef (Maybe ByteString)
pipeLeftovers = IORef (Maybe ByteString)
lo_ref}

  when wait $ do
    when verbose $
      putStrLn "Waiting 3s"
    threadDelay 3000000

  uninterruptibleMask $ serv verbose hook 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
    prog <- IO String
getProgName
    die $ prog ++ ": " ++ 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