Implement sync http client

parser-typechecker/package.yaml

@@ -50,6 +50,7 @@ library:
     - haskeline
     - http-types
     - http-media
+    - http-client
     - lens
     - ListLike
     - megaparsec >= 5.0.0 && < 7.0.0

parser-typechecker/src/Unison/Codebase/Editor/Git.hs

@@ -56,7 +56,7 @@ encodeFileName s =
       go ('$' : rem) = "$$" <> go rem
       go (c : rem)
         | elem @[] c "/\\:*?\"<>|" || not (Char.isPrint c && Char.isAscii c) =
-            "$x" <> encodeHex [c] <> "$" <> go rem
+          "$x" <> encodeHex [c] <> "$" <> go rem
         | otherwise = c : go rem
       go [] = []
       encodeHex :: String -> String

parser-typechecker/unison-parser-typechecker.cabal

@@ -241,6 +241,7 @@ library
     , hashable
     , hashtables
     , haskeline
+    , http-client
     , http-media
     , http-types
     , lens

unison-cli/package.yaml

@@ -54,7 +54,9 @@ dependencies:
   - lock-file
   - jwt
   - either
-
+  - unison-share-api
+  - servant-client
+  - servant
 
 library:
   source-dirs: src

unison-cli/src/Unison/Auth/HTTPClient.hs

@@ -1,4 +1,4 @@
-module Unison.Auth.HTTPClient where
+module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient(..)) where
 
 import qualified Data.Text.Encoding as Text
 import Network.HTTP.Client (Request)
@@ -11,6 +11,9 @@ import Unison.Codebase.Editor.Command (UCMVersion)
 import Unison.Prelude
 import qualified Unison.Util.HTTP as HTTP
 
+-- | Newtype to delineate HTTP Managers with access-token logic.
+newtype AuthorizedHttpClient = AuthorizedHttpClient HTTP.Manager
+
 -- | Returns a new http manager which applies the appropriate Authorization header to
 -- any hosts our UCM is authenticated with.
 newAuthorizedHTTPClient :: MonadIO m => CredentialManager -> UCMVersion -> m HTTP.Manager

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

@@ -0,0 +1,55 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Unison.Sync.HTTP
+  ( getPathHandler,
+    updatePathHandler,
+    downloadEntitiesHandler,
+    uploadEntitiesHandler,
+  )
+where
+
+import Control.Monad.Reader
+import Servant.API
+import Servant.Client
+import qualified Unison.Auth.HTTPClient as Auth
+import Unison.Prelude
+import qualified Unison.Sync.API as Sync
+import Unison.Sync.Types
+
+data SyncError
+  = ClientErr ClientError
+  deriving stock (Show)
+  deriving anyclass (Exception)
+
+getPathHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse
+updatePathHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> UpdatePathRequest -> IO UpdatePathResponse
+downloadEntitiesHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> DownloadEntitiesRequest -> IO DownloadEntitiesResponse
+uploadEntitiesHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> UploadEntitiesRequest -> IO UploadEntitiesResponse
+( getPathHandler,
+  updatePathHandler,
+  downloadEntitiesHandler,
+  uploadEntitiesHandler
+  ) =
+    let ( getPathHandler
+            :<|> updatePathHandler
+            :<|> downloadEntitiesHandler
+            :<|> uploadEntitiesHandler
+          ) = hoistClient Sync.api hoist (client Sync.api)
+     in (uncurryReaderT getPathHandler, uncurryReaderT updatePathHandler, uncurryReaderT downloadEntitiesHandler, uncurryReaderT uploadEntitiesHandler)
+    where
+      hoist :: forall a. ClientM a -> ReaderT (Auth.AuthorizedHttpClient, BaseUrl) IO a
+      hoist m = do
+        (Auth.AuthorizedHttpClient manager, baseUrl) <- ask
+        let clientEnv = mkClientEnv manager baseUrl
+        resp <- liftIO . throwEitherMWith ClientErr $ (runClientM m clientEnv)
+        pure resp
+
+      uncurryReaderT :: forall req resp. (req -> ReaderT (Auth.AuthorizedHttpClient, BaseUrl) IO resp) -> Auth.AuthorizedHttpClient -> BaseUrl -> req -> IO resp
+      uncurryReaderT f httpClient baseURL req =
+        runReaderT (f req) (httpClient, baseURL)

