Merge pull request #3199 from unisonweb/22-07-06-request-id-header

Print request id when we get an unexpected response

unison-cli/src/Unison/CommandLine/OutputMessages.hs

@@ -10,6 +10,7 @@ import Control.Monad.State
 import qualified Control.Monad.State.Strict as State
 import Control.Monad.Trans.Writer.CPS
 import Data.Bifunctor (first, second)
+import qualified Data.ByteString.Lazy as LazyByteString
 import qualified Data.Foldable as Foldable
 import Data.List (sort, stripPrefix)
 import qualified Data.List as List
@@ -20,8 +21,10 @@ import qualified Data.Sequence as Seq
 import qualified Data.Set as Set
 import Data.Set.NonEmpty (NESet)
 import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
 import Data.Tuple (swap)
 import Data.Tuple.Extra (dupe)
+import qualified Network.HTTP.Types as Http
 import Network.URI (URI)
 import qualified Servant.Client as Servant
 import System.Directory
@@ -640,8 +643,8 @@ notifyUser dir o = case o of
     CachedTests 0 _ -> pure . P.callout "😶" $ "No tests to run."
     CachedTests n n'
       | n == n' ->
-        pure $
-          P.lines [cache, "", displayTestResults True ppe oks fails]
+          pure $
+            P.lines [cache, "", displayTestResults True ppe oks fails]
     CachedTests _n m ->
       pure $
         if m == 0
@@ -650,6 +653,7 @@ notifyUser dir o = case o of
             P.indentN 2 $
               P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "✅  "]
       where
+
     NewlyComputed -> do
       clearCurrentLine
       pure $
@@ -1585,7 +1589,7 @@ notifyUser dir o = case o of
           "Host names should NOT include a schema or path."
         ]
   PrintVersion ucmVersion -> pure (P.text ucmVersion)
-  ShareError x -> (pure . P.warnCallout) case x of
+  ShareError x -> (pure . P.fatalCallout) case x of
     ShareErrorCheckAndSetPush e -> case e of
       (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash}) ->
         case (expectedHash, actualHash) of
@@ -1598,12 +1602,10 @@ notifyUser dir o = case o of
         expectedNonEmptyPushDest (sharePathToWriteRemotePathShare sharePath)
       (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath
       (Share.FastForwardPushInvalidParentage parent child) ->
-        P.fatalCallout
-          ( P.lines
-              [ "The server detected an error in the history being pushed, please report this as a bug in ucm.",
-                "The history in question is the hash: " <> prettyHash32 child <> " with the ancestor: " <> prettyHash32 parent
-              ]
-          )
+        P.lines
+          [ "The server detected an error in the history being pushed, please report this as a bug in ucm.",
+            "The history in question is the hash: " <> prettyHash32 child <> " with the ancestor: " <> prettyHash32 parent
+          ]
       Share.FastForwardPushErrorNotFastForward sharePath ->
         P.lines $
           [ P.wrap $
@@ -1627,24 +1629,42 @@ notifyUser dir o = case o of
         P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath
     ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err
     ShareErrorTransport te -> case te of
+      DecodeFailure msg resp ->
+        (P.lines . catMaybes)
+          [ Just ("The server sent a response that we couldn't decode: " <> P.text msg),
+            responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId)
+          ]
       Unauthenticated codeServerURL ->
-        P.fatalCallout $
-          P.wrap . P.lines $
-            [ "Authentication with this code server (" <> P.string (Servant.showBaseUrl codeServerURL) <> ") is missing or expired.",
-              "Please run " <> makeExample' IP.authLogin <> "."
-            ]
-      PermissionDenied msg -> P.fatalCallout $ P.hang "Permission denied:" (P.text msg)
+        P.wrap . P.lines $
+          [ "Authentication with this code server (" <> P.string (Servant.showBaseUrl codeServerURL) <> ") is missing or expired.",
+            "Please run " <> makeExample' IP.authLogin <> "."
+          ]
+      PermissionDenied msg -> P.hang "Permission denied:" (P.text msg)
       UnreachableCodeserver codeServerURL ->
         P.lines $
           [ P.wrap $ "Unable to reach the code server hosted at:" <> P.string (Servant.showBaseUrl codeServerURL),
             "",
             P.wrap "Please check your network, ensure you've provided the correct location, or try again later."
           ]
-      InvalidResponse resp -> P.fatalCallout $ P.hang "Invalid response received from codeserver:" (P.shown resp)
-      RateLimitExceeded -> P.warnCallout "Rate limit exceeded, please try again later."
-      InternalServerError -> P.fatalCallout "The code server encountered an error. Please try again later or report an issue if the problem persists."
-      Timeout -> P.fatalCallout "The code server timed-out when responding to your request. Please try again later or report an issue if the problem persists."
+      RateLimitExceeded -> "Rate limit exceeded, please try again later."
+      Timeout -> "The code server timed-out when responding to your request. Please try again later or report an issue if the problem persists."
+      UnexpectedResponse resp ->
+        (P.lines . catMaybes)
+          [ Just
+              ( "The server sent a "
+                  <> P.red (P.shown (Http.statusCode (Servant.responseStatusCode resp)))
+                  <> " that we didn't expect."
+              ),
+            let body = Text.decodeUtf8 (LazyByteString.toStrict (Servant.responseBody resp))
+             in if Text.null body then Nothing else Just (P.newline <> "Response body: " <> P.text body),
+            responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId)
+          ]
     where
