|
| 1 | +----------------------------------------------------------------------------- |
| 2 | +-- |
| 3 | +-- Module : Main |
| 4 | +-- Description : The server accepting commands for psc-ide |
| 5 | +-- Copyright : Christoph Hegemann 2016 |
| 6 | +-- License : MIT (http://opensource.org/licenses/MIT) |
| 7 | +-- |
| 8 | +-- Maintainer : Christoph Hegemann <[email protected]> |
| 9 | +-- Stability : experimental |
| 10 | +-- |
| 11 | +-- | |
| 12 | +-- The server accepting commands for psc-ide |
| 13 | +----------------------------------------------------------------------------- |
| 14 | + |
| 15 | +{-# LANGUAGE PackageImports #-} |
| 16 | +{-# LANGUAGE TemplateHaskell #-} |
| 17 | + |
| 18 | +module Command.QuickBuild (command) where |
| 19 | + |
| 20 | +import Protolude |
| 21 | + |
| 22 | +import Data.Aeson qualified as Aeson |
| 23 | +import Data.Set qualified as Set |
| 24 | +import Control.Concurrent.STM (newTVarIO) |
| 25 | +import "monad-logger" Control.Monad.Logger (MonadLogger, logDebug, logError, logInfo) |
| 26 | +import Data.IORef (newIORef) |
| 27 | +import Data.Text.IO qualified as T |
| 28 | +import Data.ByteString.Char8 qualified as BS8 |
| 29 | +import Data.ByteString.Lazy.Char8 qualified as BSL8 |
| 30 | +import GHC.IO.Exception (IOErrorType(..), IOException(..)) |
| 31 | +import Language.PureScript.Ide (handleCommand) |
| 32 | +import Language.PureScript.Ide.Command (Command(..), commandName) |
| 33 | +import Language.PureScript.Ide.Util (decodeT, displayTimeSpec, encodeT, logPerf, runLogger) |
| 34 | +import Language.PureScript.Ide.Error (IdeError(..)) |
| 35 | +import Language.PureScript.Ide.State (updateCacheTimestamp) |
| 36 | +import Language.PureScript.Ide.Types (Ide, IdeConfiguration(..), IdeEnvironment(..), IdeLogLevel(..), emptyIdeState) |
| 37 | +import Network.Socket qualified as Network |
| 38 | +import Options.Applicative qualified as Opts |
| 39 | +import SharedCLI qualified |
| 40 | +import System.Directory (doesDirectoryExist, getCurrentDirectory, setCurrentDirectory) |
| 41 | +import System.FilePath ((</>)) |
| 42 | +import System.IO (BufferMode(..), hClose, hFlush, hSetBuffering, hSetEncoding, utf8) |
| 43 | +import System.IO.Error (isEOFError) |
| 44 | +import Database.SQLite.Simple qualified as SQLite |
| 45 | +import Language.PureScript.Options as PO |
| 46 | + |
| 47 | +listenOnLocalhost :: Network.PortNumber -> IO Network.Socket |
| 48 | +listenOnLocalhost port = do |
| 49 | + let hints = Network.defaultHints |
| 50 | + { Network.addrFamily = Network.AF_INET |
| 51 | + , Network.addrSocketType = Network.Stream |
| 52 | + } |
| 53 | + addr:_ <- Network.getAddrInfo (Just hints) (Just "127.0.0.1") (Just (show port)) |
| 54 | + bracketOnError |
| 55 | + (Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr)) |
| 56 | + Network.close |
| 57 | + (\sock -> do |
| 58 | + Network.setSocketOption sock Network.ReuseAddr 1 |
| 59 | + Network.bind sock (Network.addrAddress addr) |
| 60 | + Network.listen sock Network.maxListenQueue |
| 61 | + pure sock) |
| 62 | + |
| 63 | +data ServerOptions = ServerOptions |
| 64 | + { _serverDirectory :: Maybe FilePath |
| 65 | + , _serverGlobs :: [FilePath] |
| 66 | + , _serverGlobsFromFile :: Maybe FilePath |
| 67 | + , _serverGlobsExcluded :: [FilePath] |
| 68 | + , _serverOutputPath :: FilePath |
| 69 | + , _srcFile :: FilePath |
| 70 | + , _serverPort :: Network.PortNumber |
| 71 | + , _serverLoglevel :: IdeLogLevel |
| 72 | + -- TODO(Christoph) Deprecated |
| 73 | + , _serverEditorMode :: Bool |
| 74 | + , _serverPolling :: Bool |
| 75 | + , _serverNoWatch :: Bool |
| 76 | + |
| 77 | + } deriving (Show) |
| 78 | + |
| 79 | +data ClientOptions = ClientOptions |
| 80 | + { clientPort :: Network.PortNumber |
| 81 | + } |
| 82 | + |
| 83 | +command :: Opts.Parser (IO ()) |
| 84 | +command = Opts.helper <*> subcommands where |
| 85 | + subcommands :: Opts.Parser (IO ()) |
| 86 | + subcommands = (Opts.subparser . fold) |
| 87 | + [ Opts.command "server" |
| 88 | + (Opts.info (fmap server serverOptions <**> Opts.helper) |
| 89 | + (Opts.progDesc "Start a server process")) |
| 90 | + ] |
| 91 | + |
| 92 | + server :: ServerOptions -> IO () |
| 93 | + server opts'@(ServerOptions dir globs globsFromFile globsExcluded outputPath srcFile port logLevel editorMode polling noWatch) = do |
| 94 | + when (logLevel == LogDebug || logLevel == LogAll) |
| 95 | + (putText "Parsed Options:" *> print opts') |
| 96 | + maybe (pure ()) setCurrentDirectory dir |
| 97 | + ideState <- newTVarIO emptyIdeState |
| 98 | + cwd <- getCurrentDirectory |
| 99 | + let fullOutputPath = cwd </> outputPath |
| 100 | + |
| 101 | + |
| 102 | + when noWatch |
| 103 | + (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") |
| 104 | + |
| 105 | + unlessM (doesDirectoryExist fullOutputPath) $ do |
| 106 | + putText "Your output directory didn't exist. This usually means you didn't compile your project yet." |
| 107 | + putText "psc-ide needs you to compile your project (for example by running pulp build)" |
| 108 | + |
| 109 | + let |
| 110 | + conf = IdeConfiguration |
| 111 | + { confLogLevel = logLevel |
| 112 | + , confOutputPath = outputPath |
| 113 | + , sqliteFilePath = outputPath </> "cache.db" |
| 114 | + , confGlobs = globs |
| 115 | + , confGlobsFromFile = globsFromFile |
| 116 | + , confGlobsExclude = globsExcluded |
| 117 | + } |
| 118 | + ts <- newIORef Nothing |
| 119 | + let |
| 120 | + env = IdeEnvironment |
| 121 | + { ideStateVar = ideState |
| 122 | + , ideConfiguration = conf |
| 123 | + , ideCacheDbTimestamp = ts |
| 124 | + , query = \q -> SQLite.withConnection (outputPath </> "cache.db") |
| 125 | + (\conn -> SQLite.query_ conn $ SQLite.Query q) |
| 126 | + } |
| 127 | + startServer srcFile env |
| 128 | + |
| 129 | + serverOptions :: Opts.Parser ServerOptions |
| 130 | + serverOptions = |
| 131 | + ServerOptions |
| 132 | + <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd')) |
| 133 | + <*> many SharedCLI.inputFile |
| 134 | + <*> SharedCLI.globInputFile |
| 135 | + <*> many SharedCLI.excludeFiles |
| 136 | + <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/") |
| 137 | + <*> Opts.strOption (Opts.long "file" `mappend` Opts.value "output/") |
| 138 | + <*> (fromIntegral <$> |
| 139 | + Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))) |
| 140 | + <*> (parseLogLevel <$> Opts.strOption |
| 141 | + (Opts.long "log-level" |
| 142 | + `mappend` Opts.value "" |
| 143 | + `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\"")) |
| 144 | + -- TODO(Christoph): Deprecated |
| 145 | + <*> Opts.switch (Opts.long "editor-mode") |
| 146 | + <*> Opts.switch (Opts.long "no-watch") |
| 147 | + <*> Opts.switch (Opts.long "polling") |
| 148 | + |
| 149 | + parseLogLevel :: Text -> IdeLogLevel |
| 150 | + parseLogLevel s = case s of |
| 151 | + "debug" -> LogDebug |
| 152 | + "perf" -> LogPerf |
| 153 | + "all" -> LogAll |
| 154 | + "none" -> LogNone |
| 155 | + _ -> LogDefault |
| 156 | + |
| 157 | +startServer :: FilePath -> IdeEnvironment -> IO () |
| 158 | +startServer fp'' env = do |
| 159 | + -- BSL8.putStrLn $ Aeson.encode fp'' |
| 160 | + runLogger (confLogLevel (ideConfiguration env)) (runReaderT (rebuildC fp'') env) |
| 161 | + -- runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env) |
| 162 | + where |
| 163 | + rebuildC :: (Ide m, MonadLogger m) => FilePath -> m () |
| 164 | + rebuildC fp = do |
| 165 | + runExceptT $ do |
| 166 | + result <- handleCommand (RebuildSync fp Nothing (Set.fromList [PO.JS])) |
| 167 | + |
| 168 | + -- liftIO $ BSL8.putStrLn $ Aeson.encode result |
| 169 | + |
| 170 | + return () |
| 171 | + |
| 172 | + |
| 173 | + return () |
| 174 | + |
| 175 | + loop :: (Ide m, MonadLogger m) => Network.Socket -> m () |
| 176 | + loop sock = do |
| 177 | + accepted <- runExceptT (acceptCommand sock) |
| 178 | + case accepted of |
| 179 | + Left err -> $(logError) err |
| 180 | + Right (cmd, h) -> do |
| 181 | + case decodeT cmd of |
| 182 | + Right cmd' -> do |
| 183 | + let message duration = |
| 184 | + "Command " |
| 185 | + <> commandName cmd' |
| 186 | + <> " took " |
| 187 | + <> displayTimeSpec duration |
| 188 | + logPerf message $ do |
| 189 | + result <- runExceptT $ do |
| 190 | + updateCacheTimestamp >>= \case |
| 191 | + Nothing -> pure () |
| 192 | + Just (before, after) -> do |
| 193 | + -- If the cache db file was changed outside of the IDE |
| 194 | + -- we trigger a reset before processing the command |
| 195 | + $(logInfo) ("cachedb was changed from: " <> show before <> ", to: " <> show after) |
| 196 | + unless (isLoadAll cmd') $ |
| 197 | + void (handleCommand Reset *> handleCommand (LoadSync [])) |
| 198 | + handleCommand cmd' |
| 199 | + liftIO $ catchGoneHandle $ BSL8.hPutStrLn h $ case result of |
| 200 | + Right r -> Aeson.encode r |
| 201 | + Left err -> Aeson.encode err |
| 202 | + liftIO (hFlush stdout) |
| 203 | + Left err -> do |
| 204 | + let errMsg = "Parsing the command failed with:\n" <> err <> "\nCommand: " <> cmd |
| 205 | + $(logError) errMsg |
| 206 | + liftIO $ do |
| 207 | + catchGoneHandle (T.hPutStrLn h (encodeT (GeneralError errMsg))) |
| 208 | + hFlush stdout |
| 209 | + liftIO $ catchGoneHandle (hClose h) |
| 210 | + |
| 211 | +isLoadAll :: Command -> Bool |
| 212 | +isLoadAll = \case |
| 213 | + Load [] -> True |
| 214 | + _ -> False |
| 215 | + |
| 216 | +catchGoneHandle :: IO () -> IO () |
| 217 | +catchGoneHandle = |
| 218 | + handle (\e -> case e of |
| 219 | + IOError { ioe_type = ResourceVanished } -> |
| 220 | + putText "[Error] psc-ide-server tried to interact with the handle, but the connection was already gone." |
| 221 | + _ -> throwIO e) |
| 222 | + |
| 223 | +acceptCommand |
| 224 | + :: (MonadIO m, MonadLogger m, MonadError Text m) |
| 225 | + => Network.Socket |
| 226 | + -> m (Text, Handle) |
| 227 | +acceptCommand sock = do |
| 228 | + h <- acceptConnection |
| 229 | + $(logDebug) "Accepted a connection" |
| 230 | + cmd' <- liftIO (catchJust |
| 231 | + -- this means that the connection was |
| 232 | + -- terminated without receiving any input |
| 233 | + (\e -> if isEOFError e then Just () else Nothing) |
| 234 | + (Just <$> T.hGetLine h) |
| 235 | + (const (pure Nothing))) |
| 236 | + case cmd' of |
| 237 | + Nothing -> throwError "Connection was closed before any input arrived" |
| 238 | + Just cmd -> do |
| 239 | + $(logDebug) ("Received command: " <> cmd) |
| 240 | + pure (cmd, h) |
| 241 | + where |
| 242 | + acceptConnection = liftIO $ do |
| 243 | + -- Use low level accept to prevent accidental reverse name resolution |
| 244 | + (s,_) <- Network.accept sock |
| 245 | + h <- Network.socketToHandle s ReadWriteMode |
| 246 | + hSetEncoding h utf8 |
| 247 | + hSetBuffering h LineBuffering |
| 248 | + pure h |
0 commit comments