Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
...
Checking mergeability… Don't worry, you can still create the pull request.
  • 7 commits
  • 23 files changed
  • 0 commit comments
  • 2 contributors
View
1  .gitignore
@@ -1,3 +1,4 @@
+tmp
*.hi
*.o
github-backup
View
4 Common.hs
@@ -3,7 +3,7 @@ module Common (module X) where
import Control.Monad as X hiding (join)
import Control.Monad.IfElse as X
import Control.Applicative as X
-import Control.Monad.State as X (liftIO)
+import Control.Monad.State.Strict as X (liftIO)
import Control.Exception.Extensible as X (IOException)
import Data.Maybe as X
@@ -21,9 +21,11 @@ import System.Posix.Process as X hiding (executeFile)
import System.Exit as X
import Utility.Misc as X
+import Utility.Exception as X
import Utility.SafeCommand as X
import Utility.Path as X
import Utility.Directory as X
import Utility.Monad as X
+import Utility.FileSystemEncoding as X
import Utility.PartialPrelude as X
View
42 Git.hs
@@ -24,15 +24,18 @@ module Git (
gitDir,
configTrue,
attributes,
+ hookPath,
assertLocal,
) where
import qualified Data.Map as M
import Data.Char
import Network.URI (uriPath, uriScheme, unEscapeString)
+import System.Posix.Files
import Common
import Git.Types
+import Utility.FileMode
{- User-visible description of a git repo. -}
repoDescribe :: Repo -> String
@@ -79,30 +82,44 @@ repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r
repoIsLocalBare _ = False
assertLocal :: Repo -> a -> a
-assertLocal repo action =
- if not $ repoIsUrl repo
- then action
- else error $ "acting on non-local git repo " ++ repoDescribe repo ++
- " not supported"
+assertLocal repo action
+ | repoIsUrl repo = error $ unwords
+ [ "acting on non-local git repo"
+ , repoDescribe repo
+ , "not supported"
+ ]
+ | otherwise = action
+
configBare :: Repo -> Bool
-configBare repo = maybe unknown configTrue $ M.lookup "core.bare" $ config repo
+configBare repo = maybe unknown (fromMaybe False . configTrue) $
+ M.lookup "core.bare" $ config repo
where
unknown = error $ "it is not known if git repo " ++
repoDescribe repo ++
" is a bare repository; config not read"
{- Path to a repository's gitattributes file. -}
-attributes :: Repo -> String
+attributes :: Repo -> FilePath
attributes repo
| configBare repo = workTree repo ++ "/info/.gitattributes"
| otherwise = workTree repo ++ "/.gitattributes"
{- Path to a repository's .git directory. -}
-gitDir :: Repo -> String
+gitDir :: Repo -> FilePath
gitDir repo
| configBare repo = workTree repo
| otherwise = workTree repo </> ".git"
+{- Path to a given hook script in a repository, only if the hook exists
+ - and is executable. -}
+hookPath :: String -> Repo -> IO (Maybe FilePath)
+hookPath script repo = do
+ let hook = gitDir repo </> "hooks" </> script
+ ifM (catchBoolIO $ isexecutable hook)
+ ( return $ Just hook , return Nothing )
+ where
+ isexecutable f = isExecutable . fileMode <$> getFileStatus f
+
{- Path to a repository's --work-tree, that is, its top.
-
- Note that for URL repositories, this is the path on the remote host. -}
@@ -112,5 +129,10 @@ workTree Repo { location = Dir d } = d
workTree Repo { location = Unknown } = undefined
{- Checks if a string from git config is a true value. -}
-configTrue :: String -> Bool
-configTrue s = map toLower s == "true"
+configTrue :: String -> Maybe Bool
+configTrue s
+ | s' == "true" = Just True
+ | s' == "false" = Just False
+ | otherwise = Nothing
+ where
+ s' = map toLower s
View
25 Git/Branch.hs
@@ -7,8 +7,6 @@
module Git.Branch where
-import qualified Data.ByteString.Lazy.Char8 as L
-
import Common
import Git
import Git.Sha
@@ -19,15 +17,15 @@ current :: Repo -> IO (Maybe Git.Ref)
current r = parse <$> pipeRead [Param "symbolic-ref", Param "HEAD"] r
where
parse v
- | L.null v = Nothing
- | otherwise = Just $ Git.Ref $ firstLine $ L.unpack v
+ | null v = Nothing
+ | otherwise = Just $ Git.Ref $ firstLine v
{- Checks if the second branch has any commits not present on the first
- branch. -}
changed :: Branch -> Branch -> Repo -> IO Bool
changed origbranch newbranch repo
| origbranch == newbranch = return False
- | otherwise = not . L.null <$> diffs
+ | otherwise = not . null <$> diffs
where
diffs = pipeRead
[ Param "log"
@@ -43,14 +41,14 @@ changed origbranch newbranch repo
-}
fastForward :: Branch -> [Ref] -> Repo -> IO Bool
fastForward _ [] _ = return True
-fastForward branch (first:rest) repo = do
+fastForward branch (first:rest) repo =
-- First, check that the branch does not contain any
-- new commits that are not in the first ref. If it does,
-- cannot fast-forward.
- diverged <- changed first branch repo
- if diverged
- then no_ff
- else maybe no_ff do_ff =<< findbest first rest
+ ifM (changed first branch repo)
+ ( no_ff
+ , maybe no_ff do_ff =<< findbest first rest
+ )
where
no_ff = return False
do_ff to = do
@@ -73,15 +71,14 @@ fastForward branch (first:rest) repo = do
- with the specified parent refs, and returns the committed sha -}
commit :: String -> Branch -> [Ref] -> Repo -> IO Sha
commit message branch parentrefs repo = do
- tree <- getSha "write-tree" $ asString $
+ tree <- getSha "write-tree" $
pipeRead [Param "write-tree"] repo
- sha <- getSha "commit-tree" $ asString $
+ sha <- getSha "commit-tree" $
ignorehandle $ pipeWriteRead
(map Param $ ["commit-tree", show tree] ++ ps)
- (L.pack message) repo
+ message repo
run "update-ref" [Param $ show branch, Param $ show sha] repo
return sha
where
ignorehandle a = snd <$> a
- asString a = L.unpack <$> a
ps = concatMap (\r -> ["-p", show r]) parentrefs
View
37 Git/Command.hs
@@ -7,7 +7,10 @@
module Git.Command where
-import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.Text.Lazy as L
+import qualified Data.Text.Lazy.IO as L
+import Control.Concurrent
+import Control.Exception (finally)
import Common
import Git
@@ -31,48 +34,46 @@ runBool subcommand params repo = assertLocal repo $
run :: String -> [CommandParam] -> Repo -> IO ()
run subcommand params repo = assertLocal repo $
unlessM (runBool subcommand params repo) $
- error $ "git " ++ show params ++ " failed"
+ error $ "git " ++ subcommand ++ " " ++ show params ++ " failed"
{- Runs a git subcommand and returns its output, lazily.
-
- Note that this leaves the git process running, and so zombies will
- result unless reap is called.
-}
-pipeRead :: [CommandParam] -> Repo -> IO L.ByteString
+pipeRead :: [CommandParam] -> Repo -> IO String
pipeRead params repo = assertLocal repo $ do
(_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo
- hSetBinaryMode h True
- L.hGetContents h
+ fileEncoding h
+ hGetContents h
{- Runs a git subcommand, feeding it input.
- You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
-pipeWrite :: [CommandParam] -> L.ByteString -> Repo -> IO PipeHandle
+pipeWrite :: [CommandParam] -> L.Text -> Repo -> IO PipeHandle
pipeWrite params s repo = assertLocal repo $ do
(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)
- L.hPut h s
+ L.hPutStr h s
hClose h
return p
{- Runs a git subcommand, feeding it input, and returning its output.
- You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
-pipeWriteRead :: [CommandParam] -> L.ByteString -> Repo -> IO (PipeHandle, L.ByteString)
+pipeWriteRead :: [CommandParam] -> String -> Repo -> IO (PipeHandle, String)
pipeWriteRead params s repo = assertLocal repo $ do
(p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo)
- hSetBinaryMode from True
- L.hPut to s
- hClose to
- c <- L.hGetContents from
+ fileEncoding to
+ fileEncoding from
+ _ <- forkIO $ finally (hPutStr to s) (hClose to)
+ c <- hGetContents from
return (p, c)
{- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it. -}
pipeNullSplit :: [CommandParam] -> Repo -> IO [String]
-pipeNullSplit params repo = map L.unpack <$> pipeNullSplitB params repo
-
-{- For when Strings are not needed. -}
-pipeNullSplitB ::[CommandParam] -> Repo -> IO [L.ByteString]
-pipeNullSplitB params repo = filter (not . L.null) . L.split '\0' <$>
- pipeRead params repo
+pipeNullSplit params repo =
+ filter (not . null) . split sep <$> pipeRead params repo
+ where
+ sep = "\0"
{- Reaps any zombie git processes. -}
reap :: IO ()
View
13 Git/Config.hs
@@ -26,16 +26,15 @@ getMaybe key repo = M.lookup key (config repo)
{- Runs git config and populates a repo with its config. -}
read :: Repo -> IO Repo
-read repo@(Repo { location = Dir d }) = do
+read repo@(Repo { location = Dir d }) = bracketcd d $
{- Cannot use pipeRead because it relies on the config having
been already read. Instead, chdir to the repo. -}
- cwd <- getCurrentDirectory
- if dirContains d cwd
- then go
- else bracket_ (changeWorkingDirectory d) (changeWorkingDirectory cwd) go
+ pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ hRead repo
where
- go = pOpen ReadFromPipe "git" ["config", "--null", "--list"] $
- hRead repo
+ bracketcd to a = bracketcd' to a =<< getCurrentDirectory
+ bracketcd' to a cwd
+ | dirContains to cwd = a
+ | otherwise = bracket_ (changeWorkingDirectory to) (changeWorkingDirectory cwd) a
read r = assertLocal r $
error $ "internal error; trying to read config of " ++ show r
View
59 Git/Construct.hs
@@ -69,27 +69,25 @@ fromPath dir = fromAbsPath =<< absPath dir
- specified. -}
fromAbsPath :: FilePath -> IO Repo
fromAbsPath dir
- | "/" `isPrefixOf` dir = do
- -- Git always looks for "dir.git" in preference to
- -- to "dir", even if dir ends in a "/".
- let canondir = dropTrailingPathSeparator dir
- let dir' = canondir ++ ".git"
- e <- doesDirectoryExist dir'
- if e
- then ret dir'
- else if "/.git" `isSuffixOf` canondir
- then do
- -- When dir == "foo/.git", git looks
- -- for "foo/.git/.git", and failing
- -- that, uses "foo" as the repository.
- e' <- doesDirectoryExist $ dir </> ".git"
- if e'
- then ret dir
- else ret $ takeDirectory canondir
- else ret dir
- | otherwise = error $ "internal error, " ++ dir ++ " is not absolute"
+ | "/" `isPrefixOf` dir =
+ ifM (doesDirectoryExist dir') ( ret dir' , hunt )
+ | otherwise =
+ error $ "internal error, " ++ dir ++ " is not absolute"
where
ret = newFrom . Dir
+ {- Git always looks for "dir.git" in preference to
+ - to "dir", even if dir ends in a "/". -}
+ canondir = dropTrailingPathSeparator dir
+ dir' = canondir ++ ".git"
+ {- When dir == "foo/.git", git looks for "foo/.git/.git",
+ - and failing that, uses "foo" as the repository. -}
+ hunt
+ | "/.git" `isSuffixOf` canondir =
+ ifM (doesDirectoryExist $ dir </> ".git")
+ ( ret dir
+ , ret $ takeDirectory canondir
+ )
+ | otherwise = ret dir
{- Remote Repo constructor. Throws exception on invalid url.
-
@@ -229,27 +227,20 @@ expandTilde = expandt True
| otherwise = findname (n++[c]) cs
seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath)
-seekUp want dir = do
- ok <- want dir
- if ok
- then return $ Just dir
- else case parentDir dir of
+seekUp want dir =
+ ifM (want dir)
+ ( return $ Just dir
+ , case parentDir dir of
"" -> return Nothing
d -> seekUp want d
+ )
isRepoTop :: FilePath -> IO Bool
-isRepoTop dir = do
- r <- isRepo
- if r
- then return r
- else isBareRepo
+isRepoTop dir = ifM isRepo ( return True , isBareRepo )
where
isRepo = gitSignature (".git" </> "config")
- isBareRepo = do
- e <- doesDirectoryExist (dir </> "objects")
- if not e
- then return e
- else gitSignature "config"
+ isBareRepo = ifM (doesDirectoryExist $ dir </> "objects")
+ ( gitSignature "config" , return False )
gitSignature file = doesFileExist (dir </> file)
newFrom :: RepoLocation -> IO Repo
View
38 Git/Queue.hs
@@ -5,21 +5,23 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE BangPatterns #-}
+
module Git.Queue (
Queue,
new,
add,
size,
full,
- flush
+ flush,
) where
import qualified Data.Map as M
import System.IO
import System.Cmd.Utils
import Data.String.Utils
-import Utility.SafeCommand
+import Utility.SafeCommand
import Common
import Git
import Git.Command
@@ -34,7 +36,11 @@ data Action = Action
{- A queue of actions to perform (in any order) on a git repository,
- with lists of files to perform them on. This allows coalescing
- similar git commands. -}
-data Queue = Queue Int (M.Map Action [FilePath])
+data Queue = Queue
+ { size :: Int
+ , _limit :: Int
+ , _items :: M.Map Action [FilePath]
+ }
deriving (Show, Eq)
{- A recommended maximum size for the queue, after which it should be
@@ -46,37 +52,33 @@ data Queue = Queue Int (M.Map Action [FilePath])
- above 20k, so this is a fairly good balance -- the queue will buffer
- only a few megabytes of stuff and a minimal number of commands will be
- run by xargs. -}
-maxSize :: Int
-maxSize = 10240
+defaultLimit :: Int
+defaultLimit = 10240
{- Constructor for empty queue. -}
-new :: Queue
-new = Queue 0 M.empty
+new :: Maybe Int -> Queue
+new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
{- Adds an action to a queue. -}
add :: Queue -> String -> [CommandParam] -> [FilePath] -> Queue
-add (Queue n m) subcommand params files = Queue (n + 1) m'
+add (Queue cur lim m) subcommand params files = Queue (cur + 1) lim m'
where
action = Action subcommand params
-- There are probably few items in the map, but there
-- can be a lot of files per item. So, optimise adding
-- files.
m' = M.insertWith' const action fs m
- fs = files ++ M.findWithDefault [] action m
-
-{- Number of items in a queue. -}
-size :: Queue -> Int
-size (Queue n _) = n
+ !fs = files ++ M.findWithDefault [] action m
{- Is a queue large enough that it should be flushed? -}
full :: Queue -> Bool
-full (Queue n _) = n > maxSize
+full (Queue cur lim _) = cur > lim
{- Runs a queue on a git repository. -}
flush :: Queue -> Repo -> IO Queue
-flush (Queue _ m) repo = do
+flush (Queue _ lim m) repo = do
forM_ (M.toList m) $ uncurry $ runAction repo
- return new
+ return $ Queue 0 lim M.empty
{- Runs an Action on a list of files in a git repository.
-
@@ -90,4 +92,6 @@ runAction repo action files =
where
params = toCommand $ gitCommandLine
(Param (getSubcommand action):getParams action) repo
- feedxargs h = hPutStr h $ join "\0" files
+ feedxargs h = do
+ fileEncoding h
+ hPutStr h $ join "\0" files
View
6 Git/Ref.hs
@@ -7,8 +7,6 @@
module Git.Ref where
-import qualified Data.ByteString.Lazy.Char8 as L
-
import Common
import Git
import Git.Command
@@ -40,7 +38,7 @@ exists ref = runBool "show-ref"
{- Get the sha of a fully qualified git ref, if it exists. -}
sha :: Branch -> Repo -> IO (Maybe Sha)
-sha branch repo = process . L.unpack <$> showref repo
+sha branch repo = process <$> showref repo
where
showref = pipeRead [Param "show-ref",
Param "--hash", -- get the hash
@@ -52,7 +50,7 @@ sha branch repo = process . L.unpack <$> showref repo
matching :: Ref -> Repo -> IO [(Ref, Branch)]
matching ref repo = do
r <- pipeRead [Param "show-ref", Param $ show ref] repo
- return $ map (gen . L.unpack) (L.lines r)
+ return $ map gen (lines r)
where
gen l = let (r, b) = separate (== ' ') l in
(Ref r, Ref b)
View
7 Makefile
@@ -1,12 +1,12 @@
PREFIX=/usr
-BASEFLAGS=-Wall
+BASEFLAGS=-Wall -outputdir tmp
GHCFLAGS=-O2 $(BASEFLAGS)
bins=github-backup
mans=github-backup.1
all=$(bins)
ifdef PROFILE
-GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp
+GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp $(BASEFLAGS)
endif
GHCMAKE=ghc $(GHCFLAGS) --make
@@ -32,7 +32,6 @@ install: all
install -m 0644 $(mans) $(DESTDIR)$(PREFIX)/share/man/man1
clean:
- rm -f $(bins)
- find . \( -name \*.o -or -name \*.hi \) -exec rm {} \;
+ rm -f $(bins) tmp
.PHONY: $(bins)
View
4 README.md
@@ -1,7 +1,7 @@
github-backup is a simple tool you run in a git repository you cloned from
GitHub. It backs up everything GitHub publishes about the repository,
-including other forks, issues, comments, wikis, milestones, pull requests,
-and watchers.
+including branches, tags, other forks, issues, comments, wikis, milestones,
+pull requests, and watchers.
## Installation
View
19 Utility/Directory.hs
@@ -13,14 +13,26 @@ import System.Directory
import Control.Exception (throw)
import Control.Monad
import Control.Monad.IfElse
+import System.FilePath
+import Control.Applicative
import Utility.SafeCommand
import Utility.TempFile
+import Utility.Exception
+
+{- Lists the contents of a directory.
+ - Unlike getDirectoryContents, paths are not relative to the directory. -}
+dirContents :: FilePath -> IO [FilePath]
+dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d
+ where
+ notcruft "." = False
+ notcruft ".." = False
+ notcruft _ = True
{- Moves one filename to another.
- First tries a rename, but falls back to moving across devices if needed. -}
moveFile :: FilePath -> FilePath -> IO ()
-moveFile src dest = try (rename src dest) >>= onrename
+moveFile src dest = tryIO (rename src dest) >>= onrename
where
onrename (Right _) = return ()
onrename (Left e)
@@ -40,11 +52,10 @@ moveFile src dest = try (rename src dest) >>= onrename
Param src, Param tmp]
unless ok $ do
-- delete any partial
- _ <- try $
- removeFile tmp
+ _ <- tryIO $ removeFile tmp
rethrow
isdir f = do
- r <- try (getFileStatus f)
+ r <- tryIO $ getFileStatus f
case r of
(Left _) -> return False
(Right s) -> return $ isDirectory s
View
39 Utility/Exception.hs
@@ -0,0 +1,39 @@
+{- Simple IO exception handling
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Exception where
+
+import Prelude hiding (catch)
+import Control.Exception
+import Control.Applicative
+
+{- Catches IO errors and returns a Bool -}
+catchBoolIO :: IO Bool -> IO Bool
+catchBoolIO a = catchDefaultIO a False
+
+{- Catches IO errors and returns a Maybe -}
+catchMaybeIO :: IO a -> IO (Maybe a)
+catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing
+
+{- Catches IO errors and returns a default value. -}
+catchDefaultIO :: IO a -> a -> IO a
+catchDefaultIO a def = catchIO a (const $ return def)
+
+{- Catches IO errors and returns the error message. -}
+catchMsgIO :: IO a -> IO (Either String a)
+catchMsgIO a = dispatch <$> tryIO a
+ where
+ dispatch (Left e) = Left $ show e
+ dispatch (Right v) = Right v
+
+{- catch specialized for IO errors only -}
+catchIO :: IO a -> (IOException -> IO a) -> IO a
+catchIO = catch
+
+{- try specialized for IO errors only -}
+tryIO :: IO a -> IO (Either IOException a)
+tryIO = try
View
43 Utility/FileMode.hs
@@ -0,0 +1,43 @@
+{- File mode utilities.
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.FileMode where
+
+import System.Posix.Files
+import System.Posix.Types
+import Foreign (complement)
+
+{- Removes a FileMode from a file.
+ - For example, call with otherWriteMode to chmod o-w -}
+unsetFileMode :: FilePath -> FileMode -> IO ()
+unsetFileMode f m = do
+ s <- getFileStatus f
+ setFileMode f $ fileMode s `intersectFileModes` complement m
+
+{- Removes the write bits from a file. -}
+preventWrite :: FilePath -> IO ()
+preventWrite f = unsetFileMode f writebits
+ where
+ writebits = foldl unionFileModes ownerWriteMode
+ [groupWriteMode, otherWriteMode]
+
+{- Turns a file's write bit back on. -}
+allowWrite :: FilePath -> IO ()
+allowWrite f = do
+ s <- getFileStatus f
+ setFileMode f $ fileMode s `unionFileModes` ownerWriteMode
+
+{- Checks if a file mode indicates it's a symlink. -}
+isSymLink :: FileMode -> Bool
+isSymLink mode = symbolicLinkMode `intersectFileModes` mode == symbolicLinkMode
+
+{- Checks if a file has any executable bits set. -}
+isExecutable :: FileMode -> Bool
+isExecutable mode = ebits `intersectFileModes` mode /= 0
+ where
+ ebits = ownerExecuteMode `unionFileModes`
+ groupExecuteMode `unionFileModes` otherExecuteMode
View
43 Utility/FileSystemEncoding.hs
@@ -0,0 +1,43 @@
+{- GHC File system encoding handling.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.FileSystemEncoding where
+
+import qualified GHC.Foreign as GHC
+import qualified GHC.IO.Encoding as Encoding
+import Foreign.C
+import System.IO
+import System.IO.Unsafe
+import qualified Data.Hash.MD5 as MD5
+
+{- Sets a Handle to use the filesystem encoding. This causes data
+ - written or read from it to be encoded/decoded the same
+ - as ghc 7.4 does to filenames etc. This special encoding
+ - allows "arbitrary undecodable bytes to be round-tripped through it". -}
+fileEncoding :: Handle -> IO ()
+fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding
+
+{- Marshal a Haskell FilePath into a NUL terminated C string using temporary
+ - storage. The FilePath is encoded using the filesystem encoding,
+ - reversing the decoding that should have been done when the FilePath
+ - was obtained. -}
+withFilePath :: FilePath -> (CString -> IO a) -> IO a
+withFilePath fp f = Encoding.getFileSystemEncoding
+ >>= \enc -> GHC.withCString enc fp f
+
+{- Encodes a FilePath into a Str, applying the filesystem encoding.
+ -
+ - This use of unsafePerformIO is belived to be safe; GHC's interface
+ - only allows doing this conversion with CStrings, and the CString buffer
+ - is allocated, used, and deallocated within the call, with no side
+ - effects.
+ -}
+{-# NOINLINE encodeFilePath #-}
+encodeFilePath :: FilePath -> MD5.Str
+encodeFilePath fp = MD5.Str $ unsafePerformIO $ do
+ enc <- Encoding.getFileSystemEncoding
+ GHC.withCString enc fp $ GHC.peekCString Encoding.char8
View
21 Utility/Misc.hs
@@ -8,9 +8,7 @@
module Utility.Misc where
import System.IO
-import System.IO.Error (try)
import Control.Monad
-import Control.Applicative
{- A version of hgetContents that is not lazy. Ensures file is
- all read before it gets closed. -}
@@ -37,22 +35,3 @@ separate c l = unbreak $ break c l
{- Breaks out the first line. -}
firstLine :: String-> String
firstLine = takeWhile (/= '\n')
-
-{- Catches IO errors and returns a Bool -}
-catchBoolIO :: IO Bool -> IO Bool
-catchBoolIO a = catchDefaultIO a False
-
-{- Catches IO errors and returns a Maybe -}
-catchMaybeIO :: IO a -> IO (Maybe a)
-catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing
-
-{- Catches IO errors and returns a default value. -}
-catchDefaultIO :: IO a -> a -> IO a
-catchDefaultIO a def = catch a (const $ return def)
-
-{- Catches IO errors and returns the error message. -}
-catchMsgIO :: IO a -> IO (Either String a)
-catchMsgIO a = dispatch <$> try a
- where
- dispatch (Left e) = Left $ show e
- dispatch (Right v) = Right v
View
14 Utility/Monad.hs
@@ -1,6 +1,6 @@
{- monadic stuff
-
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -14,11 +14,7 @@ import Control.Monad (liftM)
- predicate -}
firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
firstM _ [] = return Nothing
-firstM p (x:xs) = do
- q <- p x
- if q
- then return (Just x)
- else firstM p xs
+firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)
{- Returns true if any value in the list satisfies the predicate,
- stopping once one is found. -}
@@ -29,6 +25,12 @@ anyM p = liftM isJust . firstM p
untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool
untilTrue = flip anyM
+{- if with a monadic conditional. -}
+ifM :: Monad m => m Bool -> (m a, m a) -> m a
+ifM cond (thenclause, elseclause) = do
+ c <- cond
+ if c then thenclause else elseclause
+
{- Runs an action, passing its value to an observer before returning it. -}
observe :: Monad m => (a -> m b) -> m a -> m a
observe observer a = do
View
20 Utility/Path.hs
@@ -82,7 +82,7 @@ relPathDirToFile from to = join s $ dotdots ++ uncommon
s = [pathSeparator]
pfrom = split s from
pto = split s to
- common = map fst $ filter same $ zip pfrom pto
+ common = map fst $ takeWhile same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".."
@@ -95,6 +95,15 @@ prop_relPathDirToFile_basics from to
where
r = relPathDirToFile from to
+prop_relPathDirToFile_regressionTest :: Bool
+prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
+ where
+ {- Two paths have the same directory component at the same
+ - location, but it's not really the same directory.
+ - Code used to get this wrong. -}
+ same_dir_shortcurcuits_at_difference =
+ relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo"
+
{- Given an original list of files, and an expanded list derived from it,
- ensures that the original list's ordering is preserved.
-
@@ -119,15 +128,6 @@ preserveOrder (l:ls) new = found ++ preserveOrder ls rest
runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
runPreserveOrder a files = preserveOrder files <$> a files
-{- Lists the contents of a directory.
- - Unlike getDirectoryContents, paths are not relative to the directory. -}
-dirContents :: FilePath -> IO [FilePath]
-dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d
- where
- notcruft "." = False
- notcruft ".." = False
- notcruft _ = True
-
{- Current user's home directory. -}
myHomeDir :: IO FilePath
myHomeDir = homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID)
View
2  Utility/TempFile.hs
@@ -12,7 +12,7 @@ import System.IO
import System.Posix.Process hiding (executeFile)
import System.Directory
-import Utility.Misc
+import Utility.Exception
import Utility.Path
{- Runs an action like writeFile, writing to a temp file first and
View
2  debian/control
@@ -12,7 +12,7 @@ Build-Depends:
Maintainer: Joey Hess <joeyh@debian.org>
Standards-Version: 3.9.3
Vcs-Git: git://github.com/joeyh/github-backup.git
-Homepage: http://guthub.com/joeyh/github-backup
+Homepage: http://github.com/joeyh/github-backup
Package: github-backup
Architecture: any
View
4 github-backup.1
@@ -8,8 +8,8 @@ github-backup \- backs up data from GitHub
.I github-backup
is a simple tool you run in a git repository you cloned from
GitHub. It backs up everything GitHub publishes about the repository,
-including other forks, issues, comments, wikis, milestones, pull requests,
-and watchers.
+including other branches, tags, forks, issues, comments, wikis,
+milestones, pull requests, and watchers.
.PP
Alternately, if you pass it the username of a GitHub user, it will check
out, and back up, all that user's repositories. (Also works to pass
View
2  github-backup.cabal
@@ -25,7 +25,7 @@ Description:
Executable github-backup
Main-Is: github-backup.hs
Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,
- network, extensible-exceptions, unix, bytestring, base < 5,
+ network, extensible-exceptions, unix, bytestring, base >= 4.5, base < 5,
IfElse, pretty-show, github >= 0.2.1
source-repository head
View
29 github-backup.hs
@@ -270,10 +270,10 @@ onGithubBranch r a = bracket prep cleanup (const a)
when (oldbranch == Just branchref) $
error $ "it's not currently safe to run github-backup while the " ++
branchname ++ " branch is checked out!"
- exists <- Git.Ref.matching branchref r
- if null exists
- then checkout [Param "--orphan", Param branchname]
- else checkout [Param branchname]
+ ifM (null <$> Git.Ref.matching branchref r)
+ ( checkout [Param "--orphan", Param branchname]
+ , checkout [Param branchname]
+ )
return oldbranch
cleanup Nothing = return ()
cleanup (Just oldbranch)
@@ -301,33 +301,34 @@ commitWorkDir = do
removeDirectoryRecursive dir
updateWiki :: GithubUserRepo -> Backup ()
-updateWiki fork = do
- remotes <- Git.remotes <$> getState gitRepo
- if any (\r -> Git.remoteName r == Just remote) remotes
- then do
+updateWiki fork =
+ ifM (any (\r -> Git.remoteName r == Just remote) <$> remotes)
+ ( do
_ <- fetchwiki
return ()
- else do
+ , do
-- github often does not really have a wiki,
-- don't bloat config if there is none
unlessM (addRemote remote $ repoWikiUrl fork) $
removeRemote remote
return ()
+ )
where
fetchwiki = inRepo $ Git.Command.runBool "fetch" [Param remote]
+ remotes = Git.remotes <$> getState gitRepo
remote = remoteFor fork
remoteFor (GithubUserRepo user repo) =
"github_" ++ user ++ "_" ++ repo ++ ".wiki"
addFork :: GithubUserRepo -> Backup Bool
-addFork fork = do
- remotes <- gitHubRemotes
- if fork `elem` remotes
- then return False
- else do
+addFork fork =
+ ifM (elem fork <$> gitHubRemotes)
+ ( return False
+ , do
liftIO $ putStrLn $ "New fork: " ++ repoUrl fork
_ <- addRemote (remoteFor fork) (repoUrl fork)
return True
+ )
where
remoteFor (GithubUserRepo user repo) =
"github_" ++ user ++ "_" ++ repo

No commit comments for this range

Something went wrong with that request. Please try again.