+      -- Dig the request id out of a response header.
+      responseRequestId :: Servant.Response -> Maybe Text
+      responseRequestId =
+        fmap Text.decodeUtf8 . List.lookup "X-RequestId" . Foldable.toList @Seq . Servant.responseHeaders
+
       prettySharePath =
         prettyRelative
           . Path.Relative
@@ -1675,11 +1695,11 @@ notifyUser dir o = case o of
   where
     _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo"
     expectedEmptyPushDest writeRemotePath =
-        P.lines
-          [ "The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is not empty.",
-            "",
-            "Did you mean to use " <> IP.makeExample' IP.push <> " instead?"
-          ]
+      P.lines
+        [ "The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is not empty.",
+          "",
+          "Did you mean to use " <> IP.makeExample' IP.push <> " instead?"
+        ]
     expectedNonEmptyPushDest writeRemotePath =
       P.lines
         [ P.wrap ("The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is empty."),
@@ -2293,7 +2313,7 @@ showDiffNamespace ::
   (Pretty, NumberedArgs)
 showDiffNamespace _ _ _ _ diffOutput
   | OBD.isEmpty diffOutput =
-    ("The namespaces are identical.", mempty)
+      ("The namespaces are identical.", mempty)
 showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
   (P.sepNonEmpty "\n\n" p, toList args)
   where

unison-cli/src/Unison/Share/Sync.hs

@@ -63,6 +63,7 @@ import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity,
 import qualified Unison.Sync.Types as Share
 import Unison.Util.Monoid (foldMapM)
 import qualified UnliftIO
+import UnliftIO.Exception (throwIO)
 
 ------------------------------------------------------------------------------------------------------------------------
 -- Pile of constants
@@ -851,50 +852,45 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt
           go httpUploadEntities
         )
     where
-      hoist :: Servant.ClientM a -> ReaderT (BaseUrl, Servant.ClientEnv) IO a
+      hoist :: Servant.ClientM a -> ReaderT Servant.ClientEnv IO a
       hoist m = do
