Restore definitions used by share-api repo

codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs

@@ -45,3 +45,9 @@ instance Bifoldable LocalIds' where
 
 instance Bifunctor LocalIds' where
   bimap f g (LocalIds t d) = LocalIds (f <$> t) (g <$> d)
+
+t_ :: Traversal (LocalIds' t h) (LocalIds' t' h) t t'
+t_ f (LocalIds t d) = LocalIds <$> traverse f t <*> pure d
+
+h_ :: Traversal (LocalIds' t h) (LocalIds' t h') h h'
+h_ f (LocalIds t d) = LocalIds <$> pure t <*> traverse f d

codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs

@@ -39,6 +39,7 @@ module U.Codebase.Sqlite.Serialization
     putTermAndType,
     putSingleTerm,
     putDeclElement,
+    getTypeFromTermAndType,
     getSingleTerm,
     putLocalIdsWith,
     getLocalIdsWith,
@@ -322,6 +323,12 @@ getTermComponent =
 getTermAndType :: (MonadGet m) => m (TermFormat.Term, TermFormat.Type)
 getTermAndType = (,) <$> getFramed getSingleTerm <*> getTermElementType
 
+-- | Decode ONLY the type of a term-component element.
+-- This is useful during sync and when we need the type of a term component element but don't
+-- want to decode the whole term (which can be expensive).
+getTypeFromTermAndType :: (MonadGet m) => m (TermFormat.Type)
+getTypeFromTermAndType = skipFramed *> getTermElementType
+
 getSingleTerm :: (MonadGet m) => m TermFormat.Term
 getSingleTerm = getABT getSymbol getUnit getF
   where

codebase2/core/U/Codebase/HashTags.hs

@@ -1,6 +1,7 @@
 module U.Codebase.HashTags where
 
 import Unison.Hash (Hash)
+import Unison.Prelude
 
 -- | Represents a hash of a type or term component
 newtype ComponentHash = ComponentHash {unComponentHash :: Hash}
@@ -27,3 +28,12 @@ instance Show CausalHash where
 
 instance Show PatchHash where
   show h = "PatchHash (" ++ show (unPatchHash h) ++ ")"
+
+instance From BranchHash Text where
+  from = from @Hash @Text . unBranchHash
+
+instance From CausalHash Text where
+  from = from @Hash @Text . unCausalHash
+
+instance From PatchHash Text where
+  from = from @Hash @Text . unPatchHash

lib/unison-hash/src/Unison/Hash.hs

@@ -15,6 +15,7 @@ module Unison.Hash
 
     -- ** Base32Hex Text conversions
     fromBase32HexText,
+    unsafeFromBase32HexText,
     toBase32HexText,
   )
 where
@@ -36,6 +37,9 @@ instance Show Hash where
 newtype HashFor t = HashFor {genericHash :: Hash}
   deriving newtype (Show, Eq, Ord, Generic)
 
+instance From Hash Text where
+  from = toBase32HexText
+
 -- | Convert a hash to a byte string.
 toByteString :: Hash -> ByteString
 toByteString = B.Short.fromShort . toShort
@@ -56,6 +60,10 @@ toBase32Hex = Base32Hex.fromByteString . toByteString
 fromBase32HexText :: Text -> Maybe Hash
 fromBase32HexText = fmap fromBase32Hex . Base32Hex.fromText
 
+-- | Convert a hash from base32 hex without any validation.
+unsafeFromBase32HexText :: Text -> Hash
+unsafeFromBase32HexText = fromBase32Hex . Base32Hex.UnsafeFromText
+
 -- | Return the lowercase unpadded base32Hex encoding of this 'Hash'.
 -- Multibase prefix would be 'v', see https://github.com/multiformats/multibase
 toBase32HexText :: Hash -> Text

unison-share-api/src/Unison/Server/Orphans.hs

@@ -15,9 +15,12 @@ import Unison.Codebase.Editor.DisplayObject
 import Unison.Codebase.Path qualified as Path
 import Unison.Codebase.Path.Parse qualified as Path
 import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
+import Unison.Hash (Hash (..))
+import Unison.Hash qualified as Hash
 import Unison.HashQualified qualified as HQ
 import Unison.HashQualifiedPrime qualified as HQ'
 import Unison.Name (Name)
+import Unison.NameSegment.Internal (NameSegment)
 import Unison.Prelude
 import Unison.Project
 import Unison.Reference qualified as Reference
@@ -27,8 +30,15 @@ import Unison.ShortHash qualified as SH
 import Unison.Syntax.HashQualified qualified as HQ (parseText)
 import Unison.Syntax.HashQualifiedPrime qualified as HQ' (parseText)
 import Unison.Syntax.Name qualified as Name (parseTextEither, toText)
+import Unison.Syntax.NameSegment qualified as NameSegment
 import Unison.Util.Pretty (Width (..))
 
+instance ToJSON Hash where
+  toJSON h = String $ Hash.toBase32HexText h
+
+instance FromJSON Hash where
+  parseJSON = Aeson.withText "Hash" $ pure . Hash.unsafeFromBase32HexText
+
 instance ToJSON ShortHash where
   toJSON = Aeson.String . SH.toText
 
@@ -81,17 +91,36 @@ instance (ToJSON b, ToJSON a) => ToJSON (DisplayObject b a) where
     MissingObject sh -> object ["tag" Aeson..= String "MissingObject", "contents" Aeson..= sh]
     UserObject a -> object ["tag" Aeson..= String "UserObject", "contents" Aeson..= a]
 
+instance (FromJSON a, FromJSON b) => FromJSON (DisplayObject b a) where
+  parseJSON = withObject "DisplayObject" \o -> do
+    tag <- o .: "tag"
+    case tag of
+      "BuiltinObject" -> BuiltinObject <$> o .: "contents"
+      "MissingObject" -> MissingObject <$> o .: "contents"
+      "UserObject" -> UserObject <$> o .: "contents"
+      _ -> fail $ "Invalid tag: " <> Text.unpack tag
+
 deriving instance (ToSchema b, ToSchema a) => ToSchema (DisplayObject b a)
 
--- [21/10/07] Hello, this is Mitchell. Name refactor in progress. Changing internal representation from a flat text to a
--- list of segments (in reverse order) plus an "is absolute?" bit.
+-- [2021-10-07] Hello, this is Mitchell. Name refactor in progress. Changing internal representation from a flat text to
+-- a list of segments (in reverse order) plus an "is absolute?" bit.
 --
 -- To preserve backwards compatibility (for now, anyway -- is this even important long term?), the ToJSON and ToSchema
 -- instances below treat Name as before.
 
+instance ToJSON Name where
+  toEncoding = toEncoding . Name.toText
+  toJSON = toJSON . Name.toText
+
+instance ToJSONKey Name where
+  toJSONKey = contramap Name.toText (toJSONKey @Text)
+
 instance ToSchema Name where
   declareNamedSchema _ = declareNamedSchema (Proxy @Text)
 
+instance ToJSON NameSegment where
+  toJSON = toJSON . NameSegment.toEscapedText
+
 instance ToParamSchema Reference.Reference where
   toParamSchema _ =
     mempty

unison-share-projects-api/package.yaml

@@ -11,8 +11,11 @@ library:
 dependencies:
   - aeson
   - base
+  - jose
   - jwt
+  - lens
   - servant
+  - servant-auth
   - text
   - unison-hash
   - unison-hash-orphans-aeson

unison-share-projects-api/src/Unison/Share/API/Hash.hs

@@ -18,9 +18,12 @@ module Unison.Share.API.Hash
   )
 where
 
