Merge pull request #170 from unisoncomputing/cp/comment-download

History Comment Sync

Author: ChrisPenner

.github/workflows/ci.yaml

@@ -330,7 +330,10 @@ jobs:
 
           # Install ucm
           mkdir ucm
-          curl -L https://github.com/unisonweb/unison/releases/download/release%2F1.0.0/ucm-linux-x64.tar.gz | tar -xz -C ucm
+
+          # Use latest trunk build to get comment upload/download support for now.
+          # Old: https://github.com/unisonweb/unison/releases/download/release%2F1.0.0/ucm-linux-x64.tar.gz
+          curl -L https://github.com/unisonweb/unison/releases/download/trunk-build/ucm-linux-x64.tar.gz | tar -xz -C ucm
           export PATH=$PWD/ucm:$PATH
 
           # Start share and it's dependencies in the background

share-api/package.yaml

@@ -154,6 +154,7 @@ dependencies:
 - wai-extra
 - wai-middleware-prometheus
 - warp
+- websockets
 - witch
 - witherable
 - x509

share-api/share-api.cabal

@@ -130,6 +130,7 @@ library
       Share.Utils.Servant.Client
       Share.Utils.Servant.PathInfo
       Share.Utils.Servant.RawRequest
+      Share.Utils.Servant.Streaming
       Share.Utils.Tags
       Share.Utils.Unison
       Share.Web.Admin.API
@@ -194,6 +195,9 @@ library
       Share.Web.Support.Impl
       Share.Web.Support.Types
       Share.Web.Types
+      Share.Web.UCM.HistoryComments.API
+      Share.Web.UCM.HistoryComments.Impl
+      Share.Web.UCM.HistoryComments.Queries
       Share.Web.UCM.Projects.Impl
       Share.Web.UCM.Sync.HashJWT
       Share.Web.UCM.Sync.Impl
@@ -356,6 +360,7 @@ library
     , wai-extra
     , wai-middleware-prometheus
     , warp
+    , websockets
     , witch
     , witherable
     , x509
@@ -513,6 +518,7 @@ executable share-api
     , wai-extra
     , wai-middleware-prometheus
     , warp
+    , websockets
     , witch
     , witherable
     , x509

share-api/src/Share/Postgres.hs

@@ -685,7 +685,7 @@ cachedFor = cachedForOf traversed
 --      ) SELECT * FROM something JOIN users on something.user_id = users.id
 --     |]
 -- @@
-whenNonEmpty :: forall m f a x. (Monad m, Foldable f, Monoid a) => f x -> m a -> m a
+whenNonEmpty :: forall m f a x. (Foldable f, Monoid a, Applicative m) => f x -> m a -> m a
 whenNonEmpty f m = if null f then pure mempty else m
 
 timeTransaction :: (QueryM m) => String -> m a -> m a

share-api/src/Share/Postgres/IDs.hs

@@ -23,6 +23,7 @@ module Share.Postgres.IDs
     NamespaceTermMappingId (..),
     NamespaceTypeMappingId (..),
     ComponentSummaryDigest (..),
+    PersonalKeyId (..),
 
     -- * Conversions
     hash32AsComponentHash_,