unison-cli/unison-cli.cabal

@@ -59,6 +59,7 @@ library
       Unison.CommandLine.Main
       Unison.CommandLine.OutputMessages
       Unison.CommandLine.Welcome
+      Unison.Sync.HTTP
       Unison.Util.HTTP
   other-modules:
       Paths_unison_cli
@@ -118,6 +119,8 @@ library
     , random >=1.2.0
     , regex-tdfa
     , semialign
+    , servant
+    , servant-client
     , stm
     , text
     , these
@@ -128,6 +131,7 @@ library
     , unison-parser-typechecker
     , unison-prelude
     , unison-pretty-printer
+    , unison-share-api
     , unison-util
     , unison-util-relation
     , unliftio
@@ -206,6 +210,8 @@ executable integration-tests
     , random >=1.2.0
     , regex-tdfa
     , semialign
+    , servant
+    , servant-client
     , shellmet
     , stm
     , text
@@ -217,6 +223,7 @@ executable integration-tests
     , unison-parser-typechecker
     , unison-prelude
     , unison-pretty-printer
+    , unison-share-api
     , unison-util
     , unison-util-relation
     , unliftio
@@ -289,6 +296,8 @@ executable transcripts
     , random >=1.2.0
     , regex-tdfa
     , semialign
+    , servant
+    , servant-client
     , shellmet
     , stm
     , text
@@ -301,6 +310,7 @@ executable transcripts
     , unison-parser-typechecker
     , unison-prelude
     , unison-pretty-printer
+    , unison-share-api
     , unison-util
     , unison-util-relation
     , unliftio
@@ -375,6 +385,8 @@ executable unison
     , random >=1.2.0
     , regex-tdfa
     , semialign
+    , servant
+    , servant-client
     , shellmet
     , stm
     , template-haskell
@@ -389,6 +401,7 @@ executable unison
     , unison-parser-typechecker
     , unison-prelude
     , unison-pretty-printer
+    , unison-share-api
     , unison-util
     , unison-util-relation
     , unliftio
@@ -468,6 +481,8 @@ test-suite tests
     , random >=1.2.0
     , regex-tdfa
     , semialign
+    , servant
+    , servant-client
     , shellmet
     , stm
     , temporary
@@ -481,6 +496,7 @@ test-suite tests
     , unison-parser-typechecker
     , unison-prelude
     , unison-pretty-printer
+    , unison-share-api
     , unison-util
     , unison-util-relation
     , unliftio

unison-share-api/src/Unison/Sync/API.hs