+import Control.Lens (folding, ix, (^?))
+import Crypto.JWT qualified as Jose
 import Data.Aeson
 import Data.Aeson qualified as Aeson
 import Data.Aeson.KeyMap qualified as Aeson.KeyMap
+import Servant.Auth.JWT qualified as Servant.Auth
 import Unison.Hash32 (Hash32)
 import Unison.Hash32.Orphans.Aeson ()
 import Unison.Prelude
@@ -42,6 +45,27 @@ data HashJWTClaims = HashJWTClaims
   }
   deriving stock (Show, Eq, Ord)
 
+-- | Adding a type tag to the jwt prevents users from using jwts we issue for other things
+-- in this spot. All of our jwts should have a type parameter of some kind.
+hashJWTType :: String
+hashJWTType = "hj"
+
+instance Servant.Auth.ToJWT HashJWTClaims where
+  encodeJWT (HashJWTClaims h u) =
+    Jose.emptyClaimsSet
+      & Jose.addClaim "h" (toJSON h)
+      & Jose.addClaim "u" (toJSON u)
+      & Jose.addClaim "t" (toJSON hashJWTType)
+
+instance Servant.Auth.FromJWT HashJWTClaims where
+  decodeJWT claims = maybe (Left "Invalid HashJWTClaims") pure $ do
+    hash <- claims ^? Jose.unregisteredClaims . ix "h" . folding fromJSON
+    userId <- claims ^? Jose.unregisteredClaims . ix "u" . folding fromJSON
+    case claims ^? Jose.unregisteredClaims . ix "t" . folding fromJSON of
+      Just t | t == hashJWTType -> pure ()
+      _ -> empty
+    pure HashJWTClaims {..}
+
 instance ToJSON HashJWTClaims where
   toJSON (HashJWTClaims hash userId) =
     object

unison-share-projects-api/unison-share-projects-api.cabal

@@ -54,8 +54,11 @@ library
   build-depends:
       aeson
     , base
+    , jose
     , jwt
+    , lens
     , servant
+    , servant-auth
     , text
     , unison-hash
     , unison-hash-orphans-aeson