diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2014 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +gitcache +======= + +[![Build Status](https://travis-ci.org/vincenthz/hs-gitcache.png?branch=master)](https://travis-ci.org/vincenthz/hs-gitcache) +[![BSD](http://b.repl.ca/v1/license-BSD-blue.png)](http://en.wikipedia.org/wiki/BSD_licenses) +[![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org) + + +Documentation: [gitcache on hackage](http://hackage.haskell.org/package/gitcache) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gitcache.cabal b/gitcache.cabal new file mode 100644 --- /dev/null +++ b/gitcache.cabal @@ -0,0 +1,32 @@ +Name: gitcache +Version: 0.1 +Synopsis: Simple git utility to use and manage clone cache +Description: +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: vincent@snarc.org +Category: Tools +Stability: experimental +Build-Type: Simple +Homepage: https://github.com/vincenthz/hs-gitcache +Bug-Reports: https://github.com/vincenthz/hs-gitcache/issues +Cabal-Version: >=1.10 +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/vincenthz/hs-gitcache + +Executable gitcache + Main-Is: gitcache.hs + ghc-options: -Wall -fno-warn-missing-signatures + Hs-Source-Dirs: src + Build-depends: base >= 4 && < 5 + , process + , filepath + , directory + , utf8-string + , cryptohash + default-language: Haskell2010 diff --git a/src/gitcache.hs b/src/gitcache.hs new file mode 100644 --- /dev/null +++ b/src/gitcache.hs @@ -0,0 +1,117 @@ +#!/usr/bin/runhaskell +-- +-- Simple git overlay that cache repository locally to the user, +-- for faster cloning and updating +-- +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Data.List +import Data.Char +import Control.Applicative +import Control.Monad +import System.Environment +import System.Directory +import System.FilePath +import System.Process +import System.Exit +import "cryptohash" Crypto.Hash +import qualified Data.ByteString.UTF8 as UTF8 + +urlToHash :: String -> String +urlToHash url = show (hash (UTF8.fromString url) :: Digest SHA1) + +urlToName :: String -> String +urlToName s = reverse $ fst $ break (== '/') $ reverse s + +rawSystemEC s l = do + ec <- rawSystem s l + case ec of + ExitSuccess -> return () + ExitFailure i -> error ("call: " ++ intercalate " " (s : l) ++ " exit with " ++ show i) + +withSetDirectory newDir f = do + old <- getCurrentDirectory + setCurrentDirectory newDir + _ <- f + setCurrentDirectory old + +-- update everything in a cache repository +updateRepo repoDir = + withSetDirectory repoDir $ + rawSystemEC "git" [ "fetch", "--all" ] + +cloneRepo inDir destName url = + withSetDirectory inDir $ + rawSystemEC "git" [ "clone", "--mirror", url, destName ] + +cloneUrl gitCacheDir url pushUrl = do + let destName = urlToHash url + destDir = gitCacheDir destName + clonedAlready <- doesDirectoryExist destDir + if clonedAlready + then updateRepo destDir + else cloneRepo gitCacheDir destName url + -- and clone locally and replace the origin url + rawSystemEC "git" [ "clone", destDir, urlToName url ] + withSetDirectory (urlToName url) $ do + rawSystemEC "git" [ "remote", "set-url", "origin", url ] + maybe (return ()) (\purl -> rawSystemEC "git" [ "remote", "set-url", "origin", "--push", purl]) pushUrl + +getRepoUrl gitCacheDir repoDir = + getOriginUrl . lines <$> readFile (gitCacheDir repoDir "config") + where + getOriginUrl ("[remote \"origin\"]":l) = + stripSpaces . drop 5 . stripSpaces <$> findUrl l + getOriginUrl (_:xs) = getOriginUrl xs + getOriginUrl [] = Nothing + + findUrl = find (isPrefixOf "url =" . stripSpaces) + stripSpaces = dropWhile isSpace + +showRepoUrl gitCacheDir repoDir = do + url <- getRepoUrl gitCacheDir repoDir + putStrLn (repoDir ++ ": " ++ maybe "error: cannot determine 'url'" id url) + +listCacheRepos gitCacheDir = + filter (not . flip elem [".",".."]) <$> getDirectoryContents gitCacheDir + +initialization = do + gitCacheDir <- getGitCacheDir + mapM_ expectedDirectory [ gitCacheDir ] + return gitCacheDir + where + expectedDirectory :: FilePath -> IO () + expectedDirectory = createDirectoryIfMissing False + + getGitCacheDir = flip () ".gitcache" <$> getEnv "HOME" + +main = do + args <- getArgs + gitCacheDir <- initialization + case args of + "clone":"github":user:repo:[] -> do + cloneUrl gitCacheDir + ("https://github.com/" ++ user ++ "/" ++ repo) + (Just ("git@github.com:" ++ user ++ "/" ++ repo)) + "clone":url:[] -> + cloneUrl gitCacheDir url Nothing + "list":[] -> do + repos <- listCacheRepos gitCacheDir + mapM_ (showRepoUrl gitCacheDir) repos + "update":[] -> do + repos <- listCacheRepos gitCacheDir + let nbRepos = length repos + forM_ (zip [1..] repos) $ \(i :: Int,repo) -> do + url <- getRepoUrl gitCacheDir repo + putStrLn ("updating " ++ show i ++ "/" ++ show nbRepos ++ " " ++ maybe "" id url) + updateRepo (gitCacheDir repo) + _ -> do + putStrLn "usage: gitcache " + mapM_ putStrLn + [ " clone " + , " clone github " + , " list" + , " update" + ]