minor syntax changes

Annex/Content.hs

@@ -57,7 +57,7 @@ calcGitLink file key = do
 logStatus :: Key -> LogStatus -> Annex ()
 logStatus key status = do
 	g <- gitRepo
-	u <- getUUID g
+	u <- getUUID
 	logChange g key u status
 
 {- Runs an action, passing it a temporary filename to download,

Backend/SHA.hs

@@ -104,11 +104,11 @@ checkKeyChecksum size key = do
 	present <- liftIO $ doesFileExist file
 	if not present || fast
 		then return True
-		else do
+		else check =<< shaN size file
-			s <- shaN size file
+	where
-			if s == dropExtension (keyName key)
+		check s
-				then return True
+			| s == dropExtension (keyName key) = return True
-				else do
+			| otherwise = do
-					dest <- moveBad key
+				dest <- moveBad key
-					warning $ "Bad file content; moved to " ++ dest
+				warning $ "Bad file content; moved to " ++ dest
-					return False
+				return False

Command/ConfigList.hs

@@ -20,7 +20,6 @@ seek = [withNothing start]
 
 start :: CommandStart
 start = do
-	g <- gitRepo
+	u <- getUUID
-	u <- getUUID g
 	liftIO $ putStrLn $ "annex.uuid=" ++ u
 	stop

Command/Fsck.hs

@@ -55,7 +55,7 @@ verifyLocationLog key file = do
 		preventWrite f
 		preventWrite (parentDir f)
 
-	u <- getUUID g
+	u <- getUUID
         uuids <- keyLocations key
 
 	case (present, u `elem` uuids) of

Command/Init.hs

@@ -29,7 +29,6 @@ start ws = do
 perform :: String -> CommandPerform
 perform description = do
 	initialize
-	g <- gitRepo
+	u <- getUUID
-	u <- getUUID g
 	describeUUID u description
 	next $ return True

Command/Move.hs

@@ -72,8 +72,7 @@ remoteHasKey remote key present	= do
  -}
 toStart :: Remote.Remote Annex -> Bool -> FilePath -> CommandStart
 toStart dest move file = isAnnexed file $ \(key, _) -> do
-	g <- gitRepo
+	u <- getUUID
-	u <- getUUID g
 	ishere <- inAnnex key
 	if not ishere || u == Remote.uuid dest
 		then stop -- not here, so nothing to do
@@ -122,8 +121,7 @@ toCleanup dest move key = do
  -}
 fromStart :: Remote.Remote Annex -> Bool -> FilePath -> CommandStart
 fromStart src move file = isAnnexed file $ \(key, _) -> do
-	g <- gitRepo
+	u <- getUUID
-	u <- getUUID g
 	remotes <- Remote.keyPossibilities key
 	if u == Remote.uuid src || not (any (== src) remotes)
 		then stop

Crypto.hs

@@ -135,13 +135,12 @@ decryptCipher _ (EncryptedCipher encipher _) =
 {- 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
  - on content. It does need to be repeatable. -}
