remove Read instance for Ref
Removed instance, got it all to build using fromRef. (With a few things that really need to show something using a ref for debugging stubbed out.) Then added back Read instance, and made Logs.View use it for serialization. This changes the view log format.
This commit is contained in:
parent
eb7b8747f9
commit
4e0be2792b
32 changed files with 101 additions and 104 deletions
|
@ -58,11 +58,11 @@ name = Git.Ref "git-annex"
|
|||
|
||||
{- Fully qualified name of the branch. -}
|
||||
fullname :: Git.Ref
|
||||
fullname = Git.Ref $ "refs/heads/" ++ show name
|
||||
fullname = Git.Ref $ "refs/heads/" ++ fromRef name
|
||||
|
||||
{- Branch's name in origin. -}
|
||||
originname :: Git.Ref
|
||||
originname = Git.Ref $ "origin/" ++ show name
|
||||
originname = Git.Ref $ "origin/" ++ fromRef name
|
||||
|
||||
{- Does origin/git-annex exist? -}
|
||||
hasOrigin :: Annex Bool
|
||||
|
@ -87,8 +87,8 @@ getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
|
|||
where
|
||||
go True = do
|
||||
inRepo $ Git.Command.run
|
||||
[Param "branch", Param $ show name, Param $ show originname]
|
||||
fromMaybe (error $ "failed to create " ++ show name)
|
||||
[Param "branch", Param $ fromRef name, Param $ fromRef originname]
|
||||
fromMaybe (error $ "failed to create " ++ fromRef name)
|
||||
<$> branchsha
|
||||
go False = withIndex' True $
|
||||
inRepo $ Git.Branch.commitAlways "branch created" fullname []
|
||||
|
@ -154,7 +154,7 @@ updateTo pairs = do
|
|||
then "update"
|
||||
else "merging " ++
|
||||
unwords (map Git.Ref.describe branches) ++
|
||||
" into " ++ show name
|
||||
" into " ++ fromRef name
|
||||
localtransitions <- parseTransitionsStrictly "local"
|
||||
<$> getLocal transitionsLog
|
||||
unless (null branches) $ do
|
||||
|
@ -291,7 +291,7 @@ files = do
|
|||
branchFiles :: Annex [FilePath]
|
||||
branchFiles = withIndex $ inRepo $ Git.Command.pipeNullSplitZombie
|
||||
[ Params "ls-tree --name-only -r -z"
|
||||
, Param $ show fullname
|
||||
, Param $ fromRef fullname
|
||||
]
|
||||
|
||||
{- Populates the branch's index file with the current branch contents.
|
||||
|
@ -368,7 +368,7 @@ needUpdateIndex branchref = do
|
|||
setIndexSha :: Git.Ref -> Annex ()
|
||||
setIndexSha ref = do
|
||||
f <- fromRepo gitAnnexIndexStatus
|
||||
liftIO $ writeFile f $ show ref ++ "\n"
|
||||
liftIO $ writeFile f $ fromRef ref ++ "\n"
|
||||
setAnnexFilePerm f
|
||||
|
||||
{- Stages the journal into the index and returns an action that will
|
||||
|
@ -442,7 +442,7 @@ ignoreRefs rs = do
|
|||
let s = S.unions [old, S.fromList rs]
|
||||
f <- fromRepo gitAnnexIgnoredRefs
|
||||
replaceFile f $ \tmp -> liftIO $ writeFile tmp $
|
||||
unlines $ map show $ S.elems s
|
||||
unlines $ map fromRef $ S.elems s
|
||||
|
||||
getIgnoredRefs :: Annex (S.Set Git.Ref)
|
||||
getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content
|
||||
|
|
|
@ -286,18 +286,18 @@ setDirect wantdirect = do
|
|||
- this way things that show HEAD (eg shell prompts) will
|
||||
- hopefully show just "master". -}
|
||||
directBranch :: Ref -> Ref
|
||||
directBranch orighead = case split "/" $ show orighead of
|
||||
directBranch orighead = case split "/" $ fromRef orighead of
|
||||
("refs":"heads":"annex":"direct":_) -> orighead
|
||||
("refs":"heads":rest) ->
|
||||
Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
|
||||
_ -> Ref $ "refs/heads/" ++ show (Git.Ref.base orighead)
|
||||
_ -> Ref $ "refs/heads/" ++ fromRef (Git.Ref.base orighead)
|
||||
|
||||
{- Converts a directBranch back to the original branch.
|
||||
-
|
||||
- Any other ref is left unchanged.
|
||||
-}
|
||||
fromDirectBranch :: Ref -> Ref
|
||||
fromDirectBranch directhead = case split "/" $ show directhead of
|
||||
fromDirectBranch directhead = case split "/" $ fromRef directhead of
|
||||
("refs":"heads":"annex":"direct":rest) ->
|
||||
Ref $ "refs/heads/" ++ intercalate "/" rest
|
||||
_ -> directhead
|
||||
|
|
|
@ -35,11 +35,11 @@ toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes
|
|||
[ Just "refs/synced"
|
||||
, Just $ fromUUID u
|
||||
, toB64 <$> info
|
||||
, Just $ show $ Git.Ref.base b
|
||||
, Just $ Git.fromRef $ Git.Ref.base b
|
||||
]
|
||||
|
||||
fromTaggedBranch :: Git.Branch -> Maybe (UUID, Maybe String)
|
||||
fromTaggedBranch b = case split "/" $ show b of
|
||||
fromTaggedBranch b = case split "/" $ Git.fromRef b of
|
||||
("refs":"synced":u:info:_base) ->
|
||||
Just (toUUID u, fromB64Maybe info)
|
||||
("refs":"synced":u:_base) ->
|
||||
|
@ -58,4 +58,4 @@ taggedPush u info branch remote = Git.Command.runBool
|
|||
, Param $ refspec branch
|
||||
]
|
||||
where
|
||||
refspec b = show b ++ ":" ++ show (toTaggedBranch u info b)
|
||||
refspec b = Git.fromRef b ++ ":" ++ Git.fromRef (toTaggedBranch u info b)
|
||||
|
|
|
@ -310,7 +310,7 @@ genViewBranch :: View -> Annex () -> Annex Git.Branch
|
|||
genViewBranch view a = withIndex $ do
|
||||
a
|
||||
let branch = branchView view
|
||||
void $ inRepo $ Git.Branch.commit True (show branch) branch []
|
||||
void $ inRepo $ Git.Branch.commit True (fromRef branch) branch []
|
||||
return branch
|
||||
|
||||
{- Runs an action using the view index file.
|
||||
|
|
|
@ -80,8 +80,8 @@ onChange file
|
|||
mergecurrent (Just current)
|
||||
| equivBranches changedbranch current = do
|
||||
debug
|
||||
[ "merging", show changedbranch
|
||||
, "into", show current
|
||||
[ "merging", Git.fromRef changedbranch
|
||||
, "into", Git.fromRef current
|
||||
]
|
||||
void $ liftAnnex $ Command.Sync.mergeFrom changedbranch
|
||||
mergecurrent _ = noop
|
||||
|
@ -105,12 +105,12 @@ onChange file
|
|||
equivBranches :: Git.Ref -> Git.Ref -> Bool
|
||||
equivBranches x y = base x == base y
|
||||
where
|
||||
base = takeFileName . show
|
||||
base = takeFileName . Git.fromRef
|
||||
|
||||
isAnnexBranch :: FilePath -> Bool
|
||||
isAnnexBranch f = n `isSuffixOf` f
|
||||
where
|
||||
n = '/' : show Annex.Branch.name
|
||||
n = '/' : Git.fromRef Annex.Branch.name
|
||||
|
||||
fileToBranch :: FilePath -> Git.Ref
|
||||
fileToBranch f = Git.Ref $ "refs" </> base
|
||||
|
|
|
@ -32,7 +32,7 @@ data NetMessage
|
|||
| PairingNotification PairStage ClientID UUID
|
||||
-- used for git push over the network messager
|
||||
| Pushing ClientID PushStage
|
||||
deriving (Show, Eq, Ord)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
{- Something used to identify the client, or clients to send the message to. -}
|
||||
type ClientID = Text
|
||||
|
@ -50,7 +50,7 @@ data PushStage
|
|||
| SendPackOutput SequenceNum ByteString
|
||||
-- sent when git receive-pack exits, with its exit code
|
||||
| ReceivePackDone ExitCode
|
||||
deriving (Show, Eq, Ord)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
{- A sequence number. Incremented by one per packet in a sequence,
|
||||
- starting with 1 for the first packet. 0 means sequence numbers are
|
||||
|
|
|
@ -13,6 +13,7 @@ import Assistant.Common
|
|||
import Assistant.Types.NetMessager
|
||||
import Assistant.Pairing
|
||||
import Git.Sha (extractSha)
|
||||
import Git
|
||||
|
||||
import Network.Protocol.XMPP hiding (Node)
|
||||
import Data.Text (Text)
|
||||
|
@ -152,7 +153,7 @@ pushMessage = gitAnnexMessage . encode
|
|||
where
|
||||
encode (CanPush u shas) =
|
||||
gitAnnexTag canPushAttr $ T.pack $ unwords $
|
||||
fromUUID u : map show shas
|
||||
fromUUID u : map fromRef shas
|
||||
encode (PushRequest u) =
|
||||
gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
|
||||
encode (StartingPush u) =
|
||||
|
|
|
@ -140,7 +140,7 @@ getLog key os = do
|
|||
[ Params "log -z --pretty=format:%ct --raw --abbrev=40"
|
||||
, Param "--remove-empty"
|
||||
] ++ os ++
|
||||
[ Param $ show Annex.Branch.fullname
|
||||
[ Param $ Git.fromRef Annex.Branch.fullname
|
||||
, Param "--"
|
||||
, Param logfile
|
||||
]
|
||||
|
|
|
@ -81,4 +81,4 @@ trackingOrSyncBranch :: Ref -> Bool
|
|||
trackingOrSyncBranch b = Git.Repair.isTrackingBranch b || isAnnexSyncBranch b
|
||||
|
||||
isAnnexSyncBranch :: Ref -> Bool
|
||||
isAnnexSyncBranch b = "refs/synced/" `isPrefixOf` show b
|
||||
isAnnexSyncBranch b = "refs/synced/" `isPrefixOf` fromRef b
|
||||
|
|
|
@ -192,12 +192,12 @@ pushLocal (Just branch) = do
|
|||
|
||||
updateBranch :: Git.Ref -> Git.Repo -> IO ()
|
||||
updateBranch syncbranch g =
|
||||
unlessM go $ error $ "failed to update " ++ show syncbranch
|
||||
unlessM go $ error $ "failed to update " ++ Git.fromRef syncbranch
|
||||
where
|
||||
go = Git.Command.runBool
|
||||
[ Param "branch"
|
||||
, Param "-f"
|
||||
, Param $ show $ Git.Ref.base syncbranch
|
||||
, Param $ Git.fromRef $ Git.Ref.base syncbranch
|
||||
] g
|
||||
|
||||
pullRemote :: Remote -> Maybe Git.Ref -> CommandStart
|
||||
|
@ -283,15 +283,15 @@ pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
|
|||
, refspec branch
|
||||
]
|
||||
directpush = Git.Command.runQuiet $ pushparams
|
||||
[show $ Git.Ref.base $ fromDirectBranch branch]
|
||||
[Git.fromRef $ Git.Ref.base $ fromDirectBranch branch]
|
||||
pushparams branches =
|
||||
[ Param "push"
|
||||
, Param $ Remote.name remote
|
||||
] ++ map Param branches
|
||||
refspec b = concat
|
||||
[ show $ Git.Ref.base b
|
||||
[ Git.fromRef $ Git.Ref.base b
|
||||
, ":"
|
||||
, show $ Git.Ref.base $ syncBranch b
|
||||
, Git.fromRef $ Git.Ref.base $ syncBranch b
|
||||
]
|
||||
|
||||
commitAnnex :: CommandStart
|
||||
|
|
|
@ -24,7 +24,7 @@ check :: Annex ()
|
|||
check = do
|
||||
b <- current_branch
|
||||
when (b == Annex.Branch.name) $ error $
|
||||
"cannot uninit when the " ++ show b ++ " branch is checked out"
|
||||
"cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
|
||||
top <- fromRepo Git.repoPath
|
||||
cwd <- liftIO getCurrentDirectory
|
||||
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $
|
||||
|
@ -77,7 +77,7 @@ finish = do
|
|||
-- avoid normal shutdown
|
||||
saveState False
|
||||
inRepo $ Git.Command.run
|
||||
[Param "branch", Param "-D", Param $ show Annex.Branch.name]
|
||||
[Param "branch", Param "-D", Param $ Git.fromRef Annex.Branch.name]
|
||||
liftIO exitSuccess
|
||||
|
||||
{- Keys that were moved out of the annex have a hard link still in the
|
||||
|
|
|
@ -266,7 +266,7 @@ withKeysReferencedInGit a = do
|
|||
map (separate (== ' ')) .
|
||||
lines
|
||||
nubRefs = map (Git.Ref . snd) . nubBy (\(x, _) (y, _) -> x == y)
|
||||
ourbranchend = '/' : show Annex.Branch.name
|
||||
ourbranchend = '/' : Git.fromRef Annex.Branch.name
|
||||
ourbranches (_, b) = not (ourbranchend `isSuffixOf` b)
|
||||
&& not ("refs/synced/" `isPrefixOf` b)
|
||||
addHead headRef refs = case headRef of
|
||||
|
|
|
@ -9,6 +9,7 @@ module Command.VPop where
|
|||
|
||||
import Common.Annex
|
||||
import Command
|
||||
import qualified Git
|
||||
import qualified Git.Command
|
||||
import qualified Git.Ref
|
||||
import Types.View
|
||||
|
@ -41,7 +42,7 @@ start ps = go =<< currentView
|
|||
showOutput
|
||||
inRepo $ Git.Command.runBool
|
||||
[ Param "checkout"
|
||||
, Param $ show $ Git.Ref.base $
|
||||
, Param $ Git.fromRef $ Git.Ref.base $
|
||||
viewParentBranch v
|
||||
]
|
||||
sameparentbranch a b = viewParentBranch a == viewParentBranch b
|
||||
|
|
|
@ -73,7 +73,7 @@ checkoutViewBranch view mkbranch = do
|
|||
showOutput
|
||||
ok <- inRepo $ Git.Command.runBool
|
||||
[ Param "checkout"
|
||||
, Param (show $ Git.Ref.base branch)
|
||||
, Param (Git.fromRef $ Git.Ref.base branch)
|
||||
]
|
||||
when ok $ do
|
||||
setView view
|
||||
|
|
1
Git.hs
1
Git.hs
|
@ -13,6 +13,7 @@
|
|||
module Git (
|
||||
Repo(..),
|
||||
Ref(..),
|
||||
fromRef,
|
||||
Branch,
|
||||
Sha,
|
||||
Tag,
|
||||
|
|
|
@ -28,7 +28,7 @@ current r = do
|
|||
case v of
|
||||
Nothing -> return Nothing
|
||||
Just branch ->
|
||||
ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show branch] r)
|
||||
ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
|
||||
( return Nothing
|
||||
, return v
|
||||
)
|
||||
|
@ -36,7 +36,7 @@ current r = do
|
|||
{- The current branch, which may not really exist yet. -}
|
||||
currentUnsafe :: Repo -> IO (Maybe Git.Ref)
|
||||
currentUnsafe r = parse . firstLine
|
||||
<$> pipeReadStrict [Param "symbolic-ref", Param $ show Git.Ref.headRef] r
|
||||
<$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r
|
||||
where
|
||||
parse l
|
||||
| null l = Nothing
|
||||
|
@ -51,7 +51,7 @@ changed origbranch newbranch repo
|
|||
where
|
||||
diffs = pipeReadStrict
|
||||
[ Param "log"
|
||||
, Param (show origbranch ++ ".." ++ show newbranch)
|
||||
, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
|
||||
, Params "--oneline -n1"
|
||||
] repo
|
||||
|
||||
|
@ -74,7 +74,7 @@ fastForward branch (first:rest) repo =
|
|||
where
|
||||
no_ff = return False
|
||||
do_ff to = do
|
||||
run [Param "update-ref", Param $ show branch, Param $ show to] repo
|
||||
run [Param "update-ref", Param $ fromRef branch, Param $ fromRef to] repo
|
||||
return True
|
||||
findbest c [] = return $ Just c
|
||||
findbest c (r:rs)
|
||||
|
@ -104,14 +104,14 @@ commit allowempty message branch parentrefs repo = do
|
|||
ifM (cancommit tree)
|
||||
( do
|
||||
sha <- getSha "commit-tree" $ pipeWriteRead
|
||||
(map Param $ ["commit-tree", show tree] ++ ps)
|
||||
(map Param $ ["commit-tree", fromRef tree] ++ ps)
|
||||
(Just $ flip hPutStr message) repo
|
||||
update branch sha repo
|
||||
return $ Just sha
|
||||
, return Nothing
|
||||
)
|
||||
where
|
||||
ps = concatMap (\r -> ["-p", show r]) parentrefs
|
||||
ps = concatMap (\r -> ["-p", fromRef r]) parentrefs
|
||||
cancommit tree
|
||||
| allowempty = return True
|
||||
| otherwise = case parentrefs of
|
||||
|
@ -130,8 +130,8 @@ forcePush b = "+" ++ b
|
|||
update :: Branch -> Sha -> Repo -> IO ()
|
||||
update branch sha = run
|
||||
[ Param "update-ref"
|
||||
, Param $ show branch
|
||||
, Param $ show sha
|
||||
, Param $ fromRef branch
|
||||
, Param $ fromRef sha
|
||||
]
|
||||
|
||||
{- Checks out a branch, creating it if necessary. -}
|
||||
|
@ -140,7 +140,7 @@ checkout branch = run
|
|||
[ Param "checkout"
|
||||
, Param "-q"
|
||||
, Param "-B"
|
||||
, Param $ show $ Git.Ref.base branch
|
||||
, Param $ fromRef $ Git.Ref.base branch
|
||||
]
|
||||
|
||||
{- Removes a branch. -}
|
||||
|
@ -149,5 +149,5 @@ delete branch = run
|
|||
[ Param "branch"
|
||||
, Param "-q"
|
||||
, Param "-D"
|
||||
, Param $ show $ Git.Ref.base branch
|
||||
, Param $ fromRef $ Git.Ref.base branch
|
||||
]
|
||||
|
|
|
@ -50,7 +50,7 @@ catFileStop (CatFileHandle p _) = CoProcess.stop p
|
|||
{- Reads a file from a specified branch. -}
|
||||
catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
|
||||
catFile h branch file = catObject h $ Ref $
|
||||
show branch ++ ":" ++ toInternalGitPath file
|
||||
fromRef branch ++ ":" ++ toInternalGitPath file
|
||||
|
||||
{- Uses a running git cat-file read the content of an object.
|
||||
- Objects that do not exist will have "" returned. -}
|
||||
|
@ -60,7 +60,7 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object
|
|||
catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))
|
||||
catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive
|
||||
where
|
||||
query = show object
|
||||
query = fromRef object
|
||||
send to = hPutStrLn to query
|
||||
receive from = do
|
||||
header <- hGetLine from
|
||||
|
@ -72,8 +72,8 @@ catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive
|
|||
_ -> dne
|
||||
| otherwise -> dne
|
||||
_
|
||||
| header == show object ++ " missing" -> dne
|
||||
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
|
||||
| header == fromRef object ++ " missing" -> dne
|
||||
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, query)
|
||||
readcontent objtype bytes from sha = do
|
||||
content <- S.hGet from bytes
|
||||
eatchar '\n' from
|
||||
|
|
|
@ -36,12 +36,12 @@ data DiffTreeItem = DiffTreeItem
|
|||
{- Diffs two tree Refs. -}
|
||||
diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
|
||||
diffTree src dst = getdiff (Param "diff-tree")
|
||||
[Param (show src), Param (show dst)]
|
||||
[Param (fromRef src), Param (fromRef dst)]
|
||||
|
||||
{- Diffs two tree Refs, recursing into sub-trees -}
|
||||
diffTreeRecursive :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
|
||||
diffTreeRecursive src dst = getdiff (Param "diff-tree")
|
||||
[Param "-r", Param (show src), Param (show dst)]
|
||||
[Param "-r", Param (fromRef src), Param (fromRef dst)]
|
||||
|
||||
{- Diffs between a tree and the index. Does nothing if there is not yet a
|
||||
- commit in the repository. -}
|
||||
|
@ -61,7 +61,7 @@ diffIndex' :: Ref -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
|
|||
diffIndex' ref params repo =
|
||||
ifM (Git.Ref.headExists repo)
|
||||
( getdiff (Param "diff-index")
|
||||
( params ++ [Param $ show ref] )
|
||||
( params ++ [Param $ fromRef ref] )
|
||||
repo
|
||||
, return ([], return True)
|
||||
)
|
||||
|
|
|
@ -74,7 +74,7 @@ isMissing s r = either (const True) (const False) <$> tryIO dump
|
|||
where
|
||||
dump = runQuiet
|
||||
[ Param "show"
|
||||
, Param (show s)
|
||||
, Param (fromRef s)
|
||||
] r
|
||||
|
||||
findShas :: Bool -> String -> [Sha]
|
||||
|
|
|
@ -38,13 +38,13 @@ lsTree t repo = map parseLsTree
|
|||
<$> pipeNullSplitZombie (lsTreeParams t) repo
|
||||
|
||||
lsTreeParams :: Ref -> [CommandParam]
|
||||
lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ show t ]
|
||||
lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ]
|
||||
|
||||
{- Lists specified files in a tree. -}
|
||||
lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
|
||||
lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
|
||||
where
|
||||
ps = [Params "ls-tree --full-tree -z --", File $ show t] ++ map File fs
|
||||
ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs
|
||||
|
||||
{- Parses a line of ls-tree output.
|
||||
- (The --long format is not currently supported.) -}
|
||||
|
|
|
@ -15,7 +15,7 @@ import Git.BuildVersion
|
|||
{- Avoids recent git's interactive merge. -}
|
||||
mergeNonInteractive :: Ref -> Repo -> IO Bool
|
||||
mergeNonInteractive branch
|
||||
| older "1.7.7.6" = merge [Param $ show branch]
|
||||
| otherwise = merge [Param "--no-edit", Param $ show branch]
|
||||
| older "1.7.7.6" = merge [Param $ fromRef branch]
|
||||
| otherwise = merge [Param "--no-edit", Param $ fromRef branch]
|
||||
where
|
||||
merge ps = runBool $ Param "merge" : ps
|
||||
|
|
|
@ -32,4 +32,4 @@ listLooseObjectShas r = catchDefaultIO [] $
|
|||
looseObjectFile :: Repo -> Sha -> FilePath
|
||||
looseObjectFile r sha = objectsDir r </> prefix </> rest
|
||||
where
|
||||
(prefix, rest) = splitAt 2 (show sha)
|
||||
(prefix, rest) = splitAt 2 (fromRef sha)
|
||||
|
|
20
Git/Ref.hs
20
Git/Ref.hs
|
@ -20,12 +20,12 @@ headRef = Ref "HEAD"
|
|||
|
||||
{- Converts a fully qualified git ref into a user-visible string. -}
|
||||
describe :: Ref -> String
|
||||
describe = show . base
|
||||
describe = fromRef . base
|
||||
|
||||
{- Often git refs are fully qualified (eg: refs/heads/master).
|
||||
- Converts such a fully qualified ref into a base ref (eg: master). -}
|
||||
base :: Ref -> Ref
|
||||
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
|
||||
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
|
||||
where
|
||||
remove prefix s
|
||||
| prefix `isPrefixOf` s = drop (length prefix) s
|
||||
|
@ -35,13 +35,13 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
|
|||
- it under the directory. -}
|
||||
under :: String -> Ref -> Ref
|
||||
under dir r = Ref $ dir ++ "/" ++
|
||||
(reverse $ takeWhile (/= '/') $ reverse $ show r)
|
||||
(reverse $ takeWhile (/= '/') $ reverse $ fromRef r)
|
||||
|
||||
{- Given a directory such as "refs/remotes/origin", and a ref such as
|
||||
- refs/heads/master, yields a version of that ref under the directory,
|
||||
- such as refs/remotes/origin/master. -}
|
||||
underBase :: String -> Ref -> Ref
|
||||
underBase dir r = Ref $ dir ++ "/" ++ show (base r)
|
||||
underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)
|
||||
|
||||
{- A Ref that can be used to refer to a file in the repository, as staged
|
||||
- in the index.
|
||||
|
@ -64,12 +64,12 @@ fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
|
|||
{- Checks if a ref exists. -}
|
||||
exists :: Ref -> Repo -> IO Bool
|
||||
exists ref = runBool
|
||||
[Param "show-ref", Param "--verify", Param "-q", Param $ show ref]
|
||||
[Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]
|
||||
|
||||
{- The file used to record a ref. (Git also stores some refs in a
|
||||
- packed-refs file.) -}
|
||||
file :: Ref -> Repo -> FilePath
|
||||
file ref repo = localGitDir repo </> show ref
|
||||
file ref repo = localGitDir repo </> fromRef ref
|
||||
|
||||
{- Checks if HEAD exists. It generally will, except for in a repository
|
||||
- that was just created. -}
|
||||
|
@ -84,17 +84,17 @@ sha branch repo = process <$> showref repo
|
|||
where
|
||||
showref = pipeReadStrict [Param "show-ref",
|
||||
Param "--hash", -- get the hash
|
||||
Param $ show branch]
|
||||
Param $ fromRef branch]
|
||||
process [] = Nothing
|
||||
process s = Just $ Ref $ firstLine s
|
||||
|
||||
{- List of (shas, branches) matching a given ref or refs. -}
|
||||
matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
|
||||
matching refs repo = matching' (map show refs) repo
|
||||
matching refs repo = matching' (map fromRef refs) repo
|
||||
|
||||
{- Includes HEAD in the output, if asked for it. -}
|
||||
matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]
|
||||
matchingWithHEAD refs repo = matching' ("--head" : map show refs) repo
|
||||
matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo
|
||||
|
||||
{- List of (shas, branches) matching a given ref or refs. -}
|
||||
matching' :: [String] -> Repo -> IO [(Sha, Branch)]
|
||||
|
@ -114,7 +114,7 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo
|
|||
{- Gets the sha of the tree a ref uses. -}
|
||||
tree :: Ref -> Repo -> IO (Maybe Sha)
|
||||
tree ref = extractSha <$$> pipeReadStrict
|
||||
[ Param "rev-parse", Param (show ref ++ ":") ]
|
||||
[ Param "rev-parse", Param (fromRef ref ++ ":") ]
|
||||
|
||||
{- Checks if a String is a legal git ref name.
|
||||
-
|
||||
|
|
|
@ -18,5 +18,5 @@ get b = mapMaybe extractSha . lines <$$> pipeReadStrict
|
|||
[ Param "log"
|
||||
, Param "-g"
|
||||
, Param "--format=%H"
|
||||
, Param (show b)
|
||||
, Param (fromRef b)
|
||||
]
|
||||
|
|
|
@ -168,7 +168,7 @@ resetLocalBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], [Br
|
|||
resetLocalBranches missing goodcommits r =
|
||||
go [] [] goodcommits =<< filter islocalbranch <$> getAllRefs r
|
||||
where
|
||||
islocalbranch b = "refs/heads/" `isPrefixOf` show b
|
||||
islocalbranch b = "refs/heads/" `isPrefixOf` fromRef b
|
||||
go changed deleted gcs [] = return (changed, deleted, gcs)
|
||||
go changed deleted gcs (b:bs) = do
|
||||
(mc, gcs') <- findUncorruptedCommit missing gcs b r
|
||||
|
@ -185,12 +185,12 @@ resetLocalBranches missing goodcommits r =
|
|||
nukeBranchRef b r
|
||||
void $ runBool
|
||||
[ Param "branch"
|
||||
, Param (show $ Ref.base b)
|
||||
, Param (show c)
|
||||
, Param (fromRef $ Ref.base b)
|
||||
, Param (fromRef c)
|
||||
] r
|
||||
|
||||
isTrackingBranch :: Ref -> Bool
|
||||
isTrackingBranch b = "refs/remotes/" `isPrefixOf` show b
|
||||
isTrackingBranch b = "refs/remotes/" `isPrefixOf` fromRef b
|
||||
|
||||
{- To deal with missing objects that cannot be recovered, removes
|
||||
- any branches (filtered by a predicate) that reference them
|
||||
|
@ -231,10 +231,10 @@ explodePackedRefsFile r = do
|
|||
nukeFile f
|
||||
where
|
||||
makeref (sha, ref) = do
|
||||
let dest = localGitDir r </> show ref
|
||||
let dest = localGitDir r </> fromRef ref
|
||||
createDirectoryIfMissing True (parentDir dest)
|
||||
unlessM (doesFileExist dest) $
|
||||
writeFile dest (show sha)
|
||||
writeFile dest (fromRef sha)
|
||||
|
||||
packedRefsFile :: Repo -> FilePath
|
||||
packedRefsFile r = localGitDir r </> "packed-refs"
|
||||
|
@ -249,7 +249,7 @@ parsePacked l = case words l of
|
|||
{- git-branch -d cannot be used to remove a branch that is directly
|
||||
- pointing to a corrupt commit. -}
|
||||
nukeBranchRef :: Branch -> Repo -> IO ()
|
||||
nukeBranchRef b r = nukeFile $ localGitDir r </> show b
|
||||
nukeBranchRef b r = nukeFile $ localGitDir r </> fromRef b
|
||||
|
||||
{- Finds the most recent commit to a branch that does not need any
|
||||
- of the missing objects. If the input branch is good as-is, returns it.
|
||||
|
@ -268,7 +268,7 @@ findUncorruptedCommit missing goodcommits branch r = do
|
|||
[ Param "log"
|
||||
, Param "-z"
|
||||
, Param "--format=%H"
|
||||
, Param (show branch)
|
||||
, Param (fromRef branch)
|
||||
] r
|
||||
let branchshas = catMaybes $ map extractSha ls
|
||||
reflogshas <- RefLog.get branch r
|
||||
|
@ -297,7 +297,7 @@ verifyCommit missing goodcommits commit r
|
|||
[ Param "log"
|
||||
, Param "-z"
|
||||
, Param "--format=%H %T"
|
||||
, Param (show commit)
|
||||
, Param (fromRef commit)
|
||||
] r
|
||||
let committrees = map parse ls
|
||||
if any isNothing committrees || null committrees
|
||||
|
@ -501,9 +501,9 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
|
|||
, "remote tracking branches that referred to missing objects."
|
||||
]
|
||||
(resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g
|
||||
displayList (map show resetbranches)
|
||||
displayList (map fromRef resetbranches)
|
||||
"Reset these local branches to old versions before the missing objects were committed:"
|
||||
displayList (map show deletedbranches)
|
||||
displayList (map fromRef deletedbranches)
|
||||
"Deleted these local branches, which could not be recovered due to missing objects:"
|
||||
deindexedfiles <- rewriteIndex g
|
||||
displayList deindexedfiles
|
||||
|
@ -519,7 +519,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
|
|||
Just curr -> when (any (== curr) modifiedbranches) $ do
|
||||
putStrLn $ unwords
|
||||
[ "You currently have"
|
||||
, show curr
|
||||
, fromRef curr
|
||||
, "checked out. You may have staged changes in the index that can be committed to recover the lost state of this branch!"
|
||||
]
|
||||
putStrLn "Successfully recovered repository!"
|
||||
|
|
|
@ -47,10 +47,10 @@ type RemoteName = String
|
|||
|
||||
{- A git ref. Can be a sha1, or a branch or tag name. -}
|
||||
newtype Ref = Ref String
|
||||
deriving (Eq, Ord)
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
instance Show Ref where
|
||||
show (Ref v) = v
|
||||
fromRef :: Ref -> String
|
||||
fromRef (Ref s) = s
|
||||
|
||||
{- Aliases for Ref. -}
|
||||
type Branch = Ref
|
||||
|
|
|
@ -79,7 +79,7 @@ lsTree (Ref x) repo streamer = do
|
|||
- a given file with a given sha. -}
|
||||
updateIndexLine :: Sha -> BlobType -> TopFilePath -> String
|
||||
updateIndexLine sha filetype file =
|
||||
show filetype ++ " blob " ++ show sha ++ "\t" ++ indexPath file
|
||||
show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file
|
||||
|
||||
stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer
|
||||
stageFile sha filetype file repo = do
|
||||
|
@ -90,7 +90,7 @@ stageFile sha filetype file repo = do
|
|||
unstageFile :: FilePath -> Repo -> IO Streamer
|
||||
unstageFile file repo = do
|
||||
p <- toTopFilePath file repo
|
||||
return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ indexPath p
|
||||
return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
|
||||
|
||||
{- A streamer that adds a symlink to the index. -}
|
||||
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
|
||||
|
|
|
@ -31,7 +31,7 @@ writeFsckResults u fsckresults = do
|
|||
store s logfile = do
|
||||
createDirectoryIfMissing True (parentDir logfile)
|
||||
liftIO $ viaTmp writeFile logfile $ serialize s
|
||||
serialize = unlines . map show . S.toList
|
||||
serialize = unlines . map fromRef . S.toList
|
||||
|
||||
readFsckResults :: UUID -> Annex FsckResults
|
||||
readFsckResults u = do
|
||||
|
|
17
Logs/View.hs
17
Logs/View.hs
|
@ -24,21 +24,12 @@ import Types.MetaData
|
|||
import qualified Git
|
||||
import qualified Git.Branch
|
||||
import qualified Git.Ref
|
||||
import Git.Types
|
||||
import Utility.Tmp
|
||||
|
||||
import qualified Data.Set as S
|
||||
import Data.Char
|
||||
|
||||
showLog :: View -> String
|
||||
showLog (View branch components) = show branch ++ " " ++ show components
|
||||
|
||||
parseLog :: String -> Maybe View
|
||||
parseLog s =
|
||||
let (branch, components) = separate (== ' ') s
|
||||
in View
|
||||
<$> pure (Git.Ref branch)
|
||||
<*> readish components
|
||||
|
||||
setView :: View -> Annex ()
|
||||
setView v = do
|
||||
old <- take 99 . filter (/= v) <$> recentViews
|
||||
|
@ -47,7 +38,7 @@ setView v = do
|
|||
writeViews :: [View] -> Annex ()
|
||||
writeViews l = do
|
||||
f <- fromRepo gitAnnexViewLog
|
||||
liftIO $ viaTmp writeFile f $ unlines $ map showLog l
|
||||
liftIO $ viaTmp writeFile f $ unlines $ map show l
|
||||
|
||||
removeView :: View -> Annex ()
|
||||
removeView v = writeViews =<< filter (/= v) <$> recentViews
|
||||
|
@ -55,7 +46,7 @@ removeView v = writeViews =<< filter (/= v) <$> recentViews
|
|||
recentViews :: Annex [View]
|
||||
recentViews = do
|
||||
f <- fromRepo gitAnnexViewLog
|
||||
liftIO $ mapMaybe parseLog . lines <$> catchDefaultIO [] (readFile f)
|
||||
liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f)
|
||||
|
||||
{- Gets the currently checked out view, if there is one. -}
|
||||
currentView :: Annex (Maybe View)
|
||||
|
@ -97,4 +88,4 @@ branchView view
|
|||
| otherwise = map (\c -> if isAlphaNum c then c else '_') s
|
||||
|
||||
prop_branchView_legal :: View -> Bool
|
||||
prop_branchView_legal = Git.Ref.legal False . show . branchView
|
||||
prop_branchView_legal = Git.Ref.legal False . fromRef . branchView
|
||||
|
|
|
@ -177,7 +177,7 @@ gCryptSetup mu _ c = go $ M.lookup "gitrepo" c
|
|||
void $ inRepo $ Git.Command.runBool
|
||||
[ Param "push"
|
||||
, Param remotename
|
||||
, Param $ show Annex.Branch.fullname
|
||||
, Param $ Git.fromRef Annex.Branch.fullname
|
||||
]
|
||||
g <- inRepo Git.Config.reRead
|
||||
case Git.GCrypt.remoteRepoId g (Just remotename) of
|
||||
|
|
|
@ -20,7 +20,7 @@ data View = View
|
|||
{ viewParentBranch :: Git.Branch
|
||||
, viewComponents :: [ViewComponent]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
instance Arbitrary View where
|
||||
arbitrary = View <$> pure (Git.Ref "master") <*> arbitrary
|
||||
|
@ -29,7 +29,7 @@ data ViewComponent = ViewComponent
|
|||
{ viewField :: MetaField
|
||||
, viewFilter :: ViewFilter
|
||||
}
|
||||
deriving (Eq, Show, Read)
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
instance Arbitrary ViewComponent where
|
||||
arbitrary = ViewComponent <$> arbitrary <*> arbitrary
|
||||
|
@ -41,7 +41,7 @@ type MkFileView = FilePath -> FileView
|
|||
data ViewFilter
|
||||
= FilterValues (S.Set MetaValue)
|
||||
| FilterGlob String
|
||||
deriving (Eq, Show, Read)
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
instance Arbitrary ViewFilter where
|
||||
arbitrary = do
|
||||
|
|
|
@ -106,7 +106,10 @@ push = do
|
|||
showAction "pushing new git-annex branch to origin"
|
||||
showOutput
|
||||
inRepo $ Git.Command.run
|
||||
[Param "push", Param "origin", Param $ show Annex.Branch.name]
|
||||
[ Param "push"
|
||||
, Param "origin"
|
||||
, Param $ Git.fromRef Annex.Branch.name
|
||||
]
|
||||
_ -> do
|
||||
-- no origin exists, so just let the user
|
||||
-- know about the new branch
|
||||
|
|
Loading…
Reference in a new issue