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