-        (shareURL, clientEnv) <- Reader.ask
-        throwEitherM $
-          liftIO (Servant.runClientM m clientEnv) >>= \case
-            Right a -> pure $ Right a
-            Left err -> do
-              Debug.debugLogM Debug.Sync (show err)
-              pure . Left $ case err of
-                Servant.FailureResponse _req resp -> case HTTP.statusCode $ Servant.responseStatusCode resp of
-                  401 -> Unauthenticated shareURL
+        clientEnv <- Reader.ask
+        liftIO (Servant.runClientM m clientEnv) >>= \case
+          Right a -> pure a
+          Left err -> do
+            Debug.debugLogM Debug.Sync (show err)
+            throwIO case err of
+              Servant.FailureResponse _req resp ->
+                case HTTP.statusCode $ Servant.responseStatusCode resp of
+                  401 -> Unauthenticated (Servant.baseUrl clientEnv)
                   -- The server should provide semantically relevant permission-denied messages
                   -- when possible, but this should catch any we miss.
                   403 -> PermissionDenied (Text.Lazy.toStrict . Text.Lazy.decodeUtf8 $ Servant.responseBody resp)
                   408 -> Timeout
                   429 -> RateLimitExceeded
-                  500 -> InternalServerError
                   504 -> Timeout
-                  code
-                    | code >= 500 -> InternalServerError
-                    | otherwise -> InvalidResponse resp
-                Servant.DecodeFailure _msg resp -> InvalidResponse resp
-                Servant.UnsupportedContentType _ct resp -> InvalidResponse resp
-                Servant.InvalidContentTypeHeader resp -> InvalidResponse resp
-                Servant.ConnectionError {} -> UnreachableCodeserver shareURL
+                  _ -> UnexpectedResponse resp
+              Servant.DecodeFailure msg resp -> DecodeFailure msg resp
+              Servant.UnsupportedContentType _ct resp -> UnexpectedResponse resp
+              Servant.InvalidContentTypeHeader resp -> UnexpectedResponse resp
+              Servant.ConnectionError _ -> UnreachableCodeserver (Servant.baseUrl clientEnv)
 
       go ::
-        (req -> ReaderT (BaseUrl, Servant.ClientEnv) IO resp) ->
+        (req -> ReaderT Servant.ClientEnv IO resp) ->
         Auth.AuthenticatedHttpClient ->
         BaseUrl ->
         req ->
         IO resp
       go f (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req =
         runReaderT
           (f req)
-          ( unisonShareUrl,
-            (Servant.mkClientEnv httpClient unisonShareUrl)
-              { Servant.makeClientRequest = \url request ->
-                  -- Disable client-side timeouts
-                  (Servant.defaultMakeClientRequest url request)
-                    { Http.Client.responseTimeout = Http.Client.responseTimeoutNone
-                    }
-              }
-          )
+          (Servant.mkClientEnv httpClient unisonShareUrl)
+            { Servant.makeClientRequest = \url request ->
+                -- Disable client-side timeouts
+                (Servant.defaultMakeClientRequest url request)
+                  { Http.Client.responseTimeout = Http.Client.responseTimeoutNone
+                  }
+            }
 
 catchSyncErrors :: IO (Either e a) -> IO (Either (SyncError e) a)
 catchSyncErrors action =

unison-cli/src/Unison/Share/Sync/Types.hs

@@ -42,15 +42,15 @@ data GetCausalHashByPathError
 
 -- | Generic Codeserver transport errors
 data CodeserverTransportError
-  = Unauthenticated Servant.BaseUrl
+  = DecodeFailure Text Servant.Response
   | -- We try to catch permission failures in the endpoint's response type, but if any slip
     -- through they'll be translated as a PermissionDenied.
     PermissionDenied Text
-  | UnreachableCodeserver Servant.BaseUrl
-  | InvalidResponse Servant.Response
   | RateLimitExceeded
-  | InternalServerError
   | Timeout
+  | Unauthenticated Servant.BaseUrl
+  | UnexpectedResponse Servant.Response
+  | UnreachableCodeserver Servant.BaseUrl
   deriving stock (Show)
   deriving anyclass (Exception)