Ide.hs

-----------------------------------------------------------------------------
--
-- Module      : Main
-- Description : The server accepting commands for psc-ide
-- Copyright   : Christoph Hegemann 2016
-- License     : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>
-- Stability   : experimental
--
-- |
-- The server accepting commands for psc-ide
-----------------------------------------------------------------------------

{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TemplateHaskell #-}

module Command.Ide (command) where

import Protolude

import Data.Aeson qualified as Aeson
import Control.Concurrent.STM (newTVarIO)
import "monad-logger" Control.Monad.Logger (MonadLogger, logDebug, logError, logInfo)
import Data.IORef (newIORef)
import Data.Text.IO qualified as T
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy.Char8 qualified as BSL8
import GHC.IO.Exception (IOErrorType(..), IOException(..))
import Language.PureScript.Ide (handleCommand)
import Language.PureScript.Ide.Command (Command(..), commandName)
import Language.PureScript.Ide.Util (decodeT, displayTimeSpec, encodeT, logPerf, runLogger)
import Language.PureScript.Ide.Error (IdeError(..))
import Language.PureScript.Ide.State (updateCacheTimestamp)
import Language.PureScript.Ide.Types (Ide, IdeConfiguration(..), IdeEnvironment(..), IdeLogLevel(..), emptyIdeState)
import Network.Socket qualified as Network
import Options.Applicative qualified as Opts
import SharedCLI qualified
import System.Directory (doesDirectoryExist, getCurrentDirectory, setCurrentDirectory)
import System.FilePath ((</>))
import System.IO (BufferMode(..), hClose, hFlush, hSetBuffering, hSetEncoding, utf8)
import System.IO.Error (isEOFError)

listenOnLocalhost :: Network.PortNumber -> IO Network.Socket
listenOnLocalhost port = do
  let hints = Network.defaultHints
        { Network.addrFamily = Network.AF_INET
        , Network.addrSocketType = Network.Stream
        }
  addr:_ <- Network.getAddrInfo (Just hints) (Just "127.0.0.1") (Just (show port))
  bracketOnError
    (Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr))
    Network.close
    (\sock -> do
      Network.setSocketOption sock Network.ReuseAddr 1
      Network.bind sock (Network.addrAddress addr)
      Network.listen sock Network.maxListenQueue
      pure sock)

data ServerOptions = ServerOptions
  { _serverDirectory  :: Maybe FilePath
  , _serverGlobs      :: [FilePath]
  , _serverGlobsFromFile :: Maybe FilePath
  , _serverGlobsExcluded :: [FilePath]
  , _serverOutputPath :: FilePath
  , _serverPort       :: Network.PortNumber
  , _serverLoglevel   :: IdeLogLevel
  -- TODO(Christoph) Deprecated
  , _serverEditorMode :: Bool
  , _serverPolling    :: Bool
  , _serverNoWatch    :: Bool
  } deriving (Show)

data ClientOptions = ClientOptions
  { clientPort :: Network.PortNumber
  }