@@ -1,10 +1,14 @@
 {-# LANGUAGE DataKinds #-}
 
-module Unison.Sync.API (API) where
+module Unison.Sync.API (API, api) where
 
+import Data.Proxy
 import Servant.API
 import Unison.Sync.Types
 
+api :: Proxy API
+api = Proxy
+
 type API =
   "path" :> "get" :> GetCausalHashByPathEndpoint
     :<|> "path" :> "update" :> UpdatePathEndpoint
@@ -17,7 +21,7 @@ type GetCausalHashByPathEndpoint =
 
 type UpdatePathEndpoint =
   ReqBody '[JSON] UpdatePathRequest
-    :> UVerb 'POST '[JSON] '[WithStatus 204 NoContent, WithStatus 404 (NeedDependencies HashJWT), WithStatus 412 HashMismatch]
+    :> Post '[JSON] UpdatePathResponse
 
 type DownloadEntitiesEndpoint =
   ReqBody '[JSON] DownloadEntitiesRequest
@@ -25,4 +29,4 @@ type DownloadEntitiesEndpoint =
 
 type UploadEntitiesEndpoint =
   ReqBody '[JSON] UploadEntitiesRequest
-    :> UVerb 'POST '[JSON] '[WithStatus 200 NoContent, WithStatus 202 (NeedDependencies Hash)]
+    :> Post '[JSON] UploadEntitiesResponse

unison-share-api/src/Unison/Sync/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RecordWildCards #-}
 
 module Unison.Sync.Types where
@@ -10,6 +11,7 @@ import Data.Bifunctor
 import Data.Bitraversable
 import Data.ByteArray.Encoding (Base (Base64), convertFromBase, convertToBase)
 import Data.ByteString (ByteString)
+import Data.Function ((&))
 import Data.Map.NonEmpty (NEMap)
 import Data.Set (Set)
 import Data.Set.NonEmpty (NESet)
@@ -154,6 +156,10 @@ instance ToJSON DownloadEntitiesResponse where
       [ "entities" .= entities
       ]
 
+instance FromJSON DownloadEntitiesResponse where
+  parseJSON = Aeson.withObject "DownloadEntitiesResponse" $ \obj -> do
+    DownloadEntitiesResponse <$> obj .: "entities"
+
 data UpdatePathRequest = UpdatePathRequest
   { path :: RepoPath,
     expectedHash :: Maybe TypedHash, -- Nothing requires empty history at destination
@@ -176,12 +182,34 @@ instance FromJSON UpdatePathRequest where
     newHash <- obj .: "new_hash"
     pure UpdatePathRequest {..}
 
--- | Not used in the servant API, but is a useful return type for clients to use.
 data UpdatePathResponse
-  = UpdatePathHashMismatch HashMismatch
+  = UpdatePathSuccess
+  | UpdatePathHashMismatch HashMismatch
   | UpdatePathMissingDependencies (NeedDependencies Hash)
   deriving stock (Show, Eq, Ord)
 
+jsonUnion :: ToJSON a => Text -> a -> Value
+jsonUnion typeName val =
+  Aeson.object
+    [ "type" .= String typeName,
+      "payload" .= val
+    ]
+
+instance ToJSON UpdatePathResponse where
+  toJSON = \case
+    UpdatePathSuccess -> jsonUnion "success" (Object mempty)
+    UpdatePathHashMismatch hm -> jsonUnion "hash_mismatch" hm
+    UpdatePathMissingDependencies md -> jsonUnion "missing_dependencies" md
+
+instance FromJSON UpdatePathResponse where
+  parseJSON v =
+    v & Aeson.withObject "UploadEntitiesResponse" \obj ->
+      obj .: "type" >>= Aeson.withText "type" \case
+        "success" -> pure UpdatePathSuccess
+        "hash_mismatch" -> UpdatePathHashMismatch <$> obj .: "payload"
+        "missing_dependencies" -> UpdatePathMissingDependencies <$> obj .: "payload"
+        _ -> fail "Unknown UpdatePathResponse type"
+
 data NeedDependencies hash = NeedDependencies
   { missingDependencies :: NESet hash
   }
@@ -237,6 +265,24 @@ instance FromJSON UploadEntitiesRequest where
     entities <- obj .: "entities"
     pure UploadEntitiesRequest {..}
 
+data UploadEntitiesResponse
+  = UploadEntitiesSuccess
+  | UploadEntitiesNeedDependencies (NeedDependencies Hash)
+  deriving stock (Show, Eq, Ord)
+
+instance ToJSON UploadEntitiesResponse where
+  toJSON = \case
+    UploadEntitiesSuccess -> jsonUnion "success" (Object mempty)
+    UploadEntitiesNeedDependencies nd -> jsonUnion "need_dependencies" nd
+
+instance FromJSON UploadEntitiesResponse where
+  parseJSON v =
+    v & Aeson.withObject "UploadEntitiesResponse" \obj ->
+      obj .: "type" >>= Aeson.withText "type" \case
+        "need_dependencies" -> UploadEntitiesNeedDependencies <$> obj .: "payload"
+        "success" -> pure UploadEntitiesSuccess
+        _ -> fail "Unknown UploadEntitiesResponse type"
+
 data Entity hash replacementHash text
   = TC (TermComponent hash text)
   | DC (DeclComponent hash text)