-encryptKey :: Cipher -> Key -> IO Key
+encryptKey :: Cipher -> Key -> Key
-encryptKey c k =
+encryptKey c k = Key
-	return Key {
+	{ keyName = hmacWithCipher c (show k)
-		keyName = hmacWithCipher c (show k),
+	, keyBackendName = "GPGHMACSHA1"
-		keyBackendName = "GPGHMACSHA1",
+	, keySize = Nothing -- size and mtime omitted
-		keySize = Nothing, -- size and mtime omitted
+	, keyMtime = Nothing -- to avoid leaking data
-		keyMtime = Nothing -- to avoid leaking data
 	}
 
 {- Runs an action, passing it a handle from which it can 
@@ -223,18 +222,18 @@ gpgCipherHandle params c a b = do
 	return ret
 
 configKeyIds :: RemoteConfig -> IO KeyIds
-configKeyIds c = do
+configKeyIds c = parse <$> gpgRead params
-	let k = configGet c "encryption"
-	s <- gpgRead [Params "--with-colons --list-public-keys", Param k]
-	return $ KeyIds $ parseWithColons s
 	where
-		parseWithColons s = map keyIdField $ filter pubKey $ lines s
+		params = [Params "--with-colons --list-public-keys",
+			Param $ configGet c "encryption"]
+		parse = KeyIds . map keyIdField . filter pubKey . lines
 		pubKey = isPrefixOf "pub:"
 		keyIdField s = split ":" s !! 4
 
 configGet :: RemoteConfig -> String -> String
 configGet c key = fromMaybe missing $ M.lookup key c
-	where missing = error $ "missing " ++ key ++ " in remote config"
+	where
+		missing = error $ "missing " ++ key ++ " in remote config"
 
 hmacWithCipher :: Cipher -> String -> String
 hmacWithCipher c = hmacWithCipher' (cipherHmac c) 

Init.hs

@@ -75,6 +75,6 @@ preCommitHook = do
 
 preCommitScript :: String
 preCommitScript = 
-		"#!/bin/sh\n" ++
+	"#!/bin/sh\n" ++
-		"# automatically configured by git-annex\n" ++ 
+	"# automatically configured by git-annex\n" ++ 
-		"git annex pre-commit .\n"
+	"git annex pre-commit .\n"

Limit.hs

@@ -65,14 +65,13 @@ addExclude glob = addLimit $ return . notExcluded
 {- Adds a limit to skip files not believed to be present
  - in a specfied repository. -}
 addIn :: String -> Annex ()
-addIn name = do
+addIn name = addLimit $ check $ if name == "." then inAnnex else inremote
-	u <- Remote.nameToUUID name
-	addLimit $ if name == "." then check inAnnex else check (remote u)
 	where
 		check a f = Backend.lookupFile f >>= handle a
 		handle _ Nothing = return False
 		handle a (Just (key, _)) = a key
-		remote u key = do
+		inremote key = do
+			u <- Remote.nameToUUID name
 			us <- keyLocations key
 			return $ u `elem` us
 

Messages.hs

@@ -31,31 +31,31 @@ import qualified Annex
 import qualified Messages.JSON as JSON
 
 showStart :: String -> String -> Annex ()
-showStart command file = handle (JSON.start command file) $ do
+showStart command file = handle (JSON.start command file) $
-	putStr $ command ++ " " ++ file ++ " "
+	flushed $ putStr $ command ++ " " ++ file ++ " "
-	hFlush stdout
 
 showNote :: String -> Annex ()
-showNote s = handle (JSON.note s) $ do
+showNote s = handle (JSON.note s) $
-	putStr $ "(" ++ s ++ ") "
+	flushed $ putStr $ "(" ++ s ++ ") "
-	hFlush stdout
 
 showAction :: String -> Annex ()
 showAction s = showNote $ s ++ "..."
 
 showProgress :: Annex ()
-showProgress = handle q $ do
+showProgress = handle q $
-	putStr "."
+	flushed $ putStr "."
-	hFlush stdout
 
 showSideAction :: String -> Annex ()
-showSideAction s = handle q $ putStrLn $ "(" ++ s ++ "...)"
+showSideAction s = handle q $
+	putStrLn $ "(" ++ s ++ "...)"
 
 showOutput :: Annex ()
-showOutput = handle q $ putStr "\n"
+showOutput = handle q $
+	putStr "\n"
 
 showLongNote :: String -> Annex ()
-showLongNote s = handle (JSON.note s) $ putStrLn $ '\n' : indent s
+showLongNote s = handle (JSON.note s) $
+	putStrLn $ '\n' : indent s
 
 showEndOk :: Annex ()
 showEndOk = showEndResult True
@@ -113,3 +113,6 @@ maybeShowJSON v = handle (JSON.add v) q
 
 q :: Monad m => m ()
 q = return ()
+
+flushed :: IO () -> IO ()
+flushed a = a >> hFlush stdout

Remote.hs

@@ -78,7 +78,7 @@ genList = do
 			enumerate t >>=
 			mapM (gen m t)
 		gen m t r = do
-			u <- getUUID r
+			u <- getRepoUUID r
 			generate t r u (M.lookup u m)
 
 {- Looks up a remote by name. (Or by UUID.) Only finds currently configured
@@ -104,7 +104,7 @@ byName' n = do
  - and returns its UUID. Finds even remotes that are not configured in
  - .git/config. -}
 nameToUUID :: String -> Annex UUID
-nameToUUID "." = getUUID =<< gitRepo -- special case for current repo
+nameToUUID "." = getUUID -- special case for current repo
 nameToUUID n = do
 	res <- byName' n
 	case res of
@@ -129,7 +129,7 @@ nameToUUID n = do
  - of the UUIDs. -}
 prettyPrintUUIDs :: String -> [UUID] -> Annex String
 prettyPrintUUIDs desc uuids = do
-	here <- getUUID =<< gitRepo
+	here <- getUUID
 	m <- M.unionWith addname <$> uuidMap <*> remoteMap
 	maybeShowJSON [(desc, map (jsonify m here) uuids)]
 	return $ unwords $ map (\u -> "\t" ++ prettify m here u ++ "\n") uuids
@@ -178,8 +178,7 @@ keyPossibilitiesTrusted = keyPossibilities' True
 
 keyPossibilities' :: Bool -> Key -> Annex ([Remote Annex], [UUID])
 keyPossibilities' withtrusted key = do
-	g <- gitRepo
+	u <- getUUID
-	u <- getUUID g
 	trusted <- if withtrusted then trustGet Trusted else return []
 
 	-- get uuids of all remotes that are recorded to have the key
@@ -198,8 +197,7 @@ keyPossibilities' withtrusted key = do
 {- Displays known locations of a key. -}
 showLocations :: Key -> [UUID] -> Annex ()
 showLocations key exclude = do
-	g <- gitRepo
+	u <- getUUID
-	u <- getUUID g
 	uuids <- keyLocations key
 	untrusteduuids <- trustGet UnTrusted
 	let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids) 

