unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-17 13:27:30 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'trunk' into work/arrays

Browse Source
This commit is contained in:
Dan Doel 2022-06-20 15:20:36 -04:00
commit aef728992b
152 changed files with 7915 additions and 3257 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CONTRIBUTORS.markdown
View File

@ -68,3 +68,4 @@ The format for this list: name, GitHub handle
* Harald Gliebe (@hagl)
* Phil de Joux (@philderbeast)
* Travis Staton (@tstat)
* Dan Freeman (@dfreeman)

56
codebase2/codebase-sqlite-hashing-v2/package.yaml Normal file
View File

@ -0,0 +1,56 @@
name: unison-codebase-sqlite-hashing-v2
github: unisonweb/unison
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
ghc-options: -Wall
dependencies:
- base
- bytes
- bytestring
- containers
- lens
- text
- unison-codebase
- unison-codebase-sqlite
- unison-core
- unison-core1
- unison-hashing-v2
- unison-prelude
- unison-sqlite
- unison-util
- unison-util-base32hex
- unison-util-term
- vector
library:
source-dirs: src
when:
- condition: false
other-modules: Paths_unison_codebase_sqlite_hashing_v2
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- DeriveAnyClass
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- OverloadedStrings
- PatternSynonyms
- RecordWildCards
- RankNTypes
- ScopedTypeVariables
- TupleSections
- TypeApplications
- ViewPatterns

24
codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Decl.hs Normal file
View File

@ -0,0 +1,24 @@
module U.Codebase.Sqlite.V2.Decl
( saveDeclComponent,
)
where
import qualified U.Codebase.Decl as V2
import U.Codebase.Sqlite.DbId (ObjectId)
import qualified U.Codebase.Sqlite.Queries as U.Sqlite
import U.Codebase.Sqlite.Symbol (Symbol)
import U.Codebase.Sqlite.V2.HashHandle
import U.Util.Hash (Hash)
import Unison.Prelude
import Unison.Sqlite
saveDeclComponent ::
-- | The serialized decl component if we already have it e.g. via sync
Maybe ByteString ->
-- | decl component hash
Hash ->
-- | decl component
[V2.Decl Symbol] ->
Transaction ObjectId
saveDeclComponent =
U.Sqlite.saveDeclComponent v2HashHandle

19
codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/HashHandle.hs Normal file
View File

@ -0,0 +1,19 @@
module U.Codebase.Sqlite.V2.HashHandle
( v2HashHandle,
)
where
import qualified Data.Set as Set
import U.Codebase.Sqlite.HashHandle
import U.Util.Type (removeAllEffectVars)
import Unison.Hashing.V2.Convert2 (h2ToV2Reference, v2ToH2Type, v2ToH2TypeD)
import qualified Unison.Hashing.V2.Type as H2
v2HashHandle :: HashHandle
v2HashHandle =
HashHandle
{ toReference = h2ToV2Reference . H2.toReference . v2ToH2Type . removeAllEffectVars,
toReferenceMentions = Set.map h2ToV2Reference . H2.toReferenceMentions . v2ToH2Type . removeAllEffectVars,
toReferenceDecl = \h -> h2ToV2Reference . H2.toReference . v2ToH2TypeD h . removeAllEffectVars,
toReferenceDeclMentions = \h -> Set.map h2ToV2Reference . H2.toReferenceMentions . v2ToH2TypeD h . removeAllEffectVars
}

11
codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/SyncEntity.hs Normal file
View File

@ -0,0 +1,11 @@
module U.Codebase.Sqlite.V2.SyncEntity where
import qualified U.Codebase.Sqlite.DbId as Db
import U.Codebase.Sqlite.Entity (SyncEntity)
import qualified U.Codebase.Sqlite.Queries as Q
import U.Codebase.Sqlite.V2.HashHandle
import U.Util.Hash32 (Hash32)
import Unison.Sqlite
saveSyncEntity :: Hash32 -> SyncEntity -> Transaction (Either Db.CausalHashId Db.ObjectId)
saveSyncEntity = Q.saveSyncEntity v2HashHandle

24
codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Term.hs Normal file
View File

@ -0,0 +1,24 @@
module U.Codebase.Sqlite.V2.Term
( saveTermComponent,
)
where
import U.Codebase.Sqlite.DbId (ObjectId)
import qualified U.Codebase.Sqlite.Queries as U.Sqlite
import U.Codebase.Sqlite.Symbol (Symbol)
import U.Codebase.Sqlite.V2.HashHandle
import qualified U.Codebase.Term as V2
import U.Util.Hash (Hash)
import Unison.Prelude
import Unison.Sqlite
saveTermComponent ::
-- | The serialized term component if we already have it e.g. via sync
Maybe ByteString ->
-- | term component hash
Hash ->
-- | term component
[(V2.Term Symbol, V2.Type Symbol)] ->
Transaction ObjectId
saveTermComponent =
U.Sqlite.saveTermComponent v2HashHandle

142
codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs Normal file
View File

@ -0,0 +1,142 @@
-- | Description: Converts V2 types to the V2 hashing types
module Unison.Hashing.V2.Convert2
( v2ToH2Term,
v2ToH2Type,
v2ToH2TypeD,
h2ToV2Reference,
)
where
import qualified U.Codebase.Kind as V2
import qualified U.Codebase.Reference as V2
import qualified U.Codebase.Referent as V2.Referent
import qualified U.Codebase.Term as V2 (F, F' (..), MatchCase (..), Pattern (..), SeqOp (..), TermRef, TypeRef)
import qualified U.Codebase.Type as V2.Type
import qualified U.Core.ABT as V2
import qualified U.Core.ABT as V2.ABT
import qualified U.Util.Hash as V2 (Hash)
import qualified Unison.ABT as H2 (transform)
import qualified Unison.ABT as V1.ABT
import qualified Unison.Hashing.V2.Kind as H2
import qualified Unison.Hashing.V2.Pattern as H2.Pattern
import qualified Unison.Hashing.V2.Reference as H2
import qualified Unison.Hashing.V2.Referent as H2.Referent
import qualified Unison.Hashing.V2.Term as H2
import qualified Unison.Hashing.V2.Type as H2.Type
import Unison.Prelude
-- | Delete me ASAP. I am defined elsewhere.
abt2to1 :: Functor f => V2.ABT.Term f v a -> V1.ABT.Term f v a
abt2to1 (V2.ABT.Term fv a out) = V1.ABT.Term fv a (go out)
where
go = \case
V2.ABT.Cycle body -> V1.ABT.Cycle (abt2to1 body)
V2.ABT.Abs v body -> V1.ABT.Abs v (abt2to1 body)
V2.ABT.Var v -> V1.ABT.Var v
V2.ABT.Tm tm -> V1.ABT.Tm (abt2to1 <$> tm)
v2ToH2Term :: forall v. Ord v => V2.Hash -> V2.Term (V2.F v) v () -> H2.Term v ()
v2ToH2Term thisTermComponentHash = H2.transform convertF . abt2to1
where
convertF :: forall x. V2.F v x -> H2.F v () () x
convertF = \case
V2.Int x -> H2.Int x
V2.Nat x -> H2.Nat x
V2.Float x -> H2.Float x
V2.Boolean x -> H2.Boolean x
V2.Text x -> H2.Text x
V2.Char x -> H2.Char x
V2.Ref x -> H2.Ref (convertTermRef thisTermComponentHash x)
V2.Constructor a b -> H2.Constructor (convertReference a) b
V2.Request a b -> H2.Request (convertReference a) b
V2.Handle a b -> H2.Handle a b
V2.App a b -> H2.App a b
V2.Ann a b -> H2.Ann a (v2ToH2Type b)
V2.List a -> H2.List a
V2.If a b c -> H2.If a b c
V2.And a b -> H2.And a b
V2.Or a b -> H2.Or a b
V2.Lam a -> H2.Lam a
V2.LetRec a b -> H2.LetRec a b
V2.Let a b -> H2.Let a b
V2.Match a b -> H2.Match a (map convertMatchCase b)
V2.TermLink a -> H2.TermLink (convertReferent thisTermComponentHash a)
V2.TypeLink a -> H2.TypeLink (convertReference a)
convertMatchCase :: V2.MatchCase Text V2.TypeRef x -> H2.MatchCase () x
convertMatchCase (V2.MatchCase pat a b) = H2.MatchCase (convertPattern pat) a b
convertPattern :: V2.Pattern Text V2.TypeRef -> H2.Pattern.Pattern ()
convertPattern = \case
V2.PUnbound -> H2.Pattern.Unbound ()
V2.PVar -> H2.Pattern.Var ()
V2.PBoolean a -> H2.Pattern.Boolean () a
V2.PInt a -> H2.Pattern.Int () a
V2.PNat a -> H2.Pattern.Nat () a
V2.PFloat a -> H2.Pattern.Float () a
V2.PText a -> H2.Pattern.Text () a
V2.PChar a -> H2.Pattern.Char () a
V2.PConstructor a b c -> H2.Pattern.Constructor () (convertReference a) b (map convertPattern c)
V2.PAs a -> H2.Pattern.As () (convertPattern a)
V2.PEffectPure a -> H2.Pattern.EffectPure () (convertPattern a)
V2.PEffectBind a b c d -> H2.Pattern.EffectBind () (convertReference a) b (map convertPattern c) (convertPattern d)
V2.PSequenceLiteral a -> H2.Pattern.SequenceLiteral () (map convertPattern a)
V2.PSequenceOp a b c -> H2.Pattern.SequenceOp () (convertPattern a) (convertSeqOp b) (convertPattern c)
where
convertSeqOp = \case
V2.PCons -> H2.Pattern.Cons
V2.PSnoc -> H2.Pattern.Snoc
V2.PConcat -> H2.Pattern.Concat
convertReferent ::
V2.Hash ->
V2.Referent.Referent' (V2.Reference' Text (Maybe V2.Hash)) (V2.Reference' Text V2.Hash) ->
H2.Referent.Referent
convertReferent defaultHash = \case
V2.Referent.Ref x -> H2.Referent.Ref (convertTermRef defaultHash x)
V2.Referent.Con x cid -> H2.Referent.Con (convertReference x) cid
convertId :: V2.Hash -> V2.Id' (Maybe V2.Hash) -> H2.Id
convertId defaultHash = \case
V2.Id m p -> H2.Id (fromMaybe defaultHash m) p
convertReference :: V2.Reference -> H2.Reference
convertReference = convertReference' (\(V2.Id a b) -> H2.Id a b)
convertTermRef :: V2.Hash -> V2.TermRef -> H2.Reference
convertTermRef = convertReference' . convertId
convertReference' :: (V2.Id' hash -> H2.Id) -> V2.Reference' Text hash -> H2.Reference
convertReference' idConv = \case
V2.ReferenceBuiltin x -> H2.Builtin x
V2.ReferenceDerived x -> H2.DerivedId (idConv x)
v2ToH2Type :: forall v. Ord v => V2.Type.TypeR V2.TypeRef v -> H2.Type.Type v ()
v2ToH2Type = v2ToH2Type' convertReference
v2ToH2TypeD :: forall v. Ord v => V2.Hash -> V2.Type.TypeD v -> H2.Type.Type v ()
v2ToH2TypeD defaultHash = v2ToH2Type' (convertReference' (convertId defaultHash))
v2ToH2Type' :: forall r v. Ord v => (r -> H2.Reference) -> V2.Type.TypeR r v -> H2.Type.Type v ()
v2ToH2Type' mkReference = H2.transform convertF . abt2to1
where
convertF :: forall a. V2.Type.F' r a -> H2.Type.F a
convertF = \case
V2.Type.Ref x -> H2.Type.Ref (mkReference x)
V2.Type.Arrow a b -> H2.Type.Arrow a b
V2.Type.Ann a k -> H2.Type.Ann a (convertKind k)
V2.Type.App a b -> H2.Type.App a b
V2.Type.Effect a b -> H2.Type.Effect a b
V2.Type.Effects a -> H2.Type.Effects a
V2.Type.Forall a -> H2.Type.Forall a
V2.Type.IntroOuter a -> H2.Type.IntroOuter a
convertKind :: V2.Kind -> H2.Kind
convertKind = \case
V2.Star -> H2.Star
V2.Arrow a b -> H2.Arrow (convertKind a) (convertKind b)
h2ToV2Reference :: H2.Reference -> V2.Reference
h2ToV2Reference = \case
H2.Builtin txt -> V2.ReferenceBuiltin txt
H2.DerivedId (H2.Id x y) -> V2.ReferenceDerived (V2.Id x y)

71
codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal Normal file
View File

@ -0,0 +1,71 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.7.
--
-- see: https://github.com/sol/hpack
name: unison-codebase-sqlite-hashing-v2
version: 0.0.0
homepage: https://github.com/unisonweb/unison#readme
bug-reports: https://github.com/unisonweb/unison/issues
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
build-type: Simple
source-repository head
type: git
location: https://github.com/unisonweb/unison
library
exposed-modules:
U.Codebase.Sqlite.V2.Decl
U.Codebase.Sqlite.V2.HashHandle
U.Codebase.Sqlite.V2.SyncEntity
U.Codebase.Sqlite.V2.Term
Unison.Hashing.V2.Convert2
hs-source-dirs:
src
default-extensions:
ApplicativeDo
BangPatterns
BlockArguments
DeriveAnyClass
DeriveFunctor
DeriveGeneric
DeriveTraversable
DerivingStrategies
DerivingVia
DoAndIfThenElse
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
OverloadedStrings
PatternSynonyms
RecordWildCards
RankNTypes
ScopedTypeVariables
TupleSections
TypeApplications
ViewPatterns
ghc-options: -Wall
build-depends:
base
, bytes
, bytestring
, containers
, lens
, text
, unison-codebase
, unison-codebase-sqlite
, unison-core
, unison-core1
, unison-hashing-v2
, unison-prelude
, unison-sqlite
, unison-util
, unison-util-base32hex
, unison-util-term
, vector
default-language: Haskell2010

57
codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs
View File

