Skip to content

Commit 35f971c

Browse files
ChrisPennerChrisPenner
committed
Continue booting UCM on UCM Server port binding failure.
1 parent af2ff10 commit 35f971c

File tree

5 files changed

+49
-28
lines changed

5 files changed

+49
-28
lines changed

‎unison-cli/src/Unison/LSP.hs‎

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,8 @@ import Compat (onWindows)
1515
import Control.Monad.Reader
1616
import Data.ByteString.Builder.Extra (defaultChunkSize)
1717
import Data.Char (toLower)
18+
import Data.Text qualified as Text
19+
import Data.Text.IO qualified as Text
1820
import GHC.IO.Exception (ioe_errno)
1921
import Ki qualified
2022
import Language.LSP.Logging qualified as LSP
@@ -26,11 +28,9 @@ import Language.LSP.Server
2628
import Language.LSP.VFS
2729
import Network.Simple.TCP qualified as TCP
2830
import System.Environment (lookupEnv)
29-
import System.IO (hPutStrLn)
3031
import Unison.Codebase
3132
import Unison.Codebase.ProjectPath qualified as PP
3233
import Unison.Codebase.Runtime (Runtime)
33-
import Unison.Debug qualified as Debug
3434
import Unison.LSP.CancelRequest (cancelRequestHandler)
3535
import Unison.LSP.CodeAction (codeActionHandler)
3636
import Unison.LSP.CodeLens (codeLensHandler)
@@ -94,11 +94,9 @@ spawnLsp lspFormattingConfig codebase runtime signal =
9494
case Errno <$> ioe_errno ioerr of
9595
Just errNo
9696
| errNo == eADDRINUSE -> do
97-
putStrLn $ "Note: Port " <> lspPort <> " is already bound by another process or another UCM. The LSP server will not be started."
97+
Text.hPutStrLn UnliftIO.stderr $ "Note: Port " <> Text.pack lspPort <> " is already bound by another process or another UCM. The LSP server will not be started."
9898
_ -> do
99-
Debug.debugM Debug.LSP "LSP Exception" ioerr
100-
Debug.debugM Debug.LSP "LSP Errno" (ioe_errno ioerr)
101-
putStrLn "LSP server failed to start."
99+
Text.hPutStrLn UnliftIO.stderr $ "LSP server failed to start."
102100
-- Where to send logs that occur before a client connects
103101
lspServerLogger = Colog.filterBySeverity Colog.Error Colog.getSeverity $ Colog.cmap (fmap tShow) (LogAction print)
104102
-- Where to send logs that occur after a client connects
@@ -109,7 +107,7 @@ spawnLsp lspFormattingConfig codebase runtime signal =
109107
lookupEnv "UNISON_LSP_ENABLED" >>= \case
110108
Just (fmap toLower -> "false") -> pure ()
111109
Just (fmap toLower -> "true") -> runServer
112-
Just x -> hPutStrLn stderr $ "Invalid value for UNISON_LSP_ENABLED, expected 'true' or 'false' but found: " <> x
110+
Just x -> Text.hPutStrLn stderr $ "Invalid value for UNISON_LSP_ENABLED, expected 'true' or 'false' but found: " <> Text.pack x
113111
Nothing -> when (not onWindows) runServer
114112

115113
serverDefinition ::

‎unison-cli/src/Unison/Main.hs‎

Lines changed: 16 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -96,6 +96,7 @@ import Unison.Util.Pretty qualified as P
9696
import Unison.Version (Version)
9797
import Unison.Version qualified as Version
9898
import UnliftIO.Directory (getHomeDirectory)
99+
import UnliftIO qualified as UnliftIO
99100

100101
type Runtimes =
101102
(RTI.Runtime Symbol, RTI.Runtime Symbol, RTI.Runtime Symbol)
@@ -135,6 +136,11 @@ main version = do
135136
]
136137
else []
137138
]
139+
-- This makes our error messages more safe w/r to concurrency. Without it sometimes the
140+
-- error messaging from the UCM server and LSP server (both running in separate threads) get
141+
-- interleaved.
142+
-- https://hackage.haskell.org/package/base-4.21.0.0/docs/GHC-IO-Handle.html#v:hPutStr
143+
UnliftIO.hSetBuffering UnliftIO.stderr UnliftIO.LineBuffering
138144

139145
withCP65001 . runInUnboundThread . Ki.scoped $ \scope -> do
140146
interruptHandler <- defaultInterruptHandler
@@ -318,18 +324,19 @@ main version = do
318324
-- Windows when we move to GHC 9.*
319325
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224
320326
void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime changeSignal
321-
Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do
327+
Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \mayBaseUrl -> do
322328
case exitOption of
323329
DoNotExit -> do
324330
case isHeadless of
325331
Headless -> do
326-
PT.putPrettyLn $
327-
P.lines
328-
[ "I've started the Codebase API server at",
329-
P.text $ Server.urlFor Server.Api baseUrl,
330-
"and the Codebase UI at",
331-
P.text $ Server.urlFor (Server.ProjectBranchUI (ProjectAndBranch (UnsafeProjectName "scratch") (UnsafeProjectBranchName "main")) Path.Root Nothing) baseUrl
332-
]
332+
whenJust mayBaseUrl \baseUrl -> do
333+
PT.putPrettyLn $
334+
P.lines
335+
[ "I've started the Codebase API server at",
336+
P.text $ Server.urlFor Server.Api baseUrl,
337+
"and the Codebase UI at",
338+
P.text $ Server.urlFor (Server.ProjectBranchUI (ProjectAndBranch (UnsafeProjectName "scratch") (UnsafeProjectBranchName "main")) Path.Root Nothing) baseUrl
339+
]
333340
PT.putPrettyLn $
334341
P.string "Running the codebase manager headless with "
335342
<> P.shown GHC.Conc.numCapabilities
@@ -349,7 +356,7 @@ main version = do
349356
nRuntime
350357
theCodebase
351358
[]
352-
(Just baseUrl)
359+
mayBaseUrl
353360
(PP.toIds startingProjectPath)
354361
initRes
355362
lspCheckForChanges