command :: Opts.Parser (IO ())
command = Opts.helper <*> subcommands where
  subcommands :: Opts.Parser (IO ())
  subcommands = (Opts.subparser . fold)
    [ Opts.command "server"
        (Opts.info (fmap server serverOptions <**> Opts.helper)
          (Opts.progDesc "Start a server process"))
    , Opts.command "client"
        (Opts.info (fmap client clientOptions <**> Opts.helper)
          (Opts.progDesc "Connect to a running server"))
    ]

  client :: ClientOptions -> IO ()
  client ClientOptions{..} = do
    hSetEncoding stdin utf8
    hSetEncoding stdout utf8
    let handler (SomeException e) = do
          T.putStrLn ("Couldn't connect to purs ide server on port " <> show clientPort <> ":")
          print e
          exitFailure
    let hints = Network.defaultHints
          { Network.addrFamily = Network.AF_INET
          , Network.addrSocketType = Network.Stream
          }
    addr:_ <- Network.getAddrInfo (Just hints) (Just "127.0.0.1") (Just (show clientPort))
    sock <- Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr)
    Network.connect sock (Network.addrAddress addr) `catch` handler
    h <- Network.socketToHandle sock ReadWriteMode
    T.hPutStrLn h =<< T.getLine
    BS8.putStrLn =<< BS8.hGetLine h
    hFlush stdout
    hClose h

  clientOptions :: Opts.Parser ClientOptions
  clientOptions = ClientOptions . fromIntegral <$>
    Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))

  server :: ServerOptions -> IO ()
  server opts'@(ServerOptions dir globs globsFromFile globsExcluded outputPath port logLevel editorMode polling noWatch) = do
    when (logLevel == LogDebug || logLevel == LogAll)
      (putText "Parsed Options:" *> print opts')
    maybe (pure ()) setCurrentDirectory dir
    ideState <- newTVarIO emptyIdeState
    cwd <- getCurrentDirectory
    let fullOutputPath = cwd </> outputPath

    when editorMode
      (putText "The --editor-mode flag is deprecated and ignored. It's now the default behaviour and the flag will be removed in a future version")

    when polling
      (putText "The --polling flag is deprecated and ignored. purs ide no longer uses a file system watcher, instead it relies on its clients to notify it about updates and checks timestamps to invalidate itself")

    when noWatch
      (putText "The --no-watch flag is deprecated and ignored. purs ide no longer uses a file system watcher, instead it relies on its clients to notify it about updates and checks timestamps to invalidate itself")

    unlessM (doesDirectoryExist fullOutputPath) $ do
      putText "Your output directory didn't exist. This usually means you didn't compile your project yet."
      putText "psc-ide needs you to compile your project (for example by running pulp build)"

    let
      conf = IdeConfiguration
        { confLogLevel = logLevel
        , confOutputPath = outputPath
        , confGlobs = globs
        , confGlobsFromFile = globsFromFile
        , confGlobsExclude = globsExcluded
        }
    ts <- newIORef Nothing
    let
      env = IdeEnvironment
        { ideStateVar = ideState
        , ideConfiguration = conf
        , ideCacheDbTimestamp = ts
        }
    startServer port env

  serverOptions :: Opts.Parser ServerOptions
  serverOptions =
    ServerOptions
      <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd'))
      <*> many SharedCLI.inputFile
      <*> SharedCLI.globInputFile
      <*> many SharedCLI.excludeFiles
      <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/")
      <*> (fromIntegral <$>
           Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)))
      <*> (parseLogLevel <$> Opts.strOption
           (Opts.long "log-level"
            `mappend` Opts.value ""
            `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\""))
      -- TODO(Christoph): Deprecated
      <*> Opts.switch (Opts.long "editor-mode")
      <*> Opts.switch (Opts.long "no-watch")
      <*> Opts.switch (Opts.long "polling")

  parseLogLevel :: Text -> IdeLogLevel
  parseLogLevel s = case s of
    "debug" -> LogDebug
    "perf" -> LogPerf
    "all" -> LogAll
    "none" -> LogNone
    _ -> LogDefault

startServer :: Network.PortNumber -> IdeEnvironment -> IO ()
startServer port env = Network.withSocketsDo $ do
  sock <- listenOnLocalhost port
  runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env)
  where
    loop :: (Ide m, MonadLogger m) => Network.Socket -> m ()
    loop sock = do
      accepted <- runExceptT (acceptCommand sock)
      case accepted of
        Left err -> $(logError) err
        Right (cmd, h) -> do
          case decodeT cmd of
            Right cmd' -> do
              let message duration =
                    "Command "
                      <> commandName cmd'
                      <> " took "
                      <> displayTimeSpec duration
              logPerf message $ do
                result <- runExceptT $ do
                  updateCacheTimestamp >>= \case
                    Nothing -> pure ()
                    Just (before, after) -> do
                      -- If the cache db file was changed outside of the IDE
                      -- we trigger a reset before processing the command
                      $(logInfo) ("cachedb was changed from: " <> show before <> ", to: " <> show after)
                      unless (isLoadAll cmd') $
                        void (handleCommand Reset *> handleCommand (LoadSync []))
                  handleCommand cmd'
                liftIO $ catchGoneHandle $ BSL8.hPutStrLn h $ case result of
                  Right r  -> Aeson.encode r
                  Left err -> Aeson.encode err
              liftIO (hFlush stdout)
            Left err -> do
              let errMsg = "Parsing the command failed with:\n" <> err <> "\nCommand: " <> cmd
              $(logError) errMsg
              liftIO $ do
                catchGoneHandle (T.hPutStrLn h (encodeT (GeneralError errMsg)))
                hFlush stdout
          liftIO $ catchGoneHandle (hClose h)

isLoadAll :: Command -> Bool
isLoadAll = \case
  Load [] -> True
  _ -> False

catchGoneHandle :: IO () -> IO ()
catchGoneHandle =
  handle (\e -> case e of
    IOError { ioe_type = ResourceVanished } ->
      putText "[Error] psc-ide-server tried to interact with the handle, but the connection was already gone."
    _ -> throwIO e)

acceptCommand
  :: (MonadIO m, MonadLogger m, MonadError Text m)
  => Network.Socket
  -> m (Text, Handle)
acceptCommand sock = do
  h <- acceptConnection
  $(logDebug) "Accepted a connection"
  cmd' <- liftIO (catchJust
                  -- this means that the connection was
                  -- terminated without receiving any input
                  (\e -> if isEOFError e then Just () else Nothing)
                  (Just <$> T.hGetLine h)
                  (const (pure Nothing)))
  case cmd' of
    Nothing -> throwError "Connection was closed before any input arrived"
    Just cmd -> do
      $(logDebug) ("Received command: " <> cmd)
      pure (cmd, h)
  where
   acceptConnection = liftIO $ do
     -- Use low level accept to prevent accidental reverse name resolution
     (s,_) <- Network.accept sock
     h     <- Network.socketToHandle s ReadWriteMode
     hSetEncoding h utf8
     hSetBuffering h LineBuffering
     pure h