diff options
| -rw-r--r-- | Annex.hs | 4 | ||||
| -rw-r--r-- | Config.hs | 18 | ||||
| -rw-r--r-- | Crypto.hs | 40 | ||||
| -rw-r--r-- | Init.hs | 10 | ||||
| -rw-r--r-- | Locations.hs | 49 | ||||
| -rw-r--r-- | Messages.hs | 2 | ||||
| -rw-r--r-- | Option.hs | 30 | ||||
| -rw-r--r-- | Remote.hs | 96 | ||||
| -rw-r--r-- | Remote/Git.hs | 356 | ||||
| -rw-r--r-- | doc/coding_style.mdwn | 86 | ||||
| -rw-r--r-- | doc/download.mdwn | 5 |
11 files changed, 395 insertions, 301 deletions
@@ -73,8 +73,8 @@ instance MonadBaseControl IO Annex where liftBaseWith f = Annex $ liftBaseWith $ \runInIO -> f $ liftM StAnnex . runInIO . runAnnex restoreM = Annex . restoreM . unStAnnex - where - unStAnnex (StAnnex st) = st + where + unStAnnex (StAnnex st) = st type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a) @@ -95,24 +95,24 @@ repoSyncable r = fromMaybe True . Git.Config.isTrue - in git config. forcenumcopies overrides everything. -} getNumCopies :: Maybe Int -> Annex Int getNumCopies v = perhaps (use v) =<< Annex.getState Annex.forcenumcopies - where - use (Just n) = return n - use Nothing = perhaps (return 1) =<< - readish <$> getConfig (annexConfig "numcopies") "1" - perhaps fallback = maybe fallback (return . id) + where + use (Just n) = return n + use Nothing = perhaps (return 1) =<< + readish <$> getConfig (annexConfig "numcopies") "1" + perhaps fallback = maybe fallback (return . id) {- Gets the trust level set for a remote in git config. -} getTrustLevel :: Git.Repo -> Annex (Maybe String) getTrustLevel r = fromRepo $ Git.Config.getMaybe key - where - (ConfigKey key) = remoteConfig r "trustlevel" + where + (ConfigKey key) = remoteConfig r "trustlevel" {- Gets annex.diskreserve setting. -} getDiskReserve :: Annex Integer getDiskReserve = fromMaybe megabyte . readSize dataUnits <$> getConfig (annexConfig "diskreserve") "" - where - megabyte = 1000000 + where + megabyte = 1000000 {- Gets annex.httpheaders or annex.httpheaders-command setting, - splitting it into lines. -} @@ -75,16 +75,16 @@ updateEncryptedCipher keyid encipher@(EncryptedCipher _ ks) = do ks' <- Gpg.findPubKeys keyid cipher <- decryptCipher encipher encryptCipher cipher (merge ks ks') - where - merge (KeyIds a) (KeyIds b) = KeyIds $ a ++ b + where + merge (KeyIds a) (KeyIds b) = KeyIds $ a ++ b describeCipher :: StorableCipher -> String describeCipher (SharedCipher _) = "shared cipher" describeCipher (EncryptedCipher _ (KeyIds ks)) = "with gpg " ++ keys ks ++ " " ++ unwords ks - where - keys [_] = "key" - keys _ = "keys" + where + keys [_] = "key" + keys _ = "keys" {- Encrypts a Cipher to the specified KeyIds. -} encryptCipher :: Cipher -> KeyIds -> IO StorableCipher @@ -92,20 +92,20 @@ encryptCipher (Cipher c) (KeyIds ks) = do let ks' = nub $ sort ks -- gpg complains about duplicate recipient keyids encipher <- Gpg.pipeStrict (encrypt++recipients ks') c return $ EncryptedCipher encipher (KeyIds ks') - where - encrypt = [ Params "--encrypt" ] - recipients l = force_recipients : - concatMap (\k -> [Param "--recipient", Param k]) l - -- Force gpg to only encrypt to the specified - -- recipients, not configured defaults. - force_recipients = Params "--no-encrypt-to --no-default-recipient" + where + encrypt = [ Params "--encrypt" ] + recipients l = force_recipients : + concatMap (\k -> [Param "--recipient", Param k]) l + -- Force gpg to only encrypt to the specified + -- recipients, not configured defaults. + force_recipients = Params "--no-encrypt-to --no-default-recipient" {- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -} decryptCipher :: StorableCipher -> IO Cipher decryptCipher (SharedCipher t) = return $ Cipher t decryptCipher (EncryptedCipher t _) = Cipher <$> Gpg.pipeStrict decrypt t - where - decrypt = [ Param "--decrypt" ] + where + decrypt = [ Param "--decrypt" ] {- Generates an encrypted form of a Key. The encryption does not need to be - reversable, nor does it need to be the same type of encryption used @@ -136,8 +136,12 @@ withEncryptedContent = pass withEncryptedHandle withDecryptedContent :: Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a withDecryptedContent = pass withDecryptedHandle -pass :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a) - -> Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a +pass + :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a) + -> Cipher + -> IO L.ByteString + -> (L.ByteString -> IO a) + -> IO a pass to n s a = to n s $ a <=< L.hGetContents hmacWithCipher :: Cipher -> String -> String @@ -148,5 +152,5 @@ hmacWithCipher' c s = showDigest $ hmacSha1 (fromString c) (fromString s) {- Ensure that hmacWithCipher' returns the same thing forevermore. -} prop_hmacWithCipher_sane :: Bool prop_hmacWithCipher_sane = known_good == hmacWithCipher' "foo" "bar" - where - known_good = "46b4ec586117154dacd49d664e5d63fdc88efb51" + where + known_good = "46b4ec586117154dacd49d664e5d63fdc88efb51" @@ -52,11 +52,11 @@ uninitialize = do repos that did not intend to use it. -} ensureInitialized :: Annex () ensureInitialized = getVersion >>= maybe needsinit checkVersion - where - needsinit = ifM Annex.Branch.hasSibling - ( initialize Nothing - , error "First run: git-annex init" - ) + where + needsinit = ifM Annex.Branch.hasSibling + ( initialize Nothing + , error "First run: git-annex init" + ) {- Checks if a repository is initialized. Does not check version for ugrade. -} isInitialized :: Annex Bool diff --git a/Locations.hs b/Locations.hs index 4bb2a2274..3a7c89ea7 100644 --- a/Locations.hs +++ b/Locations.hs @@ -100,10 +100,10 @@ gitAnnexLocation key r - don't need to do any work to check if the file is - present. -} return $ inrepo $ annexLocation key hashDirMixed - where - inrepo d = Git.localGitDir r </> d - check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs - check [] = error "internal" + where + inrepo d = Git.localGitDir r </> d + check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs + check [] = error "internal" {- The annex directory of a repository. -} gitAnnexDir :: Git.Repo -> FilePath @@ -204,8 +204,8 @@ gitAnnexAssistantDefaultDir = "annex" {- Checks a symlink target to see if it appears to point to annexed content. -} isLinkToAnnex :: FilePath -> Bool isLinkToAnnex s = ('/':d) `isInfixOf` s || d `isPrefixOf` s - where - d = ".git" </> objectDir + where + d = ".git" </> objectDir {- Converts a key into a filename fragment without any directory. - @@ -232,8 +232,8 @@ keyFile key = replace "/" "%" $ replace ":" "&c" $ -} keyPath :: Key -> Hasher -> FilePath keyPath key hasher = hasher key </> f </> f - where - f = keyFile key + where + f = keyFile key {- All possibile locations to store a key using different directory hashes. -} keyPaths :: Key -> [FilePath] @@ -249,7 +249,8 @@ fileKey file = file2key $ {- for quickcheck -} prop_idempotent_fileKey :: String -> Bool prop_idempotent_fileKey s = Just k == fileKey (keyFile k) - where k = stubKey { keyName = s, keyBackendName = "test" } + where + k = stubKey { keyName = s, keyBackendName = "test" } {- Two different directory hashes may be used. The mixed case hash - came first, and is fine, except for the problem of case-strict @@ -262,14 +263,14 @@ annexHashes = [hashDirLower, hashDirMixed] hashDirMixed :: Hasher hashDirMixed k = addTrailingPathSeparator $ take 2 dir </> drop 2 dir - where - dir = take 4 $ display_32bits_as_dir =<< [a,b,c,d] - ABCD (a,b,c,d) = md5 $ md5FilePath $ key2file k + where + dir = take 4 $ display_32bits_as_dir =<< [a,b,c,d] + ABCD (a,b,c,d) = md5 $ md5FilePath $ key2file k hashDirLower :: Hasher hashDirLower k = addTrailingPathSeparator $ take 3 dir </> drop 3 dir - where - dir = take 6 $ md5s $ md5FilePath $ key2file k + where + dir = take 6 $ md5s $ md5FilePath $ key2file k {- modified version of display_32bits_as_hex from Data.Hash.MD5 - Copyright (C) 2001 Ian Lynagh @@ -277,13 +278,13 @@ hashDirLower k = addTrailingPathSeparator $ take 3 dir </> drop 3 dir -} display_32bits_as_dir :: Word32 -> String display_32bits_as_dir w = trim $ swap_pairs cs - where - -- Need 32 characters to use. To avoid inaverdently making - -- a real word, use letters that appear less frequently. - chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF" - cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7] - getc n = chars !! fromIntegral n - swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs - swap_pairs _ = [] - -- Last 2 will always be 00, so omit. - trim = take 6 + where + -- Need 32 characters to use. To avoid inaverdently making + -- a real word, use letters that appear less frequently. + chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF" + cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7] + getc n = chars !! fromIntegral n + swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs + swap_pairs _ = [] + -- Last 2 will always be 00, so omit. + trim = take 6 diff --git a/Messages.hs b/Messages.hs index d8d84d1ec..08a17b25c 100644 --- a/Messages.hs +++ b/Messages.hs @@ -84,7 +84,7 @@ showSideAction m = Annex.getState Annex.output >>= go where go (MessageState v StartBlock) = do p - Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock } + Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock } go (MessageState _ InBlock) = return () go _ = p p = handle q $ putStrLn $ "(" ++ m ++ "...)" @@ -46,18 +46,18 @@ common = , Option ['b'] ["backend"] (ReqArg setforcebackend paramName) "specify key-value backend to use" ] - where - setforce v = Annex.changeState $ \s -> s { Annex.force = v } - setfast v = Annex.changeState $ \s -> s { Annex.fast = v } - setauto v = Annex.changeState $ \s -> s { Annex.auto = v } - setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } - setdebug = liftIO $ do - s <- simpledebug - updateGlobalLogger rootLoggerName - (setLevel DEBUG . setHandlers [s]) - simpledebug = setFormatter - <$> streamHandler stderr DEBUG - <*> pure (simpleLogFormatter "[$time] $msg") + where + setforce v = Annex.changeState $ \s -> s { Annex.force = v } + setfast v = Annex.changeState $ \s -> s { Annex.fast = v } + setauto v = Annex.changeState $ \s -> s { Annex.auto = v } + setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } + setdebug = liftIO $ do + s <- simpledebug + updateGlobalLogger rootLoggerName + (setLevel DEBUG . setHandlers [s]) + simpledebug = setFormatter + <$> streamHandler stderr DEBUG + <*> pure (simpleLogFormatter "[$time] $msg") matcher :: [Option] matcher = @@ -67,9 +67,9 @@ matcher = , shortopt "(" "open group of options" , shortopt ")" "close group of options" ] - where - longopt o = Option [] [o] $ NoArg $ addToken o - shortopt o = Option o [] $ NoArg $ addToken o + where + longopt o = Option [] [o] $ NoArg $ addToken o + shortopt o = Option o [] $ NoArg $ addToken o {- An option that sets a flag. -} flag :: String -> String -> String -> Option @@ -80,10 +80,10 @@ byName (Just n) = either error Just <$> byName' n byName' :: String -> Annex (Either String Remote) byName' "" = return $ Left "no remote specified" byName' n = handle . filter matching <$> remoteList - where - handle [] = Left $ "there is no available git remote named \"" ++ n ++ "\"" - handle match = Right $ Prelude.head match - matching r = n == name r || toUUID n == uuid r + where + handle [] = Left $ "there is no available git remote named \"" ++ n ++ "\"" + handle match = Right $ Prelude.head match + matching r = n == name r || toUUID n == uuid r {- Looks up a remote by name (or by UUID, or even by description), - and returns its UUID. Finds even remotes that are not configured in @@ -93,17 +93,17 @@ nameToUUID "." = getUUID -- special case for current repo nameToUUID "here" = getUUID nameToUUID "" = error "no remote specified" nameToUUID n = byName' n >>= go - where - go (Right r) = return $ uuid r - go (Left e) = fromMaybe (error e) <$> bydescription - bydescription = do - m <- uuidMap - case M.lookup n $ transform swap m of - Just u -> return $ Just u - Nothing -> return $ byuuid m - byuuid m = M.lookup (toUUID n) $ transform double m - transform a = M.fromList . map a . M.toList - double (a, _) = (a, a) + where + go (Right r) = return $ uuid r + go (Left e) = fromMaybe (error e) <$> bydescription + bydescription = do + m <- uuidMap + case M.lookup n $ transform swap m of + Just u -> return $ Just u + Nothing -> return $ byuuid m + byuuid m = M.lookup (toUUID n) $ transform double m + transform a = M.fromList . map a . M.toList + double (a, _) = (a, a) {- Pretty-prints a list of UUIDs of remotes, for human display. - @@ -115,23 +115,23 @@ prettyPrintUUIDs desc uuids = do m <- uuidDescriptions maybeShowJSON [(desc, map (jsonify m hereu) uuids)] return $ unwords $ map (\u -> "\t" ++ prettify m hereu u ++ "\n") uuids - where - finddescription m u = M.findWithDefault "" u m - prettify m hereu u - | not (null d) = fromUUID u ++ " -- " ++ d - | otherwise = fromUUID u - where - ishere = hereu == u - n = finddescription m u - d - | null n && ishere = "here" - | ishere = addName n "here" - | otherwise = n - jsonify m hereu u = toJSObject - [ ("uuid", toJSON $ fromUUID u) - , ("description", toJSON $ finddescription m u) - , ("here", toJSON $ hereu == u) - ] + where + finddescription m u = M.findWithDefault "" u m + prettify m hereu u + | not (null d) = fromUUID u ++ " -- " ++ d + | otherwise = fromUUID u + where + ishere = hereu == u + n = finddescription m u + d + | null n && ishere = "here" + | ishere = addName n "here" + | otherwise = n + jsonify m hereu u = toJSObject + [ ("uuid", toJSON $ fromUUID u) + , ("description", toJSON $ finddescription m u) + , ("here", toJSON $ hereu == u) + ] {- List of remote names and/or descriptions, for human display. -} prettyListUUIDs :: [UUID] -> Annex [String] @@ -139,13 +139,13 @@ prettyListUUIDs uuids = do hereu <- getUUID m <- uuidDescriptions return $ map (\u -> prettify m hereu u) uuids - where - finddescription m u = M.findWithDefault "" u m - prettify m hereu u - | u == hereu = addName n "here" - | otherwise = n - where - n = finddescription m u + where + finddescription m u = M.findWithDefault "" u m + prettify m hereu u + | u == hereu = addName n "here" + | otherwise = n + where + n = finddescription m u {- Gets the git repo associated with a UUID. - There's no associated remote when this is the UUID of the local repo. -} @@ -213,12 +213,12 @@ showLocations key exclude = do ppuuidswanted <- Remote.prettyPrintUUIDs "wanted" uuidswanted ppuuidsskipped <- Remote.prettyPrintUUIDs "skipped" uuidsskipped showLongNote $ message ppuuidswanted ppuuidsskipped - where - filteruuids l x = filter (`notElem` x) l - message [] [] = "No other repository is known to contain the file." - message rs [] = "Try making some of these repositories available:\n" ++ rs - message [] us = "Also these untrusted repositories may contain the file:\n" ++ us - message rs us = message rs [] ++ message [] us + where + filteruuids l x = filter (`notElem` x) l + message [] [] = "No other repository is known to contain the file." + message rs [] = "Try making some of these repositories available:\n" ++ rs + message [] us = "Also these untrusted repositories may contain the file:\n" ++ us + message rs us = message rs [] ++ message [] us showTriedRemotes :: [Remote] -> Annex () showTriedRemotes [] = noop @@ -242,6 +242,6 @@ logStatus remote key = logChange key (uuid remote) {- Orders remotes by cost, with ones with the lowest cost grouped together. -} byCost :: [Remote] -> [[Remote]] byCost = map snd . sort . M.toList . costmap - where - costmap = M.fromListWith (++) . map costpair - costpair r = (cost r, [r]) + where + costmap = M.fromListWith (++) . map costpair + costpair r = (cost r, [r]) diff --git a/Remote/Git.hs b/Remote/Git.hs index 334c8144a..24dd9bf80 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -55,15 +55,15 @@ list = do c <- fromRepo Git.config rs <- mapM (tweakurl c) =<< fromRepo Git.remotes mapM configRead rs - where - annexurl n = "remote." ++ n ++ ".annexurl" - tweakurl c r = do - let n = fromJust $ Git.remoteName r - case M.lookup (annexurl n) c of - Nothing -> return r - Just url -> inRepo $ \g -> - Git.Construct.remoteNamed n $ - Git.Construct.fromRemoteLocation url g + where + annexurl n = "remote." ++ n ++ ".annexurl" + tweakurl c r = do + let n = fromJust $ Git.remoteName r + case M.lookup (annexurl n) c of + Nothing -> return r + Just url -> inRepo $ \g -> + Git.Construct.remoteNamed n $ + Git.Construct.fromRemoteLocation url g {- It's assumed to be cheap to read the config of non-URL remotes, so this is - done each time git-annex is run in a way that uses remotes. @@ -85,28 +85,27 @@ repoCheap = not . Git.repoIsUrl gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote gen r u _ = new <$> remoteCost r defcst - where - defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost - new cst = Remote - { uuid = u - , cost = cst - , name = Git.repoDescribe r - , storeKey = copyToRemote r - , retrieveKeyFile = copyFromRemote r - , retrieveKeyFileCheap = copyFromRemoteCheap r - , removeKey = dropKey r - , hasKey = inAnnex r - , hasKeyCheap = repoCheap r - , whereisKey = Nothing - , config = Nothing - , localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r - then Just $ Git.repoPath r - else Nothing - , repo = r - , readonly = Git.repoIsHttp r - , remotetype = remote - } - + where + defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost + new cst = Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = copyToRemote r + , retrieveKeyFile = copyFromRemote r + , retrieveKeyFileCheap = copyFromRemoteCheap r + , removeKey = dropKey r + , hasKey = inAnnex r + , hasKeyCheap = repoCheap r + , whereisKey = Nothing + , config = Nothing + , localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r + then Just $ Git.repoPath r + else Nothing + , repo = r + , readonly = Git.repoIsHttp r + , remotetype = remote + } {- Checks relatively inexpensively if a repository is available for use. -} repoAvail :: Git.Repo -> Annex Bool @@ -149,40 +148,40 @@ tryGitConfigRead r | otherwise = store $ safely $ onLocal r $ do ensureInitialized Annex.getState Annex.repo - where - -- Reading config can fail due to IO error or - -- for other reasons; catch all possible exceptions. - safely a = either (const $ return r) return - =<< liftIO (try a :: IO (Either SomeException Git.Repo)) + where + -- Reading config can fail due to IO error or + -- for other reasons; catch all possible exceptions. + safely a = either (const $ return r) return + =<< liftIO (try a :: IO (Either SomeException Git.Repo)) - pipedconfig cmd params = - withHandle StdoutHandle createProcessSuccess p $ - Git.Config.hRead r - where - p = proc cmd $ toCommand params + pipedconfig cmd params = + withHandle StdoutHandle createProcessSuccess p $ + Git.Config.hRead r + where + p = proc cmd $ toCommand params - pipedsshconfig cmd params = - liftIO (try (pipedconfig cmd params) :: IO (Either SomeException Git.Repo)) + pipedsshconfig cmd params = + liftIO (try (pipedconfig cmd params) :: IO (Either SomeException Git.Repo)) - geturlconfig headers = do - s <- Url.get (Git.repoLocation r ++ "/config") headers - withTempFile "git-annex.tmp" $ \tmpfile h -> do - hPutStr h s - hClose h - safely $ pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] + geturlconfig headers = do + s <- Url.get (Git.repoLocation r ++ "/config") headers + withTempFile "git-annex.tmp" $ \tmpfile h -> do + hPutStr h s + hClose h + safely $ pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] - store = observe $ \r' -> do - g <- gitRepo - let l = Git.remotes g - let g' = g { Git.remotes = exchange l r' } - Annex.changeState $ \s -> s { Annex.repo = g' } + store = observe $ \r' -> do + g <- gitRepo + let l = Git.remotes g + let g' = g { Git.remotes = exchange l r' } + Annex.changeState $ \s -> s { Annex.repo = g' } - exchange [] _ = [] - exchange (old:ls) new - | Git.remoteName old == Git.remoteName new = - new : exchange ls new - | otherwise = - old : exchange ls new + exchange [] _ = [] + exchange (old:ls) new + | Git.remoteName old == Git.remoteName new = + new : exchange ls new + | otherwise = + old : exchange ls new {- Checks if a given remote has the content for a key inAnnex. - If the remote cannot be accessed, or if it cannot determine @@ -193,32 +192,32 @@ inAnnex r key | Git.repoIsHttp r = checkhttp =<< getHttpHeaders | Git.repoIsUrl r = checkremote | otherwise = checklocal - where - checkhttp headers = liftIO $ go undefined $ keyUrls r key - where - go e [] = return $ Left e - go _ (u:us) = do - res <- catchMsgIO $ - Url.check u headers (keySize key) - case res of - Left e -> go e us - v -> return v - checkremote = do - showAction $ "checking " ++ Git.repoDescribe r - onRemote r (check, unknown) "inannex" [Param (key2file key)] [] - where - check c p = dispatch <$> safeSystem c p - dispatch ExitSuccess = Right True - dispatch (ExitFailure 1) = Right False - dispatch _ = unknown - checklocal = guardUsable r unknown $ dispatch <$> check - where - check = liftIO $ catchMsgIO $ onLocal r $ - Annex.Content.inAnnexSafe key - dispatch (Left e) = Left e - dispatch (Right (Just b)) = Right b - dispatch (Right Nothing) = unknown - unknown = Left $ "unable to check " ++ Git.repoDescribe r + where + checkhttp headers = liftIO $ go undefined $ keyUrls r key + where + go e [] = return $ Left e + go _ (u:us) = do + res <- catchMsgIO $ + Url.check u headers (keySize key) + case res of + Left e -> go e us + v -> return v + checkremote = do + showAction $ "checking " ++ Git.repoDescribe r + onRemote r (check, unknown) "inannex" [Param (key2file key)] [] + where + check c p = dispatch <$> safeSystem c p + dispatch ExitSuccess = Right True + dispatch (ExitFailure 1) = Right False + dispatch _ = unknown + checklocal = guardUsable r unknown $ dispatch <$> check + where + check = liftIO $ catchMsgIO $ onLocal r $ + Annex.Content.inAnnexSafe key + dispatch (Left e) = Left e + dispatch (Right (Just b)) = Right b + dispatch (Right Nothing) = unknown + unknown = Left $ "unable to check " ++ Git.repoDescribe r {- Runs an action on a local repository inexpensively, by making an annex - monad using that repository. -} @@ -233,8 +232,8 @@ onLocal r a = do keyUrls :: Git.Repo -> Key -> [String] keyUrls r key = map tourl (annexLocations key) - where - tourl l = Git.repoLocation r ++ "/" ++ l + where + tourl l = Git.repoLocation r ++ "/" ++ l dropKey :: Git.Repo -> Key -> Annex Bool dropKey r key @@ -271,44 +270,44 @@ copyFromRemote r key file dest =<< rsyncParamsRemote r True key dest file | Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest | otherwise = error "copying from non-ssh, non-http repo not supported" - where - {- Feed local rsync's progress info back to the remote, - - by forking a feeder thread that runs - - git-annex-shell transferinfo at the same time - - git-annex-shell sendkey is running. - - - - Note that it actually waits for rsync to indicate - - progress before starting transferinfo, in order - - to ensure ssh connection caching works and reuses - - the connection set up for the sendkey. - - - - Also note that older git-annex-shell does not support - - transferinfo, so stderr is dropped and failure ignored. - -} - feedprogressback a = do - u <- getUUID - let fields = (Fields.remoteUUID, fromUUID u) - : maybe [] (\f -> [(Fields.associatedFile, f)]) file - Just (cmd, params) <- git_annex_shell r "transferinfo" - [Param $ key2file key] fields - v <- liftIO $ newEmptySV - tid <- liftIO $ forkIO $ void $ tryIO $ do - bytes <- readSV v - p <- createProcess $ - (proc cmd (toCommand params)) - { std_in = CreatePipe - , std_err = CreatePipe - } - hClose $ stderrHandle p - let h = stdinHandle p - let send b = do - hPutStrLn h $ show b - hFlush h - send bytes - forever $ - send =<< readSV v - let feeder = writeSV v - bracketIO noop (const $ tryIO $ killThread tid) (a feeder) + where + {- Feed local rsync's progress info back to the remote, + - by forking a feeder thread that runs + - git-annex-shell transferinfo at the same time + - git-annex-shell sendkey is running. + - + - Note that it actually waits for rsync to indicate + - progress before starting transferinfo, in order + - to ensure ssh connection caching works and reuses + - the connection set up for the sendkey. + - + - Also note that older git-annex-shell does not support + - transferinfo, so stderr is dropped and failure ignored. + -} + feedprogressback a = do + u <- getUUID + let fields = (Fields.remoteUUID, fromUUID u) + : maybe [] (\f -> [(Fields.associatedFile, f)]) file + Just (cmd, params) <- git_annex_shell r "transferinfo" + [Param $ key2file key] fields + v <- liftIO $ newEmptySV + tid <- liftIO $ forkIO $ void $ tryIO $ do + bytes <- readSV v + p <- createProcess $ + (proc cmd (toCommand params)) + { std_in = CreatePipe + , std_err = CreatePipe + } + hClose $ stderrHandle p + let h = stdinHandle p + let send b = do + hPutStrLn h $ show b + hFlush h + send bytes + forever $ + send =<< readSV v + let feeder = writeSV v + bracketIO noop (const $ tryIO $ killThread tid) (a feeder) copyFromRemoteCheap :: Git.Repo -> Key -> FilePath -> Annex Bool copyFromRemoteCheap r key file @@ -359,26 +358,26 @@ rsyncHelper callback params = do rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool rsyncOrCopyFile rsyncparams src dest p = ifM (sameDeviceIds src dest) (docopy, dorsync) - where - sameDeviceIds a b = (==) <$> (getDeviceId a) <*> (getDeviceId b) - getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f) - dorsync = rsyncHelper (Just p) $ - rsyncparams ++ [Param src, Param dest] - docopy = liftIO $ bracket - (forkIO $ watchfilesize 0) - (void . tryIO . killThread) - (const $ copyFileExternal src dest) - watchfilesize oldsz = do - threadDelay 500000 -- 0.5 seconds - v <- catchMaybeIO $ - fromIntegral . fileSize - <$> getFileStatus dest - case v of - Just sz - | sz /= oldsz -> do - p sz - watchfilesize sz - _ -> watchfilesize oldsz + where + sameDeviceIds a b = (==) <$> (getDeviceId a) <*> (getDeviceId b) + getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f) + dorsync = rsyncHelper (Just p) $ + rsyncparams ++ [Param src, Param dest] + docopy = liftIO $ bracket + (forkIO $ watchfilesize 0) + (void . tryIO . killThread) + (const $ copyFileExternal src dest) + watchfilesize oldsz = do + threadDelay 500000 -- 0.5 seconds + v <- catchMaybeIO $ + fromIntegral . fileSize + <$> getFileStatus dest + case v of + Just sz + | sz /= oldsz -> do + p sz + watchfilesize sz + _ -> watchfilesize oldsz {- Generates rsync parameters that ssh to the remote and asks it - to either receive or send the key's content. -} @@ -397,44 +396,43 @@ rsyncParamsRemote r sending key file afile = do if sending then return $ o ++ rsyncopts eparam dummy (File file) else return $ o ++ rsyncopts eparam (File file) dummy - where - rsyncopts ps source dest - | end ps == [dashdash] = ps ++ [source, dest] - | otherwise = ps ++ [dashdash, source, dest] - dashdash = Param "--" - -- The rsync shell parameter controls where rsync - -- goes, so the source/dest parameter can be a dummy value, - -- that just enables remote rsync mode. - -- For maximum compatability with some patched rsyncs, - -- the dummy value needs to still contain a hostname, - -- even though this hostname will never be used. - dummy = Param "dummy:" + where + rsyncopts ps source dest + | end ps == [dashdash] = ps ++ [source, dest] + | otherwise = ps ++ [dashdash, source, dest] + dashdash = Param "--" + {- The rsync shell parameter controls where rsync + - goes, so the source/dest parameter can be a dummy value, + - that just enables remote rsync mode. + - For maximum compatability with some patched rsyncs, + - the dummy value needs to still contain a hostname, + - even though this hostname will never be used. -} + dummy = Param "dummy:" rsyncParams :: Git.Repo -> Annex [CommandParam] rsyncParams r = do o <- getRemoteConfig r "rsync-options" "" return $ options ++ map Param (words o) - where - -- --inplace to resume partial files - options = [Params "-p --progress --inplace"] + where + -- --inplace to resume partial files + options = [Params "-p --progress --inplace"] commitOnCleanup :: Git.Repo -> Annex a -> Annex a commitOnCleanup r a = go `after` a - where - go = Annex.addCleanup (Git.repoLocation r) cleanup - cleanup - | not $ Git.repoIsUrl r = liftIO $ onLocal r $ - doQuietSideAction $ - Annex.Branch.commit "update" - | otherwise = void $ do - Just (shellcmd, shellparams) <- - git_annex_shell r "commit" [] [] - - -- Throw away stderr, since the remote may not - -- have a new enough git-annex shell to - -- support committing. - liftIO $ catchMaybeIO $ do - print "!!!!!!!!!!!!!" - withQuietOutput createProcessSuccess $ - proc shellcmd $ - toCommand shellparams + where + go = Annex.addCleanup (Git.repoLocation r) cleanup + cleanup + | not $ Git.repoIsUrl r = liftIO $ onLocal r $ + doQuietSideAction $ + Annex.Branch.commit "update" + | otherwise = void $ do + Just (shellcmd, shellparams) <- + git_annex_shell r "commit" [] [] + + -- Throw away stderr, since the remote may not + -- have a new enough git-annex shell to + -- support committing. + liftIO $ catchMaybeIO $ do + withQuietOutput createProcessSuccess $ + proc shellcmd $ + toCommand shellparams diff --git a/doc/coding_style.mdwn b/doc/coding_style.mdwn new file mode 100644 index 000000000..2d73b37b7 --- /dev/null +++ b/doc/coding_style.mdwn @@ -0,0 +1,86 @@ +If you do nothing else, avoid use of partial functions from the Prelude! +`import Utility.PartialPrelude` helps avoid this by defining conflicting +functions for all the common ones. Also avoid `!!`, it's partial too. + +Use tabs for indentation. The one exception to this rule are +the Hamlet format files in `templates/*`. Hamlet, infuriatingly, refuses +to allow tabs to be used for indentation. + +Code should make sense with any tab stop setting, but 8 space tabs are +the default. With 8 space tabs, code should not exceed 80 characters +per line. (With larger tabs, it may of course.) + +Use spaces for layout. For example, here spaces (indicated with `.` +are used after the initial tab to make the third test line up with +the others. + + when (foo_test || bar_test || + ......some_other_long_test) + print "hi" + +As a special Haskell-specific rule, "where" clauses are indented with two +spaces, rather than a tab. This makes them stand out from the main body +of the function, and avoids excessive indentation of the where cause content. +The definitions within the where clause should be put on separate lines, +each indented with a tab. + + foo = do + foo + bar + foo + where + foo = ... + bar = ... + +Where clauses for instance definitions and modules tend to appear at the end +of a line, rather than on a separate line. + + instance MonadBaseControl IO Annex where + +When a function's type signature needs to be wrapped to another line, +it's typical to switch to displaying one parameter per line. + + foo :: Bar -> Baz -> (Bar -> Baz) -> IO Baz + + foo' + :: Bar + -> Baz + -> (Bar -> Baz) + -> IO Baz + +Note that the "::" then starts its own line. It is not put on the same +line as the function name because then it would not be guaranteed to line +up with the "->" at all tab width settings. Similarly, guards are put +on their own lines: + + splat i + | odd i = error "splat!" + | otherwise = i + +Multiline lists and record syntax are written with leading commas, +that line up with the open and close punctuation. + + list = + [ item1 + , item2 + , item3 + ] + + foo = DataStructure + { name = "bar" + , address = "baz" + } + +Module imports are separated into two blocks, one for third-party modules, +and one for modules that are part of git-annex. (Additional blocks can be used +if it makes sense.) + +Using tabs for indentation makes use of `let .. in` particularly tricky. +There's no really good way to bind multiple names in a let clause with +tab indentation. Instead, a where clause is typically used. To bind a single +name in a let clause, this is sometimes used: + + foo = let x = 42 + in x + (x-1) + x + +(Of course, monadic let binding are no problem.) diff --git a/doc/download.mdwn b/doc/download.mdwn index 4de91c913..8c6f5b514 100644 --- a/doc/download.mdwn +++ b/doc/download.mdwn @@ -33,3 +33,8 @@ The git repository has some branches: * `setup` contains configuration for this website * `pristine-tar` contains [pristine-tar](http://kitenet.net/~joey/code/pristine-tar) data to create tarballs of any past git-annex release. + +---- + +Developing git-annex? Patches are very welcome. +You should read [[coding_style]]. |