@ -1,7 +1,9 @@
module U.Codebase.Sqlite.Branch.Format
( BranchFormat (..),
BranchLocalIds (..),
SyncBranchFormat (..),
BranchLocalIds,
BranchLocalIds' (..),
SyncBranchFormat,
SyncBranchFormat' (..),
localToDbBranch,
localToDbDiff,
-- dbToLocalDiff,
@ -35,17 +37,52 @@ data BranchFormat
--
-- For example, a @branchTextLookup@ vector of @[50, 74]@ means "local id 0 corresponds to database text id 50, and
-- local id 1 corresponds to database text id 74".
data BranchLocalIds = LocalIds
{ branchTextLookup :: Vector TextId,
branchDefnLookup :: Vector ObjectId,
branchPatchLookup :: Vector PatchObjectId,
branchChildLookup :: Vector (BranchObjectId, CausalHashId)
type BranchLocalIds = BranchLocalIds' TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
-- temp_entity
-- branch #foo
--
-- temp_entity_missing_dependency
-- #foo depends on causal #bar
-- #foo depends on namespace #baz
--
-- 1. store causal #bar, go to flush dependencies like normal
-- 2. ... oh this case is different than the others - we don't want to delete that row
----
-- can't simply treat causal's value hash as a mandatory dependency because we can't be sure
-- that the causal doesn't already exist in the target codebase without the value.
-- it probably does exist together with the value (though we found cases in the past where it didn't
-- due to race conditions, but we fixed that and added transactions and it shouldn't happen again?),
-- but it's not enforced at the schema level.
-- to enforce it at the schema level, we'd have to do something like store namespace_object_id instead
-- of value_hash in causal, which would require a db migration for a thing we don't necessarily even want
-- long term.
-- so, we can't simply "require" the value hash as a dependency of the causals and expect things to work smoothly
-- without relying on prayer.
--
-- temp_entity
-- branch #foo
-- causal #bar
-- temp_entity_missing_dependency
-- #foo depends on causal #bar
-- #bar depends on namespace #baz
--
data BranchLocalIds' t d p c = LocalIds
{ branchTextLookup :: Vector t,
branchDefnLookup :: Vector d,
branchPatchLookup :: Vector p,
branchChildLookup :: Vector c
}
deriving (Show)
data SyncBranchFormat
= SyncFull BranchLocalIds ByteString
| SyncDiff BranchObjectId BranchLocalIds ByteString
data SyncBranchFormat' parent text defn patch child
= SyncFull (BranchLocalIds' text defn patch child) ByteString
| SyncDiff parent (BranchLocalIds' text defn patch child) ByteString
type SyncBranchFormat = SyncBranchFormat' BranchObjectId TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
localToDbBranch :: BranchLocalIds -> LocalBranch -> DbBranch
localToDbBranch li =

50
codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs
View File

@ -1,7 +1,12 @@
{-# LANGUAGE RecordWildCards #-}
module U.Codebase.Sqlite.Causal where
module U.Codebase.Sqlite.Causal
( DbCausal,
GDbCausal (..),
SyncCausalFormat,
SyncCausalFormat' (..),
)
where
import Data.Vector (Vector)
import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId)
import Unison.Prelude
@ -11,40 +16,11 @@ data GDbCausal causalHash valueHash = DbCausal
parents :: Set causalHash
}
-- Causal Plan
-- * Load a DbCausal (how do we do this)
-- => new function Queries.localCausalByCausalHashId, can model after loadCausalByCausalHash or factor out of
-- * Add valueHashId as a dependency if unmigrated
-- * Add parent causal hash ids as dependencies if unmigrated
-- => Queries.loadCausalParents
-- * Map over Branch hash IDs
-- * Inside saveDBCausal (new / factored out of original)
-- * Save as a new self-hash
-- ==> Queries.saveCausal
-- * Map over parent causal hash IDs
-- ==> Queries.saveCausalParents
type DbCausal = GDbCausal CausalHashId BranchHashId
-- causalHashes_ :: Traversal (GDbCausal ch vh) (GDbCausal ch' vh) ch ch'
-- causalHashes_ f DbCausal {..} =
-- DbCausal <$> f selfHash <*> pure valueHash <*> (fmap Set.fromList . traverse f . Set.toList $ parents)
data SyncCausalFormat' causalHash valueHash = SyncCausalFormat
{ valueHash :: valueHash,
parents :: Vector causalHash
}
-- valueHashes_ :: Lens (GDbCausal ch vh) (GDbCausal ch vh) vh vh'
-- valueHashes_ f DbCausal{..} =
-- (\p vh -> DbCausal selfHash vh p) parents <$> f valueHash
-- data Causal m hc he e = Causal
-- { causalHash :: hc,
-- valueHash :: he,
-- parents :: Map hc (m (Causal m hc he e)),
-- value :: m e
-- }
type SyncCausalFormat = SyncCausalFormat' CausalHashId BranchHashId

20
codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs
View File

@ -5,10 +5,12 @@ module U.Codebase.Sqlite.Decl.Format where
import Data.Vector (Vector)
import U.Codebase.Decl (DeclR)
import U.Codebase.Reference (Reference')
import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalIds, LocalTextId)
import U.Codebase.Sqlite.DbId (ObjectId, TextId)
import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalIds', LocalTextId)
import U.Codebase.Sqlite.Symbol (Symbol)
import qualified U.Codebase.Type as Type
import qualified U.Core.ABT as ABT
import Unison.Prelude
-- | Add new formats here
data DeclFormat = Decl LocallyIndexedComponent
@ -16,10 +18,22 @@ data DeclFormat = Decl LocallyIndexedComponent
-- | V1: Decls included `Hash`es inline
-- V2: Instead of `Hash`, we use a smaller index.
newtype LocallyIndexedComponent
= LocallyIndexedComponent (Vector (LocalIds, Decl Symbol))
type LocallyIndexedComponent =
LocallyIndexedComponent' TextId ObjectId
newtype LocallyIndexedComponent' t d = LocallyIndexedComponent
{unLocallyIndexedComponent :: Vector (LocalIds' t d, Decl Symbol)}
deriving (Show)
type SyncDeclFormat =
SyncDeclFormat' TextId ObjectId
data SyncDeclFormat' t d
= SyncDecl (SyncLocallyIndexedComponent' t d)
newtype SyncLocallyIndexedComponent' t d
= SyncLocallyIndexedComponent (Vector (LocalIds' t d, ByteString))
-- [OldDecl] ==map==> [NewDecl] ==number==> [(NewDecl, Int)] ==sort==> [(NewDecl, Int)] ==> permutation is map snd of that
-- type List a = Nil | Cons (List a)

188
codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs Normal file
View File

@ -0,0 +1,188 @@
-- | This module contains decoders for blobs stored in SQLite.
module U.Codebase.Sqlite.Decode
( DecodeError,
-- * @object.bytes@
decodeBranchFormat,
decodeComponentLengthOnly,
decodeDeclElement,
decodeDeclFormat,
decodePatchFormat,
decodeSyncDeclFormat,
decodeSyncNamespaceFormat,
decodeSyncPatchFormat,
decodeSyncTermFormat,
decodeSyncTermAndType,
decodeTermElementDiscardingTerm,
decodeTermElementDiscardingType,
decodeTermElementWithType,
decodeTermFormat,
-- * @temp_entity.blob@
decodeTempCausalFormat,
decodeTempDeclFormat,
decodeTempNamespaceFormat,
decodeTempPatchFormat,
decodeTempTermFormat,
-- * @watch_result.result@
decodeWatchResultFormat,
-- * unsyncs
unsyncTermComponent,
unsyncDeclComponent,
)
where
import Control.Exception (throwIO)
import Data.Bytes.Get (runGetS)
import qualified Data.Bytes.Get as Get
import qualified U.Codebase.Reference as C.Reference
import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat
import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat
import U.Codebase.Sqlite.LocalIds (LocalIds)
import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat
import U.Codebase.Sqlite.Serialization as Serialization
import U.Codebase.Sqlite.Symbol (Symbol)
import qualified U.Codebase.Sqlite.TempEntity as TempEntity
import qualified U.Codebase.Sqlite.Term.Format as TermFormat
import U.Util.Serialization (Get)
import qualified U.Util.Serialization as Serialization (lengthFramedArray)
import Unison.Prelude
import Unison.Sqlite
------------------------------------------------------------------------------------------------------------------------
-- Decode error
data DecodeError = DecodeError
{ decoder :: Text, -- the name of the decoder
err :: String -- the error message
}
deriving stock (Show)
deriving anyclass (SqliteExceptionReason, Exception)
getFromBytesOr :: Text -> Get a -> ByteString -> Either DecodeError a
getFromBytesOr decoder get bs = case runGetS get bs of
Left err -> Left (DecodeError decoder err)
Right a -> Right a
------------------------------------------------------------------------------------------------------------------------
-- object.bytes
decodeBranchFormat :: ByteString -> Either DecodeError NamespaceFormat.BranchFormat
decodeBranchFormat =
getFromBytesOr "getBranchFormat" Serialization.getBranchFormat
decodeComponentLengthOnly :: ByteString -> Either DecodeError Word64
decodeComponentLengthOnly =
getFromBytesOr "lengthFramedArray" (Get.skip 1 >> Serialization.lengthFramedArray)
decodeDeclElement :: Word64 -> ByteString -> Either DecodeError (LocalIds, DeclFormat.Decl Symbol)
decodeDeclElement i =
getFromBytesOr ("lookupDeclElement " <> tShow i) (Serialization.lookupDeclElement i)
decodeDeclFormat :: ByteString -> Either DecodeError DeclFormat.DeclFormat
decodeDeclFormat =
getFromBytesOr "getDeclFormat" Serialization.getDeclFormat
decodePatchFormat :: ByteString -> Either DecodeError PatchFormat.PatchFormat
decodePatchFormat =
getFromBytesOr "getPatchFormat" Serialization.getPatchFormat
decodeSyncDeclFormat :: ByteString -> Either DecodeError DeclFormat.SyncDeclFormat
decodeSyncDeclFormat =
getFromBytesOr "decomposeDeclFormat" Serialization.decomposeDeclFormat
decodeSyncNamespaceFormat :: ByteString -> Either DecodeError NamespaceFormat.SyncBranchFormat
decodeSyncNamespaceFormat =
getFromBytesOr "decomposeNamespaceFormat" Serialization.decomposeBranchFormat
decodeSyncPatchFormat :: ByteString -> Either DecodeError PatchFormat.SyncPatchFormat
decodeSyncPatchFormat =
getFromBytesOr "decomposePatchFormat" Serialization.decomposePatchFormat
decodeSyncTermFormat :: ByteString -> Either DecodeError TermFormat.SyncTermFormat
decodeSyncTermFormat =
getFromBytesOr "decomposeTermFormat" Serialization.decomposeTermFormat
-- | N.B. The bytestring here is not the entire object.bytes column --
-- it's just the serialized term and type from 'TermFormat.SyncTermFormat'.
decodeSyncTermAndType :: ByteString -> Either DecodeError (TermFormat.Term, TermFormat.Type)
decodeSyncTermAndType =
getFromBytesOr "getTermAndType" Serialization.getTermAndType
-- | N.B. The bytestring here is not the entire object.bytes column --
-- it's just the serialized decl from 'DeclFormat.SyncDeclFormat'.
decodeDecl :: ByteString -> Either DecodeError (DeclFormat.Decl Symbol)
decodeDecl =
getFromBytesOr "getDeclElement" Serialization.getDeclElement
decodeTermFormat :: ByteString -> Either DecodeError TermFormat.TermFormat
decodeTermFormat =
getFromBytesOr "getTermFormat" Serialization.getTermFormat
decodeTermElementDiscardingTerm :: C.Reference.Pos -> ByteString -> Either DecodeError (LocalIds, TermFormat.Type)
decodeTermElementDiscardingTerm i =
getFromBytesOr ("lookupTermElementDiscardingTerm " <> tShow i) (Serialization.lookupTermElementDiscardingTerm i)
decodeTermElementDiscardingType :: C.Reference.Pos -> ByteString -> Either DecodeError (LocalIds, TermFormat.Term)
decodeTermElementDiscardingType i =
getFromBytesOr ("lookupTermElementDiscardingType " <> tShow i) (Serialization.lookupTermElementDiscardingType i)
decodeTermElementWithType ::
C.Reference.Pos ->
ByteString ->
Either DecodeError (LocalIds, TermFormat.Term, TermFormat.Type)
decodeTermElementWithType i =
getFromBytesOr ("lookupTermElement" <> tShow i) (Serialization.lookupTermElement i)
------------------------------------------------------------------------------------------------------------------------
-- temp_entity.blob
decodeTempCausalFormat :: ByteString -> Either DecodeError TempEntity.TempCausalFormat
decodeTempCausalFormat =
getFromBytesOr "getTempCausalFormat" Serialization.getTempCausalFormat
decodeTempDeclFormat :: ByteString -> Either DecodeError TempEntity.TempDeclFormat
decodeTempDeclFormat =
getFromBytesOr "getTempDeclFormat" Serialization.getTempDeclFormat
decodeTempNamespaceFormat :: ByteString -> Either DecodeError TempEntity.TempNamespaceFormat
decodeTempNamespaceFormat =
getFromBytesOr "getTempNamespaceFormat" Serialization.getTempNamespaceFormat
decodeTempPatchFormat :: ByteString -> Either DecodeError TempEntity.TempPatchFormat
decodeTempPatchFormat =
getFromBytesOr "getTempPatchFormat" Serialization.getTempPatchFormat
decodeTempTermFormat :: ByteString -> Either DecodeError TempEntity.TempTermFormat
decodeTempTermFormat =
getFromBytesOr "getTempTermFormat" Serialization.getTempTermFormat
------------------------------------------------------------------------------------------------------------------------
-- watch_result.result
decodeWatchResultFormat :: ByteString -> Either DecodeError TermFormat.WatchResultFormat
decodeWatchResultFormat =
getFromBytesOr "getWatchResultFormat" Serialization.getWatchResultFormat
------------------------------------------------------------------------------------------------------------------------
-- unsyncs
unsyncTermComponent :: TermFormat.SyncLocallyIndexedComponent' t d -> IO (TermFormat.LocallyIndexedComponent' t d)
unsyncTermComponent (TermFormat.SyncLocallyIndexedComponent terms) = do
let phi (localIds, bs) = do
(a, b) <- decodeSyncTermAndType bs
pure (localIds, a, b)
case traverse phi terms of
Left err -> throwIO err
Right x -> pure (TermFormat.LocallyIndexedComponent x)
unsyncDeclComponent :: DeclFormat.SyncLocallyIndexedComponent' t d -> IO (DeclFormat.LocallyIndexedComponent' t d)
unsyncDeclComponent (DeclFormat.SyncLocallyIndexedComponent decls) = do
let phi (localIds, bs) = do
decl <- decodeDecl bs
pure (localIds, decl)
case traverse phi decls of
Left err -> throwIO err
Right x -> pure (DeclFormat.LocallyIndexedComponent x)

34
codebase2/codebase-sqlite/U/Codebase/Sqlite/Entity.hs Normal file
View File

@ -0,0 +1,34 @@
module U.Codebase.Sqlite.Entity where
import qualified U.Codebase.Sqlite.Branch.Format as Namespace
import qualified U.Codebase.Sqlite.Causal as Causal
import U.Codebase.Sqlite.DbId (BranchHashId, BranchObjectId, CausalHashId, HashId, ObjectId, PatchObjectId, TextId)
import qualified U.Codebase.Sqlite.Decl.Format as Decl
import qualified U.Codebase.Sqlite.Patch.Format as Patch
import U.Codebase.Sqlite.TempEntityType (TempEntityType (..))
import qualified U.Codebase.Sqlite.Term.Format as Term
-- |
-- data SyncEntity
-- = TC SyncTermFormat
-- | DC SyncDeclFormat
-- | N SyncBranchFormat
-- | P SyncPatchFormat
-- | C SyncCausalFormat
type SyncEntity =
SyncEntity' TextId HashId ObjectId PatchObjectId BranchHashId BranchObjectId CausalHashId
data SyncEntity' text hash defn patch branchh branch causal
= TC (Term.SyncTermFormat' text defn)
| DC (Decl.SyncDeclFormat' text defn)
| N (Namespace.SyncBranchFormat' branch text defn patch (branch, causal))
| P (Patch.SyncPatchFormat' patch text hash defn)
| C (Causal.SyncCausalFormat' causal branchh)
entityType :: SyncEntity' text hash defn patch branchh branch causal -> TempEntityType
entityType = \case
TC _ -> TermComponentType
DC _ -> DeclComponentType
N _ -> NamespaceType
P _ -> PatchType
C _ -> CausalType

22
codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs Normal file
View File

@ -0,0 +1,22 @@
module U.Codebase.Sqlite.HashHandle
( HashHandle (..),
)
where
import qualified U.Codebase.Reference as C
import U.Codebase.Sqlite.Symbol (Symbol)
import qualified U.Codebase.Term as C.Term
import qualified U.Codebase.Type as C.Type
import U.Util.Hash (Hash)
import Unison.Prelude
data HashHandle = HashHandle
{ -- | Hash type
toReference :: C.Term.Type Symbol -> C.Reference,
-- | Hash type's mentions
toReferenceMentions :: C.Term.Type Symbol -> Set C.Reference,
-- | Hash the type of a single constructor in a decl component. The provided hash argument is the hash of the decl component.
toReferenceDecl :: Hash -> C.Type.TypeD Symbol -> C.Reference,
-- | Hash decl's mentions
toReferenceDeclMentions :: Hash -> C.Type.TypeD Symbol -> Set C.Reference
}

571
codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs
View File

@ -4,18 +4,20 @@ module U.Codebase.Sqlite.Operations
loadRootCausalHash,
expectRootCausalHash,
expectRootCausal,
loadCausalHashAtPath,
expectCausalHashAtPath,
saveBranch,
loadCausalBranchByCausalHash,
expectCausalBranchByCausalHash,
-- * terms
saveTermComponent,
Q.saveTermComponent,
loadTermComponent,
loadTermByReference,
loadTypeOfTermByTermReference,
-- * decls
saveDeclComponent,
Q.saveDeclComponent,
loadDeclComponent,
loadDeclByReference,
expectDeclTypeById,
@ -53,11 +55,11 @@ module U.Codebase.Sqlite.Operations
dependentsOfComponent,
-- ** type index
addTypeToIndexForTerm,
Q.addTypeToIndexForTerm,
termsHavingType,
-- ** type mentions index
addTypeMentionsToIndexForTerm,
Q.addTypeMentionsToIndexForTerm,
termsMentioningType,
-- ** name lookup index
@ -66,9 +68,11 @@ module U.Codebase.Sqlite.Operations
-- * low-level stuff
expectDbBranch,
saveDbBranch,
saveDbBranchUnderHashId,
expectDbPatch,
saveBranchObject,
saveDbPatch,
expectDbBranchByCausalHashId,
-- * somewhat unexpectedly unused definitions
c2sReferenceId,
@ -76,31 +80,23 @@ module U.Codebase.Sqlite.Operations
diffPatch,
decodeTermElementWithType,
loadTermWithTypeByReference,
s2cTermWithType,
Q.s2cTermWithType,
Q.s2cDecl,
declReferencesByPrefix,
branchHashesByPrefix,
derivedDependencies,
)
where
import Control.Lens (Lens')
import qualified Control.Lens as Lens
import qualified Control.Monad.Extra as Monad
import Control.Monad.State (MonadState, evalStateT)
import Control.Monad.Writer (MonadWriter, runWriterT)
import qualified Control.Monad.Writer as Writer
import Data.Bifunctor (Bifunctor (bimap))
import Data.Bitraversable (Bitraversable (bitraverse))
import Data.Bytes.Get (runGetS)
import qualified Data.Bytes.Get as Get
import qualified Data.Foldable as Foldable
import qualified Data.Map as Map
import qualified Data.Map.Merge.Lazy as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Tuple.Extra (uncurry3, (***))
import qualified Data.Vector as Vector
import qualified U.Codebase.Branch as C.Branch
import qualified U.Codebase.Causal as C
import U.Codebase.Decl (ConstructorId)
@ -115,7 +111,6 @@ import U.Codebase.ShortHash (ShortBranchHash (ShortBranchHash))
import qualified U.Codebase.Sqlite.Branch.Diff as S.Branch
import qualified U.Codebase.Sqlite.Branch.Diff as S.Branch.Diff
import qualified U.Codebase.Sqlite.Branch.Diff as S.BranchDiff
import U.Codebase.Sqlite.Branch.Format (BranchLocalIds)
import qualified U.Codebase.Sqlite.Branch.Format as S
import qualified U.Codebase.Sqlite.Branch.Format as S.BranchFormat
import qualified U.Codebase.Sqlite.Branch.Full as S
@ -123,17 +118,15 @@ import qualified U.Codebase.Sqlite.Branch.Full as S.Branch.Full
import qualified U.Codebase.Sqlite.Branch.Full as S.MetadataSet
import qualified U.Codebase.Sqlite.DbId as Db
import qualified U.Codebase.Sqlite.Decl.Format as S.Decl
import U.Codebase.Sqlite.Decode
import U.Codebase.Sqlite.HashHandle (HashHandle (..))
import U.Codebase.Sqlite.LocalIds
( LocalDefnId (..),
LocalIds,
LocalIds' (..),
LocalTextId (..),
( LocalIds,
WatchLocalIds,
)
import qualified U.Codebase.Sqlite.LocalIds as LocalIds
import qualified U.Codebase.Sqlite.LocalizeObject as LocalizeObject
import qualified U.Codebase.Sqlite.NamedRef as S
import qualified U.Codebase.Sqlite.ObjectType as OT
import qualified U.Codebase.Sqlite.ObjectType as ObjectType
import qualified U.Codebase.Sqlite.Patch.Diff as S
import qualified U.Codebase.Sqlite.Patch.Format as S
import qualified U.Codebase.Sqlite.Patch.Format as S.Patch.Format
@ -154,17 +147,13 @@ import qualified U.Codebase.Term as C
import qualified U.Codebase.Term as C.Term
import qualified U.Codebase.TermEdit as C
import qualified U.Codebase.TermEdit as C.TermEdit
import qualified U.Codebase.Type as C.Type
import qualified U.Codebase.TypeEdit as C
import qualified U.Codebase.TypeEdit as C.TypeEdit
import U.Codebase.WatchKind (WatchKind)
import qualified U.Core.ABT as ABT
import qualified U.Util.Base32Hex as Base32Hex
import qualified U.Util.Hash as H
import qualified U.Util.Lens as Lens
import U.Util.Serialization (Get)
import qualified U.Util.Hash32 as Hash32
import qualified U.Util.Serialization as S
import qualified U.Util.Term as TermUtil
import Unison.Prelude
import Unison.Sqlite
import qualified Unison.Util.Map as Map
@ -175,29 +164,17 @@ import qualified Unison.Util.Set as Set
debug :: Bool
debug = False
data DecodeError = DecodeError
{ decoder :: Text, -- the name of the decoder
err :: String -- the error message
}
deriving stock (Show)
deriving anyclass (SqliteExceptionReason)
newtype NeedTypeForBuiltinMetadata
= NeedTypeForBuiltinMetadata Text
deriving stock (Show)
deriving anyclass (SqliteExceptionReason)
getFromBytesOr :: Text -> Get a -> ByteString -> Either DecodeError a
getFromBytesOr decoder get bs = case runGetS get bs of
Left err -> Left (DecodeError decoder err)
Right a -> Right a
-- * Database lookups
objectExistsForHash :: H.Hash -> Transaction Bool
objectExistsForHash h =
isJust <$> runMaybeT do
id <- MaybeT . Q.loadHashId . H.toBase32Hex $ h
id <- MaybeT . Q.loadHashId . Hash32.fromHash $ h
MaybeT $ Q.loadObjectIdForAnyHashId id
expectValueHashByCausalHashId :: Db.CausalHashId -> Transaction BranchHash
@ -214,6 +191,40 @@ loadRootCausalHash =
runMaybeT $
lift . Q.expectCausalHash =<< MaybeT Q.loadNamespaceRoot
-- | Load the causal hash at the given path from the root.
--
-- FIXME should we move some Path type here?
loadCausalHashAtPath :: [Text] -> Transaction (Maybe CausalHash)
loadCausalHashAtPath =
let go :: Db.CausalHashId -> [Text] -> MaybeT Transaction CausalHash
go hashId = \case
[] -> lift (Q.expectCausalHash hashId)
t : ts -> do
tid <- MaybeT (Q.loadTextId t)
S.Branch {children} <- MaybeT (loadDbBranchByCausalHashId hashId)
(_, hashId') <- MaybeT (pure (Map.lookup tid children))
go hashId' ts
in \path -> do
hashId <- Q.expectNamespaceRoot
runMaybeT (go hashId path)
-- | Expect the causal hash at the given path from the root.
--
-- FIXME should we move some Path type here?
expectCausalHashAtPath :: [Text] -> Transaction CausalHash
expectCausalHashAtPath =
let go :: Db.CausalHashId -> [Text] -> Transaction CausalHash
go hashId = \case
[] -> Q.expectCausalHash hashId
t : ts -> do
tid <- Q.expectTextId t
S.Branch {children} <- expectDbBranchByCausalHashId hashId
let (_, hashId') = children Map.! tid
go hashId' ts
in \path -> do
hashId <- Q.expectNamespaceRoot
go hashId path
-- * Reference transformations
-- ** read existing references
@ -281,12 +292,8 @@ h2cReferent = bitraverse h2cReference h2cReference
-- ** convert and save references
-- | Save the text and hash parts of a Reference to the database and substitute their ids.
saveReferenceH :: C.Reference -> Transaction S.ReferenceH
saveReferenceH = bitraverse Q.saveText Q.saveHashHash
saveReferentH :: C.Referent -> Transaction S.ReferentH
saveReferentH = bitraverse saveReferenceH saveReferenceH
saveReferentH = bitraverse Q.saveReferenceH Q.saveReferenceH
-- ** Edits transformations
@ -317,7 +324,7 @@ c2sPatch :: C.Branch.Patch -> Transaction S.Patch
c2sPatch (C.Branch.Patch termEdits typeEdits) =
S.Patch
<$> Map.bitraverse saveReferentH (Set.traverse c2sTermEdit) termEdits
<*> Map.bitraverse saveReferenceH (Set.traverse c2sTypeEdit) typeEdits
<*> Map.bitraverse Q.saveReferenceH (Set.traverse c2sTypeEdit) typeEdits
where
c2sTermEdit = \case
C.TermEdit.Replace r t -> S.TermEdit.Replace <$> c2sReferent r <*> pure (c2sTyping t)
@ -346,37 +353,6 @@ diffPatch (S.Patch fullTerms fullTypes) (S.Patch refTerms refTypes) =
addDiffSet = Map.zipWithMatched (const Set.difference)
removeDiffSet = Map.zipWithMatched (const (flip Set.difference))
-- * Deserialization helpers
decodeBranchFormat :: ByteString -> Either DecodeError S.BranchFormat.BranchFormat
decodeBranchFormat = getFromBytesOr "getBranchFormat" S.getBranchFormat
decodePatchFormat :: ByteString -> Either DecodeError S.Patch.Format.PatchFormat
decodePatchFormat = getFromBytesOr "getPatchFormat" S.getPatchFormat
decodeTermFormat :: ByteString -> Either DecodeError S.Term.TermFormat
decodeTermFormat = getFromBytesOr "getTermFormat" S.getTermFormat
decodeComponentLengthOnly :: ByteString -> Either DecodeError Word64
decodeComponentLengthOnly = getFromBytesOr "lengthFramedArray" (Get.skip 1 >> S.lengthFramedArray)
decodeTermElementWithType :: C.Reference.Pos -> ByteString -> Either DecodeError (LocalIds, S.Term.Term, S.Term.Type)
decodeTermElementWithType i = getFromBytesOr ("lookupTermElement" <> tShow i) (S.lookupTermElement i)
decodeTermElementDiscardingTerm :: C.Reference.Pos -> ByteString -> Either DecodeError (LocalIds, S.Term.Type)
decodeTermElementDiscardingTerm i =
getFromBytesOr ("lookupTermElementDiscardingTerm " <> tShow i) (S.lookupTermElementDiscardingTerm i)
decodeTermElementDiscardingType :: C.Reference.Pos -> ByteString -> Either DecodeError (LocalIds, S.Term.Term)
decodeTermElementDiscardingType i =
getFromBytesOr ("lookupTermElementDiscardingType " <> tShow i) (S.lookupTermElementDiscardingType i)
decodeDeclFormat :: ByteString -> Either DecodeError S.Decl.DeclFormat
decodeDeclFormat = getFromBytesOr "getDeclFormat" S.getDeclFormat
decodeDeclElement :: Word64 -> ByteString -> Either DecodeError (LocalIds, S.Decl.Decl Symbol)
decodeDeclElement i = getFromBytesOr ("lookupDeclElement " <> tShow i) (S.lookupDeclElement i)
getCycleLen :: H.Hash -> Transaction (Maybe Word64)
getCycleLen h = do
when debug $ traceM $ "\ngetCycleLen " ++ (Text.unpack . Base32Hex.toText $ H.toBase32Hex h)
@ -409,163 +385,14 @@ loadTermComponent :: H.Hash -> MaybeT Transaction [(C.Term Symbol, C.Term.Type S
loadTermComponent h = do
oid <- MaybeT (Q.loadObjectIdForAnyHash h)
S.Term.Term (S.Term.LocallyIndexedComponent elements) <- MaybeT (Q.loadTermObject oid decodeTermFormat)
lift . traverse (uncurry3 s2cTermWithType) $ Foldable.toList elements
saveTermComponent :: H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> Transaction Db.ObjectId
saveTermComponent h terms = do
when debug . traceM $ "Operations.saveTermComponent " ++ show h
sTermElements <- traverse (uncurry c2sTerm) terms
hashId <- Q.saveHashHash h
let li = S.Term.LocallyIndexedComponent $ Vector.fromList sTermElements
bytes = S.putBytes S.putTermFormat $ S.Term.Term li
oId <- Q.saveObject hashId OT.TermComponent bytes
-- populate dependents index
let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sTermElements `zip` [0 ..])
unlocalizeRefs :: ((LocalIds, S.Term.Term, S.Term.Type), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id)
unlocalizeRefs ((LocalIds tIds oIds, tm, tp), i) =
let self = C.Reference.Id oId i
dependencies :: Set S.Reference =
let (tmRefs, tpRefs, tmLinks, tpLinks) = TermUtil.dependencies tm
tpRefs' = Foldable.toList $ C.Type.dependencies tp
getTermSRef :: S.Term.TermRef -> S.Reference
getTermSRef = \case
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references
C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
getTypeSRef :: S.Term.TypeRef -> S.Reference
getTypeSRef = \case
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
C.Reference.Derived h i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
getSTypeLink = getTypeSRef
getSTermLink :: S.Term.TermLink -> S.Reference
getSTermLink = \case
C.Referent.Con ref _conId -> getTypeSRef ref
C.Referent.Ref ref -> getTermSRef ref
in Set.fromList $
map getTermSRef tmRefs
++ map getSTermLink tmLinks
++ map getTypeSRef (tpRefs ++ tpRefs')
++ map getSTypeLink tpLinks
in Set.map (,self) dependencies
traverse_ (uncurry Q.addToDependentsIndex) dependencies
pure oId
-- | implementation detail of c2{s,w}Term
-- The Type is optional, because we don't store them for watch expression results.
c2xTerm :: forall m t d. Monad m => (Text -> m t) -> (H.Hash -> m d) -> C.Term Symbol -> Maybe (C.Term.Type Symbol) -> m (LocalIds' t d, S.Term.Term, Maybe (S.Term.Type))
c2xTerm saveText saveDefn tm tp =
done =<< (runWriterT . flip evalStateT mempty) do
sterm <- ABT.transformM go tm
stype <- traverse (ABT.transformM goType) tp
pure (sterm, stype)
where
go :: forall m a. (MonadWriter (Seq Text, Seq H.Hash) m, MonadState (Map Text LocalTextId, Map H.Hash LocalDefnId) m) => C.Term.F Symbol a -> m (S.Term.F a)
go = \case
C.Term.Int n -> pure $ C.Term.Int n
C.Term.Nat n -> pure $ C.Term.Nat n
C.Term.Float n -> pure $ C.Term.Float n
C.Term.Boolean b -> pure $ C.Term.Boolean b
C.Term.Text t -> C.Term.Text <$> lookupText t
C.Term.Char ch -> pure $ C.Term.Char ch
C.Term.Ref r ->
C.Term.Ref <$> bitraverse lookupText (traverse lookupDefn) r
C.Term.Constructor typeRef cid ->
C.Term.Constructor
<$> bitraverse lookupText lookupDefn typeRef
<*> pure cid
C.Term.Request typeRef cid ->
C.Term.Request <$> bitraverse lookupText lookupDefn typeRef <*> pure cid
C.Term.Handle a a2 -> pure $ C.Term.Handle a a2
C.Term.App a a2 -> pure $ C.Term.App a a2
C.Term.Ann a typ -> C.Term.Ann a <$> ABT.transformM goType typ
C.Term.List as -> pure $ C.Term.List as
C.Term.If c t f -> pure $ C.Term.If c t f
C.Term.And a a2 -> pure $ C.Term.And a a2
C.Term.Or a a2 -> pure $ C.Term.Or a a2
C.Term.Lam a -> pure $ C.Term.Lam a
C.Term.LetRec bs a -> pure $ C.Term.LetRec bs a
C.Term.Let a a2 -> pure $ C.Term.Let a a2
C.Term.Match a cs -> C.Term.Match a <$> traverse goCase cs
C.Term.TermLink r ->
C.Term.TermLink
<$> bitraverse
(bitraverse lookupText (traverse lookupDefn))
(bitraverse lookupText lookupDefn)
r
C.Term.TypeLink r ->
C.Term.TypeLink <$> bitraverse lookupText lookupDefn r
goType ::
forall m a.
(MonadWriter (Seq Text, Seq H.Hash) m, MonadState (Map Text LocalTextId, Map H.Hash LocalDefnId) m) =>
C.Type.FT a ->
m (S.Term.FT a)
goType = \case
C.Type.Ref r -> C.Type.Ref <$> bitraverse lookupText lookupDefn r
C.Type.Arrow i o -> pure $ C.Type.Arrow i o
C.Type.Ann a k -> pure $ C.Type.Ann a k
C.Type.App f a -> pure $ C.Type.App f a
C.Type.Effect e a -> pure $ C.Type.Effect e a
C.Type.Effects es -> pure $ C.Type.Effects es
C.Type.Forall a -> pure $ C.Type.Forall a
C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a
goCase ::
forall m w s a.
( MonadState s m,
MonadWriter w m,
Lens.Field1' s (Map Text LocalTextId),
Lens.Field1' w (Seq Text),
Lens.Field2' s (Map H.Hash LocalDefnId),
Lens.Field2' w (Seq H.Hash)
) =>
C.Term.MatchCase Text C.Term.TypeRef a ->
m (C.Term.MatchCase LocalTextId S.Term.TypeRef a)
goCase = \case
C.Term.MatchCase pat guard body ->
C.Term.MatchCase <$> goPat pat <*> pure guard <*> pure body
goPat ::
forall m s w.
( MonadState s m,
MonadWriter w m,
Lens.Field1' s (Map Text LocalTextId),
Lens.Field1' w (Seq Text),
Lens.Field2' s (Map H.Hash LocalDefnId),
Lens.Field2' w (Seq H.Hash)
) =>
C.Term.Pattern Text C.Term.TypeRef ->
m (C.Term.Pattern LocalTextId S.Term.TypeRef)
goPat = \case
C.Term.PUnbound -> pure $ C.Term.PUnbound
C.Term.PVar -> pure $ C.Term.PVar
C.Term.PBoolean b -> pure $ C.Term.PBoolean b
C.Term.PInt i -> pure $ C.Term.PInt i
C.Term.PNat n -> pure $ C.Term.PNat n
C.Term.PFloat d -> pure $ C.Term.PFloat d
C.Term.PText t -> C.Term.PText <$> lookupText t
C.Term.PChar c -> pure $ C.Term.PChar c
C.Term.PConstructor r i ps -> C.Term.PConstructor <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat ps
C.Term.PAs p -> C.Term.PAs <$> goPat p
C.Term.PEffectPure p -> C.Term.PEffectPure <$> goPat p
C.Term.PEffectBind r i bindings k -> C.Term.PEffectBind <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat bindings <*> goPat k
C.Term.PSequenceLiteral ps -> C.Term.PSequenceLiteral <$> traverse goPat ps
C.Term.PSequenceOp l op r -> C.Term.PSequenceOp <$> goPat l <*> pure op <*> goPat r
done :: ((S.Term.Term, Maybe S.Term.Type), (Seq Text, Seq H.Hash)) -> m (LocalIds' t d, S.Term.Term, Maybe S.Term.Type)
done ((tm, tp), (localTextValues, localDefnValues)) = do
textIds <- traverse saveText localTextValues
defnIds <- traverse saveDefn localDefnValues
let ids =
LocalIds
(Vector.fromList (Foldable.toList textIds))
(Vector.fromList (Foldable.toList defnIds))
pure (ids, void tm, void <$> tp)
lift . traverse (uncurry3 Q.s2cTermWithType) $ Foldable.toList elements
loadTermWithTypeByReference :: C.Reference.Id -> MaybeT Transaction (C.Term Symbol, C.Term.Type Symbol)
loadTermWithTypeByReference (C.Reference.Id h i) = do
oid <- MaybeT (Q.loadObjectIdForPrimaryHash h)
-- retrieve and deserialize the blob
(localIds, term, typ) <- MaybeT (Q.loadTermObject oid (decodeTermElementWithType i))
lift (s2cTermWithType localIds term typ)
lift (Q.s2cTermWithType localIds term typ)
loadTermByReference :: C.Reference.Id -> MaybeT Transaction (C.Term Symbol)
loadTermByReference r@(C.Reference.Id h i) = do
@ -583,95 +410,15 @@ loadTypeOfTermByTermReference id@(C.Reference.Id h i) = do
(localIds, typ) <- MaybeT (Q.loadTermObject oid (decodeTermElementDiscardingTerm i))
lift (s2cTypeOfTerm localIds typ)
s2cTermWithType :: LocalIds -> S.Term.Term -> S.Term.Type -> Transaction (C.Term Symbol, C.Term.Type Symbol)
s2cTermWithType ids tm tp = do
(substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids
pure (x2cTerm substText substHash tm, x2cTType substText substHash tp)
s2cTerm :: LocalIds -> S.Term.Term -> Transaction (C.Term Symbol)
s2cTerm ids tm = do
(substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids
pure $ x2cTerm substText substHash tm
(substText, substHash) <- Q.localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids
pure $ Q.x2cTerm substText substHash tm
s2cTypeOfTerm :: LocalIds -> S.Term.Type -> Transaction (C.Term.Type Symbol)
s2cTypeOfTerm ids tp = do
(substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids
pure $ x2cTType substText substHash tp
-- | implementation detail of {s,w}2c*Term* & s2cDecl
localIdsToLookups :: Monad m => (t -> m Text) -> (d -> m H.Hash) -> LocalIds' t d -> m (LocalTextId -> Text, LocalDefnId -> H.Hash)
localIdsToLookups loadText loadHash localIds = do
texts <- traverse loadText $ LocalIds.textLookup localIds
hashes <- traverse loadHash $ LocalIds.defnLookup localIds
let substText (LocalTextId w) = texts Vector.! fromIntegral w
substHash (LocalDefnId w) = hashes Vector.! fromIntegral w
pure (substText, substHash)
localIdsToTypeRefLookup :: LocalIds -> Transaction (S.Decl.TypeRef -> C.Decl.TypeRef)
localIdsToTypeRefLookup localIds = do
(substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId localIds
pure $ bimap substText (fmap substHash)
-- | implementation detail of {s,w}2c*Term*
x2cTerm :: (LocalTextId -> Text) -> (LocalDefnId -> H.Hash) -> S.Term.Term -> C.Term Symbol
x2cTerm substText substHash =
-- substitute the text and hashes back into the term
C.Term.extraMap substText substTermRef substTypeRef substTermLink substTypeLink id
where
substTermRef = bimap substText (fmap substHash)
substTypeRef = bimap substText substHash
substTermLink = bimap substTermRef substTypeRef
substTypeLink = substTypeRef
-- | implementation detail of {s,w}2c*Term*
x2cTType :: (LocalTextId -> Text) -> (LocalDefnId -> H.Hash) -> S.Term.Type -> C.Term.Type Symbol
x2cTType substText substHash = C.Type.rmap (bimap substText substHash)
lookupText ::
forall m s w t.
( MonadState s m,
MonadWriter w m,
Lens.Field1' s (Map t LocalTextId),
Lens.Field1' w (Seq t),
Ord t
) =>
t ->
m LocalTextId
lookupText = lookup_ Lens._1 Lens._1 LocalTextId
lookupDefn ::
forall m s w d.
( MonadState s m,
MonadWriter w m,
Lens.Field2' s (Map d LocalDefnId),
Lens.Field2' w (Seq d),
Ord d
) =>
d ->
m LocalDefnId
lookupDefn = lookup_ Lens._2 Lens._2 LocalDefnId
-- | shared implementation of lookupTextHelper and lookupDefnHelper
-- Look up a value in the LUT, or append it.
lookup_ ::
(MonadState s m, MonadWriter w m, Ord t) =>
Lens' s (Map t t') ->
Lens' w (Seq t) ->
(Word64 -> t') ->
t ->
m t'
lookup_ stateLens writerLens mk t = do
map <- Lens.use stateLens
case Map.lookup t map of
Nothing -> do
let id = mk . fromIntegral $ Map.size map
stateLens Lens.%= Map.insert t id
Writer.tell $ Lens.set writerLens (Seq.singleton t) mempty
pure id
Just t' -> pure t'
c2sTerm :: C.Term Symbol -> C.Term.Type Symbol -> Transaction (LocalIds, S.Term.Term, S.Term.Type)
c2sTerm tm tp = c2xTerm Q.saveText Q.expectObjectIdForPrimaryHash tm (Just tp) <&> \(w, tm, Just tp) -> (w, tm, tp)
(substText, substHash) <- Q.localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids
pure $ Q.x2cTType substText substHash tp
-- *** Watch expressions
@ -682,7 +429,7 @@ listWatches k = Q.loadWatchesByWatchKind k >>= traverse h2cReferenceId
loadWatch :: WatchKind -> C.Reference.Id -> MaybeT Transaction (C.Term Symbol)
loadWatch k r = do
r' <- C.Reference.idH (lift . Q.saveHashHash) r
S.Term.WatchResult wlids t <- MaybeT (Q.loadWatch k r' (getFromBytesOr "getWatchResultFormat" S.getWatchResultFormat))
S.Term.WatchResult wlids t <- MaybeT (Q.loadWatch k r' decodeWatchResultFormat)
lift (w2cTerm wlids t)
saveWatch :: WatchKind -> C.Reference.Id -> C.Term Symbol -> Transaction ()
@ -696,12 +443,12 @@ clearWatches :: Transaction ()
clearWatches = Q.clearWatches
c2wTerm :: C.Term Symbol -> Transaction (WatchLocalIds, S.Term.Term)
c2wTerm tm = c2xTerm Q.saveText Q.saveHashHash tm Nothing <&> \(w, tm, _) -> (w, tm)
c2wTerm tm = Q.c2xTerm Q.saveText Q.saveHashHash tm Nothing <&> \(w, tm, _) -> (w, tm)
w2cTerm :: WatchLocalIds -> S.Term.Term -> Transaction (C.Term Symbol)
w2cTerm ids tm = do
(substText, substHash) <- localIdsToLookups Q.expectText Q.expectHash ids
pure $ x2cTerm substText substHash tm
(substText, substHash) <- Q.localIdsToLookups Q.expectText Q.expectHash ids
pure $ Q.x2cTerm substText substHash tm
-- ** Saving & loading type decls
@ -709,80 +456,14 @@ loadDeclComponent :: H.Hash -> MaybeT Transaction [C.Decl Symbol]
loadDeclComponent h = do
oid <- MaybeT (Q.loadObjectIdForAnyHash h)
S.Decl.Decl (S.Decl.LocallyIndexedComponent elements) <- MaybeT (Q.loadDeclObject oid decodeDeclFormat)
lift . traverse (uncurry s2cDecl) $ Foldable.toList elements
saveDeclComponent :: H.Hash -> [C.Decl Symbol] -> Transaction Db.ObjectId
saveDeclComponent h decls = do
when debug . traceM $ "Operations.saveDeclComponent " ++ show h
sDeclElements <- traverse (c2sDecl Q.saveText Q.expectObjectIdForPrimaryHash) decls
hashId <- Q.saveHashHash h
let li = S.Decl.LocallyIndexedComponent $ Vector.fromList sDeclElements
bytes = S.putBytes S.putDeclFormat $ S.Decl.Decl li
oId <- Q.saveObject hashId OT.DeclComponent bytes
-- populate dependents index
let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sDeclElements `zip` [0 ..])
unlocalizeRefs :: ((LocalIds, S.Decl.Decl Symbol), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id)
unlocalizeRefs ((LocalIds tIds oIds, decl), i) =
let self = C.Reference.Id oId i
dependencies :: Set S.Decl.TypeRef = C.Decl.dependencies decl
getSRef :: C.Reference.Reference' LocalTextId (Maybe LocalDefnId) -> S.Reference.Reference
getSRef = \case
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references
C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
in Set.map ((,self) . getSRef) dependencies
traverse_ (uncurry Q.addToDependentsIndex) dependencies
pure oId
c2sDecl ::
forall m t d.
Monad m =>
(Text -> m t) ->
(H.Hash -> m d) ->
C.Decl Symbol ->
m (LocalIds' t d, S.Decl.Decl Symbol)
c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do
done =<< (runWriterT . flip evalStateT mempty) do
cts' <- traverse (ABT.transformM goType) cts
pure (C.Decl.DataDeclaration dt m b cts')
where
goType ::
forall m a.
(MonadWriter (Seq Text, Seq H.Hash) m, MonadState (Map Text LocalTextId, Map H.Hash LocalDefnId) m) =>
C.Type.FD a ->
m (S.Decl.F a)
goType = \case
C.Type.Ref r -> C.Type.Ref <$> bitraverse lookupText (traverse lookupDefn) r
C.Type.Arrow i o -> pure $ C.Type.Arrow i o
C.Type.Ann a k -> pure $ C.Type.Ann a k
C.Type.App f a -> pure $ C.Type.App f a
C.Type.Effect e a -> pure $ C.Type.Effect e a
C.Type.Effects es -> pure $ C.Type.Effects es
C.Type.Forall a -> pure $ C.Type.Forall a
C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a
done :: (S.Decl.Decl Symbol, (Seq Text, Seq H.Hash)) -> m (LocalIds' t d, S.Decl.Decl Symbol)
done (decl, (localTextValues, localDefnValues)) = do
textIds <- traverse saveText localTextValues
defnIds <- traverse saveDefn localDefnValues
let ids =
LocalIds
(Vector.fromList (Foldable.toList textIds))
(Vector.fromList (Foldable.toList defnIds))
pure (ids, decl)
-- | Unlocalize a decl.
s2cDecl :: LocalIds -> S.Decl.Decl Symbol -> Transaction (C.Decl Symbol)
s2cDecl ids (C.Decl.DataDeclaration dt m b ct) = do
substTypeRef <- localIdsToTypeRefLookup ids
pure (C.Decl.DataDeclaration dt m b (C.Type.rmap substTypeRef <$> ct))
lift . traverse (uncurry Q.s2cDecl) $ Foldable.toList elements
loadDeclByReference :: C.Reference.Id -> MaybeT Transaction (C.Decl Symbol)
loadDeclByReference r@(C.Reference.Id h i) = do
when debug . traceM $ "loadDeclByReference " ++ show r
oid <- MaybeT (Q.loadObjectIdForPrimaryHash h)
(localIds, decl) <- MaybeT (Q.loadDeclObject oid (decodeDeclElement i))
lift (s2cDecl localIds decl)
lift (Q.s2cDecl localIds decl)
expectDeclByReference :: C.Reference.Id -> Transaction (C.Decl Symbol)
expectDeclByReference r@(C.Reference.Id h i) = do
@ -790,7 +471,7 @@ expectDeclByReference r@(C.Reference.Id h i) = do
-- retrieve the blob
Q.expectObjectIdForPrimaryHash h
>>= (\oid -> Q.expectDeclObject oid (decodeDeclElement i))
>>= uncurry s2cDecl
>>= uncurry Q.s2cDecl
-- * Branch transformation
@ -884,10 +565,13 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
boId <- Q.expectBranchObjectIdByCausalHashId chId
expectBranch boId
saveRootBranch :: C.Branch.CausalBranch Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId)
saveRootBranch c = do
saveRootBranch ::
HashHandle ->
C.Branch.CausalBranch Transaction ->
Transaction (Db.BranchObjectId, Db.CausalHashId)
saveRootBranch hh c = do
when debug $ traceM $ "Operations.saveRootBranch " ++ show (C.causalHash c)
(boId, chId) <- saveBranch c
(boId, chId) <- saveBranch hh c
Q.setNamespaceRoot chId
pure (boId, chId)
@ -930,16 +614,18 @@ saveRootBranch c = do
-- References, but also values
-- Shallow - Hash? representation of the database relationships
saveBranch :: C.Branch.CausalBranch Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId)
saveBranch (C.Causal hc he parents me) = do
saveBranch ::
HashHandle ->
C.Branch.CausalBranch Transaction ->
Transaction (Db.BranchObjectId, Db.CausalHashId)
saveBranch hh (C.Causal hc he parents me) = do
when debug $ traceM $ "\nOperations.saveBranch \n hc = " ++ show hc ++ ",\n he = " ++ show he ++ ",\n parents = " ++ show (Map.keys parents)
(chId, bhId) <- flip Monad.fromMaybeM (Q.loadCausalByCausalHash hc) do
-- if not exist, create these
chId <- Q.saveCausalHash hc
bhId <- Q.saveBranchHash he
Q.saveCausal chId bhId
-- save the link between child and parents
parentCausalHashIds <-
-- so try to save each parent (recursively) before continuing to save hc
for (Map.toList parents) $ \(parentHash, mcausal) ->
@ -947,14 +633,14 @@ saveBranch (C.Causal hc he parents me) = do
-- by checking if there are causal parents associated with hc
(flip Monad.fromMaybeM)
(Q.loadCausalHashIdByCausalHash parentHash)
(mcausal >>= fmap snd . saveBranch)
unless (null parentCausalHashIds) $
Q.saveCausalParents chId parentCausalHashIds
(mcausal >>= fmap snd . saveBranch hh)
-- Save these CausalHashIds to the causal_parents table,
Q.saveCausal hh chId bhId parentCausalHashIds
pure (chId, bhId)
boId <- flip Monad.fromMaybeM (Q.loadBranchObjectIdByCausalHashId chId) do
branch <- c2sBranch =<< me
let (li, lBranch) = LocalizeObject.localizeBranch branch
saveBranchObject bhId li lBranch
saveDbBranchUnderHashId hh bhId branch
pure (boId, chId)
where
c2sBranch :: C.Branch.Branch Transaction -> Transaction S.DbBranch
@ -963,7 +649,7 @@ saveBranch (C.Causal hc he parents me) = do
<$> Map.bitraverse saveNameSegment (Map.bitraverse c2sReferent c2sMetadata) terms
<*> Map.bitraverse saveNameSegment (Map.bitraverse c2sReference c2sMetadata) types
<*> Map.bitraverse saveNameSegment savePatchObjectId patches
<*> Map.bitraverse saveNameSegment saveBranch children
<*> Map.bitraverse saveNameSegment (saveBranch hh) children
saveNameSegment :: C.Branch.NameSegment -> Transaction Db.TextId
saveNameSegment = Q.saveText . C.Branch.unNameSegment
@ -979,14 +665,7 @@ saveBranch (C.Causal hc he parents me) = do
Just patchOID -> pure patchOID
Nothing -> do
patch <- mp
savePatch h patch
saveBranchObject :: Db.BranchHashId -> BranchLocalIds -> S.Branch.Full.LocalBranch -> Transaction Db.BranchObjectId
saveBranchObject id@(Db.unBranchHashId -> hashId) li lBranch = do
when debug $ traceM $ "saveBranchObject\n\tid = " ++ show id ++ "\n\tli = " ++ show li ++ "\n\tlBranch = " ++ show lBranch
let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full li lBranch
oId <- Q.saveObject hashId OT.Namespace bytes
pure $ Db.BranchObjectId oId
savePatch hh h patch
expectRootCausal :: Transaction (C.Branch.CausalBranch Transaction)
expectRootCausal = Q.expectNamespaceRoot >>= expectCausalBranchByCausalHashId
@ -1017,6 +696,19 @@ expectBranchByCausalHashId id = do
boId <- Q.expectBranchObjectIdByCausalHashId id
expectBranch boId
-- | Load a branch value given its causal hash id.
loadDbBranchByCausalHashId :: Db.CausalHashId -> Transaction (Maybe S.DbBranch)
loadDbBranchByCausalHashId causalHashId =
Q.loadBranchObjectIdByCausalHashId causalHashId >>= \case
Nothing -> pure Nothing
Just branchObjectId -> Just <$> expectDbBranch branchObjectId
-- | Expect a branch value given its causal hash id.
expectDbBranchByCausalHashId :: Db.CausalHashId -> Transaction S.DbBranch
expectDbBranchByCausalHashId causalHashId = do
branchObjectId <- Q.expectBranchObjectIdByCausalHashId causalHashId
expectDbBranch branchObjectId
expectDbBranch :: Db.BranchObjectId -> Transaction S.DbBranch
expectDbBranch id =
deserializeBranchObject id >>= \case
@ -1123,6 +815,36 @@ expectDbBranch id =
let (Set.fromList -> adds, Set.fromList -> removes) = S.BranchDiff.addsRemoves md'
in Just . S.MetadataSet.Inline $ (Set.union adds $ Set.difference md removes)
-- | Save a 'S.DbBranch', given its hash (which the caller is expected to produce from the branch).
--
-- Note: long-standing question: should this package depend on the hashing package? (If so, we would only need to take
-- the DbBranch, and hash internally).
saveDbBranch ::
HashHandle ->
BranchHash ->
S.DbBranch ->
Transaction Db.BranchObjectId
saveDbBranch hh hash branch = do
hashId <- Q.saveBranchHash hash
saveDbBranchUnderHashId hh hashId branch
-- | Variant of 'saveDbBranch' that might be preferred by callers that already have a hash id, not a hash.
saveDbBranchUnderHashId ::
HashHandle ->
Db.BranchHashId ->
S.DbBranch ->
Transaction Db.BranchObjectId
saveDbBranchUnderHashId hh id@(Db.unBranchHashId -> hashId) branch = do
let (localBranchIds, localBranch) = LocalizeObject.localizeBranch branch
when debug $
traceM $
"saveBranchObject\n\tid = " ++ show id ++ "\n\tli = " ++ show localBranchIds
++ "\n\tlBranch = "
++ show localBranch
let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full localBranchIds localBranch
oId <- Q.saveObject hh hashId ObjectType.Namespace bytes
pure $ Db.BranchObjectId oId
expectBranch :: Db.BranchObjectId -> Transaction (C.Branch.Branch Transaction)
expectBranch id =
expectDbBranch id >>= s2cBranch
@ -1145,16 +867,24 @@ expectDbPatch patchId =
S.Patch.Format.Full li f -> pure (S.Patch.Format.applyPatchDiffs (S.Patch.Format.localPatchToPatch li f) ds)
S.Patch.Format.Diff ref' li' d' -> doDiff ref' (S.Patch.Format.localPatchDiffToPatchDiff li' d' : ds)
savePatch :: PatchHash -> C.Branch.Patch -> Transaction Db.PatchObjectId
savePatch h c = do
savePatch ::
HashHandle ->
PatchHash ->
C.Branch.Patch ->
Transaction Db.PatchObjectId
savePatch hh h c = do
(li, lPatch) <- LocalizeObject.localizePatch <$> c2sPatch c
saveDbPatch h (S.Patch.Format.Full li lPatch)
saveDbPatch hh h (S.Patch.Format.Full li lPatch)
saveDbPatch :: PatchHash -> S.PatchFormat -> Transaction Db.PatchObjectId
saveDbPatch hash patch = do
saveDbPatch ::
HashHandle ->
PatchHash ->
S.PatchFormat ->
Transaction Db.PatchObjectId
saveDbPatch hh hash patch = do
hashId <- Q.saveHashHash (unPatchHash hash)
let bytes = S.putBytes S.putPatchFormat patch
Db.PatchObjectId <$> Q.saveObject hashId OT.Patch bytes
Db.PatchObjectId <$> Q.saveObject hh hashId ObjectType.Patch bytes
s2cPatch :: S.Patch -> Transaction C.Branch.Patch
s2cPatch (S.Patch termEdits typeEdits) =
@ -1204,19 +934,10 @@ termsMentioningType cTypeRef =
set <- traverse s2cReferentId sIds
pure (Set.fromList set)
addTypeToIndexForTerm :: S.Referent.Id -> C.Reference -> Transaction ()
addTypeToIndexForTerm sTermId cTypeRef = do
sTypeRef <- saveReferenceH cTypeRef
Q.addToTypeIndex sTypeRef sTermId
addTypeMentionsToIndexForTerm :: S.Referent.Id -> Set C.Reference -> Transaction ()
addTypeMentionsToIndexForTerm sTermId cTypeMentionRefs = do
traverse_ (flip Q.addToTypeMentionsIndex sTermId <=< saveReferenceH) cTypeMentionRefs
-- something kind of funny here. first, we don't need to enumerate all the reference pos if we're just picking one
-- second, it would be nice if we could leave these as S.References a little longer
-- so that we remember how to blow up if they're missing
componentReferencesByPrefix :: OT.ObjectType -> Text -> Maybe C.Reference.Pos -> Transaction [S.Reference.Id]
componentReferencesByPrefix :: ObjectType.ObjectType -> Text -> Maybe C.Reference.Pos -> Transaction [S.Reference.Id]
componentReferencesByPrefix ot b32prefix pos = do
oIds :: [Db.ObjectId] <- Q.objectIdByBase32Prefix ot b32prefix
let test = maybe (const True) (==) pos
@ -1225,12 +946,12 @@ componentReferencesByPrefix ot b32prefix pos = do
termReferencesByPrefix :: Text -> Maybe Word64 -> Transaction [C.Reference.Id]
termReferencesByPrefix t w =
componentReferencesByPrefix OT.TermComponent t w
componentReferencesByPrefix ObjectType.TermComponent t w
>>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId)
declReferencesByPrefix :: Text -> Maybe Word64 -> Transaction [C.Reference.Id]
declReferencesByPrefix t w =
componentReferencesByPrefix OT.DeclComponent t w
componentReferencesByPrefix ObjectType.DeclComponent t w
>>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId)
termReferentsByPrefix :: Text -> Maybe Word64 -> Transaction [C.Referent.Id]
@ -1245,7 +966,7 @@ declReferentsByPrefix ::
Maybe ConstructorId ->
Transaction [(H.Hash, C.Reference.Pos, C.DeclType, [C.Decl.ConstructorId])]
declReferentsByPrefix b32prefix pos cid = do
componentReferencesByPrefix OT.DeclComponent b32prefix pos
componentReferencesByPrefix ObjectType.DeclComponent b32prefix pos
>>= traverse (loadConstructors cid)
where
loadConstructors ::

25
codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs
View File

@ -1,7 +1,9 @@
module U.Codebase.Sqlite.Patch.Format
( PatchFormat (..),
PatchLocalIds (..),
SyncPatchFormat (..),
PatchLocalIds,
PatchLocalIds' (..),
SyncPatchFormat,
SyncPatchFormat' (..),
applyPatchDiffs,
localPatchToPatch,
localPatchDiffToPatchDiff,
@ -24,15 +26,20 @@ data PatchFormat
= Full PatchLocalIds LocalPatch
| Diff PatchObjectId PatchLocalIds LocalPatchDiff
data PatchLocalIds = LocalIds
{ patchTextLookup :: Vector TextId,
patchHashLookup :: Vector HashId,
patchDefnLookup :: Vector ObjectId
type PatchLocalIds = PatchLocalIds' TextId HashId ObjectId
data PatchLocalIds' t h d = LocalIds
{ patchTextLookup :: Vector t,
patchHashLookup :: Vector h,
patchDefnLookup :: Vector d
}
data SyncPatchFormat
= SyncFull PatchLocalIds ByteString
| SyncDiff PatchObjectId PatchLocalIds ByteString
type SyncPatchFormat = SyncPatchFormat' PatchObjectId TextId HashId ObjectId
data SyncPatchFormat' parent text hash defn
= SyncFull (PatchLocalIds' text hash defn) ByteString
| -- | p is the identity of the thing that the diff is relative to
SyncDiff parent (PatchLocalIds' text hash defn) ByteString
-- | Apply a list of patch diffs to a patch, left to right.
applyPatchDiffs :: Patch -> [PatchDiff] -> Patch

1099
codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs
View File

File diff suppressed because it is too large Load Diff

3
codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs
View File

@ -4,14 +4,13 @@
module U.Codebase.Sqlite.Reference where
import Data.Tuple.Only (Only (..))
import U.Codebase.Reference (Id' (Id), Reference' (ReferenceBuiltin, ReferenceDerived))
import U.Codebase.Sqlite.DbId (HashId, ObjectId, TextId)
import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalHashId, LocalTextId)
import U.Codebase.Sqlite.Orphans ()
import U.Util.Base32Hex
import Unison.Prelude
import Unison.Sqlite (FromField, FromRow (fromRow), RowParser, SQLData (SQLNull), ToField, ToRow (toRow), field)
import Unison.Sqlite (FromField, FromRow (fromRow), Only (..), RowParser, SQLData (SQLNull), ToField, ToRow (toRow), field)
type Reference = Reference' TextId ObjectId

3
codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs
View File

@ -6,13 +6,12 @@
module U.Codebase.Sqlite.Referent where
import Control.Applicative (liftA3)
import Data.Tuple.Only (Only (..))
import qualified U.Codebase.Reference as Reference
import U.Codebase.Referent (Id', Referent')
import qualified U.Codebase.Referent as Referent
import U.Codebase.Sqlite.DbId (ObjectId)
import qualified U.Codebase.Sqlite.Reference as Sqlite
import Unison.Sqlite (FromRow (..), SQLData (..), ToField (toField), ToRow (..), field)
import Unison.Sqlite (FromRow (..), Only (..), SQLData (..), ToField (toField), ToRow (..), field)
type Referent = Referent' Sqlite.Reference Sqlite.Reference

184
codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs
View File

@ -14,11 +14,9 @@ import Data.Bytes.Get (MonadGet, getByteString, getWord8, runGetS)
import Data.Bytes.Put (MonadPut, putByteString, putWord8)
import Data.Bytes.Serial (SerialEndian (serializeBE), deserialize, deserializeBE, serialize)
import Data.Bytes.VarInt (VarInt (VarInt), unVarInt)
import Data.Int (Int64)
import Data.List (elemIndex)
import qualified Data.Set as Set
import Data.Word (Word64)
import Debug.Trace (trace)
import Data.Vector (Vector)
import qualified U.Codebase.Decl as Decl
import U.Codebase.Kind (Kind)
import qualified U.Codebase.Kind as Kind
@ -29,7 +27,9 @@ import qualified U.Codebase.Referent as Referent
import qualified U.Codebase.Sqlite.Branch.Diff as BranchDiff
import qualified U.Codebase.Sqlite.Branch.Format as BranchFormat
import qualified U.Codebase.Sqlite.Branch.Full as BranchFull
import qualified U.Codebase.Sqlite.Causal as Causal
import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat
import qualified U.Codebase.Sqlite.Entity as Entity
import U.Codebase.Sqlite.LocalIds (LocalIds, LocalIds' (..), LocalTextId, WatchLocalIds)
import qualified U.Codebase.Sqlite.Patch.Diff as PatchDiff
import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat
@ -37,12 +37,18 @@ import qualified U.Codebase.Sqlite.Patch.Full as PatchFull
import qualified U.Codebase.Sqlite.Patch.TermEdit as TermEdit
import qualified U.Codebase.Sqlite.Patch.TypeEdit as TypeEdit
import U.Codebase.Sqlite.Symbol (Symbol (..))
import U.Codebase.Sqlite.TempEntity (TempEntity)
import qualified U.Codebase.Sqlite.TempEntity as TempEntity
import qualified U.Codebase.Sqlite.Term.Format as TermFormat
import qualified U.Codebase.Term as Term
import qualified U.Codebase.Type as Type
import qualified U.Core.ABT as ABT
import qualified U.Util.Base32Hex as Base32Hex
import U.Util.Hash32 (Hash32)
import qualified U.Util.Hash32 as Hash32
import qualified U.Util.Monoid as Monoid
import U.Util.Serialization hiding (debug)
import Unison.Prelude
import Prelude hiding (getChar, putChar)
debug :: Bool
@ -108,15 +114,22 @@ getABT getVar getA getF = getList getVar >>= go []
_ -> unknownTag "getABT" tag
putLocalIds :: (MonadPut m, Integral t, Bits t, Integral d, Bits d) => LocalIds' t d -> m ()
putLocalIds LocalIds {..} = do
putFoldable putVarInt textLookup
putFoldable putVarInt defnLookup
putLocalIds = putLocalIdsWith putVarInt putVarInt
putLocalIdsWith :: (MonadPut m) => (t -> m ()) -> (d -> m ()) -> LocalIds' t d -> m ()
putLocalIdsWith putText putDefn LocalIds {textLookup, defnLookup} = do
putFoldable putText textLookup
putFoldable putDefn defnLookup
getLocalIds :: MonadGet m => m LocalIds
getLocalIds = LocalIds <$> getVector getVarInt <*> getVector getVarInt
getLocalIds = getLocalIdsWith getVarInt getVarInt
getWatchLocalIds :: MonadGet m => m WatchLocalIds
getWatchLocalIds = LocalIds <$> getVector getVarInt <*> getVector getVarInt
getWatchLocalIds = getLocalIdsWith getVarInt getVarInt
getLocalIdsWith :: MonadGet m => m t -> m d -> m (LocalIds' t d)
getLocalIdsWith getText getDefn =
LocalIds <$> getVector getText <*> getVector getDefn
putUnit :: Applicative m => () -> m ()
putUnit _ = pure ()
@ -252,6 +265,9 @@ getTermComponent =
TermFormat.LocallyIndexedComponent
<$> getFramedArray (getTuple3 getLocalIds (getFramed getTerm) getTType)
getTermAndType :: MonadGet m => m (TermFormat.Term, TermFormat.Type)
getTermAndType = (,) <$> getFramed getTerm <*> getTType
getTerm :: MonadGet m => m TermFormat.Term
getTerm = getABT getSymbol getUnit getF
where
@ -633,7 +649,25 @@ getBranchLocalIds =
<*> getVector getVarInt
<*> getVector (getPair getVarInt getVarInt)
decomposeComponent :: MonadGet m => m [(LocalIds, BS.ByteString)]
decomposeTermFormat :: MonadGet m => m TermFormat.SyncTermFormat
decomposeTermFormat =
getWord8 >>= \case
0 ->
TermFormat.SyncTerm
. TermFormat.SyncLocallyIndexedComponent
<$> decomposeComponent
tag -> error $ "todo: unknown term format tag " ++ show tag
decomposeDeclFormat :: MonadGet m => m DeclFormat.SyncDeclFormat
decomposeDeclFormat =
getWord8 >>= \case
0 ->
DeclFormat.SyncDecl
. DeclFormat.SyncLocallyIndexedComponent
<$> decomposeComponent
tag -> error $ "todo: unknown term format tag " ++ show tag
decomposeComponent :: MonadGet m => m (Vector (LocalIds, BS.ByteString))
decomposeComponent = do
offsets <- getList (getVarInt @_ @Int)
componentBytes <- getByteString (last offsets)
@ -643,7 +677,17 @@ decomposeComponent = do
split = (,) <$> getLocalIds <*> getRemainingByteString
Monoid.foldMapM get1 (zip offsets (tail offsets))
recomposeComponent :: MonadPut m => [(LocalIds, BS.ByteString)] -> m ()
recomposeTermFormat :: MonadPut m => TermFormat.SyncTermFormat -> m ()
recomposeTermFormat = \case
TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent x) ->
putWord8 0 >> recomposeComponent x
recomposeDeclFormat :: MonadPut m => DeclFormat.SyncDeclFormat -> m ()
recomposeDeclFormat = \case
DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent x) ->
putWord8 0 >> recomposeComponent x
recomposeComponent :: MonadPut m => Vector (LocalIds, BS.ByteString) -> m ()
recomposeComponent = putFramedArray \(localIds, bytes) -> do
putLocalIds localIds
putByteString bytes
@ -686,6 +730,126 @@ recomposeBranchFormat = \case
BranchFormat.SyncDiff id li bs ->
putWord8 1 *> putVarInt id *> putBranchLocalIds li *> putByteString bs
putTempEntity :: MonadPut m => TempEntity -> m ()
putTempEntity = \case
Entity.TC tc -> case tc of
TermFormat.SyncTerm term ->
putWord8 0 *> putSyncTerm term
Entity.DC dc -> case dc of
DeclFormat.SyncDecl decl ->
putWord8 0 *> putSyncDecl decl
Entity.P p -> case p of
PatchFormat.SyncFull lids bytes ->
putWord8 0 *> putSyncFullPatch lids bytes
PatchFormat.SyncDiff parent lids bytes ->
putWord8 1 *> putSyncDiffPatch parent lids bytes
Entity.N n -> case n of
BranchFormat.SyncFull lids bytes ->
putWord8 0 *> putSyncFullNamespace lids bytes
BranchFormat.SyncDiff parent lids bytes ->
putWord8 1 *> putSyncDiffNamespace parent lids bytes
Entity.C gdc ->
putSyncCausal gdc
where
putHash32 = putText . Hash32.toText
putPatchLocalIds PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} = do
putFoldable putText patchTextLookup
putFoldable putHash32 patchHashLookup
putFoldable putHash32 patchDefnLookup
putNamespaceLocalIds BranchFormat.LocalIds {branchTextLookup, branchDefnLookup, branchPatchLookup, branchChildLookup} = do
putFoldable putText branchTextLookup
putFoldable putHash32 branchDefnLookup
putFoldable putHash32 branchPatchLookup
putFoldable (putPair putHash32 putHash32) branchChildLookup
putSyncCausal Causal.SyncCausalFormat {valueHash, parents} = do
putHash32 valueHash
putFoldable putHash32 parents
putSyncFullPatch lids bytes = do
putPatchLocalIds lids
putFramedByteString bytes
putSyncDiffPatch parent lids bytes = do
putHash32 parent
putPatchLocalIds lids
putFramedByteString bytes
putSyncFullNamespace lids bytes = do
putNamespaceLocalIds lids
putFramedByteString bytes
putSyncDiffNamespace parent lids bytes = do
putHash32 parent
putNamespaceLocalIds lids
putFramedByteString bytes
putSyncTerm (TermFormat.SyncLocallyIndexedComponent vec) =
-- we're not leaving ourselves the ability to skip over the localIds
-- when deserializing, because we don't think we need to (and it adds a
-- little overhead.)
flip putFoldable vec \(localIds, bytes) -> do
putLocalIdsWith putText putHash32 localIds
putFramedByteString bytes
putSyncDecl (DeclFormat.SyncLocallyIndexedComponent vec) =
flip putFoldable vec \(localIds, bytes) -> do
putLocalIdsWith putText putHash32 localIds
putFramedByteString bytes
getHash32 :: MonadGet m => m Hash32
getHash32 = Hash32.UnsafeFromBase32Hex . Base32Hex.UnsafeFromText <$> getText
getTempTermFormat :: MonadGet m => m TempEntity.TempTermFormat
getTempTermFormat =
getWord8 >>= \case
0 ->
TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent
<$> getVector
( getPair
(getLocalIdsWith getText getHash32)
getFramedByteString
)
tag -> unknownTag "getTempTermFormat" tag
getTempDeclFormat :: MonadGet m => m TempEntity.TempDeclFormat
getTempDeclFormat =
getWord8 >>= \case
0 ->
DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent
<$> getVector
( getPair
(getLocalIdsWith getText getHash32)
getFramedByteString
)
tag -> unknownTag "getTempDeclFormat" tag
getTempPatchFormat :: MonadGet m => m TempEntity.TempPatchFormat
getTempPatchFormat =
getWord8 >>= \case
0 -> PatchFormat.SyncFull <$> getPatchLocalIds <*> getFramedByteString
1 -> PatchFormat.SyncDiff <$> getHash32 <*> getPatchLocalIds <*> getFramedByteString
tag -> unknownTag "getTempPatchFormat" tag
where
getPatchLocalIds =
PatchFormat.LocalIds
<$> getVector getText
<*> getVector getHash32
<*> getVector getHash32
getTempNamespaceFormat :: MonadGet m => m TempEntity.TempNamespaceFormat
getTempNamespaceFormat =
getWord8 >>= \case
0 -> BranchFormat.SyncFull <$> getBranchLocalIds <*> getFramedByteString
1 -> BranchFormat.SyncDiff <$> getHash32 <*> getBranchLocalIds <*> getFramedByteString
tag -> unknownTag "getTempNamespaceFormat" tag
where
getBranchLocalIds =
BranchFormat.LocalIds
<$> getVector getText
<*> getVector getHash32
<*> getVector getHash32
<*> getVector (getPair getHash32 getHash32)
getTempCausalFormat :: MonadGet m => m TempEntity.TempCausalFormat
getTempCausalFormat =
Causal.SyncCausalFormat
<$> getHash32
<*> getVector getHash32
getSymbol :: MonadGet m => m Symbol
getSymbol = Symbol <$> getVarInt <*> getText

148
codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs
View File

@ -14,14 +14,17 @@ import Control.Monad.Validate (ValidateT, runValidateT)
import qualified Control.Monad.Validate as Validate
import Data.Bifunctor (bimap)
import Data.Bitraversable (bitraverse)
import Data.Bytes.Get (getWord8, runGetS)
import Data.Bytes.Put (putWord8, runPutS)
import Data.Bytes.Get (runGetS)
import Data.Bytes.Put (runPutS)
import Data.List.Extra (nubOrd)
import qualified Data.Set as Set
import qualified Data.Vector as Vector
import Data.Void (Void)
import qualified U.Codebase.Reference as Reference
import qualified U.Codebase.Sqlite.Branch.Format as BL
import U.Codebase.Sqlite.DbId
import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat
import U.Codebase.Sqlite.HashHandle (HashHandle)
import qualified U.Codebase.Sqlite.LocalIds as L
import qualified U.Codebase.Sqlite.ObjectType as OT
import qualified U.Codebase.Sqlite.Patch.Format as PL
@ -31,6 +34,7 @@ import qualified U.Codebase.Sqlite.Reference as Sqlite.Reference
import qualified U.Codebase.Sqlite.Referent as Sqlite.Referent
import qualified U.Codebase.Sqlite.Serialization as S
import qualified U.Codebase.Sqlite.Term.Format as TL
import qualified U.Codebase.Sqlite.Term.Format as TermFormat
import U.Codebase.Sync (Sync (Sync), TrySyncResult)
import qualified U.Codebase.Sync as Sync
import qualified U.Codebase.WatchKind as WK
@ -86,18 +90,20 @@ sync22 ::
( MonadIO m,
MonadError Error m
) =>
HashHandle ->
Env m ->
IO (Sync m Entity)
sync22 Env {runSrc, runDest, idCacheSize = size} = do
sync22 hh Env {runSrc, runDest, idCacheSize = size} = do
tCache <- Cache.semispaceCache size
hCache <- Cache.semispaceCache size
oCache <- Cache.semispaceCache size
cCache <- Cache.semispaceCache size
pure $ Sync (trySync runSrc runDest tCache hCache oCache cCache)
pure $ Sync (trySync hh runSrc runDest tCache hCache oCache cCache)
trySync ::
forall m.
(MonadIO m, MonadError Error m) =>
HashHandle ->
(forall a. Transaction a -> m a) ->
(forall a. Transaction a -> m a) ->
Cache TextId TextId ->
@ -106,7 +112,7 @@ trySync ::
Cache CausalHashId CausalHashId ->
Entity ->
m (TrySyncResult Entity)
trySync runSrc runDest tCache hCache oCache cCache = \case
trySync hh runSrc runDest tCache hCache oCache cCache = \case
-- for causals, we need to get the value_hash_id of the thingo
-- - maybe enqueue their parents
-- - enqueue the self_ and value_ hashes
@ -123,9 +129,7 @@ trySync runSrc runDest tCache hCache oCache cCache = \case
parents' :: [CausalHashId] <- findParents' chId
bhId' <- lift $ syncBranchHashId bhId
chId' <- lift $ syncCausalHashId chId
(lift . runDest) do
Q.saveCausal chId' bhId'
Q.saveCausalParents chId' parents'
lift (runDest (Q.saveCausal hh chId' bhId' parents'))
case result of
Left deps -> pure . Sync.Missing $ toList deps
@ -142,91 +146,93 @@ trySync runSrc runDest tCache hCache oCache cCache = \case
result <- runValidateT @(Set Entity) @m @ObjectId case objType of
OT.TermComponent -> do
-- split up the localIds (parsed), term, and type blobs
-- note: this whole business with `fmt` is pretty weird, and will need to be
-- revisited when there are more formats.
-- (or maybe i'll learn something by implementing sync for patches and namespaces,
-- which have two formats already)
(fmt, unzip -> (localIds, bytes)) <-
lift case flip runGetS bytes do
tag <- getWord8
component <- S.decomposeComponent
pure (tag, component) of
Right x -> pure x
Left s -> throwError $ DecodeError ErrTermComponent bytes s
-- iterate through the local ids looking for missing deps;
-- then either enqueue the missing deps, or proceed to move the object
when debug $ traceM $ "LocalIds for Source " ++ show oId ++ ": " ++ show localIds
localIds' <- traverse syncLocalIds localIds
when debug $ traceM $ "LocalIds for Dest: " ++ show localIds'
-- reassemble and save the reindexed term
let bytes' =
runPutS $
putWord8 fmt >> S.recomposeComponent (zip localIds' bytes)
oId' <- lift . runDest $ Q.saveObject hId' objType bytes'
lift do
-- copy reference-specific stuff
for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do
let ref = Reference.Id oId idx
refH = Reference.Id hId idx
ref' = Reference.Id oId' idx
-- sync watch results
for_ [WK.TestWatch] \wk ->
syncWatch wk refH
syncDependenciesIndex ref ref'
syncTypeIndex oId oId'
syncTypeMentionsIndex oId oId'
pure oId'
case flip runGetS bytes S.decomposeTermFormat of
Left s -> throwError $ DecodeError ErrTermComponent bytes s
Right
( TermFormat.SyncTerm
( TermFormat.SyncLocallyIndexedComponent
(Vector.unzip -> (localIds, bytes))
)
) -> do
-- iterate through the local ids looking for missing deps;
-- then either enqueue the missing deps, or proceed to move the object
when debug $ traceM $ "LocalIds for Source " ++ show oId ++ ": " ++ show localIds
localIds' <- traverse syncLocalIds localIds
when debug $ traceM $ "LocalIds for Dest: " ++ show localIds'
-- reassemble and save the reindexed term
let bytes' =
runPutS
. S.recomposeTermFormat
. TermFormat.SyncTerm
. TermFormat.SyncLocallyIndexedComponent
$ Vector.zip localIds' bytes
lift do
oId' <- runDest $ Q.saveObject hh hId' objType bytes'
-- copy reference-specific stuff
for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do
let ref = Reference.Id oId idx
refH = Reference.Id hId idx
ref' = Reference.Id oId' idx
-- sync watch results
for_ [WK.TestWatch] \wk ->
syncWatch wk refH
syncDependenciesIndex ref ref'
syncTypeIndex oId oId'
syncTypeMentionsIndex oId oId'
pure oId'
OT.DeclComponent -> do
-- split up the localIds (parsed), decl blobs
(fmt, unzip -> (localIds, declBytes)) <-
case flip runGetS bytes do
tag <- getWord8
component <- S.decomposeComponent
pure (tag, component) of
Right x -> pure x
Left s -> throwError $ DecodeError ErrDeclComponent bytes s
-- iterate through the local ids looking for missing deps;
-- then either enqueue the missing deps, or proceed to move the object
localIds' <- traverse syncLocalIds localIds
-- reassemble and save the reindexed term
let bytes' =
runPutS $
putWord8 fmt
>> S.recomposeComponent (zip localIds' declBytes)
oId' <- lift . runDest $ Q.saveObject hId' objType bytes'
lift do
-- copy per-element-of-the-component stuff
for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do
let ref = Reference.Id oId idx
ref' = Reference.Id oId' idx
syncDependenciesIndex ref ref'
syncTypeIndex oId oId'
syncTypeMentionsIndex oId oId'
pure oId'
case flip runGetS bytes S.decomposeDeclFormat of
Left s -> throwError $ DecodeError ErrDeclComponent bytes s
Right
( DeclFormat.SyncDecl
( DeclFormat.SyncLocallyIndexedComponent
(Vector.unzip -> (localIds, declBytes))
)
) -> do
-- iterate through the local ids looking for missing deps;
-- then either enqueue the missing deps, or proceed to move the object
localIds' <- traverse syncLocalIds localIds
-- reassemble and save the reindexed term
let bytes' =
runPutS . S.recomposeDeclFormat
. DeclFormat.SyncDecl
. DeclFormat.SyncLocallyIndexedComponent
$ Vector.zip localIds' declBytes
lift do
oId' <- runDest $ Q.saveObject hh hId' objType bytes'
-- copy per-element-of-the-component stuff
for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do
let ref = Reference.Id oId idx
ref' = Reference.Id oId' idx
syncDependenciesIndex ref ref'
syncTypeIndex oId oId'
syncTypeMentionsIndex oId oId'
pure oId'
OT.Namespace -> case flip runGetS bytes S.decomposeBranchFormat of
Right (BL.SyncFull ids body) -> do
ids' <- syncBranchLocalIds ids
let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncFull ids' body)
oId' <- lift . runDest $ Q.saveObject hId' objType bytes'
oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes'
pure oId'
Right (BL.SyncDiff boId ids body) -> do
boId' <- syncBranchObjectId boId
ids' <- syncBranchLocalIds ids
let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncDiff boId' ids' body)
oId' <- lift . runDest $ Q.saveObject hId' objType bytes'
oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes'
pure oId'
Left s -> throwError $ DecodeError ErrBranchFormat bytes s
OT.Patch -> case flip runGetS bytes S.decomposePatchFormat of
Right (PL.SyncFull ids body) -> do
ids' <- syncPatchLocalIds ids
let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncFull ids' body)
oId' <- lift . runDest $ Q.saveObject hId' objType bytes'
oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes'
pure oId'
Right (PL.SyncDiff poId ids body) -> do
poId' <- syncPatchObjectId poId
ids' <- syncPatchLocalIds ids
let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncDiff poId' ids' body)
oId' <- lift . runDest $ Q.saveObject hId' objType bytes'
oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes'
pure oId'
Left s -> throwError $ DecodeError ErrPatchFormat bytes s
case result of

37
codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs Normal file
View File

@ -0,0 +1,37 @@
module U.Codebase.Sqlite.TempEntity where
import qualified U.Codebase.Sqlite.Branch.Format as Namespace
import qualified U.Codebase.Sqlite.Causal as Causal
import qualified U.Codebase.Sqlite.Decl.Format as Decl
import qualified U.Codebase.Sqlite.Entity as Entity
import U.Codebase.Sqlite.LocalIds (LocalIds')
import qualified U.Codebase.Sqlite.Patch.Format as Patch
import qualified U.Codebase.Sqlite.Term.Format as Term
import U.Util.Hash32 (Hash32)
import Unison.Prelude
-- |
-- data TempEntity
-- = TC TempTermFormat
-- | DC TempDeclFormat
-- | N TempNamespaceFormat
-- | P TempPatchFormat
-- | C TempCausalFormat
type TempEntity =
Entity.SyncEntity' Text Hash32 Hash32 Hash32 Hash32 Hash32 Hash32
type TempLocalIds = LocalIds' Text Hash32
type TempTermFormat = Term.SyncTermFormat' Text Hash32
type TempDeclFormat = Decl.SyncDeclFormat' Text Hash32
type TempPatchFormat = Patch.SyncPatchFormat' Hash32 Text Hash32 Hash32
type TempPatchLocalIds = Patch.PatchLocalIds' Text Hash32 Hash32
type TempNamespaceFormat = Namespace.SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
type TempNamespaceLocalIds = Namespace.BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
type TempCausalFormat = Causal.SyncCausalFormat' Hash32 Hash32

20
codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntityType.hs Normal file
View File

@ -0,0 +1,20 @@
module U.Codebase.Sqlite.TempEntityType where
import Unison.Sqlite (FromField (..), SQLData (SQLInteger), ToField (..))
-- | Don't reorder these, they are part of the database,
-- and the ToField and FromField implementation currently
-- depends on the derived Enum implementation.
data TempEntityType
= TermComponentType -- 0
| DeclComponentType -- 1
| NamespaceType -- 2
| PatchType -- 3
| CausalType -- 4
deriving (Eq, Ord, Show, Enum)
instance ToField TempEntityType where
toField = SQLInteger . fromIntegral . fromEnum
instance FromField TempEntityType where
fromField = fmap toEnum . fromField

16
codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs
View File

@ -38,10 +38,13 @@ type TypeLink = TypeRef
-- * The term's type, also with internal references to local id.
type LocallyIndexedComponent = LocallyIndexedComponent' TextId ObjectId
newtype LocallyIndexedComponent' t d
= LocallyIndexedComponent (Vector (LocalIds' t d, Term, Type))
newtype LocallyIndexedComponent' t d = LocallyIndexedComponent
{unLocallyIndexedComponent :: Vector (LocalIds' t d, Term, Type)}
deriving (Show)
newtype SyncLocallyIndexedComponent' t d
= SyncLocallyIndexedComponent (Vector (LocalIds' t d, ByteString))
{-
message = "hello, world" -> ABT { ... { Term.F.Text "hello, world" } } -> hashes to (#abc, 0)
program = printLine message -> ABT { ... { Term.F.App (ReferenceBuiltin ##io.PrintLine) (Reference #abc 0) } } -> hashes to (#def, 0)
@ -109,8 +112,13 @@ type FTT = Type.F' Sqlite.Reference
type TypeOfTerm = ABT.Term FTT Symbol ()
data TermFormat
= Term LocallyIndexedComponent
type TermFormat = TermFormat' TextId ObjectId
data TermFormat' t d = Term (LocallyIndexedComponent' t d)
type SyncTermFormat = SyncTermFormat' TextId ObjectId
data SyncTermFormat' t d = SyncTerm (SyncLocallyIndexedComponent' t d)
data WatchResultFormat
= WatchResult WatchLocalIds Term

4
codebase2/codebase-sqlite/package.yaml
View File

@ -22,6 +22,7 @@ dependencies:
- generic-lens
- monad-validate
- mtl
- nonempty-containers
- safe
- text
- transformers
@ -31,6 +32,8 @@ dependencies:
- unison-prelude
- unison-sqlite
- unison-util
- unison-util-base32hex
- unison-util-base32hex-orphans-sqlite
- unison-util-serialization
- unison-util-term
- unliftio
@ -49,6 +52,7 @@ default-extensions:
- DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- DuplicateRecordFields
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies

61
codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql Normal file
View File

@ -0,0 +1,61 @@
create table temp_entity_type_description (
id integer primary key not null,
description text unique not null
);
insert into temp_entity_type_description values
(0, 'Term Component'),
(1, 'Decl Component'),
(2, 'Namespace'),
(3, 'Patch'),
(4, 'Causal');
-- A "temp entity" is a term/decl/namespace/patch/causal that we cannot store in the database proper due to missing
-- dependencies.
--
-- The existence of each `temp_entity` row implies the existence of one or more corresponding
-- `temp_entity_missing_dependency` rows: it does not make sense to make a `temp_entity` row for a thing that has no
-- missing dependencies!
--
-- Similarly, each `temp_entity` row implies we do not have the entity in the database proper. When and if we *do* store
-- an entity proper (after storing all of its dependencies), we should always atomically delete the corresponding
-- `temp_entity` row, if any.
create table temp_entity (
hash text primary key not null,
blob bytes not null,
type_id integer not null references temp_entity_type_description(id)
);
-- A many-to-many relationship between `temp_entity` (entities we can't yet store due to missing dependencies), and the
-- non-empty set of hashes of each entity's dependencies.
--
-- We store with each missing dependency the JWT that Unison Share provided us to download that dependency. For
-- downloading a particular dependency #bar, we only need one JWT, even if it's in the table multiple times. (In fact,
-- in this case, there is one "best" JWT - the one with the latest expiry time).
--
-- The JWTs are also encoded in the local ids part of entity itself (`temp_entity.blob`), but we don't want to have to
-- keep going back there there to decode during a pull.
--
-- For example, if we wanted to store term #foo, but couldn't because it depends on term #bar which we don't have yet,
-- we would end up with the following rows.
--
-- temp_entity
-- +------------------------+
-- | hash | blob | type_id |
-- |========================|
-- | #foo | ... | 0 (term) |
-- +------------------------+
--
-- temp_entity_missing_dependency
-- +----------------------------------------+
-- | dependent | dependency | dependencyJwt |
-- |========================================|
-- | #foo | #bar | aT.Eb.cx |
-- +----------------------------------------+
create table temp_entity_missing_dependency (
dependent text not null references temp_entity(hash),
dependency text not null,
dependencyJwt text not null,
unique (dependent, dependency)
);
create index temp_entity_missing_dependency_ix_dependent on temp_entity_missing_dependency (dependent);
create index temp_entity_missing_dependency_ix_dependency on temp_entity_missing_dependency (dependency)

4
codebase2/codebase-sqlite/sql/create.sql
View File

@ -3,7 +3,7 @@
CREATE TABLE schema_version (
version INTEGER NOT NULL
);
INSERT INTO schema_version (version) VALUES (4);
INSERT INTO schema_version (version) VALUES (5);
-- actually stores the 512-byte hashes
CREATE TABLE hash (
@ -140,7 +140,7 @@ CREATE TABLE watch (
CREATE INDEX watch_kind ON watch(watch_kind_id);
-- Note [Watch expression identifier]
-- The hash_id + component_index is an unevaluated term reference. We use hash_id instead of object_id because the
-- The hash_id + component_index is an unevaluated term reference. We use hash_id instead of object_id because the
-- unevaluated term may not exist in the codebase: it is not added merely by watching it without a name, e.g `> 2 + 3`.

1
codebase2/codebase-sqlite/unison Symbolic link
View File

@ -0,0 +1 @@
.

12
codebase2/codebase-sqlite/unison-codebase-sqlite.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
-- This file has been generated from package.yaml by hpack version 0.34.7.
--
-- see: https://github.com/sol/hpack
@ -10,6 +10,7 @@ homepage: https://github.com/unisonweb/unison#readme
bug-reports: https://github.com/unisonweb/unison/issues
build-type: Simple
extra-source-files:
sql/001-temp-entity-tables.sql
sql/create.sql
source-repository head
@ -24,6 +25,9 @@ library
U.Codebase.Sqlite.Causal
U.Codebase.Sqlite.DbId
U.Codebase.Sqlite.Decl.Format
U.Codebase.Sqlite.Decode
U.Codebase.Sqlite.Entity
U.Codebase.Sqlite.HashHandle
U.Codebase.Sqlite.LocalIds
U.Codebase.Sqlite.LocalizeObject
U.Codebase.Sqlite.NamedRef
@ -41,6 +45,8 @@ library
U.Codebase.Sqlite.Serialization
U.Codebase.Sqlite.Symbol
U.Codebase.Sqlite.Sync22
U.Codebase.Sqlite.TempEntity
U.Codebase.Sqlite.TempEntityType
U.Codebase.Sqlite.Term.Format
hs-source-dirs:
./
@ -57,6 +63,7 @@ library
DerivingStrategies
DerivingVia
DoAndIfThenElse
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
FunctionalDependencies
@ -89,6 +96,7 @@ library
, lens
, monad-validate
, mtl
, nonempty-containers
, safe
, text
, transformers
@ -98,6 +106,8 @@ library
, unison-prelude
, unison-sqlite
, unison-util
, unison-util-base32hex
, unison-util-base32hex-orphans-sqlite
, unison-util-serialization
, unison-util-term
, unliftio

1
codebase2/codebase/package.yaml
View File

@ -33,4 +33,5 @@ dependencies:
- text
- unison-core
- unison-util
- unison-util-base32hex
- unison-prelude

3
codebase2/codebase/unison-codebase.cabal
View File

@ -3,8 +3,6 @@ cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
--
-- hash: b4d3c77715f39c915cacffccf179f1ed62bce29ba013cecc3a25c847f5851233
name: unison-codebase
version: 0.0.0
@ -60,4 +58,5 @@ library
, unison-core
, unison-prelude
, unison-util
, unison-util-base32hex
default-language: Haskell2010

1
codebase2/util/package.yaml
View File

@ -16,6 +16,7 @@ benchmarks:
- criterion
- sandi
- unison-util
- unison-util-base32hex
main: Main.hs
source-dirs: bench

2
codebase2/util/src/U/Util/Timing.hs
View File

@ -10,7 +10,7 @@ import System.IO.Unsafe (unsafePerformIO)
import UnliftIO (MonadIO, liftIO)
enabled :: Bool
enabled = False
enabled = True
time :: MonadIO m => String -> m a -> m a
time _ ma | not enabled = ma

3
codebase2/util/unison-util.cabal
View File

@ -17,10 +17,8 @@ source-repository head
library
exposed-modules:
U.Util.Alternative
U.Util.Base32Hex
U.Util.Cache
U.Util.Components
U.Util.Hash
U.Util.Lens
U.Util.Monoid
U.Util.String
@ -97,6 +95,7 @@ benchmark bench
, text
, time
, unison-util
, unison-util-base32hex
, unison-util-relation
, unliftio
, vector

1
contrib/cabal.project
View File

@ -15,6 +15,7 @@ packages:
lib/unison-prelude
lib/unison-sqlite
lib/unison-util-base32hex
lib/unison-util-relation
lib/unison-pretty-printer

8
docs/release-steps.md
View File

@ -40,7 +40,7 @@ Cut a release of base. @runarorama does this usually.
```
.> pull git@github.com:unisonweb/base basedev.release
.> pull git(git@github.com:unisonweb/base) basedev.release
.> cd .basedev.release
.basedev.release> delete.namespace releases._latest
.basedev.release> squash trunk releases._<ReleaseName>
@ -50,7 +50,7 @@ Edit `releases._<ReleaseName>.README` to include `Release: <ReleaseName>`.
```
.basedev.release> fork releases._<ReleaseName> releases._latest
.basedev.release> push git@github.com:unisonweb/base
.basedev.release> push git(git@github.com:unisonweb/base)
```
__6__
@ -64,7 +64,7 @@ Build a new version of Unison Share by following these instructions: https://git
__8__
Update homebrew.
Update homebrew.
```
git clone git@github.com/unisonweb/homebrew-unison.git
@ -96,7 +96,7 @@ Release announcement template (be sure to update the release urls) -
We've just released a new version of Unison, $RELEASE_NAME, release notes here (link to the issue). Install/upgrade instructions in the thread.
Mac upgrade is just `brew upgrade unison-language`.
Mac upgrade is just `brew upgrade unison-language`.
A fresh install via:

79
hie.yaml
View File

@ -1,74 +1,107 @@
cradle:
stack:
- path: "codebase2/codebase"
- path: "codebase2/codebase/./"
component: "unison-codebase:lib"
- path: "codebase2/codebase-sqlite"
- path: "codebase2/codebase-sqlite/./"
component: "unison-codebase-sqlite:lib"
- path: "codebase2/codebase-sync"
- path: "codebase2/codebase-sync/./"
component: "unison-codebase-sync:lib"
- path: "codebase2/core"
- path: "codebase2/core/./"
component: "unison-core:lib"
- path: "codebase2/util/bench"
component: "unison-util:bench:bench"
- path: "codebase2/util/src"
component: "unison-util:lib"
- path: "codebase2/util-serialization"
- path: "codebase2/util/bench/Main.hs"
component: "unison-util:bench:bench"
- path: "codebase2/util-serialization/./"
component: "unison-util-serialization:lib"
- path: "codebase2/util-term"
- path: "codebase2/util-term/./"
component: "unison-util-term:lib"
- path: "lib/unison-prelude/src"
component: "unison-prelude:lib"
- path: "lib/unison-pretty-printer/src"
component: "unison-pretty-printer:lib"
- path: "lib/unison-pretty-printer/prettyprintdemo/Main.hs"
component: "unison-pretty-printer:exe:prettyprintdemo"
- path: "lib/unison-pretty-printer/tests"
component: "unison-pretty-printer:test:pretty-printer-tests"
- path: "lib/unison-sqlite/src"
component: "unison-sqlite:lib"
- path: "unison-share-api/src"
component: "unison-share-api:lib"
- path: "lib/unison-util-base32hex/src"
component: "unison-util-base32hex:lib"
- path: "lib/unison-util-base32hex-orphans-aeson/src"
component: "unison-util-base32hex-orphans-aeson:lib"
- path: "lib/unison-util-base32hex-orphans-sqlite/src"
component: "unison-util-base32hex-orphans-sqlite:lib"
- path: "lib/unison-util-relation/src"
component: "unison-util-relation:lib"
- path: "lib/unison-util-relation/test"
component: "unison-util-relation:test:tests"
component: "unison-util-relation:test:util-relation-tests"
- path: "lib/unison-util-relation/benchmarks/relation"
- path: "lib/unison-util-relation/benchmarks/relation/Main.hs"
component: "unison-util-relation:bench:relation"
- path: "parser-typechecker/src"
component: "unison-parser-typechecker:lib"
- path: "parser-typechecker/prettyprintdemo"
component: "unison-parser-typechecker:exe:prettyprintdemo"
- path: "parser-typechecker/tests"
component: "unison-parser-typechecker:exe:tests"
component: "unison-parser-typechecker:test:parser-typechecker-tests"
- path: "unison-cli/src"
component: "unison-cli:lib"
- path: "unison-cli/integration-tests"
component: "unison-cli:exe:integration-tests"
- path: "unison-cli/integration-tests/Suite.hs"
component: "unison-cli:exe:cli-integration-tests"
- path: "unison-cli/tests"
component: "unison-cli:test:tests"
- path: "unison-cli/integration-tests/IntegrationTests/ArgumentParsing.hs"
component: "unison-cli:exe:cli-integration-tests"
- path: "unison-cli/transcripts"
- path: "unison-cli/transcripts/Transcripts.hs"
component: "unison-cli:exe:transcripts"
- path: "unison-cli/unison"
- path: "unison-cli/unison/Main.hs"
component: "unison-cli:exe:unison"
- path: "unison-cli/unison/ArgParse.hs"
component: "unison-cli:exe:unison"
- path: "unison-cli/unison/System/Path.hs"
component: "unison-cli:exe:unison"
- path: "unison-cli/unison/Version.hs"
component: "unison-cli:exe:unison"
- path: "unison-cli/tests"
component: "unison-cli:test:cli-tests"
- path: "unison-core/src"
component: "unison-core1:lib"
- path: "unison-hashing-v2/src"
component: "unison-hashing-v2:lib"
- path: "unison-hashing-v2/src"
component: "unison-hashing-v2:lib"
- path: "unison-share-api/src"
component: "unison-share-api:lib"
- path: "yaks/easytest/src"
component: "easytest:lib"

8
lib/unison-prelude/src/Unison/Debug.hs
View File

@ -6,6 +6,7 @@ module Unison.Debug
whenDebug,
debugLog,
debugLogM,
shouldDebug,
DebugFlag (..),
)
where
@ -26,6 +27,7 @@ data DebugFlag
| Auth
| Migration
| Integrity
| Sync
deriving (Eq, Ord, Show, Bounded, Enum)
debugFlags :: Set DebugFlag
@ -43,6 +45,7 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of
"AUTH" -> pure Auth
"MIGRATION" -> pure Migration
"INTEGRITY" -> pure Integrity
"SYNC" -> pure Sync
_ -> empty
{-# NOINLINE debugFlags #-}
@ -70,6 +73,10 @@ debugIntegrity :: Bool
debugIntegrity = Integrity `Set.member` debugFlags
{-# NOINLINE debugIntegrity #-}
debugSync :: Bool
debugSync = Sync `Set.member` debugFlags
{-# NOINLINE debugSync #-}
-- | Use for trace-style selective debugging.
-- E.g. 1 + (debug Git "The second number" 2)
--
@ -116,3 +123,4 @@ shouldDebug = \case
Auth -> debugAuth
Migration -> debugMigration
Integrity -> debugIntegrity
Sync -> debugSync

15
lib/unison-prelude/src/Unison/Prelude.hs
View File

@ -7,10 +7,13 @@ module Unison.Prelude
uncurry4,
reportBug,
tShow,
wundefined,
-- * @Maybe@ control flow
onNothing,
whenNothing,
whenJust,
whenJustM,
eitherToMaybe,
maybeToEither,
@ -77,6 +80,14 @@ onNothing m may = maybe m pure may
whenNothing :: Applicative m => Maybe a -> m a -> m a
whenNothing may m = maybe m pure may
whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
whenJust mx f =
maybe (pure ()) f mx
whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()
whenJustM mx f = do
mx >>= maybe (pure ()) f
whenLeft :: Applicative m => Either a b -> (a -> m b) -> m b
whenLeft = \case
Left a -> \f -> f a
@ -155,3 +166,7 @@ reportBug bugId msg =
"on the issue to let the team know you encountered it, and you can add",
"any additional details you know of to the issue."
]
{-# WARNING wundefined "You left this wundefined." #-}
wundefined :: HasCallStack => a
wundefined = undefined

0
unison-core/src/Unison/Util/Monoid.hs → lib/unison-prelude/src/Unison/Util/Monoid.hs
View File

10
lib/unison-prelude/src/Unison/Util/Set.hs
View File

@ -4,12 +4,15 @@ module Unison.Util.Set
symmetricDifference,
Unison.Util.Set.traverse,
flatMap,
filterM,
)
where
import Data.Functor ((<&>))
import qualified Data.Maybe as Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Unison.Util.Monoid (foldMapM)
-- | Set difference, but return @Nothing@ if the difference is empty.
difference1 :: Ord a => Set a -> Set a -> Maybe (Set a)
@ -29,3 +32,10 @@ traverse f = fmap Set.fromList . Prelude.traverse f . Set.toList
flatMap :: Ord b => (a -> Set b) -> Set a -> Set b
flatMap f = Set.unions . fmap f . Set.toList
filterM :: (Ord a, Monad m) => (a -> m Bool) -> Set a -> m (Set a)
filterM p =
foldMapM \x ->
p x <&> \case
False -> Set.empty
True -> Set.singleton x

1
lib/unison-prelude/unison-prelude.cabal
View File

@ -20,6 +20,7 @@ library
Unison.Debug
Unison.Prelude
Unison.Util.Map
Unison.Util.Monoid
Unison.Util.Set
hs-source-dirs:
src

5
lib/unison-sqlite/src/Unison/Sqlite.hs
View File

@ -73,6 +73,9 @@ module Unison.Sqlite
queryOneRowCheck_,
queryOneColCheck_,
-- * Rows modified
rowsModified,
-- * Data version
DataVersion (..),
getDataVersion,
@ -101,11 +104,11 @@ module Unison.Sqlite
(Sqlite.Simple.:.) (..),
Sqlite.Simple.FromField (fromField),
Sqlite.Simple.FromRow (fromRow),
Sqlite.Simple.Only (..),
Sqlite.Simple.RowParser,
Sqlite.Simple.SQLData (..),
Sqlite.Simple.ToField (toField),
Sqlite.Simple.ToRow (toRow),
Sqlite.Simple.Only (..),
)
where

9
lib/unison-sqlite/src/Unison/Sqlite/Connection.hs
View File

@ -50,6 +50,9 @@ module Unison.Sqlite.Connection
queryOneRowCheck_,
queryOneColCheck_,
-- * Rows modified
rowsModified,
-- * Vacuum (into)
vacuum,
vacuumInto,
@ -472,6 +475,12 @@ queryOneColCheck_ ::
queryOneColCheck_ conn s check =
queryOneRowCheck_ conn s (coerce @(a -> Either e r) @(Sqlite.Only a -> Either e r) check)
-- Rows modified
rowsModified :: Connection -> IO Int
rowsModified (Connection _ _ conn) =
Sqlite.changes conn
-- Vacuum
-- | @VACUUM@

13
lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs
View File

@ -7,6 +7,7 @@ module Unison.Sqlite.Transaction
unsafeUnTransaction,
savepoint,
unsafeIO,
unsafeGetConnection,
-- * Executing queries
@ -54,6 +55,9 @@ module Unison.Sqlite.Transaction
queryMaybeColCheck_,
queryOneRowCheck_,
queryOneColCheck_,
-- * Rows modified
rowsModified,
)
where
@ -77,6 +81,9 @@ newtype Transaction a
-- Omit MonadThrow instance so we always throw SqliteException (via *Check) with lots of context
deriving (Applicative, Functor, Monad) via (ReaderT Connection IO)
unsafeGetConnection :: Transaction Connection
unsafeGetConnection = Transaction pure
-- | Run a transaction on the given connection.
runTransaction :: MonadIO m => Connection -> Transaction a -> m a
runTransaction conn (Transaction f) = liftIO do
@ -361,3 +368,9 @@ queryOneRowCheck_ s check =
queryOneColCheck_ :: (Sqlite.FromField a, SqliteExceptionReason e) => Sql -> (a -> Either e r) -> Transaction r
queryOneColCheck_ s check =
Transaction \conn -> Connection.queryOneColCheck_ conn s check
-- Rows modified
rowsModified :: Transaction Int
rowsModified =
Transaction Connection.rowsModified

44
lib/unison-util-base32hex-orphans-aeson/package.yaml Normal file
View File

@ -0,0 +1,44 @@
name: unison-util-base32hex-orphans-aeson
github: unisonweb/unison
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
library:
when:
- condition: false
other-modules: Paths_unison_util_base32hex_orphans_aeson
source-dirs: src
dependencies:
- aeson
- base
- text
- unison-util-base32hex
ghc-options:
-Wall
-fno-warn-orphans
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- OverloadedStrings
- PatternSynonyms
- RankNTypes
- ScopedTypeVariables
- StandaloneDeriving
- TupleSections
- TypeApplications
- ViewPatterns

16
lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs Normal file
View File

@ -0,0 +1,16 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module U.Util.Hash32.Orphans.Aeson () where
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
import Data.Text (Text)
import U.Util.Base32Hex (Base32Hex (..))
import U.Util.Hash32 (Hash32 (..))
deriving via Text instance FromJSON Hash32
deriving via Text instance FromJSONKey Hash32
deriving via Text instance ToJSON Hash32
deriving via Text instance ToJSONKey Hash32

53
lib/unison-util-base32hex-orphans-aeson/unison-util-base32hex-orphans-aeson.cabal Normal file
View File

@ -0,0 +1,53 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
name: unison-util-base32hex-orphans-aeson
version: 0.0.0
homepage: https://github.com/unisonweb/unison#readme
bug-reports: https://github.com/unisonweb/unison/issues
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
build-type: Simple
source-repository head
type: git
location: https://github.com/unisonweb/unison
library
exposed-modules:
U.Util.Hash32.Orphans.Aeson
hs-source-dirs:
src
default-extensions:
ApplicativeDo
BangPatterns
BlockArguments
DeriveFunctor
DeriveGeneric
DeriveTraversable
DerivingStrategies
DerivingVia
DoAndIfThenElse
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
OverloadedStrings
PatternSynonyms
RankNTypes
ScopedTypeVariables
StandaloneDeriving
TupleSections
TypeApplications
ViewPatterns
ghc-options: -Wall -fno-warn-orphans
build-depends:
aeson
, base
, text
, unison-util-base32hex
default-language: Haskell2010

44
lib/unison-util-base32hex-orphans-sqlite/package.yaml Normal file
View File

@ -0,0 +1,44 @@
name: unison-util-base32hex-orphans-sqlite
github: unisonweb/unison
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
library:
when:
- condition: false
other-modules: Paths_unison_util_base32hex_orphans_sqlite
source-dirs: src
dependencies:
- base
- sqlite-simple
- text
- unison-util-base32hex
ghc-options:
-Wall
-fno-warn-orphans
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- OverloadedStrings
- PatternSynonyms
- RankNTypes
- ScopedTypeVariables
- StandaloneDeriving
- TupleSections
- TypeApplications
- ViewPatterns

13
lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs Normal file
View File

@ -0,0 +1,13 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module U.Util.Hash32.Orphans.Sqlite () where
import Data.Text (Text)
import Database.SQLite.Simple.FromField (FromField)
import Database.SQLite.Simple.ToField (ToField)
import U.Util.Base32Hex (Base32Hex (..))
import U.Util.Hash32 (Hash32 (..))
deriving via Text instance ToField Hash32
deriving via Text instance FromField Hash32

53
lib/unison-util-base32hex-orphans-sqlite/unison-util-base32hex-orphans-sqlite.cabal Normal file
View File

@ -0,0 +1,53 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
name: unison-util-base32hex-orphans-sqlite
version: 0.0.0
homepage: https://github.com/unisonweb/unison#readme
bug-reports: https://github.com/unisonweb/unison/issues
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
build-type: Simple
source-repository head
type: git
location: https://github.com/unisonweb/unison
library
exposed-modules:
U.Util.Hash32.Orphans.Sqlite
hs-source-dirs:
src
default-extensions:
ApplicativeDo
BangPatterns
BlockArguments
DeriveFunctor
DeriveGeneric
DeriveTraversable
DerivingStrategies
DerivingVia
DoAndIfThenElse
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
OverloadedStrings
PatternSynonyms
RankNTypes
ScopedTypeVariables
StandaloneDeriving
TupleSections
TypeApplications
ViewPatterns
ghc-options: -Wall -fno-warn-orphans
build-depends:
base
, sqlite-simple
, text
, unison-util-base32hex
default-language: Haskell2010

44
lib/unison-util-base32hex/package.yaml Normal file
View File

@ -0,0 +1,44 @@
name: unison-util-base32hex
github: unisonweb/unison
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
library:
when:
- condition: false
other-modules: Paths_unison_util_base32hex
source-dirs: src
dependencies:
- base
- base32
- bytestring
- containers
- unison-prelude
- text
ghc-options:
-Wall
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- OverloadedStrings
- PatternSynonyms
- RankNTypes
- ScopedTypeVariables
- TupleSections
- TypeApplications
- ViewPatterns

6
codebase2/util/src/U/Util/Base32Hex.hs → lib/unison-util-base32hex/src/U/Util/Base32Hex.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE ViewPatterns #-}
module U.Util.Base32Hex
( Base32Hex (UnsafeFromText),
fromByteString,
@ -10,13 +8,11 @@ module U.Util.Base32Hex
)
where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base32.Hex as Base32.Hex
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Unison.Prelude
newtype Base32Hex = UnsafeFromText Text
deriving (Eq, Ord, Show)

0
codebase2/util/src/U/Util/Hash.hs → lib/unison-util-base32hex/src/U/Util/Hash.hs
View File

55
lib/unison-util-base32hex/src/U/Util/Hash32.hs Normal file
View File

@ -0,0 +1,55 @@
-- | A 512-bit hash, internally represented as base32hex.
module U.Util.Hash32
( -- * Hash32 type
Hash32 (..),
-- * Conversions
-- ** The other Hash :)
fromHash,
toHash,
-- ** Base32Hex
unsafeFromBase32Hex,
toBase32Hex,
-- ** Text
toText,
)
where
import U.Util.Base32Hex (Base32Hex (..))
import U.Util.Hash (Hash)
import qualified U.Util.Hash as Hash
import Unison.Prelude
-- | A 512-bit hash, internally represented as base32hex.
--
-- Some orphan instances provided in:
--
-- * @unison-util-base32hex-orphans-aeson@
-- * @unison-util-base32hex-orphans-sqlite@
newtype Hash32 = UnsafeFromBase32Hex Base32Hex
deriving (Eq, Ord, Show) via (Text)
fromHash :: Hash -> Hash32
fromHash =
unsafeFromBase32Hex . Hash.toBase32Hex
toHash :: Hash32 -> Hash
toHash =
Hash.fromBase32Hex . toBase32Hex
-- | Convert base32hex to a hash32 (asserting that it is a 512-bit hash).
unsafeFromBase32Hex :: Base32Hex -> Hash32
unsafeFromBase32Hex =
coerce
-- | Convert a hash32 to base32hex.
toBase32Hex :: Hash32 -> Base32Hex
toBase32Hex =
coerce
toText :: Hash32 -> Text
toText =
coerce

56
lib/unison-util-base32hex/unison-util-base32hex.cabal Normal file
View File

@ -0,0 +1,56 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
name: unison-util-base32hex
version: 0.0.0
homepage: https://github.com/unisonweb/unison#readme
bug-reports: https://github.com/unisonweb/unison/issues
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
build-type: Simple
source-repository head
type: git
location: https://github.com/unisonweb/unison
library
exposed-modules:
U.Util.Base32Hex
U.Util.Hash
U.Util.Hash32
hs-source-dirs:
src
default-extensions:
ApplicativeDo
BangPatterns
BlockArguments
DeriveFunctor
DeriveGeneric
DeriveTraversable
DerivingStrategies
DerivingVia
DoAndIfThenElse
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
OverloadedStrings
PatternSynonyms
RankNTypes
ScopedTypeVariables
TupleSections
TypeApplications
ViewPatterns
ghc-options: -Wall
build-depends:
base
, base32
, bytestring
, containers
, text
, unison-prelude
default-language: Haskell2010

250
parser-typechecker/package.yaml
View File

@ -13,118 +13,121 @@ when:
- condition: flag(optimized)
ghc-options: -funbox-strict-fields -O2
dependencies:
- ListLike
- NanoID
- aeson
- ansi-terminal
- async
- base
- base16 >= 0.2.1.0
- base64-bytestring
- basement
- binary
- bytes
- bytestring
- bytestring-to-vector
- cereal
- clock
- configurator
- containers >= 0.6.3
- cryptonite
- data-default
- data-memocombinators
- deepseq
- directory
- either
- errors
- exceptions
- extra
- filepath
- fingertree
- fsnotify
- fuzzyfind
- generic-lens
- generic-monoid
- hashable
- hashtables
- haskeline
- here
- http-client
- http-media
- http-types
- lens
- lucid
- megaparsec
- memory
- mmorph
- monad-validate
- mtl
- mutable-containers
- mwc-random
- natural-transformation
- network
- network-simple
- network-uri
- nonempty-containers
- open-browser
- openapi3
- optparse-applicative >= 0.16.1.0
- pem
- prelude-extras
- pretty-simple
- primitive
- process
- random >= 1.2.0
- raw-strings-qq
- regex-base
- regex-tdfa
- safe
- safe-exceptions
- semialign
- servant
- servant-client
- servant-docs
- servant-openapi3
- servant-server
- shellmet
- stm
- strings
- tagged
- temporary
- terminal-size
- text
- text-short
- these
- time
- tls
- transformers
- unicode-show
- unison-codebase
- unison-codebase-sqlite
- unison-codebase-sqlite-hashing-v2
- unison-codebase-sync
- unison-core
- unison-core1
- unison-hashing-v2
- unison-prelude
- unison-pretty-printer
- unison-sqlite
- unison-util
- unison-util-base32hex
- unison-util-relation
- unison-util-serialization
- unliftio
- uri-encode
- utf8-string
- vector
- wai
- warp
- x509
- x509-store
- x509-system
- yaml
- zlib
library:
source-dirs: src
dependencies:
- aeson
- ansi-terminal
- async
- base
- base16 >= 0.2.1.0
- base64-bytestring
- basement
- binary
- bytes
- bytestring
- bytestring-to-vector
- cereal
- clock
- containers >= 0.6.3
- configurator
- cryptonite
- data-default
- deepseq
- directory
- either
- fuzzyfind
- data-memocombinators
- errors
- exceptions
- extra
- filepath
- fingertree
- fsnotify
- generic-monoid
- generic-lens
- hashable
- hashtables
- haskeline
- here
- http-types
- http-media
- http-client
- lens
- ListLike
- megaparsec
- memory
- mmorph
- monad-validate
- mtl
- mutable-containers
- natural-transformation
- network
- network-simple
- nonempty-containers
- optparse-applicative >= 0.16.1.0
- openapi3
- pem
- prelude-extras
- pretty-simple
- process
- primitive
- random >= 1.2.0
- raw-strings-qq
- regex-base
- regex-tdfa
- safe
- safe-exceptions
- semialign
- mwc-random
- NanoID
- lucid
- yaml
- semialign
- servant
- servant-docs
- servant-openapi3
- servant-server
- shellmet
- stm
- strings
- tagged
- temporary
- terminal-size
- text
- text-short
- these
- time
- tls
- transformers
- unliftio
- utf8-string
- unicode-show
- vector
- wai
- warp
- unicode-show
- x509
- x509-store
- x509-system
- zlib
- unison-codebase
- unison-codebase-sqlite
- unison-codebase-sync
- unison-core
- unison-core1
- unison-prelude
- unison-pretty-printer
- unison-sqlite
- unison-util
- unison-util-relation
- unison-util-serialization
- open-browser
- uri-encode
- generic-lens
when:
- condition: false
other-modules: Paths_unison_parser_typechecker
@ -135,37 +138,11 @@ tests:
main: Suite.hs
ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0
dependencies:
- async
- base
- bytestring
- code-page
- containers
- directory
- easytest
- errors
- exceptions
- extra
- filepath
- filemanip
- haskeline
- here
- lens
- megaparsec
- mtl
- raw-strings-qq
- stm
- shellmet
- split
- temporary
- text
- transformers
- unliftio
- unison-core1
- unison-parser-typechecker
- unison-prelude
- unison-util
- unison-util-relation
- unison-pretty-printer
when:
- condition: false
other-modules: Paths_unison_parser_typechecker
@ -181,6 +158,7 @@ default-extensions:
- DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- DuplicateRecordFields
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving

2
parser-typechecker/src/Unison/Builtin.hs
View File

@ -655,7 +655,7 @@ hashBuiltins =
B "crypto.hmac" $ forall1 "a" (\a -> hashAlgo --> bytes --> a --> bytes),
B "crypto.hmacBytes" $ hashAlgo --> bytes --> bytes --> bytes
]
++ map h ["Sha3_512", "Sha3_256", "Sha2_512", "Sha2_256", "Blake2b_512", "Blake2b_256", "Blake2s_256"]
++ map h ["Sha3_512", "Sha3_256", "Sha2_512", "Sha2_256", "Sha1", "Blake2b_512", "Blake2b_256", "Blake2s_256"]
where
hashAlgo = Type.ref () Type.hashAlgorithmRef
h name = B ("crypto.HashAlgorithm." <> name) hashAlgo

8
parser-typechecker/src/Unison/Codebase.hs
View File

@ -120,7 +120,7 @@ import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation))
import qualified Unison.Codebase.CodeLookup as CL
import Unison.Codebase.Editor.Git (withStatus)
import qualified Unison.Codebase.Editor.Git as Git
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace)
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace)
import qualified Unison.Codebase.GitError as GitError
import Unison.Codebase.Path
import qualified Unison.Codebase.Path as Path
@ -381,14 +381,14 @@ data Preprocessing m
= Unmodified
| Preprocessed (Branch m -> m (Branch m))
-- | Sync elements as needed from a remote codebase into the local one.
-- | Sync elements as needed from a remote git codebase into the local one.
-- If `sbh` is supplied, we try to load the specified branch hash;
-- otherwise we try to load the root branch.
importRemoteBranch ::
forall m v a.
MonadUnliftIO m =>
Codebase m v a ->
ReadRemoteNamespace ->
ReadGitRemoteNamespace ->
SyncMode ->
Preprocessing m ->
m (Either GitError (Branch m))
@ -414,7 +414,7 @@ importRemoteBranch codebase ns mode preprocess = runExceptT $ do
viewRemoteBranch ::
MonadIO m =>
Codebase m v a ->
ReadRemoteNamespace ->
ReadGitRemoteNamespace ->
Git.GitBranchBehavior ->
(Branch m -> m r) ->
m (Either GitError r)

14
parser-typechecker/src/Unison/Codebase/Editor/Git.hs
View File

@ -11,6 +11,7 @@ module Unison.Codebase.Editor.Git
withIsolatedRepo,
debugGit,
gitDirToPath,
gitVerbosity,
GitBranchBehavior (..),
GitRepo (..),
@ -27,21 +28,18 @@ import qualified Data.Text as Text
import Shellmet (($?), ($^), ($|))
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath ((</>))
import System.IO.Unsafe (unsafePerformIO)
import Unison.Codebase.Editor.RemoteRepo (ReadRepo (..))
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..))
import Unison.Codebase.GitError (GitProtocolError)
import qualified Unison.Codebase.GitError as GitError
import qualified Unison.Debug as Debug
import Unison.Prelude
import qualified UnliftIO
import UnliftIO.Directory (XdgDirectory (XdgCache), doesDirectoryExist, findExecutable, getXdgDirectory)
import UnliftIO.Environment (lookupEnv)
import UnliftIO.IO (hFlush, stdout)
import qualified UnliftIO.Process as UnliftIO
debugGit :: Bool
debugGit =
isJust (unsafePerformIO (lookupEnv "UNISON_DEBUG_GIT"))
{-# NOINLINE debugGit #-}
debugGit = Debug.shouldDebug Debug.Git
gitVerbosity :: [Text]
gitVerbosity =
@ -136,7 +134,7 @@ data GitBranchBehavior
withRepo ::
forall m a.
(MonadUnliftIO m) =>
ReadRepo ->
ReadGitRepo ->
GitBranchBehavior ->
(GitRepo -> m a) ->
m (Either GitProtocolError a)
@ -209,7 +207,7 @@ withRepo repo@(ReadGitRepo {url = uri, ref = mayGitRef}) branchBehavior action =
pure succeeded
-- | Do a `git clone` (for a not-previously-cached repo).
cloneIfMissing :: (MonadIO m, MonadError GitProtocolError m) => ReadRepo -> FilePath -> m GitRepo
cloneIfMissing :: (MonadIO m, MonadError GitProtocolError m) => ReadGitRepo -> FilePath -> m GitRepo
cloneIfMissing repo@(ReadGitRepo {url = uri}) localPath = do
doesDirectoryExist localPath >>= \case
True ->

140
parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs
View File

@ -10,41 +10,129 @@ import qualified Unison.Codebase.Path as Path
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
import qualified Unison.Codebase.ShortBranchHash as SBH
import Unison.Prelude
import Unison.Share.Types
data ReadRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} deriving (Eq, Ord, Show)
data ReadRepo
= ReadRepoGit ReadGitRepo
| ReadRepoShare ShareCodeserver
deriving stock (Eq, Ord, Show)
data WriteRepo = WriteGitRepo {url' :: Text, branch :: Maybe Text} deriving (Eq, Ord, Show)
data ShareCodeserver
= DefaultCodeserver
| CustomCodeserver CodeserverURI
deriving stock (Eq, Ord, Show)
-- |
-- >>> :set -XOverloadedLists
-- >>> import Data.Maybe (fromJust)
-- >>> import Network.URI
-- >>> displayShareCodeserver DefaultCodeserver "share" ["base", "List"]
-- "share.base.List"
-- >>> displayShareCodeserver DefaultCodeserver "share" []
-- "share"
-- >>> displayShareCodeserver (CustomCodeserver . fromJust $ parseURI "https://share-next.unison-lang.org/api" >>= codeserverFromURI ) "unison" ["base", "List"]
-- "share(https://share-next.unison-lang.org:443/api).unison.base.List"
displayShareCodeserver :: ShareCodeserver -> Text -> Path -> Text
displayShareCodeserver cs repo path =
let shareServer = case cs of
DefaultCodeserver -> ""
CustomCodeserver cu -> "share(" <> tShow cu <> ")."
in shareServer <> repo <> maybePrintPath path
data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text}
deriving stock (Eq, Ord, Show)
data WriteRepo
= WriteRepoGit WriteGitRepo
| WriteRepoShare ShareCodeserver
deriving stock (Eq, Ord, Show)
data WriteGitRepo = WriteGitRepo {url :: Text, branch :: Maybe Text}
deriving stock (Eq, Ord, Show)
writeToRead :: WriteRepo -> ReadRepo
writeToRead (WriteGitRepo {url', branch}) = ReadGitRepo {url = url', ref = branch}
writeToRead = \case
WriteRepoGit repo -> ReadRepoGit (writeToReadGit repo)
WriteRepoShare repo -> ReadRepoShare repo
writeToReadGit :: WriteGitRepo -> ReadGitRepo
writeToReadGit = \case
WriteGitRepo {url, branch} -> ReadGitRepo {url = url, ref = branch}
writePathToRead :: WriteRemotePath -> ReadRemoteNamespace
writePathToRead (w, p) = (writeToRead w, Nothing, p)
writePathToRead = \case
WriteRemotePathGit WriteGitRemotePath {repo, path} ->
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sbh = Nothing, path}
WriteRemotePathShare WriteShareRemotePath {server, repo, path} ->
ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path}
printReadRepo :: ReadRepo -> Text
printReadRepo ReadGitRepo {url, ref} = url <> Monoid.fromMaybe (Text.cons ':' <$> ref)
printReadGitRepo :: ReadGitRepo -> Text
printReadGitRepo ReadGitRepo {url, ref} =
"git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) <> ")"
printWriteRepo :: WriteRepo -> Text
printWriteRepo WriteGitRepo {url', branch} = url' <> Monoid.fromMaybe (Text.cons ':' <$> branch)
printWriteGitRepo :: WriteGitRepo -> Text
printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) <> ")"
printNamespace :: ReadRepo -> Maybe ShortBranchHash -> Path -> Text
printNamespace repo sbh path =
printReadRepo repo <> case sbh of
Nothing ->
if path == Path.empty
then mempty
else ":." <> Path.toText path
Just sbh ->
":#" <> SBH.toText sbh
<> if path == Path.empty
then mempty
else "." <> Path.toText path
-- | print remote namespace
printNamespace :: ReadRemoteNamespace -> Text
printNamespace = \case
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sbh, path} ->
printReadGitRepo repo <> maybePrintSBH sbh <> maybePrintPath path
where
maybePrintSBH = \case
Nothing -> mempty
Just sbh -> "#" <> SBH.toText sbh
ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path} ->
displayShareCodeserver server repo path
printHead :: WriteRepo -> Path -> Text
printHead repo path =
printWriteRepo repo
<> if path == Path.empty then mempty else ":." <> Path.toText path
-- | Render a 'WriteRemotePath' as text.
printWriteRemotePath :: WriteRemotePath -> Text
printWriteRemotePath = \case
WriteRemotePathGit (WriteGitRemotePath {repo, path}) ->
printWriteGitRepo repo <> maybePrintPath path
WriteRemotePathShare (WriteShareRemotePath {server, repo, path}) ->
displayShareCodeserver server repo path
type ReadRemoteNamespace = (ReadRepo, Maybe ShortBranchHash, Path)
maybePrintPath :: Path -> Text
maybePrintPath path =
if path == Path.empty
then mempty
else "." <> Path.toText path
type WriteRemotePath = (WriteRepo, Path)
data ReadRemoteNamespace
= ReadRemoteNamespaceGit ReadGitRemoteNamespace
| ReadRemoteNamespaceShare ReadShareRemoteNamespace
deriving stock (Eq, Show)
data ReadGitRemoteNamespace = ReadGitRemoteNamespace
{ repo :: ReadGitRepo,
sbh :: Maybe ShortBranchHash,
path :: Path
}
deriving stock (Eq, Show)
data ReadShareRemoteNamespace = ReadShareRemoteNamespace
{ server :: ShareCodeserver,
repo :: Text,
-- sbh :: Maybe ShortBranchHash, -- maybe later
path :: Path
}
deriving stock (Eq, Show)
data WriteRemotePath
= WriteRemotePathGit WriteGitRemotePath
| WriteRemotePathShare WriteShareRemotePath
deriving stock (Eq, Show)
data WriteGitRemotePath = WriteGitRemotePath
{ repo :: WriteGitRepo,
path :: Path
}
deriving stock (Eq, Show)
data WriteShareRemotePath = WriteShareRemotePath
{ server :: ShareCodeserver,
repo :: Text,
path :: Path
}
deriving stock (Eq, Show)

26
parser-typechecker/src/Unison/Codebase/GitError.hs
View File

@ -2,7 +2,7 @@
module Unison.Codebase.GitError where
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo)
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo)
import Unison.Codebase.Path
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
import Unison.Prelude
@ -11,15 +11,15 @@ type CodebasePath = FilePath
data GitProtocolError
= NoGit
| UnrecognizableCacheDir ReadRepo CodebasePath
| UnrecognizableCheckoutDir ReadRepo CodebasePath
| UnrecognizableCacheDir ReadGitRepo CodebasePath
| UnrecognizableCheckoutDir ReadGitRepo CodebasePath
| -- srcPath destPath error-description
CopyException FilePath FilePath String
| CloneException ReadRepo String
| PushException WriteRepo String
| PushNoOp WriteRepo
| CloneException ReadGitRepo String
| PushException WriteGitRepo String
| PushNoOp WriteGitRepo
| -- url commit Diff of what would change on merge with remote
PushDestinationHasNewStuff WriteRepo
PushDestinationHasNewStuff WriteGitRepo
| CleanupError SomeException
| -- Thrown when a commit, tag, or branch isn't found in a repo.
-- repo ref
@ -28,10 +28,10 @@ data GitProtocolError
deriving anyclass (Exception)
data GitCodebaseError h
= NoRemoteNamespaceWithHash ReadRepo ShortBranchHash
| RemoteNamespaceHashAmbiguous ReadRepo ShortBranchHash (Set h)
| CouldntLoadRootBranch ReadRepo h
| CouldntParseRemoteBranch ReadRepo String
| CouldntLoadSyncedBranch ReadRemoteNamespace h
| CouldntFindRemoteBranch ReadRepo Path
= NoRemoteNamespaceWithHash ReadGitRepo ShortBranchHash
| RemoteNamespaceHashAmbiguous ReadGitRepo ShortBranchHash (Set h)
| CouldntLoadRootBranch ReadGitRepo h
| CouldntParseRemoteBranch ReadGitRepo String
| CouldntLoadSyncedBranch ReadGitRemoteNamespace h
| CouldntFindRemoteBranch ReadGitRepo Path
deriving (Show)

73
parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs
View File

@ -23,6 +23,7 @@ import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL
import Data.Void
import Text.Pretty.Simple
import U.Codebase.HashTags (BranchHash (..))
import qualified U.Codebase.Sqlite.Branch.Full as DBBranch
import qualified U.Codebase.Sqlite.DbId as DB
import qualified U.Codebase.Sqlite.Operations as Ops
@ -51,11 +52,11 @@ data IntegrityError
| -- (causal hash, branch hash)
DetectedCausalsWithoutCorrespondingBranchObjects (NESet (Hash, Hash))
| DetectedCausalsWithCausalHashAsBranchHash (NESet Hash)
| DetectedBranchErrors Hash (NESet BranchError)
| DetectedBranchErrors BranchHash (NESet BranchError)
deriving stock (Show, Eq, Ord)
data BranchError
= IncorrectHashForBranch Hash Hash
= IncorrectHashForBranch BranchHash BranchHash
| MismatchedObjectForChild Hash DB.BranchObjectId DB.BranchObjectId
| MissingObjectForChildCausal Hash
| MissingObject DB.BranchObjectId
@ -151,7 +152,7 @@ integrityCheckAllBranches = do
integrityCheckBranch objId = do
dbBranch <- Ops.expectDbBranch objId
expectedBranchHash <- Helpers.dbBranchHash dbBranch
actualBranchHash <- Q.expectPrimaryHashByObjectId (DB.unBranchObjectId objId)
actualBranchHash <- BranchHash <$> Q.expectPrimaryHashByObjectId (DB.unBranchObjectId objId)
branchHashCheck <- assertExpectedBranchHash expectedBranchHash actualBranchHash
branchChildChecks <- flip foldMapM (toListOf DBBranch.childrenHashes_ dbBranch) $ \(childObjId, childCausalHashId) -> do
let checks =
@ -164,7 +165,7 @@ integrityCheckAllBranches = do
Nothing -> pure NoIntegrityErrors
Just errs -> pure . IntegrityErrorDetected . NESet.singleton $ DetectedBranchErrors actualBranchHash errs
where
assertExpectedBranchHash :: Hash -> Hash -> Sqlite.Transaction (Set BranchError)
assertExpectedBranchHash :: BranchHash -> BranchHash -> Sqlite.Transaction (Set BranchError)
assertExpectedBranchHash expectedBranchHash actualBranchHash = do
if (expectedBranchHash /= actualBranchHash)
then do
@ -201,9 +202,9 @@ integrityCheckAllBranches = do
pure (Set.singleton $ MissingObjectForChildCausal ch)
Just foundBranchId
| foundBranchId /= branchObjId -> do
failure $ "Expected child branch object to match canonical object ID for causal hash's namespace: " <> pShow (causalHashId, foundBranchId, branchObjId)
ch <- Q.expectHash (DB.unCausalHashId causalHashId)
pure (Set.singleton $ MismatchedObjectForChild ch branchObjId foundBranchId)
failure $ "Expected child branch object to match canonical object ID for causal hash's namespace: " <> pShow (causalHashId, foundBranchId, branchObjId)
ch <- Q.expectHash (DB.unCausalHashId causalHashId)
pure (Set.singleton $ MismatchedObjectForChild ch branchObjId foundBranchId)
| otherwise -> pure mempty
failure :: TL.Text -> Sqlite.Transaction ()
@ -214,34 +215,34 @@ prettyPrintIntegrityErrors :: Foldable f => f IntegrityError -> P.Pretty P.Color
prettyPrintIntegrityErrors xs
| null xs = mempty
| otherwise =
xs
& toList
& fmap
( \case
DetectedObjectsWithoutCorrespondingHashObjects objs ->
P.hang
"Detected objects without any corresponding hash_object. Object IDs:"
(P.commas (prettyObjectId <$> NESet.toList objs))
DetectedCausalsWithoutCorrespondingBranchObjects hashes ->
P.hang
"Detected causals without a corresponding branch object:\n"
( P.column2Header
"Causal Hash"
"Branch Hash"
(toList hashes <&> bimap prettyHash prettyHash)
)
DetectedCausalsWithCausalHashAsBranchHash ns ->
P.hang
"Detected causals with the same causal hash as branch hash:"
(P.commas (prettyHash <$> toList ns))
DetectedBranchErrors bh errs ->
P.hang
("Detected errors in branch: " <> prettyHash bh)
(P.lines . fmap (<> "\n") . fmap prettyBranchError . toList $ errs)
)
& fmap (<> "\n")
& P.lines
& P.warnCallout
xs
& toList
& fmap
( \case
DetectedObjectsWithoutCorrespondingHashObjects objs ->
P.hang
"Detected objects without any corresponding hash_object. Object IDs:"
(P.commas (prettyObjectId <$> NESet.toList objs))
DetectedCausalsWithoutCorrespondingBranchObjects hashes ->
P.hang
"Detected causals without a corresponding branch object:\n"
( P.column2Header
"Causal Hash"
"Branch Hash"
(toList hashes <&> bimap prettyHash prettyHash)
)
DetectedCausalsWithCausalHashAsBranchHash ns ->
P.hang
"Detected causals with the same causal hash as branch hash:"
(P.commas (prettyHash <$> toList ns))
DetectedBranchErrors bh errs ->
P.hang
("Detected errors in branch: " <> prettyHash (unBranchHash bh))
(P.lines . fmap (<> "\n") . fmap prettyBranchError . toList $ errs)
)
& fmap (<> "\n")
& P.lines
& P.warnCallout
where
prettyHash :: Hash -> P.Pretty P.ColorText
prettyHash h = P.blue . P.text $ ("#" <> Hash.toBase32HexText h)
@ -252,7 +253,7 @@ prettyPrintIntegrityErrors xs
prettyBranchError :: BranchError -> P.Pretty P.ColorText
prettyBranchError =
P.wrap . \case
IncorrectHashForBranch expected actual -> "The Branch hash for this branch is incorrect. Expected Hash: " <> prettyHash expected <> ", Actual Hash: " <> prettyHash actual
IncorrectHashForBranch expected actual -> "The Branch hash for this branch is incorrect. Expected Hash: " <> prettyHash (unBranchHash expected) <> ", Actual Hash: " <> prettyHash (unBranchHash actual)
MismatchedObjectForChild ha obj1 obj2 ->
"The child with causal hash: " <> prettyHash ha <> " is mapped to object ID " <> prettyBranchObjectId obj1 <> " but should map to " <> prettyBranchObjectId obj2 <> "."
MissingObjectForChildCausal ha ->

9
parser-typechecker/src/Unison/Codebase/Path.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Codebase.Path
@ -79,6 +80,7 @@ import qualified Data.List.NonEmpty as List.NonEmpty
import Data.Sequence (Seq ((:<|), (:|>)))
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified GHC.Exts as GHC
import qualified Unison.HashQualified' as HQ'
import Unison.Name (Convert (..), Name, Parse)
import qualified Unison.Name as Name
@ -92,6 +94,13 @@ newtype Path = Path {toSeq :: Seq NameSegment}
deriving stock (Eq, Ord)
deriving newtype (Semigroup, Monoid)
-- | Meant for use mostly in doc-tests where it's
-- sometimes convenient to specify paths as lists.
instance GHC.IsList Path where
type Item Path = NameSegment
toList (Path segs) = Foldable.toList segs
fromList = Path . Seq.fromList
newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord)
newtype Relative = Relative {unrelative :: Path} deriving (Eq, Ord)

47
parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs
View File

@ -29,10 +29,10 @@ import qualified System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import qualified U.Codebase.Branch as V2Branch
import U.Codebase.HashTags (CausalHash (CausalHash))
import qualified U.Codebase.Reference as C.Reference
import qualified U.Codebase.Sqlite.Operations as Ops
import qualified U.Codebase.Sqlite.Queries as Q
import qualified U.Codebase.Sqlite.Sync22 as Sync22
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
import qualified U.Codebase.Sync as Sync
import qualified U.Util.Cache as Cache
import qualified U.Util.Hash as H2
@ -41,11 +41,16 @@ import Unison.Codebase (Codebase, CodebasePath)
import qualified Unison.Codebase as Codebase1
import Unison.Codebase.Branch (Branch (..))
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Branch.Names as Branch
import qualified Unison.Codebase.Causal.Type as Causal
import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo)
import qualified Unison.Codebase.Editor.Git as Git
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo (..), printWriteRepo, writeToRead)
import Unison.Codebase.Editor.RemoteRepo
( ReadGitRemoteNamespace (..),
ReadGitRepo,
WriteGitRepo (..),
printWriteGitRepo,
writeToReadGit,
)
import qualified Unison.Codebase.GitError as GitError
import qualified Unison.Codebase.Init as Codebase
import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1
@ -63,7 +68,6 @@ import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral
import Unison.Codebase.SyncMode (SyncMode)
import Unison.Codebase.Type (LocalOrRemote (..), PushGitBranchOpts (..))
import qualified Unison.Codebase.Type as C
import qualified Unison.ConstructorType as CT
import Unison.DataDeclaration (Decl)
import Unison.Hash (Hash)
import Unison.Parser.Ann (Ann)
@ -135,7 +139,7 @@ createCodebaseOrError debugName path action = do
Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL
Sqlite.runTransaction conn do
Q.createSchema
void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty
void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty
sqliteCodebase debugName path Local action >>= \case
Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.")
@ -197,20 +201,16 @@ sqliteCodebase debugName root localOrRemote action = do
typeOfTermCache <- Cache.semispaceCache 8192
declCache <- Cache.semispaceCache 1024
rootBranchCache <- newTVarIO Nothing
getDeclType <- CodebaseOps.mkGetDeclType
-- The v1 codebase interface has operations to read and write individual definitions
-- whereas the v2 codebase writes them as complete components. These two fields buffer
-- the individual definitions until a complete component has been written.
termBuffer :: TVar (Map Hash CodebaseOps.TermBufferEntry) <- newTVarIO Map.empty
declBuffer :: TVar (Map Hash CodebaseOps.DeclBufferEntry) <- newTVarIO Map.empty
declTypeCache <- Cache.semispaceCache 2048
let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann))
getTerm id =
Sqlite.runTransaction conn (CodebaseOps.getTerm getDeclType id)
getDeclType :: C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType
getDeclType =
Sqlite.unsafeIO . Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (CodebaseOps.getDeclType ref) conn)
getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann))
getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined
getTypeOfTermImpl id =
@ -470,7 +470,7 @@ sqliteCodebase debugName root localOrRemote action = do
syncFromDirectory = syncFromDirectory,
syncToDirectory = syncToDirectory,
viewRemoteBranch' = viewRemoteBranch',
pushGitBranch = (\r opts action -> pushGitBranch conn r opts action),
pushGitBranch = pushGitBranch conn,
watches = watches,
getWatch = getWatch,
putWatch = putWatch,
@ -489,9 +489,7 @@ sqliteCodebase debugName root localOrRemote action = do
beforeImpl = (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r),
namesAtPath = \path -> Sqlite.runReadOnlyTransaction conn \runTx ->
runTx (CodebaseOps.namesAtPath path),
updateNameLookup = Sqlite.runTransaction conn $ do
root <- (CodebaseOps.getRootBranch getDeclType rootBranchCache)
CodebaseOps.saveRootNamesIndex (Branch.toNames . Branch.head $ root),
updateNameLookup = Sqlite.runTransaction conn (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType),
connection = conn
}
let finalizer :: MonadIO m => m ()
@ -529,7 +527,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do
-- or if it exists in the source codebase, then we can sync22 it
-- if it doesn't exist in the dest or source branch,
-- then just use putBranch to the dest
sync <- liftIO (Sync22.sync22 (Sync22.hoistEnv lift syncEnv))
sync <- liftIO (Sync22.sync22 v2HashHandle (Sync22.hoistEnv lift syncEnv))
let doSync :: [Sync22.Entity] -> m ()
doSync =
throwExceptT
@ -675,14 +673,15 @@ syncProgress progressStateRef = Sync.Progress (liftIO . need) (liftIO . done) (l
where
v = const ()
-- FIXME(mitchell) seems like this should have "git" in its name
viewRemoteBranch' ::
forall m r.
(MonadUnliftIO m) =>
ReadRemoteNamespace ->
ReadGitRemoteNamespace ->
Git.GitBranchBehavior ->
((Branch m, CodebasePath) -> m r) ->
m (Either C.GitError r)
viewRemoteBranch' (repo, sbh, path) gitBranchBehavior action = UnliftIO.try $ do
viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior action = UnliftIO.try $ do
-- set up the cache dir
time "Git fetch" $
throwEitherMWith C.GitProtocolError . withRepo repo gitBranchBehavior $ \remoteRepo -> do
@ -731,7 +730,7 @@ pushGitBranch ::
forall m e.
(MonadUnliftIO m) =>
Sqlite.Connection ->
WriteRepo ->
WriteGitRepo ->
PushGitBranchOpts ->
-- An action which accepts the current root branch on the remote and computes a new branch.
(Branch m -> m (Either e (Branch m))) ->
@ -767,8 +766,8 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift
for newBranchOrErr $ push pushStaging repo
pure newBranchOrErr
where
readRepo :: ReadRepo
readRepo = writeToRead repo
readRepo :: ReadGitRepo
readRepo = writeToReadGit repo
doSync :: CodebaseStatus -> FilePath -> Sqlite.Connection -> Branch m -> m ()
doSync codebaseStatus remotePath destConn newBranch = do
progressStateRef <- liftIO (newIORef emptySyncProgressState)
@ -805,7 +804,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift
Just True -> pure ()
CreatedCodebase -> pure ()
run (setRepoRoot newBranchHash)
repoString = Text.unpack $ printWriteRepo repo
repoString = Text.unpack $ printWriteGitRepo repo
setRepoRoot :: Branch.CausalHash -> Sqlite.Transaction ()
setRepoRoot h = do
let h2 = Cv.causalHash1to2 h
@ -857,8 +856,8 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift
hasDeleteShm = any isShmDelete statusLines
-- Commit our changes
push :: forall n. MonadIO n => Git.GitRepo -> WriteRepo -> Branch m -> n Bool -- withIOError needs IO
push remotePath repo@(WriteGitRepo {url' = url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do
push :: forall n. MonadIO n => Git.GitRepo -> WriteGitRepo -> Branch m -> n Bool -- withIOError needs IO
push remotePath repo@(WriteGitRepo {url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do
-- has anything changed?
-- note: -uall recursively shows status for all files in untracked directories
-- we want this so that we see
@ -890,6 +889,6 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift
-- Push our changes to the repo, silencing all output.
-- Even with quiet, the remote (Github) can still send output through,
-- so we capture stdout and stderr.
(successful, _stdout, stderr) <- gitInCaptured remotePath $ ["push", "--quiet", url] ++ maybe [] (pure @[]) mayGitBranch
(successful, _stdout, stderr) <- gitInCaptured remotePath $ ["push", url] ++ Git.gitVerbosity ++ maybe [] (pure @[]) mayGitBranch
when (not successful) . throwIO $ GitError.PushException repo (Text.unpack stderr)
pure True

8
parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs
View File

@ -1,11 +1,11 @@
module Unison.Codebase.SqliteCodebase.GitError where
import U.Codebase.Sqlite.DbId (SchemaVersion)
import Unison.Codebase.Editor.RemoteRepo (ReadRepo)
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo)
import Unison.CodebasePath (CodebasePath)
data GitSqliteCodebaseError
= GitCouldntParseRootBranchHash ReadRepo String
| NoDatabaseFile ReadRepo CodebasePath
| UnrecognizedSchemaVersion ReadRepo CodebasePath SchemaVersion
= GitCouldntParseRootBranchHash ReadGitRepo String
| NoDatabaseFile ReadGitRepo CodebasePath
| UnrecognizedSchemaVersion ReadGitRepo CodebasePath SchemaVersion
deriving (Show)

4
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs
View File

@ -17,6 +17,7 @@ import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 (migrateSchema2To3)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema4To5 (migrateSchema4To5)
import qualified Unison.Codebase.SqliteCodebase.Operations as Ops2
import Unison.Codebase.SqliteCodebase.Paths
import Unison.Codebase.Type (LocalOrRemote (..))
@ -41,7 +42,8 @@ migrations getDeclType termBuffer declBuffer =
Map.fromList
[ (2, migrateSchema1To2 getDeclType termBuffer declBuffer),
(3, migrateSchema2To3),
(4, migrateSchema3To4)
(4, migrateSchema3To4),
(5, migrateSchema4To5)
]
-- | Migrates a codebase up to the most recent version known to ucm.

55
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs
View File

@ -33,7 +33,7 @@ import qualified U.Codebase.Referent as UReferent
import qualified U.Codebase.Sqlite.Branch.Full as S
import qualified U.Codebase.Sqlite.Branch.Full as S.Branch.Full
import U.Codebase.Sqlite.Causal (GDbCausal (..))
import qualified U.Codebase.Sqlite.Causal as SC
import qualified U.Codebase.Sqlite.Causal as SC.DbCausal (GDbCausal (..))
import U.Codebase.Sqlite.DbId
( BranchHashId (..),
BranchObjectId (..),
@ -50,6 +50,7 @@ import qualified U.Codebase.Sqlite.Patch.Full as S
import qualified U.Codebase.Sqlite.Patch.TermEdit as TermEdit
import qualified U.Codebase.Sqlite.Patch.TypeEdit as TypeEdit
import qualified U.Codebase.Sqlite.Queries as Q
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
import U.Codebase.Sync (Sync (Sync))
import qualified U.Codebase.Sync as Sync
import U.Codebase.WatchKind (WatchKind)
@ -171,7 +172,7 @@ data MigrationState = MigrationState
-- Remember the hashes of term/decls that we have already migrated to avoid migrating them twice.
migratedDefnHashes :: Set (Old Hash),
numMigrated :: Int,
v2EmptyBranchHashInfo :: (BranchHashId, Hash)
v2EmptyBranchHashInfo :: (BranchHashId, BranchHash)
}
deriving (Generic)
@ -230,7 +231,7 @@ migrateCausal oldCausalHashId = fmap (either id id) . runExceptT $ do
Nothing -> use (field @"v2EmptyBranchHashInfo")
Just branchObjId -> do
let (_, newBranchHashId, newBranchHash, _) = migratedObjIds ^?! ix branchObjId
pure (BranchHashId newBranchHashId, newBranchHash)
pure (BranchHashId newBranchHashId, BranchHash newBranchHash)
let (newParentHashes, newParentHashIds) =
oldCausalParentHashIds
@ -244,7 +245,7 @@ migrateCausal oldCausalHashId = fmap (either id id) . runExceptT $ do
CausalHash . Cv.hash1to2 $
Hashing.hashCausal
( Hashing.Causal
{ branchHash = newBranchHash,
{ branchHash = unBranchHash newBranchHash,
parents = Set.mapMonotonic Cv.hash2to1 newParentHashes
}
)
@ -256,8 +257,11 @@ migrateCausal oldCausalHashId = fmap (either id id) . runExceptT $ do
parents = newParentHashIds
}
(lift . lift) do
Q.saveCausal (SC.selfHash newCausal) (SC.valueHash newCausal)
Q.saveCausalParents (SC.selfHash newCausal) (Set.toList $ SC.parents newCausal)
Q.saveCausal
v2HashHandle
(SC.DbCausal.selfHash newCausal)
(SC.DbCausal.valueHash newCausal)
(Set.toList $ SC.DbCausal.parents newCausal)
field @"causalMapping" %= Map.insert oldCausalHashId (newCausalHash, newCausalHashId)
@ -331,11 +335,17 @@ migrateBranch oldObjectId = fmap (either id id) . runExceptT $ do
& S.patches_ %~ remapPatchObjectId
& S.childrenHashes_ %~ (remapBranchObjectId *** remapCausalHashId)
let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch newBranch
newHash <- lift . lift $ Hashing.dbBranchHash newBranch
newHashId <- lift . lift $ Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash))
newObjectId <- lift . lift $ Ops.saveBranchObject newHashId localBranchIds localBranch
field @"objLookup" %= Map.insert oldObjectId (unBranchObjectId newObjectId, unBranchHashId newHashId, newHash, oldHash)
newHashId <- lift . lift $ Q.saveBranchHash (coerce Cv.hash1to2 newHash)
newObjectId <- lift . lift $ Ops.saveDbBranchUnderHashId v2HashHandle newHashId newBranch
field @"objLookup"
%= Map.insert
oldObjectId
( unBranchObjectId newObjectId,
unBranchHashId newHashId,
unBranchHash newHash,
oldHash
)
pure Sync.Done
migratePatch :: Old PatchObjectId -> StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity)
@ -387,9 +397,21 @@ migratePatch oldObjectId = fmap (either id id) . runExceptT $ do
let (localPatchIds, localPatch) = S.LocalizeObject.localizePatch newPatchWithIds
newHash <- lift . lift $ Hashing.dbPatchHash newPatchWithIds
newObjectId <- lift . lift $ Ops.saveDbPatch (PatchHash (Cv.hash1to2 newHash)) (S.Patch.Format.Full localPatchIds localPatch)
newHashId <- lift . lift $ Q.expectHashIdByHash (Cv.hash1to2 newHash)
field @"objLookup" %= Map.insert (unPatchObjectId oldObjectId) (unPatchObjectId newObjectId, newHashId, newHash, oldHash)
newObjectId <-
lift . lift $
Ops.saveDbPatch
v2HashHandle
(coerce Cv.hash1to2 newHash)
(S.Patch.Format.Full localPatchIds localPatch)
newHashId <- lift . lift $ Q.expectHashIdByHash (coerce Cv.hash1to2 newHash)
field @"objLookup"
%= Map.insert
(unPatchObjectId oldObjectId)
( unPatchObjectId newObjectId,
newHashId,
unPatchHash newHash,
oldHash
)
pure Sync.Done
-- | PLAN
@ -844,11 +866,10 @@ foldSetter t s = execWriter (s & t %%~ \a -> tell [a] *> pure a)
-- | Save an empty branch and get its new hash to use when replacing
-- branches which are missing due to database corruption.
saveV2EmptyBranch :: Sqlite.Transaction (BranchHashId, Hash)
saveV2EmptyBranch :: Sqlite.Transaction (BranchHashId, BranchHash)
saveV2EmptyBranch = do
let branch = S.emptyBranch
let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch branch
newHash <- Hashing.dbBranchHash branch
newHashId <- Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash))
_ <- Ops.saveBranchObject newHashId localBranchIds localBranch
newHashId <- Q.saveBranchHash (coerce Cv.hash1to2 newHash)
_ <- Ops.saveDbBranchUnderHashId v2HashHandle newHashId branch
pure (newHashId, newHash)

21
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs
View File

@ -1,9 +1,13 @@
module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers
( dbBranchHash,
dbPatchHash,
syncCausalHash,
)
where
import qualified Data.Set as Set
import qualified Data.Vector as Vector
import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..))
import qualified U.Codebase.Reference as S hiding (Reference)
import qualified U.Codebase.Reference as S.Reference
import qualified U.Codebase.Referent as S.Referent
@ -11,6 +15,7 @@ import U.Codebase.Sqlite.Branch.Full (DbMetadataSet)
import qualified U.Codebase.Sqlite.Branch.Full as S
import qualified U.Codebase.Sqlite.Branch.Full as S.Branch.Full
import qualified U.Codebase.Sqlite.Branch.Full as S.MetadataSet
import qualified U.Codebase.Sqlite.Causal as S
import qualified U.Codebase.Sqlite.DbId as Db
import qualified U.Codebase.Sqlite.Patch.Full as S
import qualified U.Codebase.Sqlite.Patch.TermEdit as S (TermEdit)
@ -24,6 +29,7 @@ import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
import Unison.Hash (Hash)
import Unison.Hashing.V2.Branch (NameSegment (..))
import qualified Unison.Hashing.V2.Branch as Hashing.Branch
import qualified Unison.Hashing.V2.Causal as Hashing.Causal
import qualified Unison.Hashing.V2.Patch as Hashing (Patch (..))
import qualified Unison.Hashing.V2.Patch as Hashing.Patch
import qualified Unison.Hashing.V2.Reference as Hashing (Reference)
@ -39,9 +45,16 @@ import Unison.Sqlite (Transaction)
import qualified Unison.Util.Map as Map
import qualified Unison.Util.Set as Set
dbBranchHash :: S.DbBranch -> Transaction Hash
syncCausalHash :: S.SyncCausalFormat -> Transaction CausalHash
syncCausalHash S.SyncCausalFormat {valueHash = valueHashId, parents = parentChIds} = do
fmap (CausalHash . Hashing.Causal.hashCausal) $
Hashing.Causal.Causal
<$> coerce @(Transaction BranchHash) @(Transaction Hash) (Q.expectBranchHash valueHashId)
<*> fmap (Set.fromList . coerce @[CausalHash] @[Hash] . Vector.toList) (traverse Q.expectCausalHash parentChIds)
dbBranchHash :: S.DbBranch -> Transaction BranchHash
dbBranchHash (S.Branch.Full.Branch tms tps patches children) =
fmap Hashing.Branch.hashBranch $
fmap (BranchHash . Hashing.Branch.hashBranch) $
Hashing.Branch.Raw
<$> doTerms tms
<*> doTypes tps
@ -72,9 +85,9 @@ dbBranchHash (S.Branch.Full.Branch tms tps patches children) =
doChildren =
Map.bitraverse s2hNameSegment \(_boId, chId) -> causalHashIdToHash chId
dbPatchHash :: S.Patch -> Transaction Hash
dbPatchHash :: S.Patch -> Transaction PatchHash
dbPatchHash S.Patch {S.termEdits, S.typeEdits} =
fmap Hashing.Patch.hashPatch $
fmap (PatchHash . Hashing.Patch.hashPatch) $
Hashing.Patch
<$> doTermEdits termEdits
<*> doTypeEdits typeEdits

23
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs
View File

@ -12,7 +12,6 @@ import Data.Semigroup
import qualified Data.Set as Set
import Data.Set.Lens (setOf)
import Data.String.Here.Uninterpolated (here)
import qualified U.Codebase.HashTags as H
import qualified U.Codebase.Sqlite.Branch.Format as S.BranchFormat
import qualified U.Codebase.Sqlite.Branch.Full as DBBranch
import qualified U.Codebase.Sqlite.DbId as DB
@ -230,7 +229,7 @@ rehashAndCanonicalizeNamespace causalHashId possiblyIncorrectNamespaceHashId obj
liftT $ replaceBranch objId remappedBranch
correctNamespaceHash <- liftT $ Helpers.dbBranchHash remappedBranch
liftT . debugLog $ "Correct namespace hash: " <> show correctNamespaceHash
correctNamespaceHashId <- liftT $ Q.saveBranchHash (H.BranchHash correctNamespaceHash)
correctNamespaceHashId <- liftT $ Q.saveBranchHash correctNamespaceHash
when (correctNamespaceHashId == possiblyIncorrectNamespaceHashId) $ do
-- If the existing hash for this namespace was already correct, we don't need to
@ -251,17 +250,17 @@ rehashAndCanonicalizeNamespace causalHashId possiblyIncorrectNamespaceHashId obj
-- that one.
Just canonicalObjectId
| canonicalObjectId /= objId -> do
-- Found an existing but different object with this hash, so the current object is a duplicate and
-- needs to be deleted.
liftT . debugLog $ "Mapping objID: " <> show objId <> " to canonical: " <> show canonicalObjectId
liftT . debugLog $ "Unilaterally deleting: " <> show objId
-- Remove possible foreign-key references before deleting the objects themselves
liftT $ Sqlite.execute deleteHashObjectsByObjectId (Sqlite.Only objId)
liftT $ Sqlite.execute deleteObjectById (Sqlite.Only objId)
pure canonicalObjectId
-- Found an existing but different object with this hash, so the current object is a duplicate and
-- needs to be deleted.
liftT . debugLog $ "Mapping objID: " <> show objId <> " to canonical: " <> show canonicalObjectId
liftT . debugLog $ "Unilaterally deleting: " <> show objId
-- Remove possible foreign-key references before deleting the objects themselves
liftT $ Sqlite.execute deleteHashObjectsByObjectId (Sqlite.Only objId)
liftT $ Sqlite.execute deleteObjectById (Sqlite.Only objId)
pure canonicalObjectId
| otherwise -> do
-- This should be impossible.
error $ "We proved that the new hash is different from the existing one, but somehow found the same object for each hash. Please report this as a bug." <> show (objId, canonicalObjectId)
-- This should be impossible.
error $ "We proved that the new hash is different from the existing one, but somehow found the same object for each hash. Please report this as a bug." <> show (objId, canonicalObjectId)
Nothing -> do
-- There's no existing canonical object, this object BECOMES the canonical one by
-- reassigning its primary hash.

11
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema4To5.hs Normal file
View File

@ -0,0 +1,11 @@
module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema4To5 (migrateSchema4To5) where
import qualified U.Codebase.Sqlite.Queries as Q
import qualified Unison.Sqlite as Sqlite
-- | The 4 to 5 migration adds initial support for out-of-order sync i.e. Unison Share
migrateSchema4To5 :: Sqlite.Transaction ()
migrateSchema4To5 = do
Q.expectSchemaVersion 4
Q.addTempEntityTables
Q.setSchemaVersion 5

145
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs
View File

@ -7,14 +7,18 @@
-- are unified with non-sqlite operations in the Codebase interface, like 'appendReflog'.
module Unison.Codebase.SqliteCodebase.Operations where
import Control.Lens (ifor)
import Data.Bifunctor (Bifunctor (bimap), second)
import Data.Bitraversable (bitraverse)
import Data.Either.Extra ()
import qualified Data.List as List
import qualified Data.List.NonEmpty as NEList
import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified U.Codebase.Branch as V2Branch
import qualified U.Codebase.Causal as V2Causal
import U.Codebase.HashTags (CausalHash (unCausalHash))
import qualified U.Codebase.Reference as C.Reference
import qualified U.Codebase.Referent as C.Referent
@ -23,10 +27,15 @@ import qualified U.Codebase.Sqlite.NamedRef as S
import qualified U.Codebase.Sqlite.ObjectType as OT
import qualified U.Codebase.Sqlite.Operations as Ops
import qualified U.Codebase.Sqlite.Queries as Q
import U.Codebase.Sqlite.V2.Decl (saveDeclComponent)
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
import U.Codebase.Sqlite.V2.Term (saveTermComponent)
import qualified U.Util.Cache as Cache
import qualified U.Util.Hash as H2
import qualified Unison.Builtin as Builtins
import Unison.Codebase.Branch (Branch (..))
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Branch.Names as V1Branch
import qualified Unison.Codebase.Causal.Type as Causal
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Path (Path)
@ -55,6 +64,7 @@ import qualified Unison.ShortHash as SH
import qualified Unison.ShortHash as ShortHash
import Unison.Sqlite (Transaction)
import qualified Unison.Sqlite as Sqlite
import qualified Unison.Sqlite.Transaction as Sqlite
import Unison.Symbol (Symbol)
import Unison.Term (Term)
import qualified Unison.Term as Term
@ -264,24 +274,17 @@ tryFlushTermBuffer termBuffer =
let loop h =
tryFlushBuffer
termBuffer
( \h2 component -> do
oId <-
Ops.saveTermComponent h2 $
fmap (bimap (Cv.term1to2 h) Cv.ttype1to2) component
addTermComponentTypeIndex oId (fmap snd component)
( \h2 component ->
void $
saveTermComponent
Nothing
h2
(fmap (bimap (Cv.term1to2 h) Cv.ttype1to2) component)
)
loop
h
in loop
addTermComponentTypeIndex :: ObjectId -> [Type Symbol Ann] -> Transaction ()
addTermComponentTypeIndex oId types = for_ (types `zip` [0 ..]) \(tp, i) -> do
let self = C.Referent.RefId (C.Reference.Id oId i)
typeForIndexing = Hashing.typeToReference tp
typeMentionsForIndexing = Hashing.typeToReferenceMentions tp
Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing)
Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing)
addDeclComponentTypeIndex :: ObjectId -> [[Type Symbol Ann]] -> Transaction ()
addDeclComponentTypeIndex oId ctorss =
for_ (ctorss `zip` [0 ..]) \(ctors, i) ->
@ -326,10 +329,12 @@ tryFlushDeclBuffer termBuffer declBuffer =
let loop h =
tryFlushBuffer
declBuffer
( \h2 component -> do
oId <- Ops.saveDeclComponent h2 $ fmap (Cv.decl1to2 h) component
addDeclComponentTypeIndex oId $
fmap (map snd . Decl.constructors . Decl.asDataDecl) component
( \h2 component ->
void $
saveDeclComponent
Nothing
h2
(fmap (Cv.decl1to2 h) component)
)
(\h -> tryFlushTermBuffer termBuffer h >> loop h)
h
@ -359,12 +364,18 @@ getRootBranch doGetDeclType rootBranchCache =
where
forceReload :: Transaction (Branch Transaction)
forceReload = do
causal2 <- Ops.expectRootCausal
branch1 <- Cv.causalbranch2to1 doGetDeclType causal2
branch1 <- uncachedLoadRootBranch doGetDeclType
ver <- Sqlite.getDataVersion
Sqlite.unsafeIO (atomically (writeTVar rootBranchCache (Just (ver, branch1))))
pure branch1
uncachedLoadRootBranch ::
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
Transaction (Branch Transaction)
uncachedLoadRootBranch getDeclType = do
causal2 <- Ops.expectRootCausal
Cv.causalbranch2to1 getDeclType causal2
getRootBranchExists :: Transaction Bool
getRootBranchExists =
isJust <$> Ops.loadRootCausalHash
@ -373,7 +384,7 @@ putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Transaction)) -> Branch
putRootBranch rootBranchCache branch1 = do
-- todo: check to see if root namespace hash has been externally modified
-- and do something (merge?) it if necessary. But for now, we just overwrite it.
void (Ops.saveRootBranch (Cv.causalbranch1to2 branch1))
void (Ops.saveRootBranch v2HashHandle (Cv.causalbranch1to2 branch1))
Sqlite.unsafeIO (atomically $ modifyTVar' rootBranchCache (fmap . second $ const branch1))
-- if this blows up on cromulent hashes, then switch from `hashToHashId`
@ -392,7 +403,7 @@ getBranchForHash doGetDeclType h = do
putBranch :: Branch Transaction -> Transaction ()
putBranch =
void . Ops.saveBranch . Cv.causalbranch1to2
void . Ops.saveBranch v2HashHandle . Cv.causalbranch1to2
isCausalHash :: Branch.CausalHash -> Transaction Bool
isCausalHash (Causal.CausalHash h) =
@ -409,7 +420,7 @@ getPatch h =
putPatch :: Branch.EditHash -> Patch -> Transaction ()
putPatch h p =
void $ Ops.savePatch (Cv.patchHash1to2 h) (Cv.patch1to2 p)
void $ Ops.savePatch v2HashHandle (Cv.patchHash1to2 h) (Cv.patch1to2 p)
patchExists :: Branch.EditHash -> Transaction Bool
patchExists h = fmap isJust $ Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h)
@ -584,21 +595,77 @@ namesAtPath path = do
Nothing -> (mempty, [(n, ref)])
Just stripped -> ([(Name.makeRelative stripped, ref)], mempty)
saveRootNamesIndex :: Names -> Transaction ()
saveRootNamesIndex Names {Names.terms, Names.types} = do
let termNames :: [(S.NamedRef (C.Referent.Referent, Maybe C.Referent.ConstructorType))]
termNames = Rel.toList terms <&> \(name, ref) -> S.NamedRef {reversedSegments = nameSegments name, ref = splitReferent ref}
let typeNames :: [(S.NamedRef C.Reference.Reference)]
typeNames =
Rel.toList types
<&> ( \(name, ref) ->
S.NamedRef {reversedSegments = nameSegments name, ref = Cv.reference1to2 ref}
)
Ops.rebuildNameIndex termNames typeNames
-- | Update the root namespace names index which is used by the share server for serving api
-- requests.
--
-- This version should be used if you've already got the root Branch pre-loaded, otherwise
-- it's faster to use 'updateNameLookupIndexFromV2Branch'
updateNameLookupIndexFromV1Branch :: Branch Transaction -> Sqlite.Transaction ()
updateNameLookupIndexFromV1Branch root = do
saveRootNamesIndexV1 (V1Branch.toNames . Branch.head $ root)
where
nameSegments :: Name -> NonEmpty Text
nameSegments = coerce @(NonEmpty NameSegment) @(NonEmpty Text) . Name.reverseSegments
splitReferent :: Referent.Referent -> (C.Referent.Referent, Maybe C.Referent.ConstructorType)
splitReferent referent = case referent of
Referent.Ref {} -> (Cv.referent1to2 referent, Nothing)
Referent.Con _ref ct -> (Cv.referent1to2 referent, Just (Cv.constructorType1to2 ct))
saveRootNamesIndexV1 :: Names -> Transaction ()
saveRootNamesIndexV1 Names {Names.terms, Names.types} = do
let termNames :: [(S.NamedRef (C.Referent.Referent, Maybe C.Referent.ConstructorType))]
termNames = Rel.toList terms <&> \(name, ref) -> S.NamedRef {reversedSegments = nameSegments name, ref = splitReferent ref}
let typeNames :: [(S.NamedRef C.Reference.Reference)]
typeNames =
Rel.toList types
<&> ( \(name, ref) ->
S.NamedRef {reversedSegments = nameSegments name, ref = Cv.reference1to2 ref}
)
Ops.rebuildNameIndex termNames typeNames
where
nameSegments :: Name -> NonEmpty Text
nameSegments = coerce @(NonEmpty NameSegment) @(NonEmpty Text) . Name.reverseSegments
splitReferent :: Referent.Referent -> (C.Referent.Referent, Maybe C.Referent.ConstructorType)
splitReferent referent = case referent of
Referent.Ref {} -> (Cv.referent1to2 referent, Nothing)
Referent.Con _ref ct -> (Cv.referent1to2 referent, Just (Cv.constructorType1to2 ct))
-- | Update the root namespace names index which is used by the share server for serving api
-- requests.
--
-- This version should be used if you don't already have the root Branch pre-loaded,
-- If you do, use 'updateNameLookupIndexFromV2Branch' instead.
updateNameLookupIndexFromV2Root :: (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> Sqlite.Transaction ()
updateNameLookupIndexFromV2Root getDeclType = do
rootHash <- Ops.expectRootCausalHash
causalBranch <- Ops.expectCausalBranchByCausalHash rootHash
(termNameMap, typeNameMap) <- nameMapsFromV2Branch [] causalBranch
let expandedTermNames = Map.toList termNameMap >>= (\(name, refs) -> (name,) <$> Set.toList refs)
termNameList <- do
for expandedTermNames \(name, ref) -> do
refWithCT <- addReferentCT ref
pure S.NamedRef {S.reversedSegments = coerce name, S.ref = refWithCT}
let typeNameList = do
(name, refs) <- Map.toList typeNameMap
ref <- Set.toList refs
pure $ S.NamedRef {S.reversedSegments = coerce name, S.ref = ref}
Ops.rebuildNameIndex termNameList typeNameList
where
addReferentCT :: C.Referent.Referent -> Transaction (C.Referent.Referent, Maybe C.Referent.ConstructorType)
addReferentCT referent = case referent of
C.Referent.Ref {} -> pure (referent, Nothing)
C.Referent.Con ref _conId -> do
ct <- getDeclType ref
pure (referent, Just $ Cv.constructorType1to2 ct)
-- Traverse a v2 branch
-- Collects two maps, one with all term names and one with all type names.
-- Note that unlike the `Name` type in `unison-core1`, this list of name segments is
-- in reverse order, e.g. `["map", "List", "base"]`
nameMapsFromV2Branch :: Monad m => [V2Branch.NameSegment] -> V2Branch.CausalBranch m -> m (Map (NonEmpty V2Branch.NameSegment) (Set C.Referent.Referent), Map (NonEmpty V2Branch.NameSegment) (Set C.Reference.Reference))
nameMapsFromV2Branch reversedNamePrefix cb = do
b <- V2Causal.value cb
let (shallowTermNames, shallowTypeNames) = (Map.keysSet <$> V2Branch.terms b, Map.keysSet <$> V2Branch.types b)
(prefixedChildTerms, prefixedChildTypes) <-
fold <$> (ifor (V2Branch.children b) $ \nameSegment cb -> (nameMapsFromV2Branch (nameSegment : reversedNamePrefix) cb))
pure (Map.mapKeys (NEList.:| reversedNamePrefix) shallowTermNames <> prefixedChildTerms, Map.mapKeys (NEList.:| reversedNamePrefix) shallowTypeNames <> prefixedChildTypes)
mkGetDeclType :: MonadIO m => m (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType)
mkGetDeclType = do
declTypeCache <- Cache.semispaceCache 2048
pure $ \ref -> do
conn <- Sqlite.unsafeGetConnection
Sqlite.unsafeIO $ Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (getDeclType ref) conn) ref

8
parser-typechecker/src/Unison/Codebase/Type.hs
View File

@ -17,7 +17,7 @@ import qualified U.Codebase.Reference as V2
import Unison.Codebase.Branch (Branch)
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Editor.Git as Git
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo)
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo)
import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError)
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
import Unison.Codebase.Patch (Patch)
@ -111,9 +111,9 @@ data Codebase m v a = Codebase
syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
-- | Copy a branch and all of its dependencies from this codebase into the given codebase.
syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
viewRemoteBranch' :: forall r. ReadRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r),
viewRemoteBranch' :: forall r. ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r),
-- | Push the given branch to the given repo, and optionally set it as the root branch.
pushGitBranch :: forall e. WriteRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))),
pushGitBranch :: forall e. WriteGitRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))),
-- | @watches k@ returns all of the references @r@ that were previously put by a @putWatch k r t@. @t@ can be
-- retrieved by @getWatch k r@.
watches :: WK.WatchKind -> m [Reference.Id],
@ -204,7 +204,7 @@ data GitError
instance Exception GitError
gitErrorFromOpenCodebaseError :: CodebasePath -> ReadRepo -> OpenCodebaseError -> GitSqliteCodebaseError
gitErrorFromOpenCodebaseError :: CodebasePath -> ReadGitRepo -> OpenCodebaseError -> GitSqliteCodebaseError
gitErrorFromOpenCodebaseError path repo = \case
OpenCodebaseDoesntExist -> NoDatabaseFile repo path
OpenCodebaseUnknownSchemaVersion v ->

5
parser-typechecker/src/Unison/FileParser.hs
View File

@ -184,11 +184,6 @@ checkForDuplicateTermsAndConstructors uf = do
-- Or it is a binding like:
-- foo : Nat -> Nat
-- foo x = x + 42
-- Or it is a namespace like:
-- namespace Woot where
-- x = 42
-- y = 17
-- which parses as [(Woot.x, 42), (Woot.y, 17)]
data Stanza v term
= WatchBinding UF.WatchKind Ann ((Ann, v), term)

9
parser-typechecker/src/Unison/Hashing/V2/Convert.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ViewPatterns #-}
-- | Description: Converts V1 types to the V2 hashing types
module Unison.Hashing.V2.Convert
( ResolutionResult,
hashBranch0,
@ -130,8 +131,8 @@ m2hTerm = ABT.transformM \case
Memory.Term.If c t f -> pure (Hashing.Term.If c t f)
Memory.Term.Or p q -> pure (Hashing.Term.Or p q)
Memory.Term.Lam a -> pure (Hashing.Term.Lam a)
Memory.Term.LetRec isTop bs body -> pure (Hashing.Term.LetRec isTop bs body)
Memory.Term.Let isTop b body -> pure (Hashing.Term.Let isTop b body)
Memory.Term.LetRec _isTop bs body -> pure (Hashing.Term.LetRec bs body)
Memory.Term.Let _isTop b body -> pure (Hashing.Term.Let b body)
Memory.Term.Match scr cases -> pure (Hashing.Term.Match scr (fmap m2hMatchCase cases))
Memory.Term.TermLink r -> Hashing.Term.TermLink <$> m2hReferent r
Memory.Term.TypeLink r -> pure (Hashing.Term.TypeLink (m2hReference r))
@ -191,8 +192,8 @@ h2mTerm getCT = ABT.transform \case
Hashing.Term.And p q -> Memory.Term.And p q
Hashing.Term.Or p q -> Memory.Term.Or p q
Hashing.Term.Lam a -> Memory.Term.Lam a
Hashing.Term.LetRec isTop bs body -> Memory.Term.LetRec isTop bs body
Hashing.Term.Let isTop b body -> Memory.Term.Let isTop b body
Hashing.Term.LetRec bs body -> Memory.Term.LetRec False bs body
Hashing.Term.Let b body -> Memory.Term.Let False b body
Hashing.Term.Match scr cases -> Memory.Term.Match scr (h2mMatchCase <$> cases)
Hashing.Term.TermLink r -> Memory.Term.TermLink (h2mReferent getCT r)
Hashing.Term.TypeLink r -> Memory.Term.TypeLink (h2mReference r)

4
parser-typechecker/src/Unison/PrintError.hs
View File

@ -1410,11 +1410,9 @@ prettyParseError s = \case
Code
" + 1",
"\n - An `ability` declaration, like "
<> style Code "ability Foo where ...",
<> style Code "unique ability Foo where ...",
"\n - A `type` declaration, like "
<> style Code "structural type Optional a = None | Some a",
"\n - A `namespace` declaration, like "
<> style Code "namespace Seq where ...",
"\n"
]
where

1
parser-typechecker/src/Unison/Runtime/Builtin.hs
View File

@ -2311,6 +2311,7 @@ declareForeigns = do
declareHashAlgorithm "Sha3_256" Hash.SHA3_256
declareHashAlgorithm "Sha2_512" Hash.SHA512
declareHashAlgorithm "Sha2_256" Hash.SHA256
declareHashAlgorithm "Sha1" Hash.SHA1
declareHashAlgorithm "Blake2b_512" Hash.Blake2b_512
declareHashAlgorithm "Blake2b_256" Hash.Blake2b_256
declareHashAlgorithm "Blake2s_256" Hash.Blake2s_256

146
parser-typechecker/src/Unison/Share/Types.hs Normal file
View File

@ -0,0 +1,146 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards #-}
-- | Types related to Share and Codeservers.
module Unison.Share.Types
( CodeserverURI (..),
CodeserverId (..),
Scheme (..),
codeserverFromURI,
codeserverIdFromURI,
codeserverToURI,
codeserverIdFromCodeserverURI,
codeserverBaseURL,
)
where
import Data.Aeson
import qualified Data.List as List
import qualified Data.List.Extra as List
import Data.Text
import qualified Data.Text as Text
import Network.URI
import qualified Servant.Client as Servant
import Unison.Prelude
data Scheme = Http | Https
deriving (Eq, Ord, Show)
-- | This type is expanded out into all of its fields because we require certain pieces
-- which are optional in a URI, and also to make it more typesafe to eventually convert into a
-- BaseURL for servant clients.
data CodeserverURI = CodeserverURI
{ codeserverScheme :: Scheme,
codeserverUserInfo :: String,
codeserverRegName :: String,
-- A custom port, if one was specified.
codeserverPort :: Maybe Int,
codeserverPath :: [String]
}
deriving stock (Eq, Ord)
instance Show CodeserverURI where
show = show . codeserverToURI
codeserverToURI :: CodeserverURI -> URI
codeserverToURI cs@(CodeserverURI {..}) =
let scheme = case codeserverScheme of
Http -> "http:"
Https -> "https:"
authority = codeserverAuthority cs
in URI
{ uriScheme = scheme,
uriAuthority = Just authority,
uriPath = case codeserverPath of
[] -> ""
segs -> "/" <> List.intercalate "/" segs,
uriQuery = "",
uriFragment = ""
}
codeserverAuthority :: CodeserverURI -> URIAuth
codeserverAuthority (CodeserverURI {..}) =
URIAuth
{ uriUserInfo = codeserverUserInfo,
uriPort = case codeserverPort of
Nothing -> ""
Just p -> ":" <> show p,
uriRegName = codeserverRegName
}
-- |
-- >>> import Data.Maybe (fromJust)
-- >>> codeserverFromURI . fromJust $ parseURI "http://localhost:8080"
-- Just http://localhost:8080
-- >>> codeserverFromURI . fromJust $ parseURI "http://localhost:80"
-- Just http://localhost:80
-- >>> codeserverFromURI . fromJust $ parseURI "https://share.unison-lang.org/api"
-- Just https://share.unison-lang.org/api
-- >>> codeserverFromURI . fromJust $ parseURI "http://share.unison-lang.org/api"
-- Just http://share.unison-lang.org/api
codeserverFromURI :: URI -> Maybe CodeserverURI
codeserverFromURI URI {..} = do
URIAuth {uriUserInfo, uriRegName, uriPort} <- uriAuthority
scheme <- case uriScheme of
"http:" -> Just Http
"https:" -> Just Https
_ -> Nothing
let port = case uriPort of
(':' : p) -> readMaybe p
_ -> Nothing
pure $
CodeserverURI
{ codeserverScheme = scheme,
codeserverUserInfo = uriUserInfo,
codeserverRegName = uriRegName,
codeserverPort = port,
codeserverPath =
let unprefixed =
case uriPath of
('/' : path) -> path
path -> path
in case List.splitOn "/" unprefixed of
[""] -> []
p -> p
}
-- | This is distinct from the codeserver URI in that we store credentials by a normalized ID, since it's
-- much easier to look up that way than from an arbitrary path.
-- We may wish to use explicitly named configurations in the future.
-- This currently uses a stringified uriAuthority.
newtype CodeserverId = CodeserverId {codeserverId :: Text}
deriving newtype (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
-- | Gets the part of the CodeserverURI that we use for identifying that codeserver in
-- credentials files.
--
-- >>> import Data.Maybe (fromJust)
-- >>> import Network.URI (parseURI)
-- >>> codeserverIdFromURI (CodeserverURI . fromJust $ parseURI "http://localhost:5424/api")
-- >>> codeserverIdFromURI (CodeserverURI . fromJust $ parseURI "https://share.unison-lang.org/api")
-- Right "localhost"
-- Right "share.unison-lang.org"
codeserverIdFromURI :: URI -> Either Text CodeserverId
codeserverIdFromURI uri =
case uriAuthority uri of
Nothing -> Left $ "No URI Authority for URI " <> tShow uri
Just ua -> pure $ codeserverIdFromURIAuth ua
-- | Builds a CodeserverId from a URIAuth
codeserverIdFromURIAuth :: URIAuth -> CodeserverId
codeserverIdFromURIAuth ua =
(CodeserverId (Text.pack $ uriUserInfo ua <> uriRegName ua <> uriPort ua))
-- | Gets the CodeserverId for a given CodeserverURI
codeserverIdFromCodeserverURI :: CodeserverURI -> CodeserverId
codeserverIdFromCodeserverURI =
codeserverIdFromURIAuth . codeserverAuthority
-- | Builds a servant-compatible BaseUrl for a given CodeserverURI.
codeserverBaseURL :: CodeserverURI -> Servant.BaseUrl
codeserverBaseURL (CodeserverURI {..}) =
let (scheme, defaultPort) = case codeserverScheme of
Https -> (Servant.Https, 443)
Http -> (Servant.Http, 80)
host = codeserverUserInfo <> codeserverRegName
in Servant.BaseUrl scheme host (fromMaybe defaultPort codeserverPort) (List.intercalate "/" codeserverPath)

116
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.7.
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
@ -72,6 +72,7 @@ library
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema4To5
Unison.Codebase.SqliteCodebase.Operations
Unison.Codebase.SqliteCodebase.Paths
Unison.Codebase.SqliteCodebase.SyncEphemeral
@ -86,23 +87,7 @@ library
Unison.DeclPrinter
Unison.FileParser
Unison.FileParsers
Unison.Hashing.V2.ABT
Unison.Hashing.V2.Branch
Unison.Hashing.V2.Causal
Unison.Hashing.V2.Convert
Unison.Hashing.V2.DataDeclaration
Unison.Hashing.V2.Hashable
Unison.Hashing.V2.Kind
Unison.Hashing.V2.Patch
Unison.Hashing.V2.Pattern
Unison.Hashing.V2.Reference
Unison.Hashing.V2.Reference.Util
Unison.Hashing.V2.Referent
Unison.Hashing.V2.Term
Unison.Hashing.V2.TermEdit
Unison.Hashing.V2.Tokenizable
Unison.Hashing.V2.Type
Unison.Hashing.V2.TypeEdit
Unison.Lexer
Unison.NamePrinter
Unison.Parser
@ -134,6 +119,7 @@ library
Unison.Runtime.SparseVector
Unison.Runtime.Stack
Unison.Runtime.Vector
Unison.Share.Types
Unison.TermParser
Unison.TermPrinter
Unison.Typechecker
@ -178,6 +164,7 @@ library
DerivingStrategies
DerivingVia
DoAndIfThenElse
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
@ -244,6 +231,7 @@ library
, natural-transformation
, network
, network-simple
, network-uri
, nonempty-containers
, open-browser
, openapi3
@ -261,6 +249,7 @@ library
, safe-exceptions
, semialign
, servant
, servant-client
, servant-docs
, servant-openapi3
, servant-server
@ -279,13 +268,16 @@ library
, unicode-show
, unison-codebase
, unison-codebase-sqlite
, unison-codebase-sqlite-hashing-v2
, unison-codebase-sync
, unison-core
, unison-core1
, unison-hashing-v2
, unison-prelude
, unison-pretty-printer
, unison-sqlite
, unison-util
, unison-util-base32hex
, unison-util-relation
, unison-util-serialization
, unliftio
@ -350,6 +342,7 @@ test-suite parser-typechecker-tests
DerivingStrategies
DerivingVia
DoAndIfThenElse
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
@ -365,37 +358,122 @@ test-suite parser-typechecker-tests
ViewPatterns
ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0
build-depends:
async
ListLike
, NanoID
, aeson
, ansi-terminal
, async
, base
, base16 >=0.2.1.0
, base64-bytestring
, basement
, binary
, bytes
, bytestring
, bytestring-to-vector
, cereal
, clock
, code-page
, containers
, configurator
, containers >=0.6.3
, cryptonite
, data-default
, data-memocombinators
, deepseq
, directory
, easytest
, either
, errors
, exceptions
, extra
, filemanip
, filepath
, fingertree
, fsnotify
, fuzzyfind
, generic-lens
, generic-monoid
, hashable
, hashtables
, haskeline
, here
, http-client
, http-media
, http-types
, lens
, lucid
, megaparsec
, memory
, mmorph
, monad-validate
, mtl
, mutable-containers
, mwc-random
, natural-transformation
, network
, network-simple
, network-uri
, nonempty-containers
, open-browser
, openapi3
, optparse-applicative >=0.16.1.0
, pem
, prelude-extras
, pretty-simple
, primitive
, process
, random >=1.2.0
, raw-strings-qq
, regex-base
, regex-tdfa
, safe
, safe-exceptions
, semialign
, servant
, servant-client
, servant-docs
, servant-openapi3
, servant-server
, shellmet
, split
, stm
, strings
, tagged
, temporary
, terminal-size
, text
, text-short
, these
, time
, tls
, transformers
, unicode-show
, unison-codebase
, unison-codebase-sqlite
, unison-codebase-sqlite-hashing-v2
, unison-codebase-sync
, unison-core
, unison-core1
, unison-hashing-v2
, unison-parser-typechecker
, unison-prelude
, unison-pretty-printer
, unison-sqlite
, unison-util
, unison-util-base32hex
, unison-util-relation
, unison-util-serialization
, unliftio
, uri-encode
, utf8-string
, vector
, wai
, warp
, x509
, x509-store
, x509-system
, yaml
, zlib
if flag(optimized)
ghc-options: -funbox-strict-fields -O2
default-language: Haskell2010

9
stack.yaml
View File

@ -14,9 +14,11 @@ packages:
- parser-typechecker
- unison-core
- unison-cli
- unison-hashing-v2
- unison-share-api
- codebase2/codebase
- codebase2/codebase-sqlite
- codebase2/codebase-sqlite-hashing-v2
- codebase2/codebase-sync
- codebase2/core
- codebase2/util
@ -24,6 +26,9 @@ packages:
- codebase2/util-term
- lib/unison-prelude
- lib/unison-sqlite
- lib/unison-util-base32hex
- lib/unison-util-base32hex-orphans-aeson
- lib/unison-util-base32hex-orphans-sqlite
- lib/unison-util-relation
- lib/unison-pretty-printer
@ -33,8 +38,6 @@ resolver: lts-18.28
extra-deps:
- github: unisonweb/configurator
commit: e47e9e9fe1f576f8c835183b9def52d73c01327a
- github: unisonweb/haskeline
commit: 2944b11d19ee034c48276edc991736105c9d6143
- github: unisonweb/shellmet
commit: 2fd348592c8f51bb4c0ca6ba4bc8e38668913746
- guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078
@ -44,6 +47,8 @@ extra-deps:
- fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814
- monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505
- NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524
# 2.3.27 bundles sqlite >=3.35.0, needed for 'delete returning'
- direct-sqlite-2.3.27
# not in lts-18.13
- recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423
- lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484

18
stack.yaml.lock
View File

@ -15,17 +15,6 @@ packages:
sha256: 90547cd983fd15ebdc803e057d3ef8735fe93a75e29a00f8a74eadc13ee0f6e9
original:
url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz
- completed:
size: 75098
url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz
name: haskeline
version: 0.7.5.0
sha256: 6d44207a4e94a16bc99d13dccbbb79bf676190c0476436b03235eeeaf6c72f9d
pantry-tree:
size: 3717
sha256: 878c7fb5801ec7418761a49b529ca3fdab274f22707c7d2759f2b3a2df06c3ea
original:
url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz
- completed:
size: 10460
url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz
@ -86,6 +75,13 @@ packages:
sha256: d33d603a2f0d1a220ff0d5e7edb6273def89120e6bb958c2d836cae89e788334
original:
hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524
- completed:
hackage: direct-sqlite-2.3.27@sha256:94207d3018da3bda84bc6ce00d2c0236ced7edb37afbd726ed2a0bfa236e149b,3771
pantry-tree:
size: 770
sha256: c7f5afe70db567e2cf9f3119b49f4b402705e6bd08ed8ba98747a64a8a0bef41
original:
hackage: direct-sqlite-2.3.27
- completed:
hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423
pantry-tree:

57
unison-cli/package.yaml
View File

@ -10,56 +10,65 @@ flags:
ghc-options: -Wall
dependencies:
- semialign
- these
- ListLike
- aeson
- aeson-pretty
- async
- base
- bytes
- bytestring
- concurrent-output
- configurator
- containers >= 0.6.3
- nonempty-containers
- cryptonite
- directory
- either
- errors
- exceptions
- extra
- filepath
- generic-lens
- haskeline
- http-client >= 0.7.6
- http-client-tls
- http-types
- jwt
- lens
- megaparsec >= 5.0.0 && < 7.0.0
- lock-file
- megaparsec
- memory
- mtl
- transformers
- network-uri
- nonempty-containers
- open-browser
- pretty-simple
- random >= 1.2.0
- regex-tdfa
- semialign
- servant
- servant-client
- stm
- text
- these
- time
- transformers
- unison-codebase
- unison-codebase-sqlite
- unison-codebase-sqlite-hashing-v2
- unison-sqlite
- unison-core1
- unison-parser-typechecker
- unison-prelude
- unison-util
- unison-util-relation
- unison-pretty-printer
- unliftio
- network-uri
- aeson
- aeson-pretty
- http-client >= 0.7.6
- http-client-tls
- http-types
- warp
- wai
- memory
- time
- lock-file
- jwt
- either
- unison-share-api
- servant-client
- servant
- unison-sqlite
- unison-util
- unison-util-base32hex
- unison-util-relation
- unliftio
- vector
- wai
- warp
library:
source-dirs: src
@ -144,12 +153,14 @@ default-extensions:
- DeriveGeneric
- DerivingStrategies
- DoAndIfThenElse
- DuplicateRecordFields
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- OverloadedLabels
- OverloadedStrings
- PatternSynonyms
- RankNTypes

16
unison-cli/src/Unison/Auth/CredentialManager.hs
View File

@ -1,10 +1,10 @@
{-# LANGUAGE DeriveAnyClass #-}
module Unison.Auth.CredentialManager
( saveTokens,
( saveCredentials,
CredentialManager,
newCredentialManager,
getTokens,
getCredentials,
)
where
@ -22,9 +22,9 @@ import qualified UnliftIO
newtype CredentialManager = CredentialManager (UnliftIO.MVar Credentials)
-- | Saves credentials to the active profile.
saveTokens :: UnliftIO.MonadUnliftIO m => CredentialManager -> CodeserverId -> Tokens -> m ()
saveTokens credManager aud tokens = do
void . modifyCredentials credManager $ setActiveTokens aud tokens
saveCredentials :: UnliftIO.MonadUnliftIO m => CredentialManager -> CodeserverId -> CodeserverCredentials -> m ()
saveCredentials credManager aud creds = do
void . modifyCredentials credManager $ setCodeserverCredentials aud creds
-- | Atomically update the credential storage file, and update the in-memory cache.
modifyCredentials :: UnliftIO.MonadUnliftIO m => CredentialManager -> (Credentials -> Credentials) -> m Credentials
@ -33,10 +33,10 @@ modifyCredentials (CredentialManager credsVar) f = do
newCreds <- atomicallyModifyCredentialsFile f
pure (newCreds, newCreds)
getTokens :: MonadIO m => CredentialManager -> CodeserverId -> m (Either CredentialFailure Tokens)
getTokens (CredentialManager credsVar) aud = do
getCredentials :: MonadIO m => CredentialManager -> CodeserverId -> m (Either CredentialFailure CodeserverCredentials)
getCredentials (CredentialManager credsVar) aud = do
creds <- UnliftIO.readMVar credsVar
pure $ getActiveTokens aud creds
pure $ getCodeserverCredentials aud creds
newCredentialManager :: MonadIO m => m CredentialManager
newCredentialManager = do

17
unison-cli/src/Unison/Auth/Discovery.hs
View File

@ -3,22 +3,23 @@ module Unison.Auth.Discovery where
import qualified Data.Aeson as Aeson
import qualified Data.Text as Text
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import Network.URI
import Unison.Auth.Types
import Unison.Prelude
import Unison.Share.Types (CodeserverURI (..), codeserverToURI)
import qualified UnliftIO
discoveryURI :: CodeserverURI -> URI
discoveryURI cs =
discoveryURIForCodeserver :: CodeserverURI -> URI
discoveryURIForCodeserver cs =
let uri = codeserverToURI cs
in uri {uriPath = uriPath uri <> "/.well-known/openid-configuration"}
discoveryForCodeserver :: MonadIO m => HTTP.Manager -> CodeserverURI -> m (Either CredentialFailure DiscoveryDoc)
discoveryForCodeserver httpClient host = liftIO . UnliftIO.try @_ @CredentialFailure $ do
let uri = discoveryURI host
req <- HTTP.requestFromURI uri
resp <- HTTP.httpLbs req httpClient
fetchDiscoveryDoc :: MonadIO m => URI -> m (Either CredentialFailure DiscoveryDoc)
fetchDiscoveryDoc discoveryURI = liftIO . UnliftIO.try @_ @CredentialFailure $ do
unauthenticatedHttpClient <- HTTP.getGlobalManager
req <- HTTP.requestFromURI discoveryURI
resp <- HTTP.httpLbs req unauthenticatedHttpClient
case Aeson.eitherDecode (HTTP.responseBody $ resp) of
Left err -> UnliftIO.throwIO $ InvalidDiscoveryDocument uri (Text.pack err)
Left err -> UnliftIO.throwIO $ InvalidDiscoveryDocument discoveryURI (Text.pack err)
Right doc -> pure doc

47
unison-cli/src/Unison/Auth/HTTPClient.hs
View File

@ -1,41 +1,52 @@
module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient (..)) where
module Unison.Auth.HTTPClient (newAuthenticatedHTTPClient, AuthenticatedHttpClient (..)) where
import qualified Data.Text.Encoding as Text
import Network.HTTP.Client (Request)
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import Unison.Auth.CredentialManager (CredentialManager)
import Unison.Auth.Tokens (TokenProvider, newTokenProvider)
import Unison.Codebase.Editor.Command (UCMVersion)
import Unison.Auth.Tokens (TokenProvider)
import Unison.Codebase.Editor.Output (Output)
import qualified Unison.Codebase.Editor.Output as Output
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Prelude
import Unison.Share.Types (codeserverIdFromURI)
import qualified Unison.Util.HTTP as HTTP
-- | Newtype to delineate HTTP Managers with access-token logic.
newtype AuthorizedHttpClient = AuthorizedHttpClient HTTP.Manager
newtype AuthenticatedHttpClient = AuthenticatedHttpClient 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
newAuthorizedHTTPClient credsMan ucmVersion = liftIO $ do
let tokenProvider = newTokenProvider credsMan
newAuthenticatedHTTPClient :: MonadIO m => (Output v -> IO ()) -> TokenProvider -> UCMVersion -> m AuthenticatedHttpClient
newAuthenticatedHTTPClient responder tokenProvider ucmVersion = liftIO $ do
let managerSettings =
HTTP.tlsManagerSettings
& HTTP.addRequestMiddleware (authMiddleware tokenProvider)
& HTTP.addRequestMiddleware (authMiddleware responder tokenProvider)
& HTTP.setUserAgent (HTTP.ucmUserAgent ucmVersion)
HTTP.newTlsManagerWith managerSettings
AuthenticatedHttpClient <$> HTTP.newTlsManagerWith managerSettings
-- | Adds Bearer tokens to requests according to their host.
-- If a CredentialFailure occurs (failure to refresh a token), auth is simply omitted,
-- and the request is likely to trigger a 401 response which the caller can detect and initiate a re-auth.
--
-- If a host isn't associated with any credentials auth is omitted.
authMiddleware :: TokenProvider -> (Request -> IO Request)
authMiddleware tokenProvider req = do
case (codeserverIdFromURI $ (HTTP.getUri req)) of
Left _ -> pure req
Right codeserverHost -> do
result <- tokenProvider codeserverHost
case result of
Right token -> pure $ HTTP.applyBearerAuth (Text.encodeUtf8 token) req
authMiddleware :: (Output v -> IO ()) -> TokenProvider -> (Request -> IO Request)
authMiddleware responder tokenProvider req = do
-- The http manager "may run this function multiple times" when preparing a request.
-- We may wish to look into a better way to attach auth to our requests in middleware, but
-- this is a simple fix that works for now.
-- https://github.com/snoyberg/http-client/issues/350
case Prelude.lookup ("Authorization") (HTTP.requestHeaders req) of
Just _ -> pure req
Nothing -> do
case codeserverIdFromURI $ (HTTP.getUri req) of
-- If we can't identify an appropriate codeserver we pass it through without any auth.
Left _ -> pure req
Right codeserverHost -> do
tokenProvider codeserverHost >>= \case
Right token -> do
let newReq = HTTP.applyBearerAuth (Text.encodeUtf8 token) req
pure newReq
Left err -> do
responder (Output.CredentialFailureMsg err)
pure req

39
unison-cli/src/Unison/Auth/OAuth.hs
View File

@ -1,6 +1,9 @@
{-# LANGUAGE RecordWildCards #-}
module Unison.Auth.OAuth (authenticateCodeserver) where
module Unison.Auth.OAuth
( authenticateCodeserver,
)
where
import qualified Crypto.Hash as Crypto
import Crypto.Random (getRandomBytes)
@ -17,8 +20,8 @@ import Network.URI
import Network.Wai
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import Unison.Auth.CredentialManager (CredentialManager, saveTokens)
import Unison.Auth.Discovery (discoveryForCodeserver)
import Unison.Auth.CredentialManager (CredentialManager, saveCredentials)
import Unison.Auth.Discovery (discoveryURIForCodeserver, fetchDiscoveryDoc)
import Unison.Auth.Types
import Unison.Codebase.Editor.HandleInput.LoopState (MonadCommand, respond)
import qualified Unison.Codebase.Editor.Output as Output
@ -34,23 +37,27 @@ ucmOAuthClientID = "ucm"
-- | A server in the format expected for a Wai Application
-- This is a temporary server which is spun up only until we get a code back from the
-- auth server.
authTransferServer :: (Code -> IO Response) -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
authTransferServer :: (Code -> Maybe URI -> IO Response) -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
authTransferServer callback req respond =
case (requestMethod req, pathInfo req, getCodeQuery req) of
("GET", ["redirect"], Just code) -> do
callback code >>= respond
case (requestMethod req, pathInfo req, getQueryParams req) of
("GET", ["redirect"], (Just code, maybeNextURI)) -> do
callback code maybeNextURI >>= respond
_ -> respond (responseLBS status404 [] "Not Found")
where
getCodeQuery req = do
code <- join $ Prelude.lookup "code" (queryString req)
pure $ Text.decodeUtf8 code
getQueryParams req = do
let code = join $ Prelude.lookup "code" (queryString req)
nextURI = do
nextBS <- join $ Prelude.lookup "next" (queryString req)
parseURI (BSC.unpack nextBS)
in (Text.decodeUtf8 <$> code, nextURI)
-- | Direct the user through an authentication flow with the given server and store the
-- credentials in the provided credential manager.
authenticateCodeserver :: forall m n i v. (UnliftIO.MonadUnliftIO m, MonadCommand m n i v) => CredentialManager -> CodeserverURI -> m (Either CredentialFailure ())
authenticateCodeserver credsManager codeserverURI = UnliftIO.try @_ @CredentialFailure $ do
httpClient <- liftIO HTTP.getGlobalManager
doc@(DiscoveryDoc {authorizationEndpoint, tokenEndpoint}) <- throwCredFailure $ discoveryForCodeserver httpClient codeserverURI
let discoveryURI = discoveryURIForCodeserver codeserverURI
doc@(DiscoveryDoc {authorizationEndpoint, tokenEndpoint}) <- throwCredFailure $ fetchDiscoveryDoc discoveryURI
debugM Auth "Discovery Doc" doc
authResultVar <- UnliftIO.newEmptyMVar @_ @(Either CredentialFailure Tokens)
-- The redirect_uri depends on the port, so we need to spin up the server first, but
@ -59,7 +66,7 @@ authenticateCodeserver credsManager codeserverURI = UnliftIO.try @_ @CredentialF
-- and it all works out fine.
redirectURIVar <- UnliftIO.newEmptyMVar
(verifier, challenge, state) <- generateParams
let codeHandler code = do
let codeHandler code mayNextURI = do
redirectURI <- UnliftIO.readMVar redirectURIVar
result <- exchangeCode httpClient tokenEndpoint code verifier redirectURI
UnliftIO.putMVar authResultVar result
@ -68,7 +75,10 @@ authenticateCodeserver credsManager codeserverURI = UnliftIO.try @_ @CredentialF
debugM Auth "Auth Error" err
pure $ Wai.responseLBS internalServerError500 [] "Something went wrong, please try again."
Right _ ->
pure $ Wai.responseLBS ok200 [] "Authorization successful. You may close this page and return to UCM."
case mayNextURI of
Nothing -> pure $ Wai.responseLBS found302 [] "Authorization successful. You may close this page and return to UCM."
Just nextURI ->
pure $ Wai.responseLBS found302 [("LOCATION", BSC.pack $ show @URI nextURI)] "Authorization successful. You may close this page and return to UCM."
toIO <- UnliftIO.askRunInIO
liftIO . Warp.withApplication (pure $ authTransferServer codeHandler) $ \port -> toIO $ do
let redirectURI = "http://localhost:" <> show port <> "/redirect"
@ -78,7 +88,8 @@ authenticateCodeserver credsManager codeserverURI = UnliftIO.try @_ @CredentialF
respond . Output.InitiateAuthFlow $ authorizationKickoff
tokens <- throwCredFailure $ UnliftIO.readMVar authResultVar
let codeserverId = codeserverIdFromCodeserverURI codeserverURI
saveTokens credsManager codeserverId tokens
let creds = codeserverCredentials discoveryURI tokens
saveCredentials credsManager codeserverId creds
where
throwCredFailure :: m (Either CredentialFailure a) -> m a
throwCredFailure = throwEitherM

52
unison-cli/src/Unison/Auth/Tokens.hs
View File

@ -1,8 +1,16 @@
module Unison.Auth.Tokens where
import Control.Monad.Except
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Text as Text
import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import qualified Network.HTTP.Types as Network
import Network.URI (URI)
import Unison.Auth.CredentialManager
import Unison.Auth.Discovery (fetchDiscoveryDoc)
import Unison.Auth.Types
import Unison.CommandLine.InputPattern (patternName)
import qualified Unison.CommandLine.InputPatterns as IP
@ -29,17 +37,43 @@ type TokenProvider = CodeserverId -> IO (Either CredentialFailure AccessToken)
-- | Creates a 'TokenProvider' using the given 'CredentialManager'
newTokenProvider :: CredentialManager -> TokenProvider
newTokenProvider manager host = UnliftIO.try @_ @CredentialFailure $ do
tokens@(Tokens {accessToken}) <- throwEitherM $ getTokens manager host
expired <- isExpired accessToken
CodeserverCredentials {tokens, discoveryURI} <- throwEitherM $ getCredentials manager host
let Tokens {accessToken = currentAccessToken} = tokens
expired <- isExpired currentAccessToken
if expired
then do
newTokens@(Tokens {accessToken = newAccessToken}) <- throwEitherM $ refreshTokens manager host tokens
saveTokens manager host newTokens
newTokens@(Tokens {accessToken = newAccessToken}) <- throwEitherM $ performTokenRefresh discoveryURI tokens
saveCredentials manager host (codeserverCredentials discoveryURI newTokens)
pure $ newAccessToken
else pure accessToken
else pure currentAccessToken
-- | Don't yet support automatically refreshing tokens.
refreshTokens :: MonadIO m => CredentialManager -> CodeserverId -> Tokens -> m (Either CredentialFailure Tokens)
refreshTokens _manager _host _tokens =
-- Refreshing tokens is currently unsupported.
pure (Left (RefreshFailure . Text.pack $ "Unable to refresh authentication, please run " <> patternName IP.authLogin <> " and try again."))
--
-- Specification: https://datatracker.ietf.org/doc/html/rfc6749#section-6
performTokenRefresh :: MonadIO m => URI -> Tokens -> m (Either CredentialFailure Tokens)
performTokenRefresh discoveryURI (Tokens {refreshToken = currentRefreshToken}) = runExceptT $
case currentRefreshToken of
Nothing ->
throwError $ (RefreshFailure . Text.pack $ "Unable to refresh authentication, please run " <> patternName IP.authLogin <> " and try again.")
Just rt -> do
DiscoveryDoc {tokenEndpoint} <- ExceptT $ fetchDiscoveryDoc discoveryURI
req <- liftIO $ HTTP.requestFromURI tokenEndpoint
let addFormData =
HTTP.urlEncodedBody
[ ("grant_type", "refresh_token"),
("refresh_token", BSC.pack . Text.unpack $ rt)
]
let fullReq = addFormData $ req {HTTP.method = "POST", HTTP.requestHeaders = [("Accept", "application/json")]}
unauthenticatedHttpClient <- liftIO $ HTTP.getGlobalManager
resp <- liftIO $ HTTP.httpLbs fullReq unauthenticatedHttpClient
newTokens <- case HTTP.responseStatus resp of
status
| status < Network.status300 -> do
let respBytes = HTTP.responseBody resp
case Aeson.eitherDecode @Tokens respBytes of
Left err -> throwError (InvalidTokenResponse tokenEndpoint (Text.pack err))
Right a -> pure a
| otherwise -> throwError $ (InvalidTokenResponse tokenEndpoint $ "Received " <> tShow status <> " response from token endpoint")
-- According to the spec, servers may or may not update the refresh token itself.
-- If updated we need to replace it, if not updated we keep the existing one.
pure $ newTokens {refreshToken = refreshToken newTokens <|> currentRefreshToken}

67
unison-cli/src/Unison/Auth/Types.hs
View File

@ -14,8 +14,10 @@ module Unison.Auth.Types
PKCEChallenge,
ProfileName,
CredentialFailure (..),
getActiveTokens,
setActiveTokens,
CodeserverCredentials (..),
getCodeserverCredentials,
setCodeserverCredentials,
codeserverCredentials,
emptyCredentials,
)
where
@ -29,7 +31,7 @@ import Data.Time (NominalDiffTime)
import Network.URI
import qualified Network.URI as URI
import Unison.Prelude
import Unison.Share.Types (CodeserverId, CodeserverURI)
import Unison.Share.Types
defaultProfileName :: ProfileName
defaultProfileName = "default"
@ -128,26 +130,11 @@ instance Aeson.FromJSON DiscoveryDoc where
type ProfileName = Text
data Credentials = Credentials
{ credentials :: Map ProfileName (Map CodeserverId Tokens),
{ credentials :: Map ProfileName (Map CodeserverId CodeserverCredentials),
activeProfile :: ProfileName
}
deriving (Eq)
emptyCredentials :: Credentials
emptyCredentials = Credentials mempty defaultProfileName
getActiveTokens :: CodeserverId -> Credentials -> Either CredentialFailure Tokens
getActiveTokens host (Credentials {credentials, activeProfile}) =
maybeToEither (ReauthRequired host) $
credentials ^? ix activeProfile . ix host
setActiveTokens :: CodeserverId -> Tokens -> Credentials -> Credentials
setActiveTokens host tokens creds@(Credentials {credentials, activeProfile}) =
let newCredMap =
credentials
& at activeProfile . non Map.empty . at host .~ Just tokens
in creds {credentials = newCredMap}
instance Aeson.ToJSON Credentials where
toJSON (Credentials credMap activeProfile) =
Aeson.object
@ -160,3 +147,45 @@ instance Aeson.FromJSON Credentials where
credentials <- obj .: "credentials"
activeProfile <- obj .: "active_profile"
pure Credentials {..}
-- | Credentials for a specific codeserver
data CodeserverCredentials = CodeserverCredentials
{ -- The most recent set of authentication tokens
tokens :: Tokens,
-- URI where the discovery document for this codeserver can be fetched.
discoveryURI :: URI
}
deriving (Eq)
instance ToJSON CodeserverCredentials where
toJSON (CodeserverCredentials tokens discoveryURI) =
Aeson.object ["tokens" .= tokens, "discovery_uri" .= show discoveryURI]
instance FromJSON CodeserverCredentials where
parseJSON =
Aeson.withObject "CodeserverCredentials" $ \v ->
do
tokens <- v .: "tokens"
discoveryURIString <- v .: "discovery_uri"
discoveryURI <- case parseURI discoveryURIString of
Nothing -> fail "discovery_uri is not a valid URI"
Just uri -> pure uri
pure $ CodeserverCredentials {..}
emptyCredentials :: Credentials
emptyCredentials = Credentials mempty defaultProfileName
codeserverCredentials :: URI -> Tokens -> CodeserverCredentials
codeserverCredentials discoveryURI tokens = CodeserverCredentials {discoveryURI, tokens}
getCodeserverCredentials :: CodeserverId -> Credentials -> Either CredentialFailure CodeserverCredentials
getCodeserverCredentials host (Credentials {credentials, activeProfile}) =
maybeToEither (ReauthRequired host) $
credentials ^? ix activeProfile . ix host
setCodeserverCredentials :: CodeserverId -> CodeserverCredentials -> Credentials -> Credentials
setCodeserverCredentials host codeserverCreds creds@(Credentials {credentials, activeProfile}) =
let newCredMap =
credentials
& at activeProfile . non Map.empty . at host .~ Just codeserverCreds
in creds {credentials = newCredMap}

20
unison-cli/src/Unison/Codebase/Editor/Command.hs
View File

@ -13,7 +13,6 @@ module Unison.Codebase.Editor.Command
EvalResult,
commandName,
lookupEvalResult,
UCMVersion,
)
where
@ -30,6 +29,7 @@ import Unison.Codebase.Editor.AuthorInfo (AuthorInfo)
import qualified Unison.Codebase.Editor.Git as Git
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.RemoteRepo
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.IntegrityCheck (IntegrityResult)
import Unison.Codebase.Path (Path)
import qualified Unison.Codebase.Path as Path
@ -95,8 +95,6 @@ type TypecheckingResult v =
(Seq (Note v Ann))
(Either Names (UF.TypecheckedUnisonFile v Ann))
type UCMVersion = Text
data
Command
m -- Command monad
@ -198,16 +196,16 @@ data
LoadLocalBranch :: Branch.CausalHash -> Command m i v (Branch m)
-- Merge two branches, using the codebase for the LCA calculation where possible.
Merge :: Branch.MergeMode -> Branch m -> Branch m -> Command m i v (Branch m)
ViewRemoteBranch ::
ReadRemoteNamespace ->
ViewRemoteGitBranch ::
ReadGitRemoteNamespace ->
Git.GitBranchBehavior ->
(Branch m -> (Free (Command m i v) r)) ->
Command m i v (Either GitError r)
-- we want to import as little as possible, so we pass the SBH/path as part
-- of the `RemoteNamespace`. The Branch that's returned should be fully
-- imported and not retain any resources from the remote codebase
ImportRemoteBranch ::
ReadRemoteNamespace ->
ImportRemoteGitBranch ::
ReadGitRemoteNamespace ->
SyncMode ->
-- | A preprocessing step to perform on the branch before it's imported.
-- This is sometimes useful for minimizing the number of definitions to sync.
@ -218,7 +216,7 @@ data
-- Any definitions in the head of the supplied branch that aren't in the target
-- codebase are copied there.
SyncLocalRootBranch :: Branch m -> Command m i v ()
SyncRemoteBranch :: WriteRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> Command m i v (Either GitError (Either e (Branch m)))
SyncRemoteGitBranch :: WriteGitRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> Command m i v (Either GitError (Either e (Branch m)))
AppendToReflog :: Text -> Branch m -> Branch m -> Command m i v ()
-- load the reflog in file (chronological) order
LoadReflog :: Command m i v [Reflog.Entry Branch.CausalHash]
@ -318,10 +316,10 @@ commandName = \case
LoadLocalRootBranch -> "LoadLocalRootBranch"
LoadLocalBranch {} -> "LoadLocalBranch"
Merge {} -> "Merge"
ViewRemoteBranch {} -> "ViewRemoteBranch"
ImportRemoteBranch {} -> "ImportRemoteBranch"
ViewRemoteGitBranch {} -> "ViewRemoteGitBranch"
ImportRemoteGitBranch {} -> "ImportRemoteGitBranch"
SyncLocalRootBranch {} -> "SyncLocalRootBranch"
SyncRemoteBranch {} -> "SyncRemoteBranch"
SyncRemoteGitBranch {} -> "SyncRemoteGitBranch"
AppendToReflog {} -> "AppendToReflog"
LoadReflog -> "LoadReflog"
LoadTerm {} -> "LoadTerm"

9
unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs
View File

@ -22,8 +22,9 @@ import Unison.Codebase.Branch (Branch)
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Branch.Merge as Branch
import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo
import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UCMVersion, UseCache)
import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UseCache)
import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output (PrintMessage))
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.IntegrityCheck (integrityCheckFullCodebase)
import qualified Unison.Codebase.Path as Path
import Unison.Codebase.Runtime (Runtime)
@ -153,14 +154,14 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
SyncLocalRootBranch branch -> lift $ do
setBranchRef branch
Codebase.putRootBranch codebase branch
ViewRemoteBranch ns gitBranchBehavior action -> do
ViewRemoteGitBranch ns gitBranchBehavior action -> do
-- TODO: We probably won'd need to unlift anything once we remove the Command
-- abstraction.
toIO <- UnliftIO.askRunInIO
lift $ Codebase.viewRemoteBranch codebase ns gitBranchBehavior (toIO . Free.fold go . action)
ImportRemoteBranch ns syncMode preprocess ->
ImportRemoteGitBranch ns syncMode preprocess ->
lift $ Codebase.importRemoteBranch codebase ns syncMode preprocess
SyncRemoteBranch repo opts action ->
SyncRemoteGitBranch repo opts action ->
lift $ Codebase.pushGitBranch codebase repo opts action
LoadTerm r -> lift $ Codebase.getTerm codebase r
LoadTypeOfTerm r -> lift $ Codebase.getTypeOfTerm codebase r