@@ -104,6 +105,10 @@ newtype ComponentSummaryDigest = ComponentSummaryDigest {unComponentSummaryDiges
   deriving stock (Show, Eq, Ord)
   deriving (PG.EncodeValue, PG.DecodeValue) via ByteString
 
+newtype PersonalKeyId = PersonalKeyId {unPersonalKeyId :: Int32}
+  deriving stock (Eq, Ord, Show)
+  deriving (PG.DecodeValue, PG.EncodeValue) via Int32
+
 toHash32 :: (Coercible h Hash) => h -> Hash32
 toHash32 = Hash32.fromHash . coerce
 

share-api/src/Share/Postgres/Orphans.hs

@@ -33,10 +33,11 @@ import U.Codebase.TermEdit qualified as TermEdit
 import U.Util.Base32Hex qualified as Base32Hex
 import Unison.Hash (Hash)
 import Unison.Hash qualified as Hash
-import Unison.Hash32 (Hash32)
+import Unison.Hash32 (Hash32 (..))
 import Unison.Hash32 qualified as Hash32
 import Unison.Name (Name)
 import Unison.NameSegment.Internal (NameSegment (..))
+import Unison.Server.HistoryComments.Types
 import Unison.SyncV2.Types (CBORBytes (..))
 import Unison.Syntax.Name qualified as Name
 import UnliftIO (MonadUnliftIO (..))
@@ -103,6 +104,14 @@ deriving via Hash instance FromHttpApiData ComponentHash
 
 deriving via Hash instance ToHttpApiData ComponentHash
 
+deriving via Hash32 instance Hasql.DecodeValue HistoryCommentHash32
+
+deriving via Hash32 instance Hasql.EncodeValue HistoryCommentHash32
+
+deriving via Hash32 instance Hasql.DecodeValue HistoryCommentRevisionHash32
+
+deriving via Hash32 instance Hasql.EncodeValue HistoryCommentRevisionHash32
+
 deriving via Text instance Hasql.DecodeValue NameSegment
 
 deriving via Text instance Hasql.EncodeValue NameSegment

share-api/src/Share/Prelude/Orphans.hs

@@ -6,6 +6,7 @@
 module Share.Prelude.Orphans () where
 
 import Control.Comonad.Cofree (Cofree (..))
+import Control.Monad.Except
 import Control.Monad.Trans (lift)
 import Control.Monad.Trans.Maybe (MaybeT)
 import Data.Align (Semialign (..))
@@ -47,3 +48,6 @@ instance From ShortHash Text where
 
 instance (MonadTracer m) => MonadTracer (MaybeT m) where
   getTracer = lift getTracer
+
+instance (MonadTracer m) => MonadTracer (ExceptT e m) where
+  getTracer = lift getTracer

share-api/src/Share/Utils/Logging.hs

@@ -45,6 +45,7 @@ import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
 import Data.Text.IO qualified as Text
 import GHC.Stack (CallStack, callStack, prettyCallStack)
+import Network.WebSockets qualified as WS
 import Servant.Client qualified as Servant
 import Share.Env.Types qualified as Env
 import Share.OAuth.Errors (OAuth2Error)
@@ -56,6 +57,8 @@ import Share.Utils.Logging.Types as X
 import Share.Utils.Tags (MonadTags)
 import System.Log.FastLogger qualified as FL
 import Unison.Server.Backend qualified as Backend
+import Unison.Server.HistoryComments.Types (DownloadCommentsResponse (..), UploadCommentsResponse (..))
+import Unison.Server.Types (BranchRef (..))
 import Unison.Sync.Types qualified as Sync
 import Unison.Util.Monoid (intercalateMap)
 import Unison.Util.Monoid qualified as Monoid
@@ -267,3 +270,30 @@ instance Loggable Sync.UploadEntitiesError where
     Sync.UploadEntitiesError'UserNotFound userHandle ->
       textLog ("User not found: " <> userHandle)
         & withSeverity UserFault
+
+instance Loggable UploadCommentsResponse where
+  toLog = \case
+    UploadCommentsProjectBranchNotFound (BranchRef branchRef) ->
+      textLog ("Project branch not found: " <> branchRef)
+        & withSeverity UserFault
+    UploadCommentsNotAuthorized (BranchRef branchRef) ->
+      textLog ("Not authorized to upload comments to branch: " <> branchRef)
+        & withSeverity UserFault
+    UploadCommentsGenericFailure errMsg ->
+      textLog ("Upload comments generic failure: " <> errMsg)
+        & withSeverity Error
+
+instance Loggable WS.ConnectionException where
+  toLog = withSeverity Error . showLog
+
+instance Loggable DownloadCommentsResponse where
+  toLog = \case
+    DownloadCommentsProjectBranchNotFound (BranchRef branchRef) ->
+      textLog ("Project branch not found: " <> branchRef)
+        & withSeverity UserFault
+    DownloadCommentsNotAuthorized (BranchRef branchRef) ->
+      textLog ("Not authorized to download comments from branch: " <> branchRef)
+        & withSeverity UserFault
+    DownloadCommentsGenericFailure errMsg ->
+      textLog ("Download comments generic failure: " <> errMsg)
+        & withSeverity Error

share-api/src/Share/Utils/Servant/Streaming.hs

@@ -0,0 +1,63 @@
+module Share.Utils.Servant.Streaming
+  ( toConduit,
+    cborStreamToConduit,
+    fromConduit,
+    sourceIOWithAsync,
+    queueToCBORStream,
+    queueToSourceIO,
+  )
+where
+
+-- Orphan instances for SourceIO
+
+import Codec.Serialise qualified as CBOR
+import Conduit
+import Control.Concurrent.STM.TBMQueue qualified as STM
+import Control.Monad.Except
+import Data.ByteString.Builder qualified as Builder
+import Ki.Unlifted qualified as Ki
+import Servant
+import Servant.Conduit (conduitToSourceIO)
+import Servant.Types.SourceT
+import Share.Prelude
+import Unison.Util.Servant.CBOR
+import UnliftIO.STM qualified as STM
+
+-- | Run the provided IO action in the background while streaming results.
+--
+-- Servant doesn't provide any easier way to do bracketing like this, all the IO must be
+-- inside the SourceIO somehow.
+sourceIOWithAsync :: IO a -> SourceIO r -> SourceIO r
+sourceIOWithAsync action (SourceT k) =
+  SourceT \k' ->
+    Ki.scoped \scope -> do
+      _ <- Ki.fork scope action
+      k k'
+
+toConduit :: (MonadIO m, MonadIO n) => SourceIO o -> m (ConduitT void o n ())
+toConduit sourceIO = fmap (transPipe liftIO) . liftIO $ fromSourceIO $ sourceIO
+
+cborStreamToConduit :: (MonadIO m, MonadIO n, CBOR.Serialise o) => SourceIO (CBORStream o) -> m (ConduitT void o (ExceptT CBORStreamError n) ())
+cborStreamToConduit sourceIO = toConduit sourceIO <&> \stream -> (stream .| unpackCBORBytesStream)
+
+fromConduit :: ConduitT void o IO () -> SourceIO o
+fromConduit = conduitToSourceIO
+
+queueToCBORStream :: forall a f. (CBOR.Serialise a, Foldable f) => STM.TBMQueue (f a) -> ConduitT () (CBORStream a) IO ()
+queueToCBORStream q = do
+  let loop :: ConduitT () (CBORStream a) IO ()
+      loop = do
+        liftIO (STM.atomically (STM.readTBMQueue q)) >>= \case
+          -- The queue is closed.
+          Nothing -> do
+            pure ()
+          Just batches -> do
+            batches
+              & foldMap (CBOR.serialiseIncremental)
+              & (CBORStream . Builder.toLazyByteString)
+              & Conduit.yield
+            loop
+  loop
+
+queueToSourceIO :: forall a f. (CBOR.Serialise a, Foldable f) => STM.TBMQueue (f a) -> SourceIO (CBORStream a)
+queueToSourceIO q = fromConduit (queueToCBORStream q)

share-api/src/Share/Web/API.hs

@@ -18,6 +18,7 @@ import Share.Web.Share.Webhooks.API qualified as Webhooks
 import Share.Web.Support.API qualified as Support
 import Share.Web.Types
 import Share.Web.UCM.SyncV2.API qualified as SyncV2
+import Unison.Server.HistoryComments.API qualified as Unison.HistoryComments
 import Unison.Share.API.Projects qualified as UCMProjects
 import Unison.Sync.API qualified as Unison.Sync
 
@@ -53,6 +54,7 @@ type API =
     -- This path is deprecated, but is still in use by existing clients.
     :<|> ("sync" :> MaybeAuthenticatedSession :> Unison.Sync.API)
     :<|> ("ucm" :> "v1" :> "sync" :> MaybeAuthenticatedSession :> Unison.Sync.API)
+    :<|> ("ucm" :> "v1" :> "history-comments" :> MaybeAuthenticatedUserId :> Unison.HistoryComments.API)
     :<|> ("ucm" :> "v1" :> "projects" :> MaybeAuthenticatedSession :> UCMProjects.ProjectsAPI)
     :<|> ("ucm" :> "v2" :> "sync" :> MaybeAuthenticatedUserId :> SyncV2.API)
     :<|> ("admin" :> Admin.API)