Merge branch 'master' into concurrentprogress

Conflicts:
	Command/Fsck.hs
	Messages.hs
	Remote/Directory.hs
	Remote/Git.hs
	Remote/Helper/Special.hs
	Types/Remote.hs
	debian/changelog
	git-annex.cabal

.mailmap

@@ -1,7 +1,28 @@
+Antoine Beaupré <anarcat@koumbit.org> anarcat <anarcat@web>
+Antoine Beaupré <anarcat@koumbit.org> https://id.koumbit.net/anarcat <https://id.koumbit.net/anarcat@web>
+Greg Grossmeier <greg@grossmeier.net> http://grossmeier.net/ <greg@web>
+Jimmy Tang <jtang@tchpc.tcd.ie> jtang <jtang@web>
+Joachim Breitner <mail@joachim-breitner.de> http://www.joachim-breitner.de/ <nomeata@web>
+Joey Hess <id@joeyh.name> Joey Hess <joey@gnu.kitenet.net>
+Joey Hess <id@joeyh.name> Joey Hess <joey@kitenet.net>
+Joey Hess <id@joeyh.name> Joey Hess <joeyh@debian.org>
+Joey Hess <id@joeyh.name> Joey Hess <joeyh@fischer.debian.org>
+Joey Hess <id@joeyh.name> Joey Hess <joeyh@joeyh.name>
+Joey Hess <id@joeyh.name> Joey Hess <joeyh@oberon.tam-lin.net>
+Joey Hess <id@joeyh.name> Joey Hess <joeyh@oberon.underhill.private>
 Joey Hess <id@joeyh.name> http://joey.kitenet.net/ <joey@web>
-Joey Hess <id@joeyh.name> http://joeyh.name/ <joey@web>
 Joey Hess <id@joeyh.name> http://joeyh.name/ <http://joeyh.name/@web>
+Joey Hess <id@joeyh.name> http://joeyh.name/ <joey@web>
+Joey Hess <id@joeyh.name> https://www.google.com/accounts/o8/id?id=AItOawmJfIszzreLNvCqzqzvTayA9_9L6gb9RtY <Joey@web>
+Johan Kiviniemi <devel@johan.kiviniemi.name> http://johan.kiviniemi.name/ <Johan@web>
+Johan Kiviniemi <devel@johan.kiviniemi.name> http://johan.kiviniemi.name/ <http://johan.kiviniemi.name/@web>
+Nicolas Pouillard <nicolas.pouillard@gmail.com> http://ertai.myopenid.com/ <npouillard@web>
+Peter Simons <simons@cryp.to> Peter Simons <simons@ubuntu-12.04>
+Peter Simons <simons@cryp.to> http://peter-simons.myopenid.com/ <http://peter-simons.myopenid.com/@web>
+Philipp Kern <pkern@debian.org> http://phil.0x539.de/ <Philipp_Kern@web>
+Richard Hartmann <richih@debian.org> https://www.google.com/accounts/o8/id?id=AItOawl9sYlePmv1xK-VvjBdN-5doOa_Xw-jH4U <Richard@web>
 Yaroslav Halchenko <debian@onerussian.com>
 Yaroslav Halchenko <debian@onerussian.com> http://yarikoptic.myopenid.com/ <site-myopenid@web>
 Yaroslav Halchenko <debian@onerussian.com> https://www.google.com/accounts/o8/id?id=AItOawnx8kHW66N3BqmkVpgtXDlYMvr8TJ5VvfY <Yaroslav@web>
-Richard Hartmann <richih@debian.org> https://www.google.com/accounts/o8/id?id=AItOawl9sYlePmv1xK-VvjBdN-5doOa_Xw-jH4U <Richard@web>
+Øyvind A. Holm <sunny@sunbase.org> http://sunny256.sunbase.org/ <sunny256@web>
+Øyvind A. Holm <sunny@sunbase.org> https://sunny256.wordpress.com/ <sunny256@web>

