From 3aca147a826750891ad08a22dc6d95d75d880c19 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 6 Apr 2022 15:48:59 -0600 Subject: [PATCH] Implement sync http client --- parser-typechecker/package.yaml | 1 + .../src/Unison/Codebase/Editor/Git.hs | 2 +- .../unison-parser-typechecker.cabal | 1 + unison-cli/package.yaml | 4 +- unison-cli/src/Unison/Auth/HTTPClient.hs | 5 +- unison-cli/src/Unison/Sync/HTTP.hs | 55 +++++++++++++++++++ unison-cli/unison-cli.cabal | 16 ++++++ unison-share-api/src/Unison/Sync/API.hs | 10 +++- unison-share-api/src/Unison/Sync/Types.hs | 50 ++++++++++++++++- 9 files changed, 136 insertions(+), 8 deletions(-) create mode 100644 unison-cli/src/Unison/Sync/HTTP.hs diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 433342c5f..57e22cdce 100644 --- a/parser-typechecker/package.yaml +++ b/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 diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs index 7d2432e93..a11ccbd14 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ b/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 diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index eb7c346e2..8091a5dde 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -241,6 +241,7 @@ library , hashable , hashtables , haskeline + , http-client , http-media , http-types , lens diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 0abd6d0f6..024f7d9b8 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -54,7 +54,9 @@ dependencies: - lock-file - jwt - either - + - unison-share-api + - servant-client + - servant library: source-dirs: src diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index cf9a40144..60f22db59 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/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 diff --git a/unison-cli/src/Unison/Sync/HTTP.hs b/unison-cli/src/Unison/Sync/HTTP.hs new file mode 100644 index 000000000..da00125bd --- /dev/null +++ b/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) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 7264cb123..8feab7b72 100644 --- a/unison-cli/unison-cli.cabal +++ b/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 diff --git a/unison-share-api/src/Unison/Sync/API.hs b/unison-share-api/src/Unison/Sync/API.hs index 5eb6f23a7..a5eab3677 100644 --- a/unison-share-api/src/Unison/Sync/API.hs +++ b/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 diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 9032b623d..6134470f8 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/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)