‎unison-share-api/package.yaml‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@ library:
1111

1212
dependencies:
1313
- aeson >= 2.0.0.0
14-
- async
1514
- base
1615
- binary
1716
- bytes

‎unison-share-api/src/Unison/Server/CodebaseServer.hs‎

Lines changed: 27 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,6 @@
66
module Unison.Server.CodebaseServer where
77

88
import Control.Concurrent (newEmptyMVar, putMVar, readMVar)
9-
import Control.Concurrent.Async (race)
109
import Control.Exception (ErrorCall (..), throwIO)
1110
import Control.Monad.Reader
1211
import Control.Monad.Trans.Except
@@ -21,6 +20,7 @@ import Data.OpenApi.Lens qualified as OpenApi
2120
import Data.Proxy (Proxy (..))
2221
import Data.Text qualified as Text
2322
import Data.Text.Encoding qualified as Text
23+
import Data.Text.IO qualified as Text
2424
import GHC.Generics ()
2525
import Network.HTTP.Media ((//), (/:))
2626
import Network.HTTP.Types (HeaderName)
@@ -81,6 +81,7 @@ import System.Directory (canonicalizePath, doesFileExist)
8181
import System.Environment (getExecutablePath)
8282
import System.FilePath ((</>))
8383
import System.FilePath qualified as FilePath
84+
import System.IO.Error qualified as IOError
8485
import U.Codebase.Branch qualified as V2
8586
import U.Codebase.Causal qualified as Causal
8687
import U.Codebase.HashTags (CausalHash)
@@ -122,6 +123,8 @@ import Unison.Sqlite qualified as Sqlite
122123
import Unison.Symbol (Symbol)
123124
import Unison.Syntax.NameSegment qualified as NameSegment
124125
import Unison.Util.Pretty qualified as Pretty
126+
import UnliftIO qualified
127+
import UnliftIO.Async qualified as Async
125128

126129
-- HTML content type
127130
data HTML = HTML
@@ -449,7 +452,7 @@ startServer ::
449452
CodebaseServerOpts ->
450453
Rt.Runtime Symbol ->
451454
Codebase IO Symbol Ann ->
452-
(BaseUrl -> IO a) ->
455+
(Maybe BaseUrl -> IO a) ->
453456
IO a
454457
startServer env opts rt codebase onStart = do
455458
-- the `canonicalizePath` resolves symlinks
@@ -471,13 +474,28 @@ startServer env opts rt codebase onStart = do
471474
withPort settings baseUrl app' p = do
472475
started <- mkWaiter
473476
let settings' = setBeforeMainLoop (notify started ()) settings
474-
result <-
475-
race
476-
(runSettings settings' app')
477-
(waitFor started *> onStart (baseUrl p))
478-
case result of
479-
Left () -> throwIO $ ErrorCall "Server exited unexpectedly!"
480-
Right x -> pure x
477+
let runServer = do
478+
UnliftIO.try (runSettings settings' app') >>= \case
479+
Left ioerror | IOError.isAlreadyInUseError ioerror -> do
480+
Text.hPutStrLn UnliftIO.stderr $
481+
Text.unlines
482+
[ "Note: Port "
483+
<> Text.pack (show p)
484+
<> " is already bound by another process or another UCM. The UCM server will not be started."
485+
]
486+
Left e -> do
487+
Text.hPutStrLn UnliftIO.stderr $
488+
Text.unlines
489+
[ "UCM server failure: " <> Text.pack (show e),
490+
"The UCM server will not be restarted."
491+
]
492+
Right _ -> do
493+
throwIO $ ErrorCall "The UCM server exited unexpectedly, it will not be restarted."
494+
Async.withAsync runServer \serverHandle -> do
495+
-- Wait until either the server has started or the server has failed to start, then proceed with the callback, passing the base URL if the server started, and Nothing otherwise.
496+
UnliftIO.race (UnliftIO.wait serverHandle) (waitFor started) >>= \case
497+
Left _ -> onStart Nothing
498+
Right _ -> onStart (Just $ baseUrl p)
481499

482500
serveIndex :: FilePath -> Handler RawHtml
483501
serveIndex path = do

‎unison-share-api/unison-share-api.cabal‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
cabal-version: 1.12
22

3-
-- This file has been generated from package.yaml by hpack version 0.36.0.
3+
-- This file has been generated from package.yaml by hpack version 0.37.0.
44
--
55
-- see: https://github.com/sol/hpack
66

@@ -91,7 +91,6 @@ library
9191
build-depends:
9292
Diff
9393
, aeson >=2.0.0.0
94-
, async
9594
, base
9695
, binary
9796
, bytes

0 commit comments

Comments
 (0)