API.hs

{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}
module IdeSession.RPC.API (
    -- * External exceptions
    ExternalException(..)
  , serverKilledException
    -- * Client-server communication
  , RpcConversation(..)
  , Request(..)
  , Response(..)
    -- * Lazy bytestring with incremental Binary instance
  , IncBS(..)
    -- * IO utils
  , hPutFlush
  , ignoreIOExceptions
  , openPipeForWriting
  , openPipeForReading
  ) where

import Prelude hiding (take)
import Control.Applicative ((<$>))
import Control.Concurrent (threadDelay)
import Data.Binary (Binary)
import Data.Typeable (Typeable)
import System.IO (Handle, hFlush, openFile, IOMode(..), hPutChar, hGetChar)
import qualified Control.Exception as Ex
import qualified Data.Binary as Binary
import qualified Data.ByteString as BSS
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.ByteString.Lazy.Internal as BSL

--------------------------------------------------------------------------------
-- Exceptions thrown by the RPC server are retrown locally as                 --
-- 'ExternalException's                                                       --
--------------------------------------------------------------------------------

-- | Exceptions thrown by the remote server
data ExternalException = ExternalException {
     -- | The output from the server on stderr
     externalStdErr    :: String
     -- | The local exception that was thrown and alerted us to the problem
   , externalException :: Maybe Ex.IOException
   }
  deriving (Eq, Typeable)

instance Show ExternalException where
  show (ExternalException err Nothing) =
    "External exception: " ++ err
  show (ExternalException err (Just ex)) =
    "External exception: " ++ err ++ ". Local exception: " ++ show ex

instance Ex.Exception ExternalException

-- | Generic exception thrown if the server gets killed for unknown reason
serverKilledException :: Maybe Ex.IOException -> ExternalException
serverKilledException ex = ExternalException "Server killed" ex

{------------------------------------------------------------------------------
  Client-server communication
------------------------------------------------------------------------------}

data RpcConversation = RpcConversation {
    get :: forall a. (Typeable a, Binary a) => IO a
  , put :: forall a. (Typeable a, Binary a) => a -> IO ()
  }

data Request = Request IncBS | RequestShutdown
  deriving Show

newtype Response = Response IncBS

instance Binary Request where
  put (Request bs)         = Binary.putWord8 0 >> Binary.put bs
  put RequestShutdown      = Binary.putWord8 1

  get = do
    header <- Binary.getWord8
    case header of
      0 -> Request <$> Binary.get
      1 -> return RequestShutdown
      _ -> fail "Request.get: invalid header"

instance Binary Response where
  put (Response bs) = Binary.put bs
  get = Response <$> Binary.get

{------------------------------------------------------------------------------
  Lazy bytestring with an incremental Binary instance

  Note only does this avoid loading the entire ByteString into memory when
  serializing stuff, the standard Binary instance for Lazy bytestring is
  actually broken in 0.5 (http://hpaste.org/87401; fixed in 0.7, but even there
  still requires the length of the bytestring upfront).
------------------------------------------------------------------------------}

newtype IncBS = IncBS { unIncBS :: BSL.ByteString }

instance Binary IncBS where
  put (IncBS BSL.Empty)        = Binary.putWord8 0
  put (IncBS (BSL.Chunk b bs)) = do Binary.putWord8 1
                                    Binary.put b
                                    Binary.put (IncBS bs)

  get = go []
    where
      go :: [BSS.ByteString] -> Binary.Get IncBS
      go acc = do
        header <- Binary.getWord8
        case header of
          0 -> return . IncBS . BSL.fromChunks . reverse $ acc
          1 -> do b <- Binary.get ; go (b : acc)
          _ -> fail "IncBS.get: invalid header"

instance Show IncBS where
  show = show . unIncBS

{------------------------------------------------------------------------------
  Some IO utils
------------------------------------------------------------------------------}

-- | Write a bytestring to a buffer and flush
hPutFlush :: Handle -> BSL.ByteString -> IO ()
hPutFlush h bs = BSL.hPut h bs >> ignoreIOExceptions (hFlush h)

-- | Ignore IO exceptions
ignoreIOExceptions :: IO () -> IO ()
ignoreIOExceptions = Ex.handle ignore
  where
    ignore :: Ex.IOException -> IO ()
    ignore _ = return ()

-- | Open a pipe for writing
--
-- This is meant to be used together with 'openPipeForReading'
openPipeForWriting :: FilePath -> Int -> IO Handle
openPipeForWriting fp = go
  where
    go :: Int -> IO Handle
    go timeout = do
      -- We cannot open a pipe for writing without a corresponding reader
      mh <- Ex.try $ openFile fp WriteMode
      case mh of
        Left ex ->
          if timeout > delay
            then do threadDelay delay
                    go (timeout - delay)
            else Ex.throwIO (RPCPipeNotCreated ex)
        Right h -> do
          hPutChar h '!'
          hFlush h
          return h

    delay :: Int
    delay = 10000 -- 10 ms

data RPCPipeNotCreated = RPCPipeNotCreated Ex.IOException
    deriving Typeable
instance Ex.Exception RPCPipeNotCreated
instance Show RPCPipeNotCreated where
    show (RPCPipeNotCreated e) = "The bidirectional RPC pipe could not be opened. Exception was: " ++ show e

-- | Open a pipe for reading
--
-- This is meant to be used together with 'openPipeForWriting'
openPipeForReading :: FilePath -> Int -> IO Handle
openPipeForReading fp = \timeout -> do
    -- We _can_ open a pipe for reading without a corresponding writer
    h <- openFile fp ReadMode
    -- But if there is no corresponding writer, then trying to read from the
    -- pipe will report EOF. So we wait.
    go h timeout
    return h
  where
    go :: Handle -> Int -> IO ()
    go h timeout = do
      mc <- Ex.try $ hGetChar h
      case mc of
        Left ex ->
          if timeout > delay
            then do threadDelay delay
                    go h (timeout - delay)
            else Ex.throwIO (RPCPipeNotCreated ex)
        Right '!' ->
          return ()
        Right c ->
          Ex.throwIO (userError $ "openPipeForReading: Unexpected " ++ show c)

    delay :: Int
    delay = 10000 -- 10 ms