gitcache (empty) → 0.1

raw patch · 5 files changed

+187/−0 lines, 5 filesdep +basedep +cryptohashdep +directorysetup-changed

Dependencies added: base, cryptohash, directory, filepath, process, utf8-string

Files

LICENSE +27/−0
README.md +9/−0
Setup.hs +2/−0
gitcache.cabal +32/−0
src/gitcache.hs +117/−0

+ LICENSE view

@@ -0,0 +1,27 @@+Copyright (c) 2014 Vincent Hanquez <vincent@snarc.org>++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.

+ README.md view

@@ -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)

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ gitcache.cabal view

@@ -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 <vincent@snarc.org>+Author:              Vincent Hanquez <vincent@snarc.org>+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

+ src/gitcache.hs view

@@ -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 <command>"+            mapM_ putStrLn+                [ "  clone <url>"+                , "  clone github <user> <repo>"+                , "  list"+                , "  update"+                ]