content: -----------------------------------------------------------------------------
  --
  -- 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
  