Annex.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PackageImports #-}
+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PackageImports, BangPatterns #-}
 
 module Annex (
 	Annex,
@@ -32,6 +32,7 @@ module Annex (
 	getRemoteGitConfig,
 	withCurrentState,
 	changeDirectory,
+	incError,
 ) where
 
 import Common
@@ -312,3 +313,9 @@ changeDirectory d = do
 	liftIO $ setCurrentDirectory d
 	r' <- liftIO $ Git.relPath r
 	changeState $ \s -> s { repo = r' }
+
+incError :: Annex ()
+incError = changeState $ \s -> 
+	let ! c = errcounter s + 1 
+	    ! s' = s { errcounter = c }
+	in s'

Annex/Content.hs

@@ -280,17 +280,19 @@ withTmp key action = do
 {- Checks that there is disk space available to store a given key,
  - in a destination (or the annex) printing a warning if not. -}
 checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool
-checkDiskSpace destination key alreadythere = do
+checkDiskSpace destination key alreadythere = ifM (Annex.getState Annex.force)
-	reserve <- annexDiskReserve <$> Annex.getGitConfig
+	( return True
-	free <- liftIO . getDiskFree =<< dir
+	, do
-	force <- Annex.getState Annex.force
+		reserve <- annexDiskReserve <$> Annex.getGitConfig
-	case (free, keySize key) of
+		free <- liftIO . getDiskFree =<< dir
-		(Just have, Just need) -> do
+		case (free, fromMaybe 1 (keySize key)) of
-			let ok = (need + reserve <= have + alreadythere) || force
+			(Just have, need) -> do
-			unless ok $
+				let ok = (need + reserve <= have + alreadythere)
-				needmorespace (need + reserve - have - alreadythere)
+				unless ok $
-			return ok
+					needmorespace (need + reserve - have - alreadythere)
-		_ -> return True
+				return ok
+			_ -> return True
+	)
   where
 	dir = maybe (fromRepo gitAnnexDir) return destination
 	needmorespace n =
@@ -498,9 +500,9 @@ getKeysPresent keyloc = do
 	direct <- isDirect
 	dir <- fromRepo gitAnnexObjectDir
 	s <- getstate direct
-	liftIO $ traverse s direct (2 :: Int) dir
+	liftIO $ walk s direct (2 :: Int) dir
   where
-	traverse s direct depth dir = do
+	walk s direct depth dir = do
 		contents <- catchDefaultIO [] (dirContents dir)
 		if depth == 0
 			then do
@@ -508,7 +510,7 @@ getKeysPresent keyloc = do
 				let keys = mapMaybe (fileKey . takeFileName) contents'
 				continue keys []
 			else do
-				let deeper = traverse s direct (depth - 1)
+				let deeper = walk s direct (depth - 1)
 				continue [] (map deeper contents)
 	continue keys [] = return keys
 	continue keys (a:as) = do

Annex/Drop.hs

@@ -9,7 +9,7 @@ module Annex.Drop where
 
 import Common.Annex
 import Logs.Trust
-import Config.NumCopies
+import Annex.NumCopies
 import Types.Remote (uuid)
 import Types.Key (key2file)
 import qualified Remote

Annex/Init.hs

@@ -57,15 +57,15 @@ genDescription Nothing = do
 
 initialize :: Maybe String -> Annex ()
 initialize mdescription = do
+	{- This will make the first commit to git, so ensure git is set up
+	 - properly to allow commits when running it. -}
+	ensureCommit $ Annex.Branch.create
+
 	prepUUID
 	initialize'
 
 	u <- getUUID
-	{- This will make the first commit to git, so ensure git is set up
+	describeUUID u =<< genDescription mdescription
-	 - properly to allow commits when running it. -}
-	ensureCommit $ do
-		Annex.Branch.create
-		describeUUID u =<< genDescription mdescription
 
 -- Everything except for uuid setup.
 initialize' :: Annex ()

Annex/NumCopies.hs

@@ -1,11 +1,11 @@
-{- git-annex numcopies configuration
+{- git-annex numcopies configuration and checking
  -
- - Copyright 2014 Joey Hess <id@joeyh.name>
+ - Copyright 2014-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Config.NumCopies (
+module Annex.NumCopies (
 	module Types.NumCopies,
 	module Logs.NumCopies,
 	getFileNumCopies,
@@ -15,6 +15,8 @@ module Config.NumCopies (
 	defaultNumCopies,
 	numCopiesCheck,
 	numCopiesCheck',
+	verifyEnoughCopies,
+	knownCopies,
 ) where
 
 import Common.Annex
@@ -24,6 +26,8 @@ import Logs.NumCopies
 import Logs.Trust
 import Annex.CheckAttr
 import qualified Remote
+import Annex.UUID
+import Annex.Content
 
 defaultNumCopies :: NumCopies
 defaultNumCopies = NumCopies 1
@@ -83,3 +87,61 @@ numCopiesCheck' :: FilePath -> (Int -> Int -> v) -> [UUID] -> Annex v
 numCopiesCheck' file vs have = do
 	NumCopies needed <- getFileNumCopies file
 	return $ length have `vs` needed
+
+{- Verifies that enough copies of a key exist amoung the listed remotes,
+ - priting an informative message if not.
+ -}
+verifyEnoughCopies 
+	:: String -- message to print when there are no known locations
+	-> Key
+	-> NumCopies
+	-> [UUID] -- repos to skip (generally untrusted remotes)
+	-> [UUID] -- repos that are trusted or already verified to have it
+	-> [Remote] -- remotes to check to see if they have it
+	-> Annex Bool
+verifyEnoughCopies nolocmsg key need skip trusted tocheck = 
+	helper [] [] (nub trusted) (nub tocheck)
+  where
+	helper bad missing have []
+		| NumCopies (length have) >= need = return True
+		| otherwise = do
+			notEnoughCopies key need have (skip++missing) bad nolocmsg
+			return False
+	helper bad missing have (r:rs)
+		| NumCopies (length have) >= need = return True
+		| otherwise = do
+			let u = Remote.uuid r
+			let duplicate = u `elem` have
+			haskey <- Remote.hasKey r key
+			case (duplicate, haskey) of
+				(False, Right True)  -> helper bad missing (u:have) rs
+				(False, Left _)      -> helper (r:bad) missing have rs
+				(False, Right False) -> helper bad (u:missing) have rs
+				_                    -> helper bad missing have rs
+
+notEnoughCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> String -> Annex ()
+notEnoughCopies key need have skip bad nolocmsg = do
+	showNote "unsafe"
+	showLongNote $
+		"Could only verify the existence of " ++
+		show (length have) ++ " out of " ++ show (fromNumCopies need) ++ 
+		" necessary copies"
+	Remote.showTriedRemotes bad
+	Remote.showLocations True key (have++skip) nolocmsg
+
+{- Cost ordered lists of remotes that the location log indicates
+ - may have a key.
+ -
+ - Also returns a list of UUIDs that are trusted to have the key
+ - (some may not have configured remotes). If the current repository
+ - currently has the key, and is not untrusted, it is included in this list.
+ -}
+knownCopies :: Key -> Annex ([Remote], [UUID])
+knownCopies key = do
+	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
+	u <- getUUID
+	trusteduuids' <- ifM (inAnnex key <&&> (<= SemiTrusted) <$> lookupTrust u)
+		( pure (u:trusteduuids)
+		, pure trusteduuids
+		)
+	return (remotes, trusteduuids')

Annex/Perms.hs

@@ -69,14 +69,14 @@ annexFileMode = withShared $ return . go
 {- Creates a directory inside the gitAnnexDir, including any parent
  - directories. Makes directories with appropriate permissions. -}
 createAnnexDirectory :: FilePath -> Annex ()
-createAnnexDirectory dir = traverse dir [] =<< top
+createAnnexDirectory dir = walk dir [] =<< top
   where
 	top = parentDir <$> fromRepo gitAnnexDir
-	traverse d below stop
+	walk d below stop
 		| d `equalFilePath` stop = done
 		| otherwise = ifM (liftIO $ doesDirectoryExist d)
 			( done
-			, traverse (parentDir d) (d:below) stop
+			, walk (parentDir d) (d:below) stop
 			)
 	  where
 		done = forM_ below $ \p -> do

Assistant.hs

@@ -57,7 +57,6 @@ import Utility.LogFile
 #ifdef mingw32_HOST_OS
 import Utility.Env
 import Annex.Path
-import Config.Files
 import System.Environment (getArgs)
 #endif
 

Assistant/DaemonStatus.hs

@@ -16,6 +16,7 @@ import Assistant.Types.NetMessager
 import Utility.NotificationBroadcaster
 import Logs.Transfer
 import Logs.Trust
+import Logs.TimeStamp
 import qualified Remote
 import qualified Types.Remote as Remote
 import qualified Git
@@ -23,8 +24,6 @@ import qualified Git
 import Control.Concurrent.STM
 import System.Posix.Types
 import Data.Time.Clock.POSIX
-import Data.Time
-import System.Locale
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Data.Text as T
@@ -125,21 +124,18 @@ readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file
   where
 	parse status = foldr parseline status . lines
 	parseline line status
-		| key == "lastRunning" = parseval readtime $ \v ->
+		| key == "lastRunning" = parseval parsePOSIXTime $ \v ->
 			status { lastRunning = Just v }
 		| key == "scanComplete" = parseval readish $ \v ->
 			status { scanComplete = v }
 		| key == "sanityCheckRunning" = parseval readish $ \v ->
 			status { sanityCheckRunning = v }
-		| key == "lastSanityCheck" = parseval readtime $ \v ->
+		| key == "lastSanityCheck" = parseval parsePOSIXTime $ \v ->
 			status { lastSanityCheck = Just v }
 		| otherwise = status -- unparsable line
 	  where
 		(key, value) = separate (== ':') line
 		parseval parser a = maybe status a (parser value)
-		readtime s = do
-			d <- parseTime defaultTimeLocale "%s%Qs" s
-			Just $ utcTimeToPOSIXSeconds d
 
 {- Checks if a time stamp was made after the daemon was lastRunning.
  -

Assistant/Install.hs

@@ -145,10 +145,12 @@ installFileManagerHooks program = do
 		, "Name=" ++ command
 		, "Icon=git-annex"
 		, unwords
-			[ "Exec=sh -c 'cd \"$(dirname '%U')\" &&"
+			[ "Exec=sh -c 'cd \"$(dirname \"$1\")\" &&"
 			, program
 			, command
-			, "--notify-start --notify-finish -- %U'"
+			, "--notify-start --notify-finish -- \"$1\"'"
+			, "false" -- this becomes $0 in sh, so unused
+			, "%f"
 			]
 		]
 #else

Assistant/Install/AutoStart.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Assistant.Install.AutoStart where
 

Assistant/Install/Menu.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Assistant.Install.Menu where
 

Assistant/Pairing.hs

@@ -81,6 +81,8 @@ data PairingInProgress = PairingInProgress
 	}
 	deriving (Show)
 
+data AddrClass = IPv4AddrClass | IPv6AddrClass
+
 data SomeAddr = IPv4Addr HostAddress
 {- My Android build of the Network library does not currently have IPV6
  - support. -}

Assistant/Pairing/MakeRemote.hs

@@ -88,8 +88,8 @@ bestHostName msg = case remoteHostName $ pairMsgData msg of
 	fallback = do
 		let a = pairMsgAddr msg
 		let sockaddr = case a of
-			IPv4Addr addr -> SockAddrInet (PortNum 0) addr
+			IPv4Addr addr -> SockAddrInet (fromInteger 0) addr
-			IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0
+			IPv6Addr addr -> SockAddrInet6 (fromInteger 0) 0 addr 0
 		fromMaybe (showAddr a)
 			<$> catchDefaultIO Nothing
 				(fst <$> getNameInfo [] True False sockaddr)

Assistant/Pairing/Network.hs

@@ -33,9 +33,9 @@ pairingPort = 55556
 {- Goal: Reach all hosts on the same network segment.
  - Method: Use same address that avahi uses. Other broadcast addresses seem
  - to not be let through some routers. -}
-multicastAddress :: SomeAddr -> HostName
+multicastAddress :: AddrClass -> HostName
-multicastAddress (IPv4Addr _) = "224.0.0.251"
+multicastAddress IPv4AddrClass = "224.0.0.251"
-multicastAddress (IPv6Addr _) = "ff02::fb"
+multicastAddress IPv6AddrClass = "ff02::fb"
 
 {- Multicasts a message repeatedly on all interfaces, with a 2 second
  - delay between each transmission. The message is repeated forever
@@ -62,7 +62,7 @@ multicastPairMsg repeats secret pairdata stage = go M.empty repeats
 	sendinterface cache i = void $ tryIO $
 		withSocketsDo $ bracket setup cleanup use
 	  where
-		setup = multicastSender (multicastAddress i) pairingPort
+		setup = multicastSender (multicastAddress IPv4AddrClass) pairingPort
 		cleanup (sock, _) = sClose sock -- FIXME does not work
 		use (sock, addr) = do
 			setInterface sock (showAddr i)

Assistant/Threads/Committer.hs

@@ -196,7 +196,7 @@ maxCommitSize :: Int
 maxCommitSize = 5000
 
 {- Decide if now is a good time to make a commit.
- - Note that the list of changes has an undefined order.
+ - Note that the list of changes has a random order.
  -
  - Current strategy: If there have been 10 changes within the past second,
  - a batch activity is taking place, so wait for later.

Assistant/Threads/MountWatcher.hs

@@ -63,11 +63,7 @@ dbusThread urlrenderer = do
 				wasmounted <- liftIO $ swapMVar mvar nowmounted
 				handleMounts urlrenderer wasmounted nowmounted
 			liftIO $ forM_ mountChanged $ \matcher ->
-#if MIN_VERSION_dbus(0,10,7)
 				void $ addMatch client matcher handleevent
-#else
-				listen client matcher handleevent
-#endif
 		, do
 			liftAnnex $
 				warning "No known volume monitor available through dbus; falling back to mtab polling"

Assistant/Threads/NetWatcher.hs

@@ -112,11 +112,7 @@ checkNetMonitor client = do
  -}
 listenNMConnections :: Client -> (Bool -> IO ()) -> IO ()
 listenNMConnections client setconnected =
-#if MIN_VERSION_dbus(0,10,7)
 	void $ addMatch client matcher
-#else
-	listen client matcher
-#endif
 		$ \event -> mapM_ handleevent
 			(map dictionaryItems $ mapMaybe fromVariant $ signalBody event)
   where
@@ -166,11 +162,7 @@ listenWicdConnections client setconnected = do
 		| any (== wicd_disconnected) status = setconnected False
 		| otherwise = noop
 	match matcher a = 
-#if MIN_VERSION_dbus(0,10,7)
 		void $ addMatch client matcher a
-#else
-		listen client matcher a
-#endif
 #endif
 
 handleConnection :: Assistant ()

Assistant/Threads/PairListener.hs

@@ -31,7 +31,7 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
   where
 	{- Note this can crash if there's no network interface,
 	 - or only one like lo that doesn't support multicast. -}
-	getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
+	getsock = multicastReceiver (multicastAddress IPv4AddrClass) pairingPort
 		
 	go reqs cache sock = liftIO (getmsg sock []) >>= \msg -> case readish msg of
 		Nothing -> go reqs cache sock

Assistant/Threads/XMPPPusher.hs

@@ -78,4 +78,5 @@ selectNextPush lastpushedto l = go [] l
 		(Pushing clientid _)
 			| Just clientid /= lastpushedto -> (m, rejected ++ ms)
 		_ -> go (m:rejected) ms
-	go [] [] = undefined
+	go [] [] = error "empty push queue"
+

Assistant/Types/BranchChange.hs

@@ -8,7 +8,8 @@
 module Assistant.Types.BranchChange where
 
 import Control.Concurrent.MSampleVar
-import Common.Annex
+import Control.Applicative
+import Prelude
 
 newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ())
 

Assistant/WebApp/Bootstrap3.hs

@@ -1,260 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE OverloadedStrings #-}
--- | Helper functions for creating forms when using Bootstrap v3.
--- This is a copy of the Yesod.Form.Bootstrap3 module that has been slightly
--- modified to be compatible with Yesod 1.0.1
-module Assistant.WebApp.Bootstrap3
-  ( -- * Rendering forms
-    renderBootstrap3
-  , BootstrapFormLayout(..)
-  , BootstrapGridOptions(..)
-    -- * Field settings
-  , bfs
-  , withPlaceholder
-  , withAutofocus
-  , withLargeInput
-  , withSmallInput
-    -- * Submit button
-  , bootstrapSubmit
-  , mbootstrapSubmit
-  , BootstrapSubmit(..)
-  ) where
-
-import Control.Arrow (second)
-import Control.Monad (liftM)
-import Data.Text (Text)
-import Data.String (IsString(..))
-import Yesod.Core
-
-import qualified Data.Text as T
-
-import Yesod.Form.Types
-import Yesod.Form.Functions
-
--- | Create a new 'FieldSettings' with the classes that are
--- required by Bootstrap v3.
---
--- Since: yesod-form 1.3.8
-bfs :: RenderMessage site msg => msg -> FieldSettings site
-bfs msg =
-    FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")]
-
-
--- | Add a placeholder attribute to a field.  If you need i18n
--- for the placeholder, currently you\'ll need to do a hack and
--- use 'getMessageRender' manually.
---
--- Since: yesod-form 1.3.8
-withPlaceholder :: Text -> FieldSettings site -> FieldSettings site
-withPlaceholder placeholder fs = fs { fsAttrs = newAttrs }
-    where newAttrs = ("placeholder", placeholder) : fsAttrs fs
-
-
--- | Add an autofocus attribute to a field.
---
--- Since: yesod-form 1.3.8
-withAutofocus :: FieldSettings site -> FieldSettings site
-withAutofocus fs = fs { fsAttrs = newAttrs }
-    where newAttrs = ("autofocus", "autofocus") : fsAttrs fs
-
-
--- | Add the @input-lg@ CSS class to a field.
---
--- Since: yesod-form 1.3.8
-withLargeInput :: FieldSettings site -> FieldSettings site
-withLargeInput fs = fs { fsAttrs = newAttrs }
-    where newAttrs = addClass "input-lg" (fsAttrs fs)
-
-
--- | Add the @input-sm@ CSS class to a field.
---
--- Since: yesod-form 1.3.8
-withSmallInput :: FieldSettings site -> FieldSettings site
-withSmallInput fs = fs { fsAttrs = newAttrs }
-    where newAttrs = addClass "input-sm" (fsAttrs fs)
-
-
-addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
-addClass klass []                    = [("class", klass)]
-addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
-addClass klass (other         :rest) = other : addClass klass rest
-
-
--- | How many bootstrap grid columns should be taken (see
--- 'BootstrapFormLayout').
---
--- Since: yesod-form 1.3.8
-data BootstrapGridOptions =
-    ColXs !Int
-  | ColSm !Int
-  | ColMd !Int
-  | ColLg !Int
-    deriving (Eq, Ord, Show)
-
-toColumn :: BootstrapGridOptions -> String
-toColumn (ColXs 0) = ""
-toColumn (ColSm 0) = ""
-toColumn (ColMd 0) = ""
-toColumn (ColLg 0) = ""
-toColumn (ColXs columns) = "col-xs-" ++ show columns
-toColumn (ColSm columns) = "col-sm-" ++ show columns
-toColumn (ColMd columns) = "col-md-" ++ show columns
-toColumn (ColLg columns) = "col-lg-" ++ show columns
-
-toOffset :: BootstrapGridOptions -> String
-toOffset (ColXs 0) = ""
-toOffset (ColSm 0) = ""
-toOffset (ColMd 0) = ""
-toOffset (ColLg 0) = ""
-toOffset (ColXs columns) = "col-xs-offset-" ++ show columns
-toOffset (ColSm columns) = "col-sm-offset-" ++ show columns
-toOffset (ColMd columns) = "col-md-offset-" ++ show columns
-toOffset (ColLg columns) = "col-lg-offset-" ++ show columns
-
-addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions
-addGO (ColXs a) (ColXs b) = ColXs (a+b)
-addGO (ColSm a) (ColSm b) = ColSm (a+b)
-addGO (ColMd a) (ColMd b) = ColMd (a+b)
-addGO (ColLg a) (ColLg b) = ColLg (a+b)
-addGO a b     | a > b = addGO b a
-addGO (ColXs a) other = addGO (ColSm a) other
-addGO (ColSm a) other = addGO (ColMd a) other
-addGO (ColMd a) other = addGO (ColLg a) other
-addGO (ColLg _) _     = error "Yesod.Form.Bootstrap.addGO: never here"
-
-
--- | The layout used for the bootstrap form.
---
--- Since: yesod-form 1.3.8
-data BootstrapFormLayout =
-    BootstrapBasicForm
-  | BootstrapInlineForm
-  | BootstrapHorizontalForm
-      { bflLabelOffset :: !BootstrapGridOptions
-      , bflLabelSize   :: !BootstrapGridOptions
-      , bflInputOffset :: !BootstrapGridOptions
-      , bflInputSize   :: !BootstrapGridOptions
-      }
-    deriving (Show)
-
-
--- | Render the given form using Bootstrap v3 conventions.
---
--- Sample Hamlet for 'BootstrapHorizontalForm':
---
--- >  <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>
--- >    ^{formWidget}
--- >    ^{bootstrapSubmit MsgSubmit}
---
--- Since: yesod-form 1.3.8
-renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a
-renderBootstrap3 formLayout aform fragment = do
-    (res, views') <- aFormToForm aform
-    let views = views' []
-        has (Just _) = True
-        has Nothing  = False
-        widget = [whamlet|
-            #{fragment}
-            $forall view <- views
-              <div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
-                $case formLayout
-                  $of BootstrapBasicForm
-                    $if nequals (fvId view) bootstrapSubmitId
-                      <label for=#{fvId view}>#{fvLabel view}
-                    ^{fvInput view}
-                    ^{helpWidget view}
-                  $of BootstrapInlineForm
-                    $if nequals (fvId view) bootstrapSubmitId
-                      <label .sr-only for=#{fvId view}>#{fvLabel view}
-                    ^{fvInput view}
-                    ^{helpWidget view}
-                  $of BootstrapHorizontalForm _a _b _c _d
-                    $if nequals (fvId view) bootstrapSubmitId
-                      <label .control-label .#{toOffset (bflLabelOffset formLayout)} .#{toColumn (bflLabelSize formLayout)} for=#{fvId view}>#{fvLabel view}
-                      <div .#{toOffset (bflInputOffset formLayout)} .#{toColumn (bflInputSize formLayout)}>
-                        ^{fvInput view}
-                        ^{helpWidget view}
-                    $else
-                      <div .#{toOffset (addGO (bflInputOffset formLayout) (addGO (bflLabelOffset formLayout) (bflLabelSize formLayout)))} .#{toColumn (bflInputSize formLayout)}>
-                        ^{fvInput view}
-                        ^{helpWidget view}
-                |]
-    return (res, widget)
-  where
-    nequals a b = a /= b -- work around older hamlet versions not liking /=
-
--- | (Internal) Render a help widget for tooltips and errors.
-helpWidget :: FieldView sub master -> GWidget sub master ()
-helpWidget view = [whamlet|
-    $maybe tt <- fvTooltip view
-      <span .help-block>#{tt}
-    $maybe err <- fvErrors view
-      <span .help-block>#{err}
-|]
-
-
--- | How the 'bootstrapSubmit' button should be rendered.
---
--- Since: yesod-form 1.3.8
-data BootstrapSubmit msg =
-    BootstrapSubmit
-        { bsValue   :: msg
-          -- ^ The text of the submit button.
-        , bsClasses :: Text
-          -- ^ Classes added to the @<button>@.
-        , bsAttrs   :: [(Text, Text)]
-          -- ^ Attributes added to the @<button>@.
-        } deriving (Show)
-
-instance IsString msg => IsString (BootstrapSubmit msg) where
-    fromString msg = BootstrapSubmit (fromString msg) " btn-default " []
-
-
--- | A Bootstrap v3 submit button disguised as a field for
--- convenience.  For example, if your form currently is:
---
--- > Person <$> areq textField "Name"    Nothing
--- >        <*> areq textField "Surname" Nothing
---
--- Then just change it to:
---
--- > Person <$> areq textField "Name"    Nothing
--- >        <*> areq textField "Surname" Nothing
--- >        <*  bootstrapSubmit "Register"
---
--- (Note that @<*@ is not a typo.)
---
--- Alternatively, you may also just create the submit button
--- manually as well in order to have more control over its
--- layout.
---
--- Since: yesod-form 1.3.8
-bootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> AForm sub master ()
-bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
-
-
--- | Same as 'bootstrapSubmit' but for monadic forms.  This isn't
--- as useful since you're not going to use 'renderBootstrap3'
--- anyway.
---
--- Since: yesod-form 1.3.8
-mbootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> MForm sub master (FormResult (), FieldView sub master)
-mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
-    let res = FormSuccess ()
-        widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]
-        fv  = FieldView { fvLabel    = ""
-                        , fvTooltip  = Nothing
-                        , fvId       = bootstrapSubmitId
-                        , fvInput    = widget
-                        , fvErrors   = Nothing
-                        , fvRequired = False }
-    in return (res, fv)
-
-
--- | A royal hack.  Magic id used to identify whether a field
--- should have no label.  A valid HTML4 id which is probably not
--- going to clash with any other id should someone use
--- 'bootstrapSubmit' outside 'renderBootstrap3'.
-bootstrapSubmitId :: Text
-bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"

Assistant/WebApp/Common.hs

@@ -5,8 +5,6 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
-
 module Assistant.WebApp.Common (module X) where
 
 import Assistant.Common as X
@@ -15,9 +13,5 @@ import Assistant.WebApp.Page as X
 import Assistant.WebApp.Form as X
 import Assistant.WebApp.Types as X
 import Assistant.WebApp.RepoId as X
-#if MIN_VERSION_yesod(1,2,0)
 import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
-#else
-import Utility.Yesod as X hiding (textField, passwordField, selectField, selectFieldList, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
-#endif
 import Data.Text as X (Text)

Assistant/WebApp/Configurators/Edit.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Assistant.WebApp.Configurators.Edit where
 

Assistant/WebApp/Configurators/Local.hs

@@ -5,7 +5,8 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings, RankNTypes, KindSignatures, TypeFamilies #-}
+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE RankNTypes, KindSignatures, TypeFamilies, FlexibleContexts #-}
 
 module Assistant.WebApp.Configurators.Local where
 
@@ -50,18 +51,10 @@ data RepositoryPath = RepositoryPath Text
  -
  - Validates that the path entered is not empty, and is a safe value
  - to use as a repository. -}
-#if MIN_VERSION_yesod(1,2,0)
 repositoryPathField :: forall (m :: * -> *). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text
-#else
-repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
-#endif
 repositoryPathField autofocus = Field
-#if ! MIN_VERSION_yesod_form(1,2,0)
-	{ fieldParse = parse
-#else
 	{ fieldParse = \l _ -> parse l
 	, fieldEnctype = UrlEncoded
-#endif
 	, fieldView = view
 	}
   where

Assistant/WebApp/Configurators/Pairing.hs

@@ -39,7 +39,7 @@ import Git
 import qualified Data.Text as T
 #ifdef WITH_PAIRING
 import qualified Data.Text.Encoding as T
-import qualified Data.ByteString.Lazy as B
+import qualified Data.ByteString as B
 import Data.Char
 import qualified Control.Exception as E
 import Control.Concurrent
@@ -304,7 +304,7 @@ secretProblem s
 	| otherwise = Nothing
 
 toSecret :: Text -> Secret
-toSecret s = B.fromChunks [T.encodeUtf8 $ T.toLower $ T.filter isAlphaNum s]
+toSecret s = T.encodeUtf8 $ T.toLower $ T.filter isAlphaNum s
 
 {- From Dickens -}
 sampleQuote :: Text

Assistant/WebApp/Configurators/Preferences.hs

@@ -17,7 +17,7 @@ import qualified Annex
 import qualified Git
 import Config
 import Config.Files
-import Config.NumCopies
+import Annex.NumCopies
 import Utility.DataUnits
 import Git.Config
 import Types.Distribution

Assistant/WebApp/Configurators/Ssh.hs

@@ -6,7 +6,7 @@
  -}
 
 {-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, FlexibleContexts #-}
 
 module Assistant.WebApp.Configurators.Ssh where
 
@@ -86,11 +86,7 @@ mkSshInput s = SshInput
 	, inputPort = sshPort s
 	}
 
-#if MIN_VERSION_yesod(1,2,0)
 sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
-#else
-sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput
-#endif
 sshInputAForm hostnamefield d = normalize <$> gen
   where
 	gen = SshInput
@@ -107,7 +103,7 @@ sshInputAForm hostnamefield d = normalize <$> gen
 		, ("existing ssh key", ExistingSshKey)
 		]
 
-	check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
+	check_username = checkBool (all (`notElem` ("/:@ \t" :: String)) . T.unpack)
 		bad_username textField
 
 	bad_username = "bad user name" :: Text

Assistant/WebApp/Form.hs

@@ -8,28 +8,15 @@
 {-# LANGUAGE FlexibleContexts, TypeFamilies, QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses, TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings, RankNTypes #-}
-{-# LANGUAGE CPP #-}
 
 module Assistant.WebApp.Form where
 
 import Assistant.WebApp.Types
 import Assistant.Gpg
 
-#if MIN_VERSION_yesod(1,2,0)
 import Yesod hiding (textField, passwordField)
 import Yesod.Form.Fields as F
-#else
-import Yesod hiding (textField, passwordField, selectField, selectFieldList)
-import Yesod.Form.Fields as F hiding (selectField, selectFieldList)
-import Data.String (IsString (..))
-import Control.Monad (unless)
-import Data.Maybe (listToMaybe)
-#endif
-#if MIN_VERSION_yesod_form(1,3,8)
 import Yesod.Form.Bootstrap3 as Y hiding (bfs)
-#else
-import Assistant.WebApp.Bootstrap3 as Y hiding (bfs)
-#endif
 import Data.Text (Text)
 
 {- Yesod's textField sets the required attribute for required fields.
@@ -61,60 +48,8 @@ passwordField = F.passwordField
 |]
 	}
 
-{- In older Yesod versions attrs is written into the <option> tag instead of the
- - surrounding <select>. This breaks the Bootstrap 3 layout of select fields as
- - it requires the "form-control" class on the <select> tag.
- - We need to change that to behave the same way as in newer versions.
- -}
-#if ! MIN_VERSION_yesod(1,2,0)
-selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a
-selectFieldList = selectField . optionsPairs
-
-selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
-selectField = selectFieldHelper
-	(\theId name attrs inside -> [whamlet|<select ##{theId} name=#{name} *{attrs}>^{inside}|]) -- outside
-	(\_theId _name isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
-	(\_theId _name _attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected>#{text}|]) -- inside
-
-selectFieldHelper :: (Eq a, RenderMessage master FormMessage)
-	=> (Text -> Text -> [(Text, Text)] -> GWidget sub master () -> GWidget sub master ())
-	-> (Text -> Text -> Bool -> GWidget sub master ())
-	-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget sub master ())
-	-> GHandler sub master (OptionList a) -> Field sub master a
-selectFieldHelper outside onOpt inside opts' = Field
-	{ fieldParse = \x -> do
-		opts <- opts'
-		return $ selectParser opts x
-	, fieldView = \theId name attrs val isReq -> do
-		opts <- fmap olOptions $ lift opts'
-		outside theId name attrs $ do
-			unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
-			flip mapM_ opts $ \opt -> inside
-				theId
-				name
-				((if isReq then (("required", "required"):) else id) attrs)
-				(optionExternalValue opt)
-				((render opts val) == optionExternalValue opt)
-				(optionDisplay opt)
-	}
-  where
-	render _ (Left _) = ""
-	render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts
-	selectParser _ [] = Right Nothing
-	selectParser opts (s:_) = case s of
-		"" -> Right Nothing
-		"none" -> Right Nothing
-		x -> case olReadExternal opts x of
-			Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
-			Just y -> Right $ Just y
-#endif
-
 {- Makes a note widget be displayed after a field. -}
-#if MIN_VERSION_yesod(1,2,0)
 withNote :: (Monad m, ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v
-#else
-withNote :: Field sub master v -> GWidget sub master () -> Field sub master v
-#endif
 withNote field note = field { fieldView = newview }
   where
 	newview theId name attrs val isReq = 
@@ -122,11 +57,7 @@ withNote field note = field { fieldView = newview }
 		in [whamlet|^{fieldwidget}&nbsp;&nbsp;<span>^{note}</span>|]
 
 {- Note that the toggle string must be unique on the form. -}
-#if MIN_VERSION_yesod(1,2,0)
 withExpandableNote :: (Monad m, ToWidget (HandlerSite m) w) => Field m v -> (String, w) -> Field m v
-#else
-withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v
-#endif
 withExpandableNote field (toggle, note) = withNote field $ [whamlet|
 <a .btn .btn-default data-toggle="collapse" data-target="##{ident}">#{toggle}</a>
 <div ##{ident} .collapse>
@@ -136,11 +67,7 @@ withExpandableNote field (toggle, note) = withNote field $ [whamlet|
 	ident = "toggle_" ++ toggle
 
 {- Adds a check box to an AForm to control encryption. -}
-#if MIN_VERSION_yesod(1,2,0)
 enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT site IO) EnableEncryption
-#else
-enableEncryptionField :: RenderMessage master FormMessage => AForm sub master EnableEncryption
-#endif
 enableEncryptionField = areq (selectFieldList choices) (bfs "Encryption") (Just SharedEncryption)
   where
 	choices :: [(Text, EnableEncryption)]

Assistant/WebApp/Notifications.hs

@@ -5,13 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
-
-#if defined VERSION_yesod_default
-#if ! MIN_VERSION_yesod_default(1,1,0)
-#define WITH_OLD_YESOD
-#endif
-#endif
 
 module Assistant.WebApp.Notifications where
 
@@ -26,9 +20,7 @@ import Utility.WebApp
 
 import Data.Text (Text)
 import qualified Data.Text as T
-#ifndef WITH_OLD_YESOD
 import qualified Data.Aeson.Types as Aeson
-#endif
 
 {- Add to any widget to make it auto-update using long polling.
  -
@@ -42,15 +34,9 @@ import qualified Data.Aeson.Types as Aeson
  -}
 autoUpdate :: Text -> Route WebApp -> Int -> Int -> Widget
 autoUpdate tident geturl ms_delay ms_startdelay = do
-#ifdef WITH_OLD_YESOD
-	let delay = show ms_delay
-	let startdelay = show ms_startdelay
-	let ident = "'" ++ T.unpack tident ++ "'"
-#else
 	let delay = Aeson.String (T.pack (show ms_delay))
 	let startdelay = Aeson.String (T.pack (show ms_startdelay))
 	let ident = Aeson.String tident
-#endif
 	$(widgetFile "notifications/longpolling")
 
 {- Notifier urls are requested by the javascript, to avoid allocation

Assistant/WebApp/SideBar.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
 
 module Assistant.WebApp.SideBar where
 

Assistant/WebApp/Types.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
 {-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
 {-# LANGUAGE FlexibleInstances, FlexibleContexts, ViewPatterns #-}
-{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Assistant.WebApp.Types where
@@ -83,58 +82,30 @@ instance Yesod WebApp where
 instance RenderMessage WebApp FormMessage where
 	renderMessage _ _ = defaultFormMessage
 
-#if MIN_VERSION_yesod(1,2,0)
 instance LiftAnnex Handler where
-#else
-instance LiftAnnex (GHandler sub WebApp) where
-#endif
 	liftAnnex a = ifM (noAnnex <$> getYesod)
 		( error "internal liftAnnex"
 		, liftAssistant $ liftAnnex a
 		)
 
-#if MIN_VERSION_yesod(1,2,0)
 instance LiftAnnex (WidgetT WebApp IO) where
-#else
-instance LiftAnnex (GWidget WebApp WebApp) where
-#endif
 	liftAnnex = liftH . liftAnnex
 
 class LiftAssistant m where
 	liftAssistant :: Assistant a -> m a
 
-#if MIN_VERSION_yesod(1,2,0)
 instance LiftAssistant Handler where
-#else
-instance LiftAssistant (GHandler sub WebApp) where
-#endif
 	liftAssistant a = liftIO . flip runAssistant a
 		=<< assistantData <$> getYesod
 
-#if MIN_VERSION_yesod(1,2,0)
 instance LiftAssistant (WidgetT WebApp IO) where
-#else
-instance LiftAssistant (GWidget WebApp WebApp) where
-#endif
 	liftAssistant = liftH . liftAssistant
 
-#if MIN_VERSION_yesod(1,2,0)
 type MkMForm x = MForm Handler (FormResult x, Widget)
-#else
-type MkMForm x = MForm WebApp WebApp (FormResult x, Widget)
-#endif
 
-#if MIN_VERSION_yesod(1,2,0)
 type MkAForm x = AForm Handler x
-#else
-type MkAForm x = AForm WebApp WebApp x
-#endif
 
-#if MIN_VERSION_yesod(1,2,0)
+type MkField x = forall m. Monad m => RenderMessage (HandlerSite m) FormMessage => Field m x
-type MkField x = Monad m => RenderMessage (HandlerSite m) FormMessage => Field m x
-#else
-type MkField x = RenderMessage master FormMessage => Field sub master x
-#endif
 
 data RepoSelector = RepoSelector
 	{ onlyCloud :: Bool
@@ -154,12 +125,6 @@ data RemovableDrive = RemovableDrive
 data RepoKey = RepoKey KeyId | NoRepoKey
 	deriving (Read, Show, Eq, Ord)
 
-#if ! MIN_VERSION_path_pieces(0,1,4)
-instance PathPiece Bool where
-	toPathPiece = pack . show
-	fromPathPiece = readish . unpack
-#endif
-
 instance PathPiece RemovableDrive where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack

Assistant/XMPP.hs

@@ -22,7 +22,8 @@ import qualified Data.Map as M
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import Data.XML.Types
-import qualified "dataenc" Codec.Binary.Base64 as B64
+import qualified "sandi" Codec.Binary.Base64 as B64
+import Data.Bits.Utils
 
 {- Name of the git-annex tag, in our own XML namespace.
  - (Not using a namespace URL to avoid unnecessary bloat.) -}
@@ -212,10 +213,10 @@ encodeExitCode (ExitFailure n) = n
 
 {- Base 64 encoding a ByteString to use as the content of a tag. -}
 encodeTagContent :: ByteString -> [Node]
-encodeTagContent b = [NodeContent $ ContentText $ T.pack $ B64.encode $ B.unpack b]
+encodeTagContent b = [NodeContent $ ContentText $ T.pack $ w82s $ B.unpack $ B64.encode b]
 
 decodeTagContent :: Element -> Maybe ByteString
-decodeTagContent elt = B.pack <$> B64.decode s
+decodeTagContent elt = either (const Nothing) Just (B64.decode $ B.pack $ s2w8 s)
   where
 	s = T.unpack $ T.concat $ elementText elt
 

Build/BundledPrograms.hs

@@ -35,13 +35,14 @@ bundledPrograms = catMaybes
 #endif
 	, Just "rsync"
 #ifndef darwin_HOST_OS
+#ifndef mingw32_HOST_OS
 	-- OS X has ssh installed by default.
 	-- Linux probably has ssh, but not guaranteed.
-	-- On Windows, msysgit provides ssh, but not in PATH, 
+	-- On Windows, msysgit provides ssh.
-	-- so we ship our own.
 	, Just "ssh"
 	, Just "ssh-keygen"
 #endif
+#endif
 #ifndef mingw32_HOST_OS
 	, Just "sh"
 #endif

Build/Configure.hs

@@ -1,5 +1,7 @@
 {- Checks system configuration and generates SysConfig.hs. -}
 
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
 module Build.Configure where
 
 import System.Directory

Build/DesktopFile.hs

@@ -7,6 +7,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Build.DesktopFile where
 

Build/DistributionUpdate.hs

@@ -10,7 +10,7 @@
 
 import Common.Annex
 import Types.Distribution
-import Build.Version
+import Build.Version (getChangelogVersion, Version)
 import Utility.UserInfo
 import Utility.Url
 import qualified Git.Construct

Build/NullSoftInstaller.hs

@@ -1,7 +1,8 @@
 {- Generates a NullSoft installer program for git-annex on Windows.
  - 
  - To build the installer, git-annex should already be built by cabal,
- - and ssh and rsync, as well as cygwin libraries, already installed.
+ - and ssh and rsync etc, as well as cygwin libraries, already installed
+ - from cygwin.
  -
  - This uses the Haskell nsis package (cabal install nsis)
  - to generate a .nsi file, which is then used to produce
@@ -11,7 +12,7 @@
  - exception of git. The user needs to install git separately,
  - and the installer checks for that.
  -
- - Copyright 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -22,13 +23,17 @@ import Development.NSIS
 import System.Directory
 import System.FilePath
 import Control.Monad
+import Control.Applicative
 import Data.String
 import Data.Maybe
+import Data.Char
+import Data.List (nub, isPrefixOf)
 
 import Utility.Tmp
 import Utility.Path
 import Utility.CopyFile
 import Utility.SafeCommand
+import Utility.Process
 import Build.BundledPrograms
 
 main = do
@@ -37,17 +42,19 @@ main = do
 		mustSucceed "ln" [File "dist/build/git-annex/git-annex.exe", File gitannex]
 		let license = tmpdir </> licensefile
 		mustSucceed "sh" [Param "-c", Param $ "zcat standalone/licences.gz > '" ++ license ++ "'"]
-		extrabins <- forM (cygwinPrograms ++ cygwinDlls) $ \f -> do
+		extrabins <- forM (cygwinPrograms) $ \f -> do
 			p <- searchPath f
 			when (isNothing p) $
 				print ("unable to find in PATH", f)
 			return p
+		dlls <- forM (catMaybes extrabins) findCygLibs
+		dllpaths <- mapM searchPath (nub (concat dlls))
 		webappscript <- vbsLauncher tmpdir "git-annex-webapp" "git-annex webapp"
 		autostartscript <- vbsLauncher tmpdir "git-annex-autostart" "git annex assistant --autostart"
 		let htmlhelp = tmpdir </> "git-annex.html"
 		writeFile htmlhelp htmlHelpText
 		writeFile nsifile $ makeInstaller gitannex license htmlhelp
-			(catMaybes extrabins)
+			(wrappers ++ catMaybes (extrabins ++ dllpaths))
 			[ webappscript, autostartscript ]
 		mustSucceed "makensis" [File nsifile]
 	removeFile nsifile -- left behind if makensis fails
@@ -85,7 +92,7 @@ uninstaller = "git-annex-uninstall.exe"
 gitInstallDir :: Exp FilePath
 gitInstallDir = fromString "$PROGRAMFILES\\Git"
 
--- This intentionall has a different name than git-annex or
+-- This intentionally has a different name than git-annex or
 -- git-annex-webapp, since it is itself treated as an executable file.
 -- Also, on XP, the filename is displayed, not the description.
 startMenuItem :: Exp FilePath
@@ -169,46 +176,6 @@ makeInstaller gitannex license htmlhelp extrabins launchers = nsis $ do
 cygwinPrograms :: [FilePath]
 cygwinPrograms = map (\p -> p ++ ".exe") bundledPrograms
 
--- These are the dlls needed by Cygwin's rsync, ssh, etc.
--- TODO: Use ldd (available in cygwin) to automatically find all
--- needed libs.
-cygwinDlls :: [FilePath]
-cygwinDlls =
-	[ "cygwin1.dll"
-	, "cygasn1-8.dll"
-	, "cygattr-1.dll"
-	, "cygheimbase-1.dll"
-	, "cygroken-18.dll"
-	, "cygcom_err-2.dll"
-	, "cygheimntlm-0.dll"
-	, "cygsqlite3-0.dll"
-	, "cygcrypt-0.dll"
-	, "cyghx509-5.dll"
-	, "cygssp-0.dll"
-	, "cygcrypto-1.0.0.dll"
-	, "cygiconv-2.dll"
-	, "cyggcc_s-1.dll"
-	, "cygintl-8.dll"
-	, "cygwind-0.dll"
-	, "cyggssapi-3.dll"
-	, "cygkrb5-26.dll"
-	, "cygz.dll"
-	, "cygidn-11.dll"
-	, "libcurl-4.dll"
-	, "cyggnutls-26.dll"
-	, "libcrypto.dll"
-	, "libssl.dll"
-	, "cyggcrypt-11.dll"
-	, "cyggpg-error-0.dll"
-	, "cygp11-kit-0.dll"
-	, "cygtasn1-3.dll"
-	, "cygffi-6.dll"
-	, "cygbz2-1.dll"
-	, "cygreadline7.dll"
-	, "cygncursesw-10.dll"
-	, "cygusb0.dll"
-	]
-
 -- msysgit opens Program Files/Git/doc/git/html/git-annex.html
 -- when git annex --help is run.
 htmlHelpText :: String
@@ -221,3 +188,18 @@ htmlHelpText = unlines
 	, "</body>"
 	, "</html"
 	]
+
+-- Find cygwin libraries used by the specified executable.
+findCygLibs :: FilePath -> IO [FilePath]
+findCygLibs p = filter iscyg . mapMaybe parse . lines <$> readProcess "ldd" [p]
+  where
+	parse l = case words (dropWhile isSpace l) of
+		(dll:"=>":_dllpath:_offset:[]) -> Just dll
+		_ -> Nothing
+	iscyg f = "cyg" `isPrefixOf` f || "lib" `isPrefixOf` f
+
+wrappers :: [FilePath]
+wrappers = 
+	[ "standalone\\windows\\ssh.cmd"
+	, "standalone\\windows\\ssh-keygen.cmd"
+	]

Build/TestConfig.hs

@@ -1,5 +1,7 @@
 {- Tests the system and generates Build.SysConfig.hs. -}
 
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
 module Build.TestConfig where
 
 import Utility.Path

Build/Version.hs

@@ -1,5 +1,7 @@
 {- Package version determination, for configure script. -}
 
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
 module Build.Version where
 
 import Data.Maybe
@@ -18,7 +20,7 @@ type Version = String
 {- Set when making an official release. (Distribution vendors should set
  - this too.) -}
 isReleaseBuild :: IO Bool
-isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD")
+isReleaseBuild = (== Just "1") <$> catchMaybeIO (getEnv "RELEASE_BUILD")
 
 {- Version is usually based on the major version from the changelog, 
  - plus the date of the last commit, plus the git rev of that commit.

Build/mdwn2man

@@ -20,6 +20,7 @@ while (<>) {
 	s/^[ \n]+//;
 	s/^\t/ /;
 	s/-/\\-/g;
+	s/git\\-annex/git-annex/g;
 	s/^Warning:.*//g;
 	s/^$/.PP\n/;
 	s/^\*\s+(.*)/.IP "$1"/;

CmdLine/Action.hs

@@ -5,8 +5,6 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE BangPatterns #-}
-
 module CmdLine.Action where
 
 import Common.Annex
@@ -119,14 +117,11 @@ includeCommandAction a = account =<< tryIO go
 	account (Right True) = return True
 	account (Right False) = incerr
 	account (Left err) = do
-		showErr err
+		toplevelWarning True (show err)
 		showEndFail
 		incerr
 	incerr = do
-		Annex.changeState $ \s -> 
+		Annex.incError
-			let ! c = Annex.errcounter s + 1 
-			    ! s' = s { Annex.errcounter = c }
-			in s'
 		return False
 
 {- Runs a single command action through the start, perform and cleanup

CmdLine/Batch.hs

@@ -0,0 +1,41 @@
+{- git-annex batch commands
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module CmdLine.Batch where
+
+import Common.Annex
+import Command
+
+batchOption :: Option
+batchOption = flagOption [] "batch" "enable batch mode"
+
+data BatchMode = Batch | NoBatch
+type Batchable t = BatchMode -> t -> CommandStart
+
+-- A Batchable command can run in batch mode, or not.
+-- In batch mode, one line at a time is read, parsed, and a reply output to
+-- stdout. In non batch mode, the command's parameters are parsed and
+-- a reply output for each.
+batchable :: ((t -> CommandStart) -> CommandSeek) -> Batchable t -> CommandSeek
+batchable seeker starter params = ifM (getOptionFlag batchOption)
+	( batchloop
+	, seeker (starter NoBatch) params
+	)
+  where
+	batchloop = do
+		mp <- liftIO $ catchMaybeIO getLine
+		case mp of
+			Nothing -> return ()
+			Just p -> do
+				seeker (starter Batch) [p]
+				batchloop
+
+-- bad input is indicated by an empty line in batch mode. In non batch
+-- mode, exit on bad input.
+batchBadInput :: BatchMode -> Annex ()
+batchBadInput NoBatch = liftIO exitFailure
+batchBadInput Batch = liftIO $ putStrLn ""

CmdLine/GitAnnex.hs

@@ -74,6 +74,7 @@ import qualified Command.Dead
 import qualified Command.Group
 import qualified Command.Wanted
 import qualified Command.GroupWanted
+import qualified Command.Required
 import qualified Command.Schedule
 import qualified Command.Ungroup
 import qualified Command.Vicfg
@@ -149,6 +150,7 @@ cmds = concat
 	, Command.Group.cmd
 	, Command.Wanted.cmd
 	, Command.GroupWanted.cmd
+	, Command.Required.cmd
 	, Command.Schedule.cmd
 	, Command.Ungroup.cmd
 	, Command.Vicfg.cmd

CmdLine/Seek.hs

@@ -218,8 +218,9 @@ seekHelper a params = do
 	ll <- inRepo $ \g -> concat <$> forM (segmentXargsOrdered params)
 		(runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g))
 	forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p ->
-		unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $
+		unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ do
-			error $ p ++ " not found"
+			toplevelWarning False (p ++ " not found")
+			Annex.incError
 	return $ concat ll
 
 notSymlink :: FilePath -> IO Bool

Command/Add.hs

@@ -116,7 +116,10 @@ start file = ifAnnexed file addpresent add
  - Lockdown can fail if a file gets deleted, and Nothing will be returned.
  -}
 lockDown :: FilePath -> Annex (Maybe KeySource)
-lockDown = either (\e -> showErr e >> return Nothing) (return . Just) <=< lockDown'
+lockDown = either 
+		(\e -> warning (show e) >> return Nothing)
+		(return . Just)
+	<=< lockDown'
 
 lockDown' :: FilePath -> Annex (Either IOException KeySource)
 lockDown' file = ifM crippledFileSystem

Command/AddUrl.hs

@@ -178,7 +178,7 @@ startWeb relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI urlstring
 		pathmax <- liftIO $ fileNameLengthLimit "."
 		let file = flip fromMaybe optfile $
 			truncateFilePath pathmax $ sanitizeFilePath $
-				Quvi.pageTitle page ++ "." ++ Quvi.linkSuffix link
+				Quvi.pageTitle page ++ "." ++ fromMaybe "m" (Quvi.linkSuffix link)
 		showStart "addurl" file
 		next $ performQuvi relaxed urlstring (Quvi.linkUrl link) file
 #else

Command/Assistant.hs

@@ -20,7 +20,7 @@ import Assistant.Install
 import System.Environment
 
 cmd :: [Command]
-cmd = [noRepo checkAutoStart $ dontCheck repoExists $ withOptions options $
+cmd = [noRepo checkNoRepoOpts $ dontCheck repoExists $ withOptions options $
 	notBareRepo $ command "assistant" paramNothing seek SectionCommon
 		"automatically sync changes"]
 
@@ -30,11 +30,15 @@ options =
 	, Command.Watch.stopOption
 	, autoStartOption
 	, startDelayOption
+	, autoStopOption
 	]
 
 autoStartOption :: Option
 autoStartOption = flagOption [] "autostart" "start in known repositories"
 
+autoStopOption :: Option
+autoStopOption = flagOption [] "autostop" "stop in known repositories"
+
 startDelayOption :: Option
 startDelayOption = fieldOption [] "startdelay" paramNumber "delay before running startup scan"
 
@@ -43,25 +47,31 @@ seek ps = do
 	stopdaemon <- getOptionFlag Command.Watch.stopOption
 	foreground <- getOptionFlag Command.Watch.foregroundOption
 	autostart <- getOptionFlag autoStartOption
+	autostop <- getOptionFlag autoStopOption
 	startdelay <- getOptionField startDelayOption (pure . maybe Nothing parseDuration)
-	withNothing (start foreground stopdaemon autostart startdelay) ps
+	withNothing (start foreground stopdaemon autostart autostop startdelay) ps
 
-start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart
+start :: Bool -> Bool -> Bool -> Bool -> Maybe Duration -> CommandStart
-start foreground stopdaemon autostart startdelay
+start foreground stopdaemon autostart autostop startdelay
 	| autostart = do
 		liftIO $ autoStart startdelay
 		stop
+	| autostop = do
+		liftIO autoStop
+		stop
 	| otherwise = do
 		liftIO ensureInstalled
 		ensureInitialized
 		Command.Watch.start True foreground stopdaemon startdelay
 
-{- Run outside a git repository. Check to see if any parameter is
+{- Run outside a git repository; support autostart and autostop mode. -}
- - --autostart and enter autostart mode. -}
+checkNoRepoOpts :: CmdParams -> IO ()
-checkAutoStart :: CmdParams -> IO ()
+checkNoRepoOpts _ = ifM (elem "--autostart" <$> getArgs)
-checkAutoStart _ = ifM (elem "--autostart" <$> getArgs)
 	( autoStart Nothing
-	, error "Not in a git repository."
+	, ifM (elem "--autostop" <$> getArgs)
+		( autoStop
+		, error "Not in a git repository."
+		)
 	) 
 
 autoStart :: Maybe Duration -> IO ()
@@ -89,3 +99,15 @@ autoStart startdelay = do
 			[ Param "assistant"
 			, Param $ "--startdelay=" ++ fromDuration (fromMaybe (Duration 5) startdelay)
 			]
+
+autoStop :: IO ()
+autoStop = do
+	dirs <- liftIO readAutoStartFile
+	program <- programPath
+	forM_ dirs $ \d -> do
+		putStrLn $ "git-annex autostop in " ++ d
+		setCurrentDirectory d
+		ifM (boolSystem program [Param "assistant", Param "--stop"])
+			( putStrLn "ok"
+			, putStrLn "failed"
+			)

Command/ContentLocation.hs

@@ -9,19 +9,20 @@ module Command.ContentLocation where
 
 import Common.Annex
 import Command
+import CmdLine.Batch
 import Annex.Content
 
 cmd :: [Command]
-cmd = [noCommit $ noMessages $
+cmd = [withOptions [batchOption] $ noCommit $ noMessages $
 	command "contentlocation" (paramRepeating paramKey) seek
 		SectionPlumbing "looks up content for a key"]
 
 seek :: CommandSeek
-seek = withKeys start
+seek = batchable withKeys start
 
-start :: Key -> CommandStart
+start :: Batchable Key
-start k = do
+start batchmode k = do
-	liftIO . maybe exitFailure putStrLn
+	maybe (batchBadInput batchmode) (liftIO . putStrLn)
 		=<< inAnnex' (pure True) Nothing check k
 	stop
   where

Command/Copy.hs

@@ -12,7 +12,7 @@ import Command
 import qualified Command.Move
 import qualified Remote
 import Annex.Wanted
-import Config.NumCopies
+import Annex.NumCopies
 
 cmd :: [Command]
 cmd = [withOptions copyOptions $ command "copy" paramPaths seek

Command/Drop.hs

@@ -15,7 +15,7 @@ import Annex.UUID
 import Logs.Location
 import Logs.Trust
 import Logs.PreferredContent
-import Config.NumCopies
+import Annex.NumCopies
 import Annex.Content
 import Annex.Wanted
 import Annex.Notification
@@ -27,7 +27,7 @@ cmd = [withOptions (dropOptions) $ command "drop" paramPaths seek
 	SectionCommon "indicate content of files not currently wanted"]
 
 dropOptions :: [Option]
-dropOptions = dropFromOption : annexedMatchingOptions ++ [autoOption]
+dropOptions = dropFromOption : annexedMatchingOptions ++ [autoOption] ++ keyOptions
 
 dropFromOption :: Option
 dropFromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote"
@@ -36,23 +36,32 @@ seek :: CommandSeek
 seek ps = do
 	from <- getOptionField dropFromOption Remote.byNameWithUUID
 	auto <- getOptionFlag autoOption
-	withFilesInGit (whenAnnexed $ start auto from) ps
+	withKeyOptions auto
+		(startKeys auto from)
+		(withFilesInGit $ whenAnnexed $ start auto from)
+		ps
 
 start :: Bool -> Maybe Remote -> FilePath -> Key -> CommandStart
-start auto from file key = checkDropAuto auto from file key $ \numcopies ->
+start auto from file key = start' auto from key (Just file)
+
+start' :: Bool -> Maybe Remote -> Key -> AssociatedFile -> CommandStart
+start' auto from key afile = checkDropAuto auto from afile key $ \numcopies ->
 	stopUnless want $
 		case from of
-			Nothing -> startLocal (Just file) numcopies key Nothing
+			Nothing -> startLocal afile numcopies key Nothing
 			Just remote -> do
 				u <- getUUID
 				if Remote.uuid remote == u
-					then startLocal (Just file) numcopies key Nothing
+					then startLocal afile numcopies key Nothing
-					else startRemote (Just file) numcopies key remote
+					else startRemote afile numcopies key remote
   where
 	want
-		| auto = wantDrop False (Remote.uuid <$> from) (Just key) (Just file)
+		| auto = wantDrop False (Remote.uuid <$> from) (Just key) afile
 		| otherwise = return True
 
+startKeys :: Bool -> Maybe Remote -> Key -> CommandStart
+startKeys auto from key = start' auto from key Nothing
+
 startLocal :: AssociatedFile -> NumCopies -> Key -> Maybe Remote -> CommandStart
 startLocal afile numcopies key knownpresentremote = stopUnless (inAnnex key) $ do
 	showStart' "drop" key afile
@@ -72,7 +81,7 @@ performLocal key afile numcopies knownpresentremote = lockContent key $ \content
 	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
 	let trusteduuids' = case knownpresentremote of
 		Nothing -> trusteduuids
-		Just r -> nub (Remote.uuid r:trusteduuids)
+		Just r -> Remote.uuid r:trusteduuids
 	untrusteduuids <- trustGet UnTrusted
 	let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids'++untrusteduuids)
 	u <- getUUID
@@ -91,17 +100,9 @@ performRemote key afile numcopies remote = do
 	-- Filter the remote it's being dropped from out of the lists of
 	-- places assumed to have the key, and places to check.
 	-- When the local repo has the key, that's one additional copy,
-	-- as long asthe local repo is not untrusted.
+	-- as long as the local repo is not untrusted.
-	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
+	(remotes, trusteduuids) <- knownCopies key
-	present <- inAnnex key
+	let have = filter (/= uuid) trusteduuids
-	u <- getUUID
-	trusteduuids' <- if present
-		then ifM ((<= SemiTrusted) <$> lookupTrust u)
-			( pure (u:trusteduuids)
-			, pure trusteduuids
-			)
-		else pure trusteduuids
-	let have = filter (/= uuid) trusteduuids'
 	untrusteduuids <- trustGet UnTrusted
 	let tocheck = filter (/= remote) $
 		Remote.remotesWithoutUUID remotes (have++untrusteduuids)
@@ -131,45 +132,20 @@ cleanupRemote key remote ok = do
  - --force overrides and always allows dropping.
  -}
 canDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [Remote] -> [UUID] -> Annex Bool
-canDrop dropfrom key afile numcopies have check skip = ifM (Annex.getState Annex.force)
+canDrop dropfrom key afile numcopies have check skip = 
-	( return True
+	ifM (Annex.getState Annex.force)
-	, checkRequiredContent dropfrom key afile
+		( return True
-		<&&>
+			, ifM (checkRequiredContent dropfrom key afile
-	  findCopies key numcopies skip have check
+				<&&> verifyEnoughCopies nolocmsg key numcopies skip have check
-	)
+				)
-
+				( return True
-findCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
+				, do
-findCopies key need skip = helper [] []
+					hint
+					return False
+				)
+		)
   where
-	helper bad missing have []
+	nolocmsg = "Rather than dropping this file, try using: git annex move"
-		| NumCopies (length have) >= need = return True
-		| otherwise = notEnoughCopies key need have (skip++missing) bad
-	helper bad missing have (r:rs)
-		| NumCopies (length have) >= need = return True
-		| otherwise = do
-			let u = Remote.uuid r
-			let duplicate = u `elem` have
-			haskey <- Remote.hasKey r key
-			case (duplicate, haskey) of
-				(False, Right True)  -> helper bad missing (u:have) rs
-				(False, Left _)      -> helper (r:bad) missing have rs
-				(False, Right False) -> helper bad (u:missing) have rs
-				_                    -> helper bad missing have rs
-
-notEnoughCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
-notEnoughCopies key need have skip bad = do
-	unsafe
-	showLongNote $
-		"Could only verify the existence of " ++
-		show (length have) ++ " out of " ++ show (fromNumCopies need) ++ 
-		" necessary copies"
-	Remote.showTriedRemotes bad
-	Remote.showLocations True key (have++skip)
-		"Rather than dropping this file, try using: git annex move"
-	hint
-	return False
-  where
-	unsafe = showNote "unsafe"
 	hint = showLongNote "(Use --force to override this check, or adjust numcopies.)"
 
 checkRequiredContent :: UUID -> Key -> AssociatedFile -> Annex Bool
@@ -187,8 +163,8 @@ requiredContent = do
 
 {- In auto mode, only runs the action if there are enough
  - copies on other semitrusted repositories. -}
-checkDropAuto :: Bool -> Maybe Remote -> FilePath -> Key -> (NumCopies -> CommandStart) -> CommandStart
+checkDropAuto :: Bool -> Maybe Remote -> AssociatedFile -> Key -> (NumCopies -> CommandStart) -> CommandStart
-checkDropAuto auto mremote file key a = go =<< getFileNumCopies file
+checkDropAuto auto mremote afile key a = go =<< maybe getNumCopies getFileNumCopies afile
   where
 	go numcopies
 		| auto = do

Command/DropUnused.hs

@@ -14,7 +14,7 @@ import qualified Command.Drop
 import qualified Remote
 import qualified Git
 import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
-import Config.NumCopies
+import Annex.NumCopies
 
 cmd :: [Command]
 cmd = [withOptions [Command.Drop.dropFromOption] $

Command/ExamineKey.hs

@@ -9,21 +9,22 @@ module Command.ExamineKey where
 
 import Common.Annex
 import Command
+import CmdLine.Batch
 import qualified Utility.Format
 import Command.Find (formatOption, getFormat, showFormatted, keyVars)
 import Types.Key
 
 cmd :: [Command]
-cmd = [noCommit $ noMessages $ withOptions [formatOption, jsonOption] $
+cmd = [noCommit $ noMessages $ withOptions [formatOption, jsonOption, batchOption] $
 	command "examinekey" (paramRepeating paramKey) seek
 	SectionPlumbing "prints information from a key"]
 
 seek :: CommandSeek
 seek ps = do
 	format <- getFormat
-	withKeys (start format) ps
+	batchable withKeys (start format) ps
 
-start :: Maybe Utility.Format.Format -> Key -> CommandStart
+start :: Maybe Utility.Format.Format -> Batchable Key
-start format key = do
+start format _ key = do
 	showFormatted format (key2file key) (keyVars key)
 	stop

Command/Fsck.hs

@@ -24,21 +24,21 @@ import Annex.Link
 import Logs.Location
 import Logs.Trust
 import Logs.Activity
-import Config.NumCopies
+import Logs.TimeStamp
+import Annex.NumCopies
 import Annex.UUID
 import Utility.DataUnits
 import Config
 import Types.Key
 import Types.CleanupActions
 import Utility.HumanTime
+import Utility.CopyFile
 import Git.FilePath
 import Utility.PID
 import qualified Database.Fsck as FsckDb
 
 import Data.Time.Clock.POSIX
-import Data.Time
 import System.Posix.Types (EpochTime)
-import System.Locale
 
 cmd :: [Command]
 cmd = [withOptions fsckOptions $ command "fsck" paramPaths seek
@@ -75,7 +75,7 @@ seek ps = do
 		(withFilesInGit $ whenAnnexed $ start from i)
 		ps
 	withFsckDb i FsckDb.closeDb
-	recordActivity Fsck u
+	void $ tryIO $ recordActivity Fsck u
 
 start :: Maybe Remote -> Incremental -> FilePath -> Key -> CommandStart
 start from inc file key = do
@@ -111,14 +111,15 @@ performRemote key file backend numcopies remote =
 	dispatch (Left err) = do
 		showNote err
 		return False
-	dispatch (Right True) = withtmp $ \tmpfile ->
+	dispatch (Right True) = withtmp $ \tmpfile -> do
-		ifM (getfile tmpfile)
+		r <- getfile tmpfile
-			( go True (Just tmpfile)
+		case r of
-			, do
+			Nothing -> go True Nothing
+			Just True -> go True (Just tmpfile)
+			Just False -> do
 				warning "failed to download file from remote"
 				void $ go True Nothing
 				return False
-			)
 	dispatch (Right False) = go False Nothing
 	go present localcopy = check
 		[ verifyLocationLogRemote key file remote present
@@ -134,14 +135,17 @@ performRemote key file backend numcopies remote =
 		let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
 		cleanup
 		cleanup `after` a tmp
-	getfile tmp =
+	getfile tmp = ifM (checkDiskSpace (Just tmp) key 0)
-		ifM (Remote.retrieveKeyFileCheap remote key (Just file) tmp)
+		( ifM (Remote.retrieveKeyFileCheap remote key (Just file) tmp)
-			( return True
+			( return (Just True)
 			, ifM (Annex.getState Annex.fast)
-				( return False
+				( return Nothing
-				, Remote.retrieveKeyFile remote key (Just file) tmp dummymeter
+				, Just <$>
+					Remote.retrieveKeyFile remote key Nothing tmp dummymeter
 				)
 			)
+		, return (Just False)
+		)
 	dummymeter _ = noop
 
 startKey :: Incremental -> Key -> NumCopies -> CommandStart
@@ -273,7 +277,7 @@ checkKeySize key = ifM isDirect
 checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool
 checkKeySizeRemote _ _ Nothing = return True
 checkKeySizeRemote key remote (Just file) =
-	checkKeySizeOr (badContentRemote remote) key file
+	checkKeySizeOr (badContentRemote remote file) key file
 
 checkKeySizeOr :: (Key -> Annex String) -> Key -> FilePath -> Annex Bool
 checkKeySizeOr bad key file = case Types.Key.keySize key of
@@ -318,7 +322,7 @@ checkBackend backend key mfile = go =<< isDirect
 checkBackendRemote :: Backend -> Key -> Remote -> Maybe FilePath -> Annex Bool
 checkBackendRemote backend key remote = maybe (return True) go
   where
-	go = checkBackendOr (badContentRemote remote) backend key
+	go file = checkBackendOr (badContentRemote remote file) backend key file
 
 checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool
 checkBackendOr bad backend key file =
@@ -380,13 +384,36 @@ badContentDirect file key = do
 	logStatus key InfoMissing
 	return "left in place for you to examine"
 
-badContentRemote :: Remote -> Key -> Annex String
+{- Bad content is dropped from the remote. We have downloaded a copy
-badContentRemote remote key = do
+ - from the remote to a temp file already (in some cases, it's just a
-	ok <- Remote.removeKey remote key
+ - symlink to a file in the remote). To avoid any further data loss,
-	when ok $
+ - that temp file is moved to the bad content directory unless 
+ - the local annex has a copy of the content. -}
+badContentRemote :: Remote -> FilePath -> Key -> Annex String
+badContentRemote remote localcopy key = do
+	bad <- fromRepo gitAnnexBadDir
+	let destbad = bad </> key2file key
+	movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad))
+		( return False
+		, do
+			createAnnexDirectory (parentDir destbad)
+			liftIO $ catchDefaultIO False $
+				ifM (isSymbolicLink <$> getSymbolicLinkStatus localcopy)
+					( copyFileExternal CopyTimeStamps localcopy destbad
+					, do
+						moveFile localcopy destbad
+						return True
+					)
+		)
+
+	dropped <- Remote.removeKey remote key
+	when dropped $
 		Remote.logStatus remote key InfoMissing
-	return $ (if ok then "dropped from " else "failed to drop from ")
+	return $ case (movedbad, dropped) of
-		++ Remote.name remote
+		(True, True) -> "moved from " ++ Remote.name remote ++
+			" to " ++ destbad
+		(False, True) -> "dropped from " ++ Remote.name remote
+		(_, False) -> "failed to drop from" ++ Remote.name remote
 
 runFsck :: Incremental -> FilePath -> Key -> Annex Bool -> CommandStart
 runFsck inc file key a = ifM (needFsck inc key)
@@ -448,14 +475,11 @@ getStartTime u = do
 	liftIO $ catchDefaultIO Nothing $ do
 		timestamp <- modificationTime <$> getFileStatus f
 		let fromstatus = Just (realToFrac timestamp)
-		fromfile <- readishTime <$> readFile f
+		fromfile <- parsePOSIXTime <$> readFile f
 		return $ if matchingtimestamp fromfile fromstatus
 			then Just timestamp
 			else Nothing
   where
-	readishTime :: String -> Maybe POSIXTime
-	readishTime s = utcTimeToPOSIXSeconds <$>
-		parseTime defaultTimeLocale "%s%Qs" s
 	matchingtimestamp fromfile fromstatus =
 #ifndef mingw32_HOST_OS
 		fromfile == fromstatus

Command/Get.hs

@@ -12,7 +12,7 @@ import Command
 import qualified Remote
 import Annex.Content
 import Annex.Transfer
-import Config.NumCopies
+import Annex.NumCopies
 import Annex.Wanted
 import qualified Command.Move
 

Command/GroupWanted.hs

@@ -8,13 +8,9 @@
 module Command.GroupWanted where
 
 import Common.Annex
-import qualified Annex
 import Command
 import Logs.PreferredContent
-import Types.Messages
+import Command.Wanted (performGet, performSet)
-import Types.Group
-
-import qualified Data.Map as M
 
 cmd :: [Command]
 cmd = [command "groupwanted" (paramPair paramGroup (paramOptional paramExpression)) seek
@@ -24,22 +20,8 @@ seek :: CommandSeek
 seek = withWords start
 
 start :: [String] -> CommandStart
-start (g:[]) = next $ performGet g
+start (g:[]) = next $ performGet groupPreferredContentMapRaw g
 start (g:expr:[]) = do
 	showStart "groupwanted" g
-	next $ performSet g expr
+	next $ performSet groupPreferredContentSet expr g
 start _ = error "Specify a group."
-
-performGet :: Group -> CommandPerform
-performGet g = do
-	Annex.setOutput QuietOutput
-	m <- groupPreferredContentMapRaw
-	liftIO $ putStrLn $ fromMaybe "" $ M.lookup g m
-	next $ return True
-
-performSet :: Group -> String -> CommandPerform
-performSet g expr = case checkPreferredContentExpression expr of
-	Just e -> error $ "Parse error: " ++ e
-	Nothing -> do
-		groupPreferredContentSet g expr
-		next $ return True

Command/Import.hs

@@ -9,6 +9,7 @@ module Command.Import where
 
 import Common.Annex
 import Command
+import qualified Git
 import qualified Annex
 import qualified Command.Add
 import Utility.CopyFile
@@ -16,6 +17,10 @@ import Backend
 import Remote
 import Types.KeySource
 import Types.Key
+import Annex.CheckIgnore
+import Annex.NumCopies
+import Types.TrustLevel
+import Logs.Trust
 
 cmd :: [Command]
 cmd = [withOptions opts $ notBareRepo $ command "import" paramPaths seek
@@ -58,6 +63,10 @@ getDuplicateMode = go . catMaybes <$> mapM getflag [minBound..maxBound]
 seek :: CommandSeek
 seek ps = do
 	mode <- getDuplicateMode
+	repopath <- liftIO . absPath =<< fromRepo Git.repoPath
+	inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath ps
+	unless (null inrepops) $ do
+		error $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
 	withPathContents (start mode) ps
 
 start :: DuplicateMode -> (FilePath, FilePath) -> CommandStart
@@ -75,23 +84,41 @@ start mode (srcfile, destfile) =
   where
 	deletedup k = do
 		showNote $ "duplicate of " ++ key2file k
-		liftIO $ removeFile srcfile
+		ifM (verifiedExisting k destfile)
-		next $ return True
+			( do
+				liftIO $ removeFile srcfile
+				next $ return True
+			, do
+				warning "Could not verify that the content is still present in the annex; not removing from the import location."
+				stop
+			)
 	importfile = do
-		handleexisting =<< liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile)
+		ignored <- not <$> Annex.getState Annex.force <&&> checkIgnored destfile
+		if ignored
+			then do
+				warning $ "not importing " ++ destfile ++ " which is .gitignored (use --force to override)"
+				stop
+			else do
+				existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile)
+				case existing of
+					Nothing -> importfilechecked
+					(Just s)
+						| isDirectory s -> notoverwriting "(is a directory)"
+						| otherwise -> ifM (Annex.getState Annex.force)
+							( do
+								liftIO $ nukeFile destfile
+								importfilechecked
+							, notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)"
+							)
+	importfilechecked = do
 		liftIO $ createDirectoryIfMissing True (parentDir destfile)
 		liftIO $ if mode == Duplicate || mode == SkipDuplicates
 			then void $ copyFileExternal CopyAllMetaData srcfile destfile
 			else moveFile srcfile destfile
 		Command.Add.perform destfile
-	handleexisting Nothing = noop
+	notoverwriting why = do
-	handleexisting (Just s)
+		warning $ "not overwriting existing " ++ destfile ++ " " ++ why
-		| isDirectory s = notoverwriting "(is a directory)"
+		stop
-		| otherwise = ifM (Annex.getState Annex.force)
-			( liftIO $ nukeFile destfile
-			, notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)"
-			)
-	notoverwriting why = error $ "not overwriting existing " ++ destfile ++ " " ++ why
 	checkdup dupa notdupa = do
 		backend <- chooseBackend destfile
 		let ks = KeySource srcfile srcfile Nothing
@@ -107,3 +134,14 @@ start mode (srcfile, destfile) =
 		CleanDuplicates -> checkdup (Just deletedup) Nothing
 		SkipDuplicates -> checkdup Nothing (Just importfile)
 		_ -> return (Just importfile)
+
+verifiedExisting :: Key -> FilePath -> Annex Bool
+verifiedExisting key destfile = do
+	-- Look up the numcopies setting for the file that it would be
+	-- imported to, if it were imported.
+	need <- getFileNumCopies destfile
+
+	(remotes, trusteduuids) <- knownCopies key
+	untrusteduuids <- trustGet UnTrusted
+	let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
+	verifyEnoughCopies [] key need trusteduuids [] tocheck

Command/ImportFeed.hs

@@ -16,7 +16,9 @@ import qualified Data.Set as S
 import qualified Data.Map as M
 import Data.Time.Clock
 import Data.Time.Format
+#if ! MIN_VERSION_time(1,5,0)
 import System.Locale
+#endif
 
 import Common.Annex
 import qualified Annex
@@ -196,7 +198,7 @@ performDownload opts cache todownload = case location todownload of
 					Just link -> do
 						let videourl = Quvi.linkUrl link
 						checkknown videourl $
-							rundownload videourl ("." ++ Quvi.linkSuffix link) $ \f ->
+							rundownload videourl ("." ++ fromMaybe "m" (Quvi.linkSuffix link)) $ \f ->
 								maybeToList <$> addUrlFileQuvi (relaxedOpt opts) quviurl videourl f
 #else
 		return False

Command/Info.hs

@@ -30,7 +30,7 @@ import Types.Key
 import Logs.UUID
 import Logs.Trust
 import Logs.Location
-import Config.NumCopies
+import Annex.NumCopies
 import Remote
 import Config
 import Utility.Percentage

Command/Log.hs

@@ -5,15 +5,19 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Command.Log where
 
 import qualified Data.Set as S
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Char
 import Data.Time.Clock.POSIX
 import Data.Time
+#if ! MIN_VERSION_time(1,5,0)
 import System.Locale
-import Data.Char
+#endif
 
 import Common.Annex
 import Command
@@ -172,7 +176,11 @@ parseRaw l = go $ words l
 
 parseTimeStamp :: String -> POSIXTime
 parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") .
+#if MIN_VERSION_time(1,5,0)
+	parseTimeM True defaultTimeLocale "%s"
+#else
 	parseTime defaultTimeLocale "%s"
+#endif
 
 showTimeStamp :: TimeZone -> POSIXTime -> String
 showTimeStamp zone = show . utcToLocalTime zone . posixSecondsToUTCTime

Command/LookupKey.hs

@@ -9,18 +9,20 @@ module Command.LookupKey where
 
 import Common.Annex
 import Command
+import CmdLine.Batch
 import Annex.CatFile
 import Types.Key
 
 cmd :: [Command]
-cmd = [notBareRepo $ noCommit $ noMessages $
+cmd = [withOptions [batchOption] $ notBareRepo $ noCommit $ noMessages $
 	command "lookupkey" (paramRepeating paramFile) seek
 		SectionPlumbing "looks up key used for file"]
 
 seek :: CommandSeek
-seek = withStrings start
+seek = batchable withStrings start
 
-start :: String -> CommandStart
+start :: Batchable String
-start file = do
+start batchmode file = do
-	liftIO . maybe exitFailure (putStrLn . key2file) =<< catKeyFile file
+	maybe (batchBadInput batchmode) (liftIO . putStrLn . key2file)
+		=<< catKeyFile file
 	stop

Command/Mirror.hs

@@ -14,7 +14,7 @@ import qualified Command.Drop
 import qualified Command.Get
 import qualified Remote
 import Annex.Content
-import Config.NumCopies
+import Annex.NumCopies
 
 cmd :: [Command]
 cmd = [withOptions mirrorOptions $ command "mirror" paramPaths seek

Command/NumCopies.hs

@@ -10,7 +10,7 @@ module Command.NumCopies where
 import Common.Annex
 import qualified Annex
 import Command
-import Config.NumCopies
+import Annex.NumCopies
 import Types.Messages
 
 cmd :: [Command]

Command/Required.hs

@@ -0,0 +1,17 @@
+{- git-annex command
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Required where
+
+import Command
+import Logs.PreferredContent
+import qualified Command.Wanted
+
+cmd :: [Command]
+cmd = Command.Wanted.cmd' "required" "get or set required content expression"
+	requiredContentMapRaw
+	requiredContentSet

Command/Wanted.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -13,39 +13,47 @@ import Command
 import qualified Remote
 import Logs.PreferredContent
 import Types.Messages
+import Types.StandardGroups
 
 import qualified Data.Map as M
 
 cmd :: [Command]
-cmd = [command "wanted" (paramPair paramRemote (paramOptional paramExpression)) seek
+cmd = cmd' "wanted" "get or set preferred content expression" 
-	SectionSetup "get or set preferred content expression"]
+	preferredContentMapRaw
+	preferredContentSet
 
-seek :: CommandSeek
+cmd'
-seek = withWords start
+	:: String
-
+	-> String
-start :: [String] -> CommandStart
+	-> Annex (M.Map UUID PreferredContentExpression)
-start = parse
+	-> (UUID -> PreferredContentExpression -> Annex ())
+	-> [Command]
+cmd' name desc getter setter = [command name pdesc seek SectionSetup desc]
   where
-	parse (name:[]) = go name performGet
+	pdesc = paramPair paramRemote (paramOptional paramExpression)
-	parse (name:expr:[]) = go name $ \uuid -> do
-		showStart "wanted" name
-		performSet expr uuid
-	parse _ = error "Specify a repository."
 
-	go name a = do
+	seek = withWords start
-		u <- Remote.nameToUUID name
+
+	start (rname:[]) = go rname (performGet getter)
+	start (rname:expr:[]) = go rname $ \uuid -> do
+		showStart name rname
+		performSet setter expr uuid
+	start _ = error "Specify a repository."
+		
+	go rname a = do
+		u <- Remote.nameToUUID rname
 		next $ a u
 
-performGet :: UUID -> CommandPerform
+performGet :: Ord a => Annex (M.Map a PreferredContentExpression) -> a -> CommandPerform
-performGet uuid = do
+performGet getter a = do
 	Annex.setOutput QuietOutput
-	m <- preferredContentMapRaw
+	m <- getter
-	liftIO $ putStrLn $ fromMaybe "" $ M.lookup uuid m
+	liftIO $ putStrLn $ fromMaybe "" $ M.lookup a m
 	next $ return True
 
-performSet :: String -> UUID -> CommandPerform
+performSet :: Ord a => (a -> PreferredContentExpression -> Annex ()) -> String -> a -> CommandPerform
-performSet expr uuid = case checkPreferredContentExpression expr of
+performSet setter expr a = case checkPreferredContentExpression expr of
 	Just e -> error $ "Parse error: " ++ e
 	Nothing -> do
-		preferredContentSet uuid expr
+		setter a expr
 		next $ return True

Command/WebApp.hs

@@ -143,10 +143,10 @@ firstRun :: Maybe HostName -> IO ()
 firstRun listenhost = do
 	checkEnvironmentIO
 	{- Without a repository, we cannot have an Annex monad, so cannot
-	 - get a ThreadState. Using undefined is only safe because the
+	 - get a ThreadState. This is only safe because the
 	 - webapp checks its noAnnex field before accessing the
 	 - threadstate. -}
-	let st = undefined
+	let st = error "annex state not available"
 	{- Get a DaemonStatus without running in the Annex monad. -}
 	dstatus <- atomically . newTMVar =<< newDaemonStatus
 	d <- newAssistantData st dstatus

Config/Files.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
 module Config.Files where
 
 import Common

Crypto.hs

@@ -34,8 +34,7 @@ module Crypto (
 ) where
 
 import qualified Data.ByteString.Lazy as L
-import Data.ByteString.Lazy.UTF8 (fromString)
+import Data.ByteString.UTF8 (fromString)
-import Control.Applicative
 import qualified Data.Map as M
 import Control.Monad.IO.Class
 
@@ -93,7 +92,7 @@ genSharedCipher highQuality =
 {- Updates an existing Cipher, re-encrypting it to add or remove keyids,
  - depending on whether the first component is True or False. -}
 updateEncryptedCipher :: [(Bool, String)] -> StorableCipher -> IO StorableCipher
-updateEncryptedCipher _ SharedCipher{} = undefined
+updateEncryptedCipher _ SharedCipher{} = error "Cannot update shared cipher"
 updateEncryptedCipher [] encipher = return encipher
 updateEncryptedCipher newkeys encipher@(EncryptedCipher _ variant (KeyIds ks)) = do
 	dropKeys <- listKeyIds [ k | (False, k) <- newkeys ]

Database/Fsck.hs

@@ -25,6 +25,7 @@ import qualified Database.Handle as H
 import Locations
 import Utility.PosixFiles
 import Utility.Exception
+import Common
 import Annex
 import Types.Key
 import Types.UUID
@@ -33,13 +34,6 @@ import Annex.LockFile
 
 import Database.Persist.TH
 import Database.Esqueleto hiding (Key)
-import Control.Monad
-import Control.Monad.IfElse
-import Control.Monad.IO.Class (liftIO)
-import System.Directory
-import System.FilePath
-import Data.Maybe
-import Control.Applicative
 
 data FsckHandle = FsckHandle H.DbHandle UUID
 
@@ -55,7 +49,7 @@ Fscked
  -
  - This may fail, if other fsck processes are currently running using the
  - database. Removing the database in that situation would lead to crashes
- - or undefined behavior.
+ - or unknown behavior.
  -}
 newPass :: UUID -> Annex Bool
 newPass u = isJust <$> tryExclusiveLock (gitAnnexFsckDbLock u) go

Git.hs

@@ -60,7 +60,7 @@ repoLocation Repo { location = Url url } = show url
 repoLocation Repo { location = Local { worktree = Just dir } } = dir
 repoLocation Repo { location = Local { gitdir = dir } } = dir
 repoLocation Repo { location = LocalUnknown dir } = dir
-repoLocation Repo { location = Unknown } = undefined
+repoLocation Repo { location = Unknown } = error "unknown repoLocation"
 
 {- Path to a repository. For non-bare, this is the worktree, for bare, 
  - it's the gitdir, and for URL repositories, is the path on the remote
@@ -70,12 +70,12 @@ repoPath Repo { location = Url u } = unEscapeString $ uriPath u
 repoPath Repo { location = Local { worktree = Just d } } = d
 repoPath Repo { location = Local { gitdir = d } } = d
 repoPath Repo { location = LocalUnknown dir } = dir
-repoPath Repo { location = Unknown } = undefined
+repoPath Repo { location = Unknown } = error "unknown repoPath"
 
 {- Path to a local repository's .git directory. -}
 localGitDir :: Repo -> FilePath
 localGitDir Repo { location = Local { gitdir = d } } = d
-localGitDir _ = undefined
+localGitDir _ = error "unknown localGitDir"
 
 {- Some code needs to vary between URL and normal repos,
  - or bare and non-bare, these functions help with that. -}

Git/CatFile.hs

@@ -110,4 +110,4 @@ catTree h treeref = go <$> catObjectDetails h treeref
 	parsemodefile b = 
 		let (modestr, file) = separate (== ' ') (decodeBS b)
 		in (file, readmode modestr)
-	readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct
+	readmode = fromMaybe 0 . fmap fst . headMaybe . readOct

Git/LsFiles.hs

@@ -181,12 +181,13 @@ parseUnmerged s
 	| otherwise = case words metadata of
 		(rawblobtype:rawsha:rawstage:_) -> do
 			stage <- readish rawstage :: Maybe Int
-			unless (stage == 2 || stage == 3) $
+			if stage /= 2 && stage /= 3
-				fail undefined -- skip stage 1
+				then Nothing
-			blobtype <- readBlobType rawblobtype
+				else do
-			sha <- extractSha rawsha
+					blobtype <- readBlobType rawblobtype
-			return $ InternalUnmerged (stage == 2) file
+					sha <- extractSha rawsha
-				(Just blobtype) (Just sha)
+					return $ InternalUnmerged (stage == 2) file
+						(Just blobtype) (Just sha)
 		_ -> Nothing
   where
 	(metadata, file) = separate (== '\t') s

Git/LsTree.hs

@@ -13,10 +13,6 @@ module Git.LsTree (
 	parseLsTree
 ) where
 
-import Numeric
-import Control.Applicative
-import System.Posix.Types
-
 import Common
 import Git
 import Git.Command
@@ -24,6 +20,9 @@ import Git.Sha
 import Git.FilePath
 import qualified Git.Filename
 
+import Numeric
+import System.Posix.Types
+
 data TreeItem = TreeItem
 	{ mode :: FileMode
 	, typeobj :: String

Git/Remote/Remove.hs

@@ -1,4 +1,4 @@
-{- git remote stuff
+{- git remote removal
  -
  - Copyright 2012 Joey Hess <id@joeyh.name>
  -

Git/Version.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
 module Git.Version (
 	installed,
 	older,

Limit.hs

@@ -15,7 +15,7 @@ import qualified Backend
 import Annex.Content
 import Annex.UUID
 import Logs.Trust
-import Config.NumCopies
+import Annex.NumCopies
 import Types.TrustLevel
 import Types.Key
 import Types.Group

Logs/Difference.hs

@@ -12,7 +12,6 @@ module Logs.Difference (
 	module Logs.Difference.Pure
 ) where
 
-import Data.Monoid
 import Data.Time.Clock.POSIX
 import qualified Data.Map as M
 

Logs/Difference/Pure.hs

@@ -10,7 +10,6 @@ module Logs.Difference.Pure (
 	parseDifferencesLog,
 ) where
 
-import Data.Monoid
 import qualified Data.Map as M
 
 import Common.Annex

Logs/MapLog.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 {- git-annex Map log
  -
  - This is used to store a Map, in a way that can be union merged.
@@ -13,10 +15,9 @@ module Logs.MapLog where
 
 import qualified Data.Map as M
 import Data.Time.Clock.POSIX
-import Data.Time
-import System.Locale
 
 import Common
+import Logs.TimeStamp
 
 data TimeStamp = Unknown | Date POSIXTime
 	deriving (Eq, Ord, Show)
@@ -42,7 +43,7 @@ parseMapLog fieldparser valueparser = M.fromListWith best . mapMaybe parse . lin
 	parse line = do
 		let (ts, rest) = splitword line
 		    (sf, sv) = splitword rest
-		date <- Date . utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" ts
+		date <- Date <$> parsePOSIXTime ts
 		f <- fieldparser sf
 		v <- valueparser sv
 		Just (f, LogEntry date v)

Logs/MetaData.hs

@@ -41,12 +41,11 @@ import qualified Annex.Branch
 import qualified Annex
 import Logs
 import Logs.SingleValue
+import Logs.TimeStamp
 
 import qualified Data.Set as S
 import qualified Data.Map as M
 import Data.Time.Clock.POSIX
-import Data.Time.Format
-import System.Locale
 
 instance SingleValueSerializable MetaData where
 	serialize = Types.MetaData.serialize
@@ -86,7 +85,7 @@ getCurrentMetaData k = do
 		    ts = lastchangedval l
 		in M.map (const ts) m
 	lastchangedval l = S.singleton $ toMetaValue $ showts $ changed l
-	showts = formatTime defaultTimeLocale "%F@%H-%M-%S" . posixSecondsToUTCTime
+	showts = formatPOSIXTime "%F@%H-%M-%S"
 
 {- Adds in some metadata, which can override existing values, or unset
  - them, but otherwise leaves any existing metadata as-is. -}

Logs/Presence/Pure.hs

@@ -8,11 +8,10 @@
 module Logs.Presence.Pure where
 
 import Data.Time.Clock.POSIX
-import Data.Time
-import System.Locale
 import qualified Data.Map as M
 
 import Common.Annex
+import Logs.TimeStamp
 import Utility.QuickCheck
 
 data LogLine = LogLine {
@@ -29,7 +28,7 @@ parseLog :: String -> [LogLine]
 parseLog = mapMaybe parseline . lines
   where
 	parseline l = LogLine
-		<$> (utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" d)
+		<$> parsePOSIXTime d
 		<*> parseStatus s
 		<*> pure rest
 	  where

Logs/SingleValue.hs

@@ -15,11 +15,10 @@ module Logs.SingleValue where
 
 import Common.Annex
 import qualified Annex.Branch
+import Logs.TimeStamp
 
 import qualified Data.Set as S
 import Data.Time.Clock.POSIX
-import Data.Time
-import System.Locale
 
 class SingleValueSerializable v where
 	serialize :: v -> String
@@ -42,7 +41,7 @@ parseLog = S.fromList . mapMaybe parse . lines
   where
 	parse line = do
 		let (ts, s) = splitword line
-		date <- utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" ts
+		date <- parsePOSIXTime ts
 		v <- deserialize s
 		Just (LogEntry date v)
 	splitword = separate (== ' ')

Logs/TimeStamp.hs

@@ -0,0 +1,30 @@
+{- log timestamp parsing
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Logs.TimeStamp where
+
+import Data.Time.Clock.POSIX
+import Data.Time
+#if ! MIN_VERSION_time(1,5,0)
+import System.Locale
+#endif
+import Control.Applicative
+import Prelude
+
+{- Parses how POSIXTime shows itself: "1431286201.113452s"
+ - Also handles the format with no fractional seconds. -}
+parsePOSIXTime :: String -> Maybe POSIXTime
+#if MIN_VERSION_time(1,5,0)
+parsePOSIXTime s = utcTimeToPOSIXSeconds <$> parseTimeM True defaultTimeLocale "%s%Qs" s
+#else
+parsePOSIXTime s = utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" s
+#endif
+
+formatPOSIXTime :: String -> POSIXTime -> String
+formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t)

Logs/Transfer.hs

@@ -18,11 +18,10 @@ import Utility.Percentage
 import Utility.QuickCheck
 import Utility.PID
 import Utility.LockFile
+import Logs.TimeStamp
 
 import Data.Time.Clock
 import Data.Time.Clock.POSIX
-import Data.Time
-import System.Locale
 import Control.Concurrent
 
 {- Enough information to uniquely identify a transfer, used as the filename
@@ -276,10 +275,6 @@ readTransferInfo mpid s = TransferInfo
 		then Just <$> readish =<< headMaybe (drop 1 bits)
 		else pure Nothing -- not failure
 
-parsePOSIXTime :: String -> Maybe POSIXTime
-parsePOSIXTime s = utcTimeToPOSIXSeconds
-	<$> parseTime defaultTimeLocale "%s%Qs" s
-
 {- The directory holding transfer information files for a given Direction. -}
 transferDir :: Direction -> Git.Repo -> FilePath
 transferDir direction r = gitAnnexTransferDir r </> showLcDirection direction

Logs/Transitions.hs

@@ -15,11 +15,10 @@
 module Logs.Transitions where
 
 import Data.Time.Clock.POSIX
-import Data.Time
-import System.Locale
 import qualified Data.Set as S
 
 import Common.Annex
+import Logs.TimeStamp
 
 transitionsLog :: FilePath
 transitionsLog = "transitions.log"
@@ -66,12 +65,13 @@ showTransitionLine :: TransitionLine -> String
 showTransitionLine (TransitionLine ts t) = unwords [show t, show ts]
 
 parseTransitionLine :: String -> Maybe TransitionLine
-parseTransitionLine s = TransitionLine <$> pdate ds <*> readish ts
+parseTransitionLine s = TransitionLine
+	<$> parsePOSIXTime ds
+	<*> readish ts
   where
 	ws = words s
 	ts = Prelude.head ws
 	ds = unwords $ Prelude.tail ws
-	pdate = utcTimeToPOSIXSeconds <$$> parseTime defaultTimeLocale "%s%Qs"
 
 combineTransitions :: [Transitions] -> Transitions
 combineTransitions = S.unions

Logs/UUIDBased.hs

@@ -30,12 +30,11 @@ module Logs.UUIDBased (
 
 import qualified Data.Map as M
 import Data.Time.Clock.POSIX
-import Data.Time
-import System.Locale
 
 import Common
 import Types.UUID
 import Logs.MapLog
+import Logs.TimeStamp
 
 type Log v = MapLog UUID v
 
@@ -73,9 +72,9 @@ parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . lines
 		info
 			| ts == Unknown = drop 1 ws
 			| otherwise = drop 1 $ beginning ws
-		pdate s = case parseTime defaultTimeLocale "%s%Qs" s of
+		pdate s = case parsePOSIXTime s of
 			Nothing -> Unknown
-			Just d -> Date $ utcTimeToPOSIXSeconds d
+			Just d -> Date d
 
 showLogNew :: (v -> String) -> Log v -> String
 showLogNew = showMapLog fromUUID

Logs/Unused.hs

@@ -32,12 +32,12 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Time.Clock.POSIX
 import Data.Time
-import System.Locale
 
 import Common.Annex
 import qualified Annex
 import Types.Key
 import Utility.Tmp
+import Logs.TimeStamp
 
 -- everything that is stored in the unused log
 type UnusedLog = M.Map Key (Int, Maybe POSIXTime)
@@ -81,7 +81,7 @@ readUnusedLog prefix = do
 		, return M.empty
 		)
   where
-	parse line = case (readish sint, file2key skey, utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" ts) of
+	parse line = case (readish sint, file2key skey, parsePOSIXTime ts) of
 		(Just int, Just key, mtimestamp) -> Just (key, (int, mtimestamp))
 		_ -> Nothing
 	  where

Makefile

@@ -140,6 +140,25 @@ linuxstandalone-nobuild: Build/Standalone Build/LinuxMkLibs
 	cd tmp/git-annex.linux && find . -type l >> git-annex.MANIFEST
 	cd tmp && tar czf git-annex-standalone-$(shell dpkg --print-architecture).tar.gz git-annex.linux
 
+# Run this target to build git-annex-standalone*.deb
+debianstandalone: dpkg-buildpackage-F
+# Run this target to build git-annex-standalone*.dsc
+debianstandalone-dsc: dpkg-buildpackage-S
+
+prep-standalone:
+	$(MAKE) undo-standalone
+	QUILT_PATCHES=debian/patches QUILT_SERIES=series.standalone-build quilt push -a
+	debian/create-standalone-changelog
+
+undo-standalone:
+	test -e .git
+	git checkout debian/changelog
+	quilt pop -a || true
+
+dpkg-buildpackage%: prep-standalone
+	umask 022; dpkg-buildpackage -rfakeroot $*
+	$(MAKE) undo-standalone
+
 OSXAPP_DEST=tmp/build-dmg/git-annex.app
 OSXAPP_BASE=$(OSXAPP_DEST)/Contents/MacOS/bundle
 osxapp: Build/Standalone Build/OSXMkLibs

Messages.hs

@@ -20,7 +20,7 @@ module Messages (
 	showEndFail,
 	showEndResult,
 	endResult,
-	showErr,
+	toplevelWarning,
 	warning,
 	warningIO,
 	indent,
@@ -118,15 +118,16 @@ endResult :: Bool -> String
 endResult True = "ok"
 endResult False = "failed"
 
-showErr :: (Show a) => a -> Annex ()
+toplevelWarning :: Bool -> String -> Annex ()
-showErr e = warning' $ "git-annex: " ++ show e
+toplevelWarning makeway s = warning' makeway ("git-annex: " ++ s)
 
 warning :: String -> Annex ()
-warning = warning' . indent
+warning = warning' True . indent
 
-warning' :: String -> Annex ()
+warning' :: Bool -> String -> Annex ()
-warning' w = do
+warning' makeway w = do
-	handleMessage q $ putStr "\n"
+	when makeway $
+		handleMessage q $ putStr "\n"
 	liftIO $ do
 		hFlush stdout
 		hPutStrLn stderr w

Remote.hs

@@ -282,7 +282,9 @@ showLocations separateuntrusted key exclude nolocmsg = do
 	let uuidsskipped = filteruuids uuids (u:exclude++uuidswanted)
 	ppuuidswanted <- prettyPrintUUIDs "wanted" uuidswanted
 	ppuuidsskipped <- prettyPrintUUIDs "skipped" uuidsskipped
-	showLongNote $ message ppuuidswanted ppuuidsskipped
+	let msg = message ppuuidswanted ppuuidsskipped
+	unless (null msg) $
+		showLongNote msg
 	ignored <- filter (remoteAnnexIgnore . gitconfig) <$> remoteList
 	unless (null ignored) $
 		showLongNote $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")"

Remote/Directory.hs

@@ -162,9 +162,13 @@ retrieveCheap _ (UnpaddedChunks _) _ _ _ = return False
 retrieveCheap _ (LegacyChunks _) _ _ _ = return False
 #ifndef mingw32_HOST_OS
 retrieveCheap d NoChunks k _af f = liftIO $ catchBoolIO $ do
-	file <- getLocation d k
+	file <- absPath =<< getLocation d k
-	createSymbolicLink file f
+	ifM (doesFileExist file)
-	return True
+		( do
+			createSymbolicLink file f
+			return True
+		, return False
+		)
 #else
 retrieveCheap _ _ _ _ _ = return False
 #endif

Remote/GCrypt.hs

@@ -397,7 +397,7 @@ getGCryptId fast r gc
 	| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$>
 		liftIO (catchMaybeIO $ Git.Config.read r)
 	| not fast = extract . liftM fst <$> getM (eitherToMaybe <$>)
-		[ Ssh.onRemote r (Git.Config.fromPipe r, return (Left undefined)) "configlist" [] []
+		[ Ssh.onRemote r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] []
 		, getConfigViaRsync r gc
 		]
 	| otherwise = return (Nothing, r)

Remote/Git.hs

@@ -200,7 +200,7 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo
 tryGitConfigRead r 
 	| haveconfig r = return r -- already read
 	| Git.repoIsSsh r = store $ do
-		v <- Ssh.onRemote r (pipedconfig, return (Left undefined)) "configlist" [] []
+		v <- Ssh.onRemote r (pipedconfig, return (Left $ error "configlist failed")) "configlist" [] []
 		case v of
 			Right r'
 				| haveconfig r' -> return r'
@@ -229,9 +229,10 @@ tryGitConfigRead r
 		uo <- Url.getUrlOptions
 		v <- liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do
 			hClose h
-			ifM (Url.downloadQuiet (Git.repoLocation r ++ "/config") tmpfile uo)
+			let url = Git.repoLocation r ++ "/config"
+			ifM (Url.downloadQuiet url tmpfile uo)
 				( pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
-				, return $ Left undefined
+				, return $ Left $ error $ "unable to load config from " ++ url
 				)
 		case v of
 			Left _ -> do
@@ -450,10 +451,17 @@ copyFromRemote' r key file dest meterupdate
 copyFromRemoteCheap :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
 #ifndef mingw32_HOST_OS
 copyFromRemoteCheap r key af file
-	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ do
+	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ liftIO $ do
-		loc <- liftIO $ gitAnnexLocation key (repo r) $
+		loc <- gitAnnexLocation key (repo r) $
 			fromJust $ remoteGitConfig $ gitconfig r
-		liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
+		ifM (doesFileExist loc)
+			( do
+				absloc <- absPath loc
+				catchBoolIO $ do
+					createSymbolicLink absloc file
+					return True
+			, return False
+			)
 	| Git.repoIsSsh (repo r) =
 		ifM (Annex.Content.preseedTmp key file)
 			( parallelMetered Nothing key af $

Remote/Helper/Chunked.hs

@@ -72,7 +72,7 @@ chunkKeyStream basek chunksize = ChunkKeyStream $ map mk [1..]
 
 nextChunkKeyStream :: ChunkKeyStream -> (Key, ChunkKeyStream)
 nextChunkKeyStream (ChunkKeyStream (k:l)) = (k, ChunkKeyStream l)
-nextChunkKeyStream (ChunkKeyStream []) = undefined -- stream is infinite!
+nextChunkKeyStream (ChunkKeyStream []) = error "expected infinite ChunkKeyStream"
 
 takeChunkKeyStream :: ChunkCount -> ChunkKeyStream -> [Key]
 takeChunkKeyStream n (ChunkKeyStream l) = genericTake n l

Remote/Helper/Encryptable.hs

@@ -20,7 +20,8 @@ module Remote.Helper.Encryptable (
 ) where
 
 import qualified Data.Map as M
-import qualified "dataenc" Codec.Binary.Base64 as B64
+import qualified "sandi" Codec.Binary.Base64 as B64
+import qualified Data.ByteString as B
 import Data.Bits.Utils
 
 import Common.Annex
@@ -172,12 +173,12 @@ describeEncryption c = case extractCipher c of
 		]
 
 {- Not using Utility.Base64 because these "Strings" are really
- - bags of bytes and that would convert to unicode and not roung-trip
+ - bags of bytes and that would convert to unicode and not round-trip
  - cleanly. -}
 toB64bs :: String -> String
-toB64bs = B64.encode . s2w8
+toB64bs = w82s . B.unpack . B64.encode . B.pack . s2w8
 
 fromB64bs :: String -> String
-fromB64bs s = fromMaybe bad $ w82s <$> B64.decode s
+fromB64bs s = either (const bad) (w82s . B.unpack) (B64.decode $ B.pack $ s2w8 s)
   where
 	bad = error "bad base64 encoded data"

Remote/Helper/Special.hs

@@ -199,7 +199,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
 				readBytes $ \encb ->
 					storer (enck k) (ByteContent encb) p
 
-	-- call retrieve-r to get chunks; decrypt them; stream to dest file
+	-- call retriever to get chunks; decrypt them; stream to dest file
 	retrieveKeyFileGen k f dest p enc =
 		safely $ prepareretriever k $ safely . go
 	  where

Remote/S3.hs

@@ -28,6 +28,8 @@ import Control.Monad.Trans.Resource
 import Control.Monad.Catch
 import Data.Conduit
 import Data.IORef
+import Data.Bits.Utils
+import System.Log.Logger
 
 import Common.Annex
 import Types.Remote
@@ -88,13 +90,7 @@ gen r u c gc = do
 			, availability = GloballyAvailable
 			, remotetype = remote
 			, mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc
-			, getInfo = includeCredsInfo c (AWS.creds u) $ catMaybes
+			, getInfo = includeCredsInfo c (AWS.creds u) (s3Info c)
-				[ Just ("bucket", fromMaybe "unknown" (getBucketName c))
-				, if configIA c
-					then Just ("internet archive item", iaItemUrl $ fromMaybe "unknown" $ getBucketName c)
-					else Nothing
-				, Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c))
-				]
 			, claimUrl = Nothing
 			, checkUrl = Nothing
 			}
@@ -102,9 +98,9 @@ gen r u c gc = do
 s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
 s3Setup mu mcreds c = do
 	u <- maybe (liftIO genUUID) return mu
-	s3Setup' u mcreds c
+	s3Setup' (isNothing mu) u mcreds c
-s3Setup' :: UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
+s3Setup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-s3Setup' u mcreds c = if configIA c then archiveorg else defaulthost
+s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost
   where
 	remotename = fromJust (M.lookup "name" c)
 	defbucket = remotename ++ "-" ++ fromUUID u
@@ -124,7 +120,8 @@ s3Setup' u mcreds c = if configIA c then archiveorg else defaulthost
 		(c', encsetup) <- encryptionSetup c
 		c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
 		let fullconfig = c'' `M.union` defaults
-		genBucket fullconfig u
+		when new $
+			genBucket fullconfig u
 		use fullconfig
 
 	archiveorg = do
@@ -132,7 +129,7 @@ s3Setup' u mcreds c = if configIA c then archiveorg else defaulthost
 		c' <- setRemoteCredPair noEncryptionUsed c (AWS.creds u) mcreds
 		-- Ensure user enters a valid bucket name, since
 		-- this determines the name of the archive.org item.
-		let validbucket = replace " " "-" $ map toLower $
+		let validbucket = replace " " "-" $
 			fromMaybe (error "specify bucket=") $
 				getBucketName c'
 		let archiveconfig = 
@@ -149,7 +146,7 @@ s3Setup' u mcreds c = if configIA c then archiveorg else defaulthost
 			writeUUIDFile archiveconfig u
 		use archiveconfig
 
--- Sets up a http connection manager for S3 encdpoint, which allows
+-- Sets up a http connection manager for S3 endpoint, which allows
 -- http connections to be reused across calls to the helper.
 prepareS3 :: Remote -> S3Info -> (S3Handle -> helper) -> Preparer helper
 prepareS3 r info = resourcePrepare $ const $
@@ -388,13 +385,13 @@ sendS3Handle'
 	=> S3Handle
 	-> r
 	-> ResourceT IO a
-sendS3Handle' h = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h)
+sendS3Handle' h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r
 
 withS3Handle :: RemoteConfig -> UUID -> S3Info -> (S3Handle -> Annex a) -> Annex a
 withS3Handle c u info a = do
 	creds <- getRemoteCredPairFor "S3" c (AWS.creds u)
 	awscreds <- liftIO $ genCredentials $ fromMaybe nocreds creds
-	let awscfg = AWS.Configuration AWS.Timestamp awscreds (AWS.defaultLog AWS.Error)
+	let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper
 	bracketIO (newManager httpcfg) closeManager $ \mgr -> 
 		a $ S3Handle mgr awscfg s3cfg info
   where
@@ -450,7 +447,7 @@ extractS3Info c = do
 		}
 
 getBucketName :: RemoteConfig -> Maybe BucketName
-getBucketName = M.lookup "bucket"
+getBucketName = map toLower <$$> M.lookup "bucket"
 
 getStorageClass :: RemoteConfig -> S3.StorageClass
 getStorageClass c = case M.lookup "storageclass" c of
@@ -486,7 +483,7 @@ iaMunge = (>>= munge)
   where
 	munge c
 		| isAsciiUpper c || isAsciiLower c || isNumber c = [c]
-		| c `elem` "_-.\"" = [c]
+		| c `elem` ("_-.\"" :: String) = [c]
 		| isSpace c = []
 		| otherwise = "&" ++ show (ord c) ++ ";"
 
@@ -518,3 +515,26 @@ genCredentials (keyid, secret) = AWS.Credentials
 mkLocationConstraint :: AWS.Region -> S3.LocationConstraint
 mkLocationConstraint "US" = S3.locationUsClassic
 mkLocationConstraint r = r
+
+debugMapper :: AWS.Logger
+debugMapper level t = forward "S3" (T.unpack t)
+  where
+	forward = case level of
+		AWS.Debug -> debugM
+		AWS.Info -> infoM
+		AWS.Warning -> warningM
+		AWS.Error -> errorM
+
+s3Info :: RemoteConfig -> [(String, String)]
+s3Info c = catMaybes
+	[ Just ("bucket", fromMaybe "unknown" (getBucketName c))
+	, Just ("endpoint", w82s (S.unpack (S3.s3Endpoint s3c)))
+	, Just ("port", show (S3.s3Port s3c))
+	, Just ("storage class", show (getStorageClass c))
+	, if configIA c
+		then Just ("internet archive item", iaItemUrl $ fromMaybe "unknown" $ getBucketName c)
+		else Nothing
+	, Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c))
+	]
+  where
+	s3c = s3Configuration c

Remote/Tahoe.hs

@@ -177,7 +177,7 @@ getSharedConvergenceSecret configdir = go (60 :: Int)
 			v <- catchMaybeIO (readFile f)
 			case v of
 				Just s | "\n" `isSuffixOf` s || "\r" `isSuffixOf` s ->
-					return $ takeWhile (`notElem` "\n\r") s
+					return $ takeWhile (`notElem` ("\n\r" :: String)) s
 				_ -> do
 					threadDelaySeconds (Seconds 1)
 					go (n - 1)

Setup.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 {- cabal setup file -}
 

Test.hs

@@ -14,7 +14,6 @@ import Test.Tasty.Runners
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
 import Test.Tasty.Ingredients.Rerun
-import Data.Monoid
 
 import Options.Applicative hiding (command)
 import qualified Data.Map as M
@@ -156,6 +155,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
 	, testProperty "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel
 	, testProperty "prop_parse_show_TrustLog" Logs.Trust.prop_parse_show_TrustLog
 	, testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable
+	, testProperty "prop_mac_stable" Utility.Hash.prop_mac_stable
 	, testProperty "prop_schedule_roundtrips" Utility.Scheduled.prop_schedule_roundtrips
 	, testProperty "prop_past_sane" Utility.Scheduled.prop_past_sane
 	, testProperty "prop_duration_roundtrips" Utility.HumanTime.prop_duration_roundtrips
@@ -199,6 +199,7 @@ unitTests note = testGroup ("Unit Tests " ++ note)
 	, testCase "fsck (bare)" test_fsck_bare
 	, testCase "fsck (local untrusted)" test_fsck_localuntrusted
 	, testCase "fsck (remote untrusted)" test_fsck_remoteuntrusted
+	, testCase "fsck --from remote" test_fsck_fromremote
 	, testCase "migrate" test_migrate
 	, testCase "migrate (via gitattributes)" test_migrate_via_gitattributes
 	, testCase "unused" test_unused
@@ -613,6 +614,10 @@ test_fsck_remoteuntrusted = intmpclonerepo $ do
 	git_annex "untrust" ["origin"] @? "untrust of origin failed"
 	fsck_should_fail "content not replicated to enough non-untrusted repositories"
 
+test_fsck_fromremote :: Assertion
+test_fsck_fromremote = intmpclonerepo $ do
+	git_annex "fsck" ["--from", "origin"] @? "fsck --from origin failed"
+
 fsck_should_fail :: String -> Assertion
 fsck_should_fail m = not <$> git_annex "fsck" []
 	@? "fsck failed to fail with " ++ m