Remote/Git.hs

@@ -48,7 +48,7 @@ gen r u _ = do
 		(False, "") -> tryGitConfigRead r
 		_ -> return r
 
-	u' <- getUUID r'
+	u' <- getRepoUUID r'
 
 	let defcst = if cheap then cheapRemoteCost else expensiveRemoteCost
 	cst <- remoteCost r' defcst

Remote/Helper/Encryptable.hs

@@ -78,8 +78,6 @@ remoteCipher c = maybe expensive cached =<< Annex.getState Annex.cipher
 {- Gets encryption Cipher, and encrypted version of Key. -}
 cipherKey :: Maybe RemoteConfig -> Key -> Annex (Maybe (Cipher, Key))
 cipherKey Nothing _ = return Nothing
-cipherKey (Just c) k = remoteCipher c >>= maybe (return Nothing) encrypt
+cipherKey (Just c) k = maybe Nothing encrypt <$> remoteCipher c
 	where
-		encrypt ciphertext = do
+		encrypt ciphertext = Just (ciphertext, encryptKey ciphertext k)
-			k' <- liftIO $ encryptKey ciphertext k
-			return $ Just (ciphertext, k')

UUID.hs

@@ -16,6 +16,7 @@
 module UUID (
 	UUID,
 	getUUID,
+	getRepoUUID,
 	getUncachedUUID,
 	prepUUID,
 	genUUID,
@@ -44,7 +45,7 @@ logfile = "uuid.log"
 {- Generates a UUID. There is a library for this, but it's not packaged,
  - so use the command line tool. -}
 genUUID :: IO UUID
-genUUID = liftIO $ pOpen ReadFromPipe command params $ \h -> hGetLine h
+genUUID = pOpen ReadFromPipe command params hGetLine
 	where
 		command = SysConfig.uuid
 		params = if command == "uuid"
@@ -53,9 +54,12 @@ genUUID = liftIO $ pOpen ReadFromPipe command params $ \h -> hGetLine h
 			-- uuidgen generates random uuid by default
 			else []
 
+getUUID :: Annex UUID
+getUUID = getRepoUUID =<< gitRepo
+
 {- Looks up a repo's UUID. May return "" if none is known. -}
-getUUID :: Git.Repo -> Annex UUID
+getRepoUUID :: Git.Repo -> Annex UUID
-getUUID r = do
+getRepoUUID r = do
 	g <- gitRepo
 
 	let c = cached g
@@ -76,11 +80,8 @@ getUncachedUUID r = Git.configGet r configkey ""
 
 {- Make sure that the repo has an annex.uuid setting. -}
 prepUUID :: Annex ()
-prepUUID = do
+prepUUID = whenM (null <$> getUUID) $
-	u <- getUUID =<< gitRepo
+	setConfig configkey =<< liftIO genUUID
-	when (null u) $ do
-		uuid <- liftIO genUUID
-		setConfig configkey uuid
 
 {- Records a description for a uuid in the log. -}
 describeUUID :: UUID -> String -> Annex ()

Utility.hs

@@ -19,6 +19,7 @@ module Utility (
 	anyM
 ) where
 
+import Control.Applicative
 import IO (bracket)
 import System.IO
 import System.Posix.Process hiding (executeFile)
@@ -69,9 +70,7 @@ withTempFile template a = bracket create remove use
 {- Lists the contents of a directory.
  - Unlike getDirectoryContents, paths are not relative to the directory. -}
 dirContents :: FilePath -> IO [FilePath]
-dirContents d = do
+dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d
-	c <- getDirectoryContents d
-	return $ map (d </>) $ filter notcruft c
 	where
 		notcruft "." = False
 		notcruft ".." = False
@@ -79,10 +78,7 @@ dirContents d = do
 
 {- Current user's home directory. -}
 myHomeDir :: IO FilePath
-myHomeDir = do
+myHomeDir = homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID)
-	uid <- getEffectiveUserID
-	u <- getUserEntryForID uid
-	return $ homeDirectory u
 
 {- Catches IO errors and returns a Bool -}
 catchBool :: IO Bool -> IO Bool

Utility/Path.hs

@@ -17,10 +17,9 @@ import Control.Applicative
 
 {- Returns the parent directory of a path. Parent of / is "" -}
 parentDir :: FilePath -> FilePath
-parentDir dir =
+parentDir dir
-	if not $ null dirs
+	| not $ null dirs = slash ++ join s (init dirs)
-	then slash ++ join s (init dirs)
+	| otherwise = ""
-	else ""
 		where
 			dirs = filter (not . null) $ split s dir
 			slash = if isAbsolute dir then s else ""
@@ -72,7 +71,7 @@ relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
  - Both must be absolute, and normalized (eg with absNormpath).
  -}
 relPathDirToFile :: FilePath -> FilePath -> FilePath
-relPathDirToFile from to = path
+relPathDirToFile from to = join s $ dotdots ++ uncommon
 	where
 		s = [pathSeparator]
 		pfrom = split s from
@@ -82,7 +81,6 @@ relPathDirToFile from to = path
 		uncommon = drop numcommon pto
 		dotdots = replicate (length pfrom - numcommon) ".."
 		numcommon = length common
-		path = join s $ dotdots ++ uncommon
 
 prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
 prop_relPathDirToFile_basics from to
@@ -99,14 +97,11 @@ prop_relPathDirToFile_basics from to
  - appear at the same position as it did in the input list.
  -}
 preserveOrder :: [FilePath] -> [FilePath] -> [FilePath]
--- optimisation, only one item in original list, so no reordering needed
+preserveOrder [] new = new
-preserveOrder [_] new = new
+preserveOrder [_] new = new -- optimisation
-preserveOrder orig new = collect orig new
+preserveOrder (l:ls) new = found ++ preserveOrder ls rest
 	where
-		collect [] n = n
+		(found, rest)=partition (l `dirContains`) new
-		collect [_] n = n -- optimisation
-		collect (l:ls) n = found ++ collect ls rest
-			where (found, rest)=partition (l `dirContains`) n
 
 {- Runs an action that takes a list of FilePaths, and ensures that 
  - its return list preserves order.

Utility/Ssh.hs

@@ -34,7 +34,7 @@ git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePat
 git_annex_shell r command params
 	| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts)
 	| Git.repoIsSsh r = do
-		uuid <- getUUID r
+		uuid <- getRepoUUID r
 		sshparams <- sshToRepo r [Param $ sshcmd uuid ]
 		return $ Just ("ssh", sshparams)
 	| otherwise = return Nothing

git-annex-shell.hs

@@ -37,7 +37,7 @@ options = uuid : commonOptions
 	where
 		uuid = Option [] ["uuid"] (ReqArg check paramUUID) "repository uuid"
 		check expected = do
-			u <- getUUID =<< gitRepo
+			u <- getUUID
 			when (u /= expected) $ error $
 				"expected repository UUID " ++ expected
 					++ " but found UUID " ++ u

test.hs

@@ -609,9 +609,7 @@ checkdangling f = do
 
 checklocationlog :: FilePath -> Bool -> Assertion
 checklocationlog f expected = do
-	thisuuid <- annexeval $ do
+	thisuuid <- annexeval UUID.getUUID
-		g <- Annex.gitRepo
-		UUID.getUUID g
 	r <- annexeval $ Backend.lookupFile f
 	case r of
 		Just (k, _) -> do