424
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -8,9 +8,11 @@ where
-- TODO: Don't import backend
import Control.Concurrent.STM (atomically, newTVarIO, readTVar, readTVarIO, writeTVar)
import qualified Control.Error.Util as ErrorUtil
import Control.Lens
import Control.Monad.Except (ExceptT (..), runExceptT, throwError, withExceptT)
import Control.Monad.Reader (ask)
import Control.Monad.State (StateT)
import qualified Control.Monad.State as State
import Data.Bifunctor (first, second)
@ -26,13 +28,17 @@ import Data.Set.NonEmpty (NESet)
import qualified Data.Set.NonEmpty as NESet
import qualified Data.Text as Text
import Data.Tuple.Extra (uncurry3)
import qualified System.Console.Regions as Console.Regions
import qualified Text.Megaparsec as P
import U.Util.Timing (unsafeTime)
import U.Codebase.HashTags (CausalHash)
import qualified U.Codebase.Sqlite.Operations as Ops
import U.Util.Timing (time, unsafeTime)
import qualified Unison.ABT as ABT
import qualified Unison.Builtin as Builtin
import qualified Unison.Builtin.Decls as DD
import qualified Unison.Builtin.Terms as Builtin
import Unison.Codebase (Preprocessing (..), PushGitBranchOpts (..))
import qualified Unison.Codebase as Codebase
import Unison.Codebase.Branch (Branch (..), Branch0 (..))
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Branch.Merge as Branch
@ -44,7 +50,7 @@ import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..))
import Unison.Codebase.Editor.Command as Command
import Unison.Codebase.Editor.DisplayObject
import qualified Unison.Codebase.Editor.Git as Git
import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin)
import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin, ensureAuthenticatedWithCodeserver)
import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', MonadCommand (..), eval, liftF, respond, respondNumbered)
import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState
import qualified Unison.Codebase.Editor.HandleInput.NamespaceDependencies as NamespaceDependencies
@ -55,7 +61,19 @@ import qualified Unison.Codebase.Editor.Output as Output
import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff
import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN
import qualified Unison.Codebase.Editor.Propagate as Propagate
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemotePath, WriteRepo, printNamespace, writePathToRead)
import Unison.Codebase.Editor.RemoteRepo
( ReadGitRemoteNamespace (..),
ReadRemoteNamespace (..),
ReadShareRemoteNamespace (..),
WriteGitRemotePath (..),
WriteGitRepo,
WriteRemotePath (..),
WriteShareRemotePath (..),
printNamespace,
writePathToRead,
writeToReadGit,
)
import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo
import qualified Unison.Codebase.Editor.Slurp as Slurp
import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..))
import qualified Unison.Codebase.Editor.SlurpComponent as SC
@ -76,11 +94,12 @@ import qualified Unison.Codebase.PushBehavior as PushBehavior
import qualified Unison.Codebase.Reflog as Reflog
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
import qualified Unison.Codebase.ShortBranchHash as SBH
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
import qualified Unison.Codebase.SyncMode as SyncMode
import Unison.Codebase.TermEdit (TermEdit (..))
import qualified Unison.Codebase.TermEdit as TermEdit
import qualified Unison.Codebase.TermEdit.Typing as TermEdit
import Unison.Codebase.Type (GitError)
import Unison.Codebase.Type (Codebase (..), GitError)
import qualified Unison.Codebase.TypeEdit as TypeEdit
import qualified Unison.Codebase.Verbosity as Verbosity
import qualified Unison.CommandLine.DisplayValues as DisplayValues
@ -125,8 +144,13 @@ import Unison.Server.QueryResult
import Unison.Server.SearchResult (SearchResult)
import qualified Unison.Server.SearchResult as SR
import qualified Unison.Server.SearchResult' as SR'
import qualified Unison.Share.Codeserver as Codeserver
import qualified Unison.Share.Sync as Share
import Unison.Share.Types (codeserverBaseURL)
import qualified Unison.ShortHash as SH
import qualified Unison.Sqlite as Sqlite
import Unison.Symbol (Symbol)
import qualified Unison.Sync.Types as Share (Path (..))
import Unison.Term (Term)
import qualified Unison.Term as Term
import Unison.Type (Type)
@ -150,6 +174,7 @@ import Unison.Util.TransitiveClosure (transitiveClosure)
import Unison.Var (Var)
import qualified Unison.Var as Var
import qualified Unison.WatchKind as WK
import qualified Unison.Share.Sync.Types as Sync
defaultPatchNameSegment :: NameSegment
defaultPatchNameSegment = "patch"
@ -409,7 +434,7 @@ loop = do
-- todo: show the actual config-loaded namespace
<> maybe
"(remote namespace from .unisonConfig)"
(uncurry3 printNamespace)
printNamespace
orepo
<> " "
<> p' dest
@ -421,9 +446,9 @@ loop = do
CreatePullRequestI {} -> wat
LoadPullRequestI base head dest ->
"pr.load "
<> uncurry3 printNamespace base
<> printNamespace base
<> " "
<> uncurry3 printNamespace head
<> printNamespace head
<> " "
<> p' dest
PushRemoteBranchI {} -> wat
@ -486,9 +511,8 @@ loop = do
(Branch m -> Action m i v1 (Branch m)) ->
Action m i v1 Bool
updateAtM = Unison.Codebase.Editor.HandleInput.updateAtM inputDescription
unlessGitError = unlessError' Output.GitError
importRemoteBranch ns mode preprocess =
ExceptT . eval $ ImportRemoteBranch ns mode preprocess
importRemoteGitBranch ns mode preprocess =
ExceptT . eval $ ImportRemoteGitBranch ns mode preprocess
loadSearchResults = eval . LoadSearchResults
saveAndApplyPatch patchPath'' patchName patch' = do
stepAtM
@ -644,24 +668,20 @@ loop = do
(resolveToAbsolute <$> after)
ppe
outputDiff
CreatePullRequestI baseRepo headRepo -> do
result <-
join @(Either GitError) <$> viewRemoteBranch baseRepo Git.RequireExistingBranch \baseBranch -> do
viewRemoteBranch headRepo Git.RequireExistingBranch \headBranch -> do
merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch
(ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged)
pure $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff
case result of
Left gitErr -> respond (Output.GitError gitErr)
Right diff -> respondNumbered diff
CreatePullRequestI baseRepo headRepo -> handleCreatePullRequest baseRepo headRepo
LoadPullRequestI baseRepo headRepo dest0 -> do
let desta = resolveToAbsolute dest0
let dest = Path.unabsolute desta
destb <- getAt desta
let tryImportBranch = \case
ReadRemoteNamespaceGit repo ->
withExceptT Output.GitError (importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified)
ReadRemoteNamespaceShare repo ->
ExceptT (importRemoteShareBranch repo)
if Branch.isEmpty0 (Branch.head destb)
then unlessGitError do
baseb <- importRemoteBranch baseRepo SyncMode.ShortCircuit Unmodified
headb <- importRemoteBranch headRepo SyncMode.ShortCircuit Unmodified
then unlessError do
baseb <- tryImportBranch baseRepo
headb <- tryImportBranch headRepo
lift $ do
mergedb <- eval $ Merge Branch.RegularMerge baseb headb
squashedb <- eval $ Merge Branch.SquashMerge headb baseb
@ -701,8 +721,8 @@ loop = do
case getAtSplit' dest of
Just existingDest
| not (Branch.isEmpty0 (Branch.head existingDest)) -> do
-- Branch exists and isn't empty, print an error
throwError (BranchAlreadyExists (Path.unsplit' dest))
-- Branch exists and isn't empty, print an error
throwError (BranchAlreadyExists (Path.unsplit' dest))
_ -> pure ()
-- allow rewriting history to ensure we move the branch's history too.
lift $
@ -773,7 +793,7 @@ loop = do
doDelete = do
stepAt Branch.CompressHistory $ BranchUtil.makeDeleteBranch (resolveSplit' p)
respond Success
-- Looks similar to the 'toDelete' above... investigate me! ;)
-- Looks similar to the 'toDelete' above... investigate me! ;)
computeEndangerments :: Branch0 m1 -> Action' m v (Map LabeledDependency (NESet LabeledDependency))
computeEndangerments b0 = do
let rootNames = Branch.toNames root0
@ -1390,11 +1410,11 @@ loop = do
case filtered of
[(Referent.Ref ref, ty)]
| Typechecker.isSubtype ty mainType ->
eval (MakeStandalone ppe ref output) >>= \case
Just err -> respond $ EvaluationFailure err
Nothing -> pure ()
eval (MakeStandalone ppe ref output) >>= \case
Just err -> respond $ EvaluationFailure err
Nothing -> pure ()
| otherwise ->
respond $ BadMainFunction smain ty ppe [mainType]
respond $ BadMainFunction smain ty ppe [mainType]
_ -> respond $ NoMainFunction smain ppe [mainType]
IOTestI main -> do
-- todo - allow this to run tests from scratch file, using addRunMain
@ -1490,9 +1510,11 @@ loop = do
let preprocess = case pullMode of
Input.PullWithHistory -> Unmodified
Input.PullWithoutHistory -> Preprocessed $ pure . Branch.discardHistory
ns <- maybe (writePathToRead <$> resolveConfiguredGitUrl Pull path) pure mayRepo
lift $ unlessGitError do
remoteBranch <- importRemoteBranch ns syncMode preprocess
ns <- maybe (writePathToRead <$> resolveConfiguredUrl Pull path) pure mayRepo
lift $ unlessError do
remoteBranch <- case ns of
ReadRemoteNamespaceGit repo -> withExceptT Output.GitError (importRemoteGitBranch repo syncMode preprocess)
ReadRemoteNamespaceShare repo -> ExceptT (importRemoteShareBranch repo)
let unchangedMsg = PullAlreadyUpToDate ns path
let destAbs = resolveToAbsolute path
let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path
@ -1632,7 +1654,7 @@ loop = do
UpdateBuiltinsI -> notImplemented
QuitI -> empty
GistI input -> handleGist input
AuthLoginI -> authLogin
AuthLoginI -> authLogin (Codeserver.resolveCodeserver RemoteRepo.DefaultCodeserver)
VersionI -> do
ucmVersion <- eval UCMVersion
respond $ PrintVersion ucmVersion
@ -1644,6 +1666,65 @@ loop = do
Right input -> LoopState.lastInput .= Just input
_ -> pure ()
handleCreatePullRequest :: forall m v. MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteNamespace -> Action' m v ()
handleCreatePullRequest baseRepo0 headRepo0 = do
root' <- use LoopState.root
currentPath' <- use LoopState.currentPath
-- One of these needs a callback and the other doesn't. you might think you can get around that problem with
-- a helper function to unify the two cases, but we tried that and they were in such different monads that it
-- was hard to do.
-- viewRemoteBranch' :: forall r. ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r),
-- because there's no MonadUnliftIO instance on Action.
-- We need `Command` to go away (the FreeT layer goes away),
-- We have the StateT layer goes away (can put it into an IORef in the environment),
-- We have the MaybeT layer that signals end of input (can just been an IORef bool that we check before looping),
-- and once all those things become IO, we can add a MonadUnliftIO instance on Action, and unify these cases.
let mergeAndDiff :: MonadCommand n m i v => Branch m -> Branch m -> n (NumberedOutput v)
mergeAndDiff baseBranch headBranch = do
merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch
(ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged)
pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff
case (baseRepo0, headRepo0) of
(ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceGit headRepo) -> do
result <-
viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch ->
viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch ->
mergeAndDiff baseBranch headBranch
case join result of
Left gitErr -> respond (Output.GitError gitErr)
Right diff -> respondNumbered diff
(ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceShare headRepo) ->
importRemoteShareBranch headRepo >>= \case
Left err -> respond err
Right headBranch -> do
result <-
viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch ->
mergeAndDiff baseBranch headBranch
case result of
Left gitErr -> respond (Output.GitError gitErr)
Right diff -> respondNumbered diff
(ReadRemoteNamespaceShare baseRepo, ReadRemoteNamespaceGit headRepo) ->
importRemoteShareBranch baseRepo >>= \case
Left err -> respond err
Right baseBranch -> do
result <-
viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch ->
mergeAndDiff baseBranch headBranch
case result of
Left gitErr -> respond (Output.GitError gitErr)
Right diff -> respondNumbered diff
(ReadRemoteNamespaceShare baseRepo, ReadRemoteNamespaceShare headRepo) ->
importRemoteShareBranch headRepo >>= \case
Left err -> respond err
Right headBranch ->
importRemoteShareBranch baseRepo >>= \case
Left err -> respond err
Right baseBranch -> do
diff <- mergeAndDiff baseBranch headBranch
respondNumbered diff
handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v ()
handleDependents hq = do
hqLength <- eval CodebaseHashLength
@ -1683,7 +1764,7 @@ handleDependents hq = do
-- | Handle a @gist@ command.
handleGist :: MonadUnliftIO m => GistInput -> Action' m v ()
handleGist (GistInput repo) =
doPushRemoteBranch repo Path.relativeEmpty' SyncMode.ShortCircuit Nothing
doPushRemoteBranch (GistyPush repo) Path.relativeEmpty' SyncMode.ShortCircuit
-- | Handle a @push@ command.
handlePushRemoteBranch ::
@ -1697,51 +1778,75 @@ handlePushRemoteBranch ::
PushBehavior ->
SyncMode.SyncMode ->
Action' m v ()
handlePushRemoteBranch mayRepo path pushBehavior syncMode = do
unlessError do
(repo, remotePath) <- maybe (resolveConfiguredGitUrl Push path) pure mayRepo
lift (doPushRemoteBranch repo path syncMode (Just (remotePath, pushBehavior)))
handlePushRemoteBranch mayRepo path pushBehavior syncMode =
time
"handlePushRemoteBranch"
case mayRepo of
Nothing ->
runExceptT (resolveConfiguredUrl Push path) >>= \case
Left output -> respond output
Right repo -> push repo
Just repo -> push repo
where
push repo =
doPushRemoteBranch (NormalPush repo pushBehavior) path syncMode
-- | Either perform a "normal" push (updating a remote path), which takes a 'PushBehavior' (to control whether creating
-- a new namespace is allowed), or perform a "gisty" push, which doesn't update any paths (and also is currently only
-- uploaded for remote git repos, not remote Share repos).
data PushFlavor
= NormalPush WriteRemotePath PushBehavior
| GistyPush WriteGitRepo
-- Internal helper that implements pushing to a remote repo, which generalizes @gist@ and @push@.
doPushRemoteBranch ::
forall m v.
MonadUnliftIO m =>
-- | The repo to push to.
WriteRepo ->
PushFlavor ->
-- | The local path to push. If relative, it's resolved relative to the current path (`cd`).
Path' ->
SyncMode.SyncMode ->
-- | The remote target. If missing, the given branch contents should be pushed to the remote repo without updating the
-- root namespace.
Maybe (Path, PushBehavior) ->
Action' m v ()
doPushRemoteBranch repo localPath syncMode remoteTarget = do
sourceBranch <- do
currentPath' <- use LoopState.currentPath
getAt (Path.resolve currentPath' localPath)
doPushRemoteBranch pushFlavor localPath0 syncMode = do
currentPath' <- use LoopState.currentPath
let localPath = Path.resolve currentPath' localPath0
unlessError do
withExceptT Output.GitError $ do
case remoteTarget of
Nothing -> do
let opts = PushGitBranchOpts {setRoot = False, syncMode}
syncRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))
sbhLength <- (eval BranchHashLength)
respond (GistCreated sbhLength repo (Branch.headHash sourceBranch))
Just (remotePath, pushBehavior) -> do
let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m))
withRemoteRoot remoteRoot = do
let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this
-- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already.
f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing
Branch.modifyAtM remotePath f remoteRoot & \case
Nothing -> pure (Left $ RefusedToPush pushBehavior)
Just newRemoteRoot -> pure (Right newRemoteRoot)
let opts = PushGitBranchOpts {setRoot = True, syncMode}
runExceptT (syncRemoteBranch repo opts withRemoteRoot) >>= \case
Left gitErr -> respond (Output.GitError gitErr)
Right (Left output) -> respond output
Right (Right _branch) -> respond Success
case pushFlavor of
NormalPush (writeRemotePath@(WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath})) pushBehavior -> do
sourceBranch <- getAt localPath
let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m))
withRemoteRoot remoteRoot = do
let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this
-- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already.
f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing
Branch.modifyAtM remotePath f remoteRoot & \case
Nothing -> pure (Left $ RefusedToPush pushBehavior writeRemotePath)
Just newRemoteRoot -> pure (Right newRemoteRoot)
let opts = PushGitBranchOpts {setRoot = True, syncMode}
runExceptT (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case
Left gitErr -> respond (Output.GitError gitErr)
Right (Left errOutput) -> respond errOutput
Right (Right _branch) -> respond Success
NormalPush (WriteRemotePathShare sharePath) pushBehavior ->
handlePushToUnisonShare sharePath localPath pushBehavior
GistyPush repo -> do
sourceBranch <- getAt localPath
let opts = PushGitBranchOpts {setRoot = False, syncMode}
runExceptT (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) >>= \case
Left gitErr -> respond (Output.GitError gitErr)
Right (Left errOutput) -> respond errOutput
Right _result -> do
sbhLength <- eval BranchHashLength
respond $
GistCreated
( ReadRemoteNamespaceGit
ReadGitRemoteNamespace
{ repo = writeToReadGit repo,
sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)),
path = Path.empty
}
)
where
-- Per `pushBehavior`, we are either:
--
@ -1753,6 +1858,84 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do
PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch)
PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch))
handlePushToUnisonShare :: (MonadUnliftIO m) => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v ()
handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} localPath behavior = do
let codeserver = Codeserver.resolveCodeserver server
let baseURL = codeserverBaseURL codeserver
let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath)
ensureAuthenticatedWithCodeserver codeserver
LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask
-- doesn't handle the case where a non-existent path is supplied
Sqlite.runTransaction connection (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath)))
>>= \case
Nothing -> respond (BranchNotFound . Path.absoluteToPath' $ localPath)
Just localCausalHash ->
case behavior of
PushBehavior.RequireEmpty -> do
let push :: IO (Either (Sync.SyncError Share.CheckAndSetPushError) ())
push =
withEntitiesUploadedProgressCallback \entitiesUploadedProgressCallback ->
Share.checkAndSetPush
authHTTPClient
baseURL
connection
sharePath
Nothing
localCausalHash
entitiesUploadedProgressCallback
liftIO push >>= \case
Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorCheckAndSetPush err))
Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err))
Right () -> pure ()
PushBehavior.RequireNonEmpty -> do
let push :: IO (Either (Sync.SyncError Share.FastForwardPushError) ())
push = do
withEntitiesUploadedProgressCallback \entitiesUploadedProgressCallback ->
Share.fastForwardPush
authHTTPClient
baseURL
connection
sharePath
localCausalHash
entitiesUploadedProgressCallback
liftIO push >>= \case
Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorFastForwardPush err))
Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err))
Right () -> pure ()
where
pathToSegments :: Path -> [Text]
pathToSegments =
coerce Path.toList
-- Provide the given action a callback that prints out the number of entities uploaded, and the number of entities
-- enqueued to be uploaded.
withEntitiesUploadedProgressCallback :: ((Int -> Int -> IO ()) -> IO a) -> IO a
withEntitiesUploadedProgressCallback action = do
entitiesUploadedVar <- newTVarIO 0
entitiesToUploadVar <- newTVarIO 0
Console.Regions.displayConsoleRegions do
Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do
Console.Regions.setConsoleRegion region do
entitiesUploaded <- readTVar entitiesUploadedVar
entitiesToUpload <- readTVar entitiesToUploadVar
pure $
"\n Uploaded "
<> tShow entitiesUploaded
<> "/"
<> tShow (entitiesUploaded + entitiesToUpload)
<> " entities...\n\n"
result <-
action \entitiesUploaded entitiesToUpload ->
atomically do
writeTVar entitiesUploadedVar entitiesUploaded
writeTVar entitiesToUploadVar entitiesToUpload
entitiesUploaded <- readTVarIO entitiesUploadedVar
Console.Regions.finishConsoleRegion region $
"\n Uploaded " <> tShow entitiesUploaded <> " entities.\n"
pure result
-- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`.
handleShowDefinition ::
forall m v.
@ -2079,27 +2262,40 @@ manageLinks silent srcs mdValues op = do
-- Takes a maybe (namespace address triple); returns it as-is if `Just`;
-- otherwise, tries to load a value from .unisonConfig, and complains
-- if needed.
resolveConfiguredGitUrl ::
resolveConfiguredUrl ::
PushPull ->
Path' ->
ExceptT (Output v) (Action m i v) WriteRemotePath
resolveConfiguredGitUrl pushPull destPath' = ExceptT do
resolveConfiguredUrl pushPull destPath' = ExceptT do
currentPath' <- use LoopState.currentPath
let destPath = Path.resolve currentPath' destPath'
let configKey = gitUrlKey destPath
(eval . ConfigLookup) configKey >>= \case
Just url ->
case P.parse UriParser.writeRepoPath (Text.unpack configKey) url of
let remoteMappingConfigKey = remoteMappingKey destPath
(eval . ConfigLookup) remoteMappingConfigKey >>= \case
Nothing -> do
let gitUrlConfigKey = gitUrlKey destPath
-- Fall back to deprecated GitUrl key
(eval . ConfigLookup) gitUrlConfigKey >>= \case
Just url ->
case WriteRemotePathGit <$> P.parse UriParser.deprecatedWriteGitRemotePath (Text.unpack gitUrlConfigKey) url of
Left e ->
pure . Left $
ConfiguredRemoteMappingParseError pushPull destPath url (show e)
Right ns ->
pure . Right $ ns
Nothing ->
pure . Left $ NoConfiguredRemoteMapping pushPull destPath
Just url -> do
case P.parse UriParser.writeRemotePath (Text.unpack remoteMappingConfigKey) url of
Left e ->
pure . Left $
ConfiguredGitUrlParseError pushPull destPath' url (show e)
ConfiguredRemoteMappingParseError pushPull destPath url (show e)
Right ns ->
pure . Right $ ns
Nothing ->
pure . Left $ NoConfiguredGitUrl pushPull destPath'
gitUrlKey :: Path.Absolute -> Text
gitUrlKey = configKey "GitUrl"
where
gitUrlKey :: Path.Absolute -> Text
gitUrlKey = configKey "GitUrl"
remoteMappingKey :: Path.Absolute -> Text
remoteMappingKey = configKey "RemoteMapping"
configKey :: Text -> Path.Absolute -> Text
configKey k p =
@ -2109,26 +2305,66 @@ configKey k p =
NameSegment.toText
(Path.toSeq $ Path.unabsolute p)
viewRemoteBranch ::
viewRemoteGitBranch ::
(MonadCommand n m i v, MonadUnliftIO m) =>
ReadRemoteNamespace ->
ReadGitRemoteNamespace ->
Git.GitBranchBehavior ->
(Branch m -> Free (Command m i v) r) ->
n (Either GitError r)
viewRemoteBranch ns gitBranchBehavior action = do
eval $ ViewRemoteBranch ns gitBranchBehavior action
viewRemoteGitBranch ns gitBranchBehavior action = do
eval $ ViewRemoteGitBranch ns gitBranchBehavior action
importRemoteShareBranch :: MonadUnliftIO m => ReadShareRemoteNamespace -> Action' m v (Either (Output v) (Branch m))
importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do
let codeserver = Codeserver.resolveCodeserver server
let baseURL = codeserverBaseURL codeserver
ensureAuthenticatedWithCodeserver codeserver
mapLeft Output.ShareError <$> do
let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path))
LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask
let pull :: IO (Either (Sync.SyncError Share.PullError) CausalHash)
pull =
withEntitiesDownloadedProgressCallback \entitiesDownloadedProgressCallback ->
Share.pull
authHTTPClient
baseURL
connection
shareFlavoredPath
entitiesDownloadedProgressCallback
liftIO pull >>= \case
Left (Sync.SyncError err) -> pure (Left (Output.ShareErrorPull err))
Left (Sync.TransportError err) -> pure (Left (Output.ShareErrorTransport err))
Right causalHash -> do
(eval . Eval) (Codebase.getBranchForHash codebase (Cv.causalHash2to1 causalHash)) >>= \case
Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)"
Just branch -> pure (Right branch)
where
-- Provide the given action a callback that prints out the number of entities downloaded.
withEntitiesDownloadedProgressCallback :: ((Int -> IO ()) -> IO a) -> IO a
withEntitiesDownloadedProgressCallback action = do
entitiesDownloadedVar <- newTVarIO 0
Console.Regions.displayConsoleRegions do
Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do
Console.Regions.setConsoleRegion region do
entitiesDownloaded <- readTVar entitiesDownloadedVar
pure ("\n Downloaded " <> tShow entitiesDownloaded <> " entities...\n\n")
result <- action \entitiesDownloaded -> atomically (writeTVar entitiesDownloadedVar entitiesDownloaded)
entitiesDownloaded <- readTVarIO entitiesDownloadedVar
Console.Regions.finishConsoleRegion region $
"\n Downloaded " <> tShow entitiesDownloaded <> " entities.\n"
pure result
-- | Given the current root branch of a remote
-- (or an empty branch if no root branch exists)
-- compute a new branch, which will then be synced and pushed.
syncRemoteBranch ::
syncGitRemoteBranch ::
MonadCommand n m i v =>
WriteRepo ->
WriteGitRepo ->
PushGitBranchOpts ->
(Branch m -> m (Either e (Branch m))) ->
ExceptT GitError n (Either e (Branch m))
syncRemoteBranch repo opts action =
ExceptT . eval $ SyncRemoteBranch repo opts action
syncGitRemoteBranch repo opts action =
ExceptT . eval $ SyncRemoteGitBranch repo opts action
-- todo: compare to `getHQTerms` / `getHQTypes`. Is one universally better?
resolveHQToLabeledDependencies :: Functor m => HQ.HashQualified Name -> Action' m v (Set LabeledDependency)
@ -2407,10 +2643,10 @@ searchBranchScored names0 score queries =
pair qn
HQ.HashQualified qn h
| h `SH.isPrefixOf` Referent.toShortHash ref ->
pair qn
pair qn
HQ.HashOnly h
| h `SH.isPrefixOf` Referent.toShortHash ref ->
Set.singleton (Nothing, result)
Set.singleton (Nothing, result)
_ -> mempty
where
result = SR.termSearchResult names0 name ref
@ -2427,10 +2663,10 @@ searchBranchScored names0 score queries =
pair qn
HQ.HashQualified qn h
| h `SH.isPrefixOf` Reference.toShortHash ref ->
pair qn
pair qn
HQ.HashOnly h
| h `SH.isPrefixOf` Reference.toShortHash ref ->
Set.singleton (Nothing, result)
Set.singleton (Nothing, result)
_ -> mempty
where
result = SR.typeSearchResult names0 name ref
@ -2823,7 +3059,7 @@ docsI srcLoc prettyPrintNames src = do
| Set.size s == 1 -> displayI prettyPrintNames ConsoleLocation dotDoc
| Set.size s == 0 -> respond $ ListOfLinks mempty []
| otherwise -> -- todo: return a list of links here too
respond $ ListOfLinks mempty []
respond $ ListOfLinks mempty []
filterBySlurpResult ::
Ord v =>

36
unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs
View File

@ -1,36 +1,24 @@
module Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) where
module Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin, ensureAuthenticatedWithCodeserver) where
import Control.Monad.Reader
import Network.URI (URIAuth (..), parseURI)
import System.IO.Unsafe (unsafePerformIO)
import Unison.Auth.CredentialManager (getCredentials)
import Unison.Auth.OAuth (authenticateCodeserver)
import Unison.Codebase.Editor.HandleInput.LoopState
import Unison.Codebase.Editor.Output (Output (CredentialFailureMsg, Success))
import Unison.Prelude
import Unison.Share.Types
import qualified UnliftIO
import UnliftIO.Environment (lookupEnv)
-- | This is the URI where the share API is based.
defaultShareURI :: CodeserverURI
defaultShareURI = unsafePerformIO $ do
lookupEnv "UNISON_SHARE_HOST" <&> \case
-- TODO: swap to production share before release.
Nothing ->
CodeserverURI
{ codeserverScheme = "https:",
codeserverAuthority = URIAuth {uriUserInfo = "", uriRegName = "share-next.us-west-2.unison-lang.org", uriPort = ""},
codeserverPath = "/api"
}
Just shareHost ->
fromMaybe (error $ "Share Host is not a valid URI: " <> shareHost) $ do
uri <- parseURI shareHost
codeserverFromURI uri
{-# NOINLINE defaultShareURI #-}
-- | Checks if the user has valid auth for the given codeserver,
-- and runs through an authentication flow if not.
ensureAuthenticatedWithCodeserver :: UnliftIO.MonadUnliftIO m => CodeserverURI -> Action m i v ()
ensureAuthenticatedWithCodeserver codeserverURI = do
credsMan <- asks credentialManager
getCredentials credsMan (codeserverIdFromCodeserverURI codeserverURI) >>= \case
Right _ -> pure ()
Left _ -> authLogin codeserverURI
authLogin :: UnliftIO.MonadUnliftIO m => Action m i v ()
authLogin = do
let host = defaultShareURI
authLogin :: UnliftIO.MonadUnliftIO m => CodeserverURI -> Action m i v ()
authLogin host = do
credsMan <- asks credentialManager
(Action . lift . lift . lift $ authenticateCodeserver credsMan host) >>= \case
Left err -> respond (CredentialFailureMsg err)

19
unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs
View File

@ -11,8 +11,9 @@ import Control.Monad.State
import Data.Configurator ()
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as Nel
import qualified Network.HTTP.Client as HTTP
import Unison.Auth.CredentialManager (CredentialManager)
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
import Unison.Codebase (Codebase)
import Unison.Codebase.Branch
( Branch (..),
)
@ -28,18 +29,19 @@ import qualified Unison.Util.Free as Free
type F m i v = Free (Command m i v)
data Env = Env
{ authHTTPClient :: HTTP.Manager,
data Env m v = Env
{ authHTTPClient :: AuthenticatedHttpClient,
codebase :: Codebase m v Ann,
credentialManager :: CredentialManager
}
newtype Action m i v a = Action {unAction :: MaybeT (ReaderT Env (StateT (LoopState m v) (F m i v))) a}
deriving newtype (Functor, Applicative, Alternative, Monad, MonadIO, MonadState (LoopState m v), MonadReader Env)
newtype Action m i v a = Action {unAction :: MaybeT (ReaderT (Env m v) (StateT (LoopState m v) (F m i v))) a}
deriving newtype (Functor, Applicative, Alternative, Monad, MonadIO, MonadState (LoopState m v), MonadReader (Env m v))
-- We should likely remove this MonadFail instance since it's really hard to debug,
-- but it's currently in use.
deriving newtype (MonadFail)
runAction :: Env -> LoopState m v -> Action m i v a -> (F m i v (Maybe a, LoopState m v))
runAction :: Env m v -> LoopState m v -> Action m i v a -> (F m i v (Maybe a, LoopState m v))
runAction env state (Action m) =
m
& runMaybeT
@ -125,3 +127,8 @@ respondNumbered output = do
args <- eval $ NotifyNumbered output
unless (null args) $
numberedArgs .= toList args
-- | Get the codebase out of the environment.
askCodebase :: Action m i v (Codebase m v Ann)
askCodebase =
asks codebase

4
unison-cli/src/Unison/Codebase/Editor/Input.hs
View File

@ -188,9 +188,9 @@ data Input
| VersionI
deriving (Eq, Show)
-- | @"gist repo"@ pushes the contents of the current namespace to @repo@.
-- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@.
data GistInput = GistInput
{ repo :: WriteRepo
{ repo :: WriteGitRepo
}
deriving stock (Eq, Show)

25
unison-cli/src/Unison/Codebase/Editor/Output.hs
View File

@ -10,6 +10,7 @@ module Unison.Codebase.Editor.Output
UndoFailureReason (..),
PushPull (..),
ReflogEntry (..),
ShareError (..),
pushPull,
isFailure,
isNumberedFailure,
@ -57,6 +58,7 @@ import qualified Unison.Reference as Reference
import Unison.Referent (Referent)
import Unison.Server.Backend (ShallowListEntry (..))
import Unison.Server.SearchResult' (SearchResult')
import qualified Unison.Share.Sync.Types as Sync
import Unison.ShortHash (ShortHash)
import Unison.Term (Term)
import Unison.Type (Type)
@ -207,9 +209,10 @@ data Output v
-- and a nicer render.
BustedBuiltins (Set Reference) (Set Reference)
| GitError GitError
| ShareError ShareError
| ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText)
| NoConfiguredGitUrl PushPull Path'
| ConfiguredGitUrlParseError PushPull Path' Text String
| NoConfiguredRemoteMapping PushPull Path.Absolute
| ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String
| MetadataMissingType PPE.PrettyPrintEnv Referent
| TermMissingType Reference
| MetadataAmbiguous (HQ.HashQualified Name) PPE.PrettyPrintEnv [Referent]
@ -248,9 +251,9 @@ data Output v
| NamespaceEmpty (NonEmpty AbsBranchId)
| NoOp
| -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace.
RefusedToPush PushBehavior
| -- | @GistCreated repo hash@ means causal @hash@ was just published to @repo@.
GistCreated Int WriteRepo Branch.CausalHash
RefusedToPush PushBehavior WriteRemotePath
| -- | @GistCreated repo@ means a causal was just published to @repo@.
GistCreated ReadRemoteNamespace
| -- | Directs the user to URI to begin an authorization flow.
InitiateAuthFlow URI
| UnknownCodeServer Text
@ -258,6 +261,13 @@ data Output v
| PrintVersion Text
| IntegrityCheck IntegrityResult
data ShareError
= ShareErrorCheckAndSetPush Sync.CheckAndSetPushError
| ShareErrorFastForwardPush Sync.FastForwardPushError
| ShareErrorPull Sync.PullError
| ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError
| ShareErrorTransport Sync.CodeserverTransportError
data ReflogEntry = ReflogEntry {hash :: ShortBranchHash, reason :: Text}
deriving (Show)
@ -345,8 +355,8 @@ isFailure o = case o of
GitError {} -> True
BustedBuiltins {} -> True
ConfiguredMetadataParseError {} -> True
NoConfiguredGitUrl {} -> True
ConfiguredGitUrlParseError {} -> True
NoConfiguredRemoteMapping {} -> True
ConfiguredRemoteMappingParseError {} -> True
MetadataMissingType {} -> True
MetadataAmbiguous {} -> True
PatchNeedsToBeConflictFree {} -> True
@ -387,6 +397,7 @@ isFailure o = case o of
case r of
NoIntegrityErrors -> False
IntegrityErrorDetected {} -> True
ShareError {} -> True
isNumberedFailure :: NumberedOutput v -> Bool
isNumberedFailure = \case

5
unison-cli/src/Unison/Codebase/Editor/UCMVersion.hs Normal file
View File

@ -0,0 +1,5 @@
module Unison.Codebase.Editor.UCMVersion where
import Data.Text (Text)
type UCMVersion = Text

247
unison-cli/src/Unison/Codebase/Editor/UriParser.hs
View File

@ -1,6 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
module Unison.Codebase.Editor.UriParser (repoPath, writeRepo, writeRepoPath) where
module Unison.Codebase.Editor.UriParser
( repoPath,
writeGitRepo,
deprecatedWriteGitRemotePath,
writeRemotePath,
)
where
import Data.Char (isAlphaNum, isDigit, isSpace)
import Data.Sequence as Seq
@ -8,14 +14,24 @@ import Data.Text as Text
import Data.Void
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as C
import qualified Text.Megaparsec.Char.Lexer as L
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (..), WriteRemotePath, WriteRepo (..))
import Unison.Codebase.Editor.RemoteRepo
( ReadGitRemoteNamespace (..),
ReadGitRepo (..),
ReadRemoteNamespace (..),
ReadShareRemoteNamespace (..),
ShareCodeserver (DefaultCodeserver),
WriteGitRemotePath (..),
WriteGitRepo (..),
WriteRemotePath (..),
WriteShareRemotePath (..),
)
import Unison.Codebase.Path (Path (..))
import qualified Unison.Codebase.Path as Path
import Unison.Codebase.ShortBranchHash (ShortBranchHash (..))
import qualified Unison.Hash as Hash
import qualified Unison.Lexer
import Unison.NameSegment (NameSegment (..))
import qualified Unison.NameSegment as NameSegment
import Unison.Prelude
type P = P.Parsec Void Text.Text
@ -39,30 +55,157 @@ type P = P.Parsec Void Text.Text
-- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]]
repoPath :: P ReadRemoteNamespace
repoPath = P.label "generic git repo" $ do
protocol <- parseProtocol
treeish <- P.optional treeishSuffix
repoPath =
P.label "generic repo" $
fmap ReadRemoteNamespaceGit readGitRemoteNamespace
<|> fmap ReadRemoteNamespaceShare readShareRemoteNamespace
-- >>> P.parseMaybe writeRemotePath "unisonweb.base._releases.M4"
-- >>> P.parseMaybe writeRemotePath "git(git@github.com:unisonweb/base:v3)._releases.M3"
-- Just (WriteRemotePathShare (WriteShareRemotePath {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}))
-- Just (WriteRemotePathGit (WriteGitRemotePath {repo = WriteGitRepo {url = "git@github.com:unisonweb/base", branch = Just "v3"}, path = _releases.M3}))
writeRemotePath :: P WriteRemotePath
writeRemotePath =
(fmap WriteRemotePathGit writeGitRemotePath)
<|> fmap WriteRemotePathShare writeShareRemotePath
-- >>> P.parseMaybe writeShareRemotePath "unisonweb.base._releases.M4"
-- Just (WriteShareRemotePath {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})
writeShareRemotePath :: P WriteShareRemotePath
writeShareRemotePath =
P.label "write share remote path" $
WriteShareRemotePath
<$> pure DefaultCodeserver
<*> (NameSegment.toText <$> nameSegment)
<*> (Path.fromList <$> P.many (C.char '.' *> nameSegment))
-- >>> P.parseMaybe readShareRemoteNamespace ".unisonweb.base._releases.M4"
-- >>> P.parseMaybe readShareRemoteNamespace "unisonweb.base._releases.M4"
-- Nothing
-- Just (ReadShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})
readShareRemoteNamespace :: P ReadShareRemoteNamespace
readShareRemoteNamespace = do
P.label "read share remote namespace" $
ReadShareRemoteNamespace
<$> pure DefaultCodeserver
-- <*> sbh <- P.optional shortBranchHash
<*> (NameSegment.toText <$> nameSegment)
<*> (Path.fromList <$> P.many (C.char '.' *> nameSegment))
-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf"
-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf."
-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)"
-- >>> P.parseMaybe readGitRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3"
-- >>> P.parseMaybe readGitRemoteNamespace "git( user@server:project.git:branch )#asdf.foo.bar"
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = })
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = })
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Nothing, path = })
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sbh = Nothing, path = _releases.M3})
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = foo.bar})
readGitRemoteNamespace :: P ReadGitRemoteNamespace
readGitRemoteNamespace = P.label "generic git repo" $ do
C.string "git("
protocol <- parseGitProtocol
treeish <- P.optional gitTreeishSuffix
let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish}
nshashPath <- P.optional (C.char ':' *> namespaceHashPath)
case nshashPath of
Nothing -> pure (repo, Nothing, Path.empty)
Just (sbh, p) -> pure (repo, sbh, p)
C.string ")"
nshashPath <- P.optional namespaceHashPath
pure case nshashPath of
Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty}
Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path}
writeRepo :: P WriteRepo
writeRepo = P.label "repo root for writing" $ do
uri <- parseProtocol
treeish <- P.optional treeishSuffix
pure WriteGitRepo {url' = printProtocol uri, branch = treeish}
-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git)"
-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git:branch)"
-- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Nothing})
-- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"})
--
-- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git)"
-- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git:branch)"
-- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing})
-- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"})
--
-- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git)"
-- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git:base)"
-- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing})
-- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"})
--
-- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git)"
-- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git:branch)"
-- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git)"
-- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git:branch)"
-- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing})
-- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"})
-- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Nothing})
-- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"})
--
-- >>> P.parseMaybe writeGitRepo "git(server:project)"
-- >>> P.parseMaybe writeGitRepo "git(user@server:project.git:branch)"
-- Just (WriteGitRepo {url = "server:project", branch = Nothing})
-- Just (WriteGitRepo {url = "user@server:project.git", branch = Just "branch"})
writeGitRepo :: P WriteGitRepo
writeGitRepo = P.label "repo root for writing" $ do
C.string "git("
uri <- parseGitProtocol
treeish <- P.optional gitTreeishSuffix
C.string ")"
pure WriteGitRepo {url = printProtocol uri, branch = treeish}
writeRepoPath :: P WriteRemotePath
writeRepoPath = P.label "generic git repo" $ do
repo <- writeRepo
-- | A parser for the deprecated format of git URLs, which may still exist in old GitURL
-- unisonConfigs.
--
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "/srv/git/project.git:.namespace"
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "/srv/git/project.git:branch:.namespace"
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Nothing}, path = namespace})
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"}, path = namespace})
--
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "file:///srv/git/project.git"
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "file:///srv/git/project.git:branch"
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing}, path = })
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"}, path = })
--
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "https://example.com/gitproject.git"
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "https://example.com/gitproject.git:base"
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing}, path = })
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"}, path = })
--
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "ssh://user@server/project.git"
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "ssh://user@server/project.git:branch"
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "ssh://server/project.git"
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "ssh://server/project.git:branch"
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing}, path = })
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"}, path = })
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Nothing}, path = })
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"}, path = })
--
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "server:project"
-- >>> P.parseMaybe deprecatedWriteGitRemotePath "user@server:project.git:branch"
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "server:project", branch = Nothing}, path = })
-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "user@server:project.git", branch = Just "branch"}, path = })
deprecatedWriteGitRemotePath :: P WriteGitRemotePath
deprecatedWriteGitRemotePath = P.label "generic write repo" $ do
repo <- deprecatedWriteGitRepo
path <- P.optional (C.char ':' *> absolutePath)
pure (repo, fromMaybe Path.empty path)
pure WriteGitRemotePath {repo, path = fromMaybe Path.empty path}
where
deprecatedWriteGitRepo :: P WriteGitRepo
deprecatedWriteGitRepo = do
P.label "repo root for writing" $ do
uri <- parseGitProtocol
treeish <- P.optional deprecatedTreeishSuffix
pure WriteGitRepo {url = printProtocol uri, branch = treeish}
deprecatedTreeishSuffix :: P Text
deprecatedTreeishSuffix = P.label "git treeish" . P.try $ do
void $ C.char ':'
notdothash <- P.noneOf @[] ".#:"
rest <- P.takeWhileP (Just "not colon") (/= ':')
pure $ Text.cons notdothash rest
-- does this not exist somewhere in megaparsec? yes in 7.0
symbol :: Text -> P Text
symbol = L.symbol (pure ())
-- git(myrepo@git.com).foo.bar
writeGitRemotePath :: P WriteGitRemotePath
writeGitRemotePath = P.label "generic write repo" $ do
repo <- writeGitRepo
path <- P.optional absolutePath
pure WriteGitRemotePath {repo, path = fromMaybe Path.empty path}
data GitProtocol
= HttpsProtocol (Maybe User) HostInfo UrlPath
@ -110,29 +253,29 @@ type Host = Text -- no port
-- doesn't yet handle basic authentication like https://user:pass@server.com
-- (does anyone even want that?)
-- or handle ipv6 addresses (https://en.wikipedia.org/wiki/IPv6#Addressing)
parseProtocol :: P GitProtocol
parseProtocol =
P.label "parseProtocol" $
parseGitProtocol :: P GitProtocol
parseGitProtocol =
P.label "parseGitProtocol" $
fileRepo <|> httpsRepo <|> sshRepo <|> scpRepo <|> localRepo
where
localRepo, fileRepo, httpsRepo, sshRepo, scpRepo :: P GitProtocol
parsePath =
P.takeWhile1P
(Just "repo path character")
(\c -> not (isSpace c || c == ':'))
(\c -> not (isSpace c || c == ':' || c == ')'))
localRepo = LocalProtocol <$> parsePath
fileRepo = P.label "fileRepo" $ do
void $ symbol "file://"
void $ C.string "file://"
FileProtocol <$> parsePath
httpsRepo = P.label "httpsRepo" $ do
void $ symbol "https://"
void $ C.string "https://"
HttpsProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath
sshRepo = P.label "sshRepo" $ do
void $ symbol "ssh://"
void $ C.string "ssh://"
SshProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath
scpRepo =
P.label "scpRepo" . P.try $
ScpProtocol <$> P.optional userInfo <*> parseHost <* symbol ":" <*> parsePath
ScpProtocol <$> P.optional userInfo <*> parseHost <* C.string ":" <*> parsePath
userInfo :: P User
userInfo = P.label "userInfo" . P.try $ do
username <- P.takeWhile1P (Just "username character") (/= '@')
@ -143,7 +286,7 @@ parseProtocol =
P.label "parseHostInfo" $
HostInfo <$> parseHost
<*> ( P.optional $ do
void $ symbol ":"
void $ C.char ':'
P.takeWhile1P (Just "digits") isDigit
)
@ -164,29 +307,47 @@ parseProtocol =
pure $ Text.pack $ o1 <> "." <> o2 <> "." <> o3 <> "." <> o4
decOctet = P.count' 1 3 C.digitChar
-- #nshashabc.path.foo.bar or .path.foo.bar
-- >>> P.parseMaybe namespaceHashPath "#nshashabc.path.foo.bar"
-- Just (Just #nshashabc,path.foo.bar)
--
-- >>> P.parseMaybe namespaceHashPath ".path.foo.bar"
-- Just (Nothing,path.foo.bar)
--
-- >>> P.parseMaybe namespaceHashPath "#nshashabc"
-- Just (Just #nshashabc,)
--
-- >>> P.parseMaybe namespaceHashPath "#nshashabc."
-- Just (Just #nshashabc,)
--
-- >>> P.parseMaybe namespaceHashPath "."
-- Just (Nothing,)
namespaceHashPath :: P (Maybe ShortBranchHash, Path)
namespaceHashPath = do
sbh <- P.optional shortBranchHash
p <- P.optional absolutePath
pure (sbh, fromMaybe Path.empty p)
-- >>> P.parseMaybe absolutePath "."
-- Just
--
-- >>> P.parseMaybe absolutePath ".path.foo.bar"
-- Just path.foo.bar
absolutePath :: P Path
absolutePath = do
void $ C.char '.'
Path . Seq.fromList . fmap (NameSegment . Text.pack)
<$> P.sepBy1
( (:) <$> P.satisfy Unison.Lexer.wordyIdStartChar
<*> P.many (P.satisfy Unison.Lexer.wordyIdChar)
)
(C.char '.')
Path . Seq.fromList <$> P.sepBy nameSegment (C.char '.')
treeishSuffix :: P Text
treeishSuffix = P.label "git treeish" . P.try $ do
nameSegment :: P NameSegment
nameSegment =
NameSegment . Text.pack
<$> ( (:) <$> P.satisfy Unison.Lexer.wordyIdStartChar
<*> P.many (P.satisfy Unison.Lexer.wordyIdChar)
)
gitTreeishSuffix :: P Text
gitTreeishSuffix = P.label "git treeish" . P.try $ do
void $ C.char ':'
notdothash <- P.noneOf @[] ".#:"
rest <- P.takeWhileP (Just "not colon") (/= ':')
pure $ Text.cons notdothash rest
P.takeWhile1P (Just "not close paren") (/= ')')
shortBranchHash :: P ShortBranchHash
shortBranchHash = P.label "short branch hash" $ do

28
unison-cli/src/Unison/Codebase/Editor/VersionParser.hs
View File

@ -15,7 +15,7 @@ import qualified Unison.Codebase.Path as Path
-- "release/M1j" -> "releases._M1j"
-- "release/M1j.2" -> "releases._M1j_2"
-- "latest-*" -> "trunk"
defaultBaseLib :: Parsec Void Text ReadRemoteNamespace
defaultBaseLib :: Parsec Void Text ReadGitRemoteNamespace
defaultBaseLib = fmap makeNS $ latest <|> release
where
latest, release, version :: Parsec Void Text Text
@ -23,16 +23,18 @@ defaultBaseLib = fmap makeNS $ latest <|> release
release = fmap ("releases._" <>) $ "release/" *> version <* eof
version = do
Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-']))
makeNS :: Text -> ReadRemoteNamespace
makeNS :: Text -> ReadGitRemoteNamespace
makeNS t =
( ReadGitRepo
{ url = "https://github.com/unisonweb/base",
-- Use the 'v4' branch of base for now.
-- We can revert back to the main branch once enough people have upgraded ucm and
-- we're okay with pushing the v4 base codebase to main (perhaps by the next ucm
-- release).
ref = Just "v4"
},
Nothing,
Path.fromText t
)
ReadGitRemoteNamespace
{ repo =
ReadGitRepo
{ url = "https://github.com/unisonweb/base",
-- Use the 'v4' branch of base for now.
-- We can revert back to the main branch once enough people have upgraded ucm and
-- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm
-- release).
ref = Just "v4"
},
sbh = Nothing,
path = Path.fromText t
}

33
unison-cli/src/Unison/Codebase/TranscriptParser.hs
View File

@ -33,19 +33,24 @@ import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Network.HTTP.Client as HTTP
import System.Directory (doesFileExist)
import System.Environment (lookupEnv)
import System.Exit (die)
import qualified System.IO as IO
import System.IO.Error (catchIOError)
import qualified Text.Megaparsec as P
import qualified Unison.Auth.CredentialManager as AuthN
import qualified Unison.Auth.HTTPClient as AuthN
import qualified Unison.Auth.Tokens as AuthN
import Unison.Codebase (Codebase)
import qualified Unison.Codebase as Codebase
import qualified Unison.Codebase.Branch as Branch
import Unison.Codebase.Editor.Command (LoadSourceResult (..), UCMVersion)
import Unison.Codebase.Editor.Command (LoadSourceResult (..))
import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand
import qualified Unison.Codebase.Editor.HandleInput as HandleInput
import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState
import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..))
import qualified Unison.Codebase.Editor.Output as Output
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import qualified Unison.Codebase.Path as Path
import qualified Unison.Codebase.Path.Parse as Path
import qualified Unison.Codebase.Runtime as Runtime
@ -70,6 +75,13 @@ import Prelude hiding (readFile, writeFile)
terminalWidth :: Pretty.Width
terminalWidth = 65
-- | If provided, this access token will be used on all
-- requests which use the Authenticated HTTP Client; i.e. all codeserver interactions.
--
-- It's useful in scripted contexts or when running transcripts against a codeserver.
accessTokenEnvVarKey :: String
accessTokenEnvVarKey = "UNISON_SHARE_ACCESS_TOKEN"
type ExpectingError = Bool
type ScratchFileName = Text
@ -218,6 +230,15 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do
]
root <- Codebase.getRootBranch codebase
do
mayShareAccessToken <- fmap Text.pack <$> lookupEnv accessTokenEnvVarKey
credMan <- AuthN.newCredentialManager
let tokenProvider :: AuthN.TokenProvider
tokenProvider =
case mayShareAccessToken of
Nothing -> do
AuthN.newTokenProvider credMan
Just accessToken ->
\_codeserverID -> pure $ Right accessToken
pathRef <- newIORef initialPath
rootBranchRef <- newIORef root
numberedArgsRef <- newIORef []
@ -360,6 +381,7 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do
let f = LoadSuccess <$> readUtf8 (Text.unpack name)
in f <|> pure InvalidSourceNameError
print :: Output.Output Symbol -> IO ()
print o = do
msg <- notifyUser dir o
errOk <- readIORef allowErrors
@ -370,6 +392,7 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do
then writeIORef hasErrors True
else dieWithMsg rendered
printNumbered :: Output.NumberedOutput Symbol -> IO Output.NumberedArgs
printNumbered o = do
let (msg, numberedArgs) = notifyNumbered o
errOk <- readIORef allowErrors
@ -419,12 +442,14 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do
"The transcript was expecting an error in the stanza above, but did not encounter one."
]
loop state = do
authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient print tokenProvider ucmVersion
let loop state = do
writeIORef pathRef (view LoopState.currentPath state)
let env =
LoopState.Env
{ LoopState.authHTTPClient = error "Error: No access to authorized requests from transcripts.",
LoopState.credentialManager = error "Error: No access to credentials from transcripts."
{ LoopState.authHTTPClient = authenticatedHTTPClient,
LoopState.codebase = codebase,
LoopState.credentialManager = credMan
}
let free = LoopState.runAction env state $ HandleInput.loop
rng i = pure $ Random.drgNewSeed (Random.seedFromInteger (fromIntegral i))

110
unison-cli/src/Unison/CommandLine/InputPatterns.hs
View File

@ -22,7 +22,7 @@ import qualified Unison.Codebase.Branch.Merge as Branch
import qualified Unison.Codebase.Branch.Names as Branch
import Unison.Codebase.Editor.Input (Input)
import qualified Unison.Codebase.Editor.Input as Input
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemotePath, WriteRepo)
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemotePath)
import qualified Unison.Codebase.Editor.SlurpResult as SR
import qualified Unison.Codebase.Editor.UriParser as UriParser
import qualified Unison.Codebase.Path as Path
@ -998,7 +998,7 @@ pullImpl name verbosity pullMode addendum = do
name
[]
I.Visible
[(Optional, gitUrlArg), (Optional, namespaceArg)]
[(Optional, remoteNamespaceArg), (Optional, namespaceArg)]
( P.lines
[ P.wrap
"The"
@ -1017,8 +1017,7 @@ pullImpl name verbosity pullMode addendum = do
),
( makeExample' self,
"merges the remote namespace configured in `.unisonConfig`"
<> "with the key `GitUrl.ns` where `ns` is the current namespace,"
<> "into the current namespace"
<> "at the key `RemoteMappings.<namespace>` where `<namespace>` is the current namespace,"
)
],
"",
@ -1029,10 +1028,10 @@ pullImpl name verbosity pullMode addendum = do
[] ->
Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.ShortCircuit pullMode verbosity
[url] -> do
ns <- parseUri "url" url
ns <- parseReadRemoteNamespace "remote-namespace" url
Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.ShortCircuit pullMode verbosity
[url, path] -> do
ns <- parseUri "url" url
ns <- parseReadRemoteNamespace "remote-namespace" url
p <- first fromString $ Path.parsePath' path
Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.ShortCircuit pullMode verbosity
_ -> Left (I.help self)
@ -1044,7 +1043,7 @@ pullExhaustive =
"debug.pull-exhaustive"
[]
I.Visible
[(Required, gitUrlArg), (Optional, namespaceArg)]
[(Required, remoteNamespaceArg), (Optional, namespaceArg)]
( P.lines
[ P.wrap $
"The " <> makeExample' pullExhaustive <> "command can be used in place of"
@ -1058,10 +1057,10 @@ pullExhaustive =
[] ->
Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.Complete Input.PullWithHistory Verbosity.Default
[url] -> do
ns <- parseUri "url" url
ns <- parseReadRemoteNamespace "remote-namespace" url
Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.Complete Input.PullWithHistory Verbosity.Default
[url, path] -> do
ns <- parseUri "url" url
ns <- parseReadRemoteNamespace "remote-namespace" url
p <- first fromString $ Path.parsePath' path
Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.Complete Input.PullWithHistory Verbosity.Default
_ -> Left (I.help pull)
@ -1073,7 +1072,7 @@ push =
"push"
[]
I.Visible
[(Required, gitUrlArg), (Optional, namespaceArg)]
[(Required, remoteNamespaceArg), (Optional, namespaceArg)]
( P.lines
[ P.wrap
"The `push` command merges a local namespace into a remote namespace.",
@ -1087,9 +1086,8 @@ push =
"publishes the current namespace into the remote namespace `remote`"
),
( "`push`",
"publishes the current namespace"
<> "into the remote namespace configured in `.unisonConfig`"
<> "with the key `GitUrl.ns` where `ns` is the current namespace"
"publishes the current namespace into the remote namespace configured in your `.unisonConfig`"
<> "at the key `RemoteMappings.<namespace>` where `<namespace>` is the current namespace."
)
],
"",
@ -1100,12 +1098,12 @@ push =
[] ->
Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireNonEmpty SyncMode.ShortCircuit
url : rest -> do
(repo, path) <- parsePushPath "url" url
pushPath <- parseWriteRemotePath "remote-path" url
p <- case rest of
[] -> Right Path.relativeEmpty'
[path] -> first fromString $ Path.parsePath' path
_ -> Left (I.help push)
Right $ Input.PushRemoteBranchI (Just (repo, path)) p PushBehavior.RequireNonEmpty SyncMode.ShortCircuit
Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireNonEmpty SyncMode.ShortCircuit
)
pushCreate :: InputPattern
@ -1114,7 +1112,7 @@ pushCreate =
"push.create"
[]
I.Visible
[(Required, gitUrlArg), (Optional, namespaceArg)]
[(Required, remoteNamespaceArg), (Optional, namespaceArg)]
( P.lines
[ P.wrap
"The `push.create` command pushes a local namespace to an empty remote namespace.",
@ -1128,9 +1126,9 @@ pushCreate =
"publishes the current namespace into the empty remote namespace `remote`"
),
( "`push`",
"publishes the current namespace"
<> "into the empty remote namespace configured in `.unisonConfig`"
<> "with the key `GitUrl.ns` where `ns` is the current namespace"
"publishes the current namespace into the remote namespace configured in your `.unisonConfig`"
<> "at the key `RemoteMappings.<namespace>` where `<namespace>` is the current namespace,"
<> "then publishes the current namespace to that location."
)
],
"",
@ -1141,12 +1139,12 @@ pushCreate =
[] ->
Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireEmpty SyncMode.ShortCircuit
url : rest -> do
(repo, path) <- parsePushPath "url" url
pushPath <- parseWriteRemotePath "remote-path" url
p <- case rest of
[] -> Right Path.relativeEmpty'
[path] -> first fromString $ Path.parsePath' path
_ -> Left (I.help push)
Right $ Input.PushRemoteBranchI (Just (repo, path)) p PushBehavior.RequireEmpty SyncMode.ShortCircuit
Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireEmpty SyncMode.ShortCircuit
)
pushExhaustive :: InputPattern
@ -1155,7 +1153,7 @@ pushExhaustive =
"debug.push-exhaustive"
[]
I.Visible
[(Required, gitUrlArg), (Optional, namespaceArg)]
[(Required, remoteNamespaceArg), (Optional, namespaceArg)]
( P.lines
[ P.wrap $
"The " <> makeExample' pushExhaustive <> "command can be used in place of"
@ -1169,12 +1167,12 @@ pushExhaustive =
[] ->
Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireNonEmpty SyncMode.Complete
url : rest -> do
(repo, path) <- parsePushPath "url" url
pushPath <- parseWriteRemotePath "remote-path" url
p <- case rest of
[] -> Right Path.relativeEmpty'
[path] -> first fromString $ Path.parsePath' path
_ -> Left (I.help push)
Right $ Input.PushRemoteBranchI (Just (repo, path)) p PushBehavior.RequireNonEmpty SyncMode.Complete
Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireNonEmpty SyncMode.Complete
)
createPullRequest :: InputPattern
@ -1183,7 +1181,7 @@ createPullRequest =
"pull-request.create"
["pr.create"]
I.Visible
[(Required, gitUrlArg), (Required, gitUrlArg), (Optional, namespaceArg)]
[(Required, remoteNamespaceArg), (Required, remoteNamespaceArg), (Optional, namespaceArg)]
( P.group $
P.lines
[ P.wrap $
@ -1201,8 +1199,8 @@ createPullRequest =
)
( \case
[baseUrl, headUrl] -> do
baseRepo <- parseUri "baseRepo" baseUrl
headRepo <- parseUri "headRepo" headUrl
baseRepo <- parseReadRemoteNamespace "base-remote-namespace" baseUrl
headRepo <- parseReadRemoteNamespace "head-remote-namespace" headUrl
pure $ Input.CreatePullRequestI baseRepo headRepo
_ -> Left (I.help createPullRequest)
)
@ -1213,7 +1211,7 @@ loadPullRequest =
"pull-request.load"
["pr.load"]
I.Visible
[(Required, gitUrlArg), (Required, gitUrlArg), (Optional, namespaceArg)]
[(Required, remoteNamespaceArg), (Required, remoteNamespaceArg), (Optional, namespaceArg)]
( P.lines
[ P.wrap $
makeExample loadPullRequest ["base", "head"]
@ -1228,19 +1226,19 @@ loadPullRequest =
)
( \case
[baseUrl, headUrl] -> do
baseRepo <- parseUri "baseRepo" baseUrl
headRepo <- parseUri "topicRepo" headUrl
baseRepo <- parseReadRemoteNamespace "base-remote-namespace" baseUrl
headRepo <- parseReadRemoteNamespace "head-remote-namespace" headUrl
pure $ Input.LoadPullRequestI baseRepo headRepo Path.relativeEmpty'
[baseUrl, headUrl, dest] -> do
baseRepo <- parseUri "baseRepo" baseUrl
headRepo <- parseUri "topicRepo" headUrl
baseRepo <- parseReadRemoteNamespace "base-remote-namespace" baseUrl
headRepo <- parseReadRemoteNamespace "head-remote-namespace" headUrl
destPath <- first fromString $ Path.parsePath' dest
pure $ Input.LoadPullRequestI baseRepo headRepo destPath
_ -> Left (I.help loadPullRequest)
)
parseUri :: String -> String -> Either (P.Pretty P.ColorText) ReadRemoteNamespace
parseUri label input =
parseReadRemoteNamespace :: String -> String -> Either (P.Pretty P.ColorText) ReadRemoteNamespace
parseReadRemoteNamespace label input =
let printError err = P.lines [P.string "I couldn't parse the repository address given above.", prettyPrintParseError input err]
in first printError (P.parse UriParser.repoPath label (Text.pack input))
@ -1279,17 +1277,17 @@ prettyPrintParseError input errBundle =
message = [expected] <> catMaybes [found]
in P.oxfordCommasWith "." message
parseWriteRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteRepo
parseWriteRepo label input = do
parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo
parseWriteGitRepo label input = do
first
(fromString . show) -- turn any parsing errors into a Pretty.
(P.parse UriParser.writeRepo label (Text.pack input))
(P.parse UriParser.writeGitRepo label (Text.pack input))
parsePushPath :: String -> String -> Either (P.Pretty P.ColorText) WriteRemotePath
parsePushPath label input = do
parseWriteRemotePath :: String -> String -> Either (P.Pretty P.ColorText) WriteRemotePath
parseWriteRemotePath label input = do
first
(fromString . show) -- turn any parsing errors into a Pretty.
(P.parse UriParser.writeRepoPath label (Text.pack input))
(P.parse UriParser.writeRemotePath label (Text.pack input))
squashMerge :: InputPattern
squashMerge =
@ -2032,7 +2030,7 @@ gist =
)
( \case
[repoString] -> do
repo <- parseWriteRepo "repo" repoString
repo <- parseWriteGitRepo "repo" repoString
pure (Input.GistI (Input.GistInput repo))
_ -> Left (showPatternHelp gist)
)
@ -2345,12 +2343,30 @@ gitUrlArg =
suggestions =
let complete s = pure [Completion s s False]
in \input _ _ _ -> case input of
"gh" -> complete "https://github.com/"
"gl" -> complete "https://gitlab.com/"
"bb" -> complete "https://bitbucket.com/"
"ghs" -> complete "git@github.com:"
"gls" -> complete "git@gitlab.com:"
"bbs" -> complete "git@bitbucket.com:"
"gh" -> complete "git(https://github.com/"
"gl" -> complete "git(https://gitlab.com/"
"bb" -> complete "git(https://bitbucket.com/"
"ghs" -> complete "git(git@github.com:"
"gls" -> complete "git(git@gitlab.com:"
"bbs" -> complete "git(git@bitbucket.com:"
_ -> pure [],
globTargets = mempty
}
-- | Refers to a namespace on some remote code host.
remoteNamespaceArg :: ArgumentType
remoteNamespaceArg =
ArgumentType
{ typeName = "remote-namespace",
suggestions =
let complete s = pure [Completion s s False]
in \input _ _ _ -> case input of
"gh" -> complete "git(https://github.com/"
"gl" -> complete "git(https://gitlab.com/"
"bb" -> complete "git(https://bitbucket.com/"
"ghs" -> complete "git(git@github.com:"
"gls" -> complete "git(git@gitlab.com:"
"bbs" -> complete "git(git@bitbucket.com:"
_ -> pure [],
globTargets = mempty
}

Some files were not shown because too many files have changed in this diff Show More