summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Annex.hs4
-rw-r--r--Config.hs18
-rw-r--r--Crypto.hs40
-rw-r--r--Init.hs10
-rw-r--r--Locations.hs49
-rw-r--r--Messages.hs2
-rw-r--r--Option.hs30
-rw-r--r--Remote.hs96
-rw-r--r--Remote/Git.hs356
-rw-r--r--doc/coding_style.mdwn86
-rw-r--r--doc/download.mdwn5
11 files changed, 395 insertions, 301 deletions
diff --git a/Annex.hs b/Annex.hs
index 3c8379019..7fb8afd5c 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -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)
diff --git a/Config.hs b/Config.hs
index 04ab66507..10777303a 100644
--- a/Config.hs
+++ b/Config.hs
@@ -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. -}
diff --git a/Crypto.hs b/Crypto.hs
index 3387be142..071fb7a25 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -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"
diff --git a/Init.hs b/Init.hs
index 0b3605e41..effa61eac 100644
--- a/Init.hs
+++ b/Init.hs
@@ -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 ++ "...)"
diff --git a/Option.hs b/Option.hs
index ff70fb685..1475aafbe 100644
--- a/Option.hs
+++ b/Option.hs
@@ -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
diff --git a/Remote.hs b/Remote.hs
index e1ff9e7d8..272fc6d23 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -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]].