content: {-# LANGUAGE DeriveGeneric       #-}
  {-# LANGUAGE OverloadedStrings   #-}
  {-# LANGUAGE RankNTypes          #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StandaloneDeriving  #-}
  {-# OPTIONS_GHC -Wall            #-}
  
  module Cardano.NodeIPC (startNodeJsIPC) where
  
  import           Control.Arrow ((>>>))
  import           Control.Concurrent (forkIO)
  import           Control.Monad.Reader (MonadReader)
  import           Data.Aeson (FromJSON (parseJSON), ToJSON (toEncoding),
                       defaultOptions, eitherDecode, encode, genericParseJSON,
                       genericToEncoding)
  import           Data.Aeson.Types (Options, SumEncoding (ObjectWithSingleField),
                       sumEncoding)
  import           Data.Binary.Get (getWord32le, getWord64le, runGet)
  import           Data.Binary.Put (putLazyByteString, putWord32le, putWord64le,
                       runPut)
  import qualified Data.ByteString.Lazy as BSL
  import qualified Data.ByteString.Lazy.Char8 as BSLC
  import           Distribution.System (OS (Windows), buildOS)
  import           GHC.Generics (Generic)
  import           GHC.IO.Handle.FD (fdToHandle)
  import           System.Environment (lookupEnv)
  import           System.IO (hFlush, hGetLine, hSetNewlineMode,
                       noNewlineTranslation)
  import           System.IO.Error (IOError, isEOFError)
  import           Universum
  
  import           Pos.Infra.InjectFail (FInject, listFInjects, setFInject)
  import           Pos.Infra.Shutdown.Class (HasShutdownContext (..))
  import           Pos.Infra.Shutdown.Logic (triggerShutdown)
  import           Pos.Infra.Shutdown.Types (ShutdownContext (..), shdnFInjects)
  import           Pos.Util.Wlog (WithLogger, logError, logInfo, usingLoggerName)
  
  data MsgIn  = QueryPort | Ping | SetFInject FInject Bool
    deriving (Show, Eq, Generic)
  data MsgOut = Started | ReplyPort Word16 | Pong | ParseError Text | FInjects [FInject]
    deriving (Show, Eq, Generic)
  
  opts :: Options
  opts = defaultOptions { sumEncoding = ObjectWithSingleField }
  
  instance FromJSON MsgIn  where parseJSON = genericParseJSON opts
  instance ToJSON   MsgOut where toEncoding = genericToEncoding opts
  
  startNodeJsIPC ::
      (MonadIO m, WithLogger m, MonadReader ctx m, HasShutdownContext ctx)
      => Word16 -> m ()
  startNodeJsIPC port = void $ runMaybeT $ do
    ctx <- view shutdownContext
    fdstring <- liftIO (lookupEnv "NODE_CHANNEL_FD") >>= (pure >>> MaybeT)
    case readEither fdstring of
      Left err -> lift $ logError $ "unable to parse NODE_CHANNEL_FD: " <> err
      Right fd -> liftIO $ do
          handle <- fdToHandle fd
          void $ forkIO $ startIpcListener ctx handle port
  
  startIpcListener :: ShutdownContext -> Handle -> Word16 -> IO ()
  startIpcListener ctx handle port = usingLoggerName "NodeIPC" $ flip runReaderT ctx (ipcListener handle port)
  
  readInt64 :: Handle -> IO Word64
  readInt64 hnd = do
      bs <- BSL.hGet hnd 8
      pure $ runGet getWord64le bs
  
  readInt32 :: Handle -> IO Word32
  readInt32 hnd = do
      bs <- BSL.hGet hnd 4
      pure $ runGet getWord32le bs
  
  readMessage :: (MonadIO m, WithLogger m) => Handle -> m BSL.ByteString
  readMessage handle = do
      if buildOS == Windows
          then do
              (int1, int2, blob) <- liftIO $ windowsReadMessage handle
              logInfo $ "int is: " <> (show [int1, int2]) <> " and blob is: " <> (show blob)
              return blob
          else
              liftIO $ linuxReadMessage handle
  
  windowsReadMessage :: Handle -> IO (Word32, Word32, BSL.ByteString)
  windowsReadMessage handle = do
      int1 <- readInt32 handle
      int2 <- readInt32 handle
      size <- readInt64 handle
      blob <- BSL.hGet handle $ fromIntegral size
      return (int1, int2, blob)
  
  linuxReadMessage :: Handle -> IO BSL.ByteString
  linuxReadMessage handle = do
      line <- hGetLine handle
      return $ BSLC.pack line
  
  sendMessage :: Handle -> BSL.ByteString -> IO ()
  sendMessage handle blob = do
      if buildOS == Windows
          then sendWindowsMessage handle 1 0 (blob <> "\n")
          else sendLinuxMessage handle blob
      hFlush handle
  
  sendWindowsMessage :: Handle -> Word32 -> Word32 -> BSL.ByteString -> IO ()
  sendWindowsMessage handle int1 int2 blob = do
      BSLC.hPut handle $ runPut $ (putWord32le int1) <> (putWord32le int2) <> (putWord64le $ fromIntegral $ BSL.length blob) <> (putLazyByteString blob)
  
  sendLinuxMessage :: Handle -> BSL.ByteString -> IO ()
  sendLinuxMessage = BSLC.hPutStrLn
  
  ipcListener ::
      forall m ctx . (MonadCatch m, MonadIO m, WithLogger m, MonadReader ctx m, HasShutdownContext ctx)
      => Handle -> Word16 -> m ()
  ipcListener handle port = do
    liftIO $ hSetNewlineMode handle noNewlineTranslation
    shutCtx <- view shutdownContext
    let
      send :: MsgOut -> m ()
      send cmd = liftIO $ sendMessage handle $ encode cmd
      action :: MsgIn -> m ()
      action QueryPort          = send $ ReplyPort port
      action Ping               = send Pong
      action (SetFInject fi en) = do
        liftIO $ setFInject (shutCtx ^. shdnFInjects) fi en
        send =<< FInjects <$> (liftIO $ listFInjects (shutCtx ^. shdnFInjects))
    let
      loop :: m ()
      loop = do
        send Started
        forever $ do
          line <- readMessage handle
          let
            handleMsgIn :: Either String MsgIn -> m ()
            handleMsgIn (Left err)  = send $ ParseError $ toText err
            handleMsgIn (Right cmd) = action cmd
          handleMsgIn $ eitherDecode line
      handler :: IOError -> m ()
      handler err = do
        logError $ "exception caught in NodeIPC: " <> (show err)
        when (isEOFError err) $ logError "its an eof"
        liftIO $ hFlush stdout
        triggerShutdown
    catch loop handler
  