Merge branch 'master' into s3-aws

Conflicts:
	Utility/Url.hs
	debian/changelog
	git-annex.cabal

Utility/Bloom.hs

@@ -9,7 +9,7 @@
 
 module Utility.Bloom (
 	Bloom,
-	suggestSizing,
+	safeSuggestSizing,
 	Hashable,
 	cheapHashes,
 	notElemB,
@@ -25,7 +25,7 @@ import qualified Data.BloomFilter as Bloom
 #else
 import qualified Data.BloomFilter as Bloom
 #endif
-import Data.BloomFilter.Easy (suggestSizing, Bloom)
+import Data.BloomFilter.Easy (safeSuggestSizing, Bloom)
 import Data.BloomFilter.Hash (Hashable, cheapHashes)
 import Control.Monad.ST.Safe (ST)
 

Utility/CopyFile.hs

@@ -1,6 +1,6 @@
 {- file copying
  -
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - License: BSD-2-clause
  -}
@@ -9,16 +9,20 @@
 
 module Utility.CopyFile (
 	copyFileExternal,
-	createLinkOrCopy
+	createLinkOrCopy,
+	CopyMetaData(..)
 ) where
 
 import Common
 import qualified Build.SysConfig as SysConfig
 
+data CopyMetaData = CopyTimeStamps | CopyAllMetaData
+	deriving (Eq)
+
 {- The cp command is used, because I hate reinventing the wheel,
  - and because this allows easy access to features like cp --reflink. -}
-copyFileExternal :: FilePath -> FilePath -> IO Bool
-copyFileExternal src dest = do
+copyFileExternal :: CopyMetaData -> FilePath -> FilePath -> IO Bool
+copyFileExternal meta src dest = do
 	whenM (doesFileExist dest) $
 		removeFile dest
 	boolSystem "cp" $ params ++ [File src, File dest]
@@ -26,12 +30,16 @@ copyFileExternal src dest = do
 #ifndef __ANDROID__
 	params = map snd $ filter fst
 		[ (SysConfig.cp_reflink_auto, Param "--reflink=auto")
-		, (SysConfig.cp_a, Param "-a")
-		, (SysConfig.cp_p && not SysConfig.cp_a, Param "-p")
+		, (allmeta && SysConfig.cp_a, Param "-a")
+		, (allmeta && SysConfig.cp_p && not SysConfig.cp_a
+			, Param "-p")
+		, (not allmeta && SysConfig.cp_preserve_timestamps
+			, Param "--preserve=timestamps")
 		]
 #else
 	params = []
 #endif
+	allmeta = meta == CopyAllMetaData
 
 {- Create a hard link if the filesystem allows it, and fall back to copying
  - the file. -}
@@ -42,7 +50,7 @@ createLinkOrCopy src dest = go `catchIO` const fallback
   	go = do
 		createLink src dest
 		return True
-  	fallback = copyFileExternal src dest
+  	fallback = copyFileExternal CopyAllMetaData src dest
 #else
-createLinkOrCopy = copyFileExternal
+createLinkOrCopy = copyFileExternal CopyAllMetaData
 #endif

Utility/Daemon.hs

@@ -15,7 +15,7 @@ import Utility.PID
 import Utility.LogFile
 #else
 import Utility.WinProcess
-import Utility.WinLock
+import Utility.LockFile
 #endif
 
 #ifndef mingw32_HOST_OS

Utility/Gpg.hs

@@ -163,8 +163,9 @@ type UserId = String
 {- All of the user's secret keys, with their UserIds.
  - Note that the UserId may be empty. -}
 secretKeys :: IO (M.Map KeyId UserId)
-secretKeys = M.fromList . parse . lines <$> readStrict params
+secretKeys = catchDefaultIO M.empty makemap
   where
+	makemap = M.fromList . parse . lines <$> readStrict params
   	params = [Params "--with-colons --list-secret-keys --fixed-list-mode"]
 	parse = extract [] Nothing . map (split ":")
 	extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) =

Utility/LockFile.hs

@@ -0,0 +1,20 @@
+{- Lock files
+ -
+ - Posix and Windows lock files are extremely different.
+ - This module does *not* attempt to be a portability shim, it just exposes
+ - the native locking of the OS.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.LockFile (module X) where
+
+#ifndef mingw32_HOST_OS
+import Utility.LockFile.Posix as X
+#else
+import Utility.LockFile.Windows as X
+#endif

Utility/LockFile/Posix.hs

@@ -0,0 +1,99 @@
+{- Posix lock files
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.LockFile.Posix (
+	LockHandle,
+	lockShared,
+	lockExclusive,
+	tryLockExclusive,
+	createLockFile,
+	openExistingLockFile,
+	isLocked,
+	checkLocked,
+	getLockStatus,
+	dropLock,
+) where
+
+import Utility.Exception
+import Utility.Applicative
+
+import System.IO
+import System.Posix
+import Data.Maybe
+
+type LockFile = FilePath
+
+newtype LockHandle = LockHandle Fd
+
+-- Takes a shared lock, blocking until the lock is available.
+lockShared :: Maybe FileMode -> LockFile -> IO LockHandle
+lockShared = lock ReadLock
+
+-- Takes an exclusive lock, blocking until the lock is available.
+lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle
+lockExclusive = lock WriteLock
+
+-- Tries to take an exclusive lock, but does not block.
+tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
+tryLockExclusive mode lockfile = do
+	l <- openLockFile mode lockfile
+	v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
+	case v of
+		Left _ -> do
+			closeFd l
+			return Nothing
+		Right _ -> return $ Just $ LockHandle l
+
+-- Setting the FileMode allows creation of a new lock file.
+-- If it's Nothing then this only succeeds when the lock file already exists.
+lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle
+lock lockreq mode lockfile = do
+	l <- openLockFile mode lockfile
+	waitToSetLock l (lockreq, AbsoluteSeek, 0, 0)
+	return (LockHandle l)
+
+-- Create and opens lock file; does not lock it.
+createLockFile :: FileMode -> LockFile -> IO Fd
+createLockFile filemode = openLockFile (Just filemode)
+
+-- Opens an existing lock file; does not lock it, and if it does not exist,
+-- returns Nothing.
+openExistingLockFile :: LockFile -> IO (Maybe Fd)
+openExistingLockFile = catchMaybeIO . openLockFile Nothing
+
+-- Close on exec flag is set so child processes do not inherit the lock.
+openLockFile :: Maybe FileMode -> LockFile -> IO Fd
+openLockFile filemode lockfile = do
+	l <- openFd lockfile ReadWrite filemode defaultFileFlags
+	setFdOption l CloseOnExec True
+	return l
+
+-- Check if a file is locked, either exclusively, or with shared lock.
+-- When the file doesn't exist, it's considered not locked.
+isLocked :: LockFile -> IO Bool
+isLocked = fromMaybe False <$$> checkLocked
+
+-- Returns Nothing when the file doesn't exist, for cases where
+-- that is different from it not being locked.
+checkLocked :: LockFile -> IO (Maybe Bool)
+checkLocked = maybe Nothing (Just . isJust) <$$> getLockStatus'
+
+getLockStatus :: LockFile -> IO (Maybe (ProcessID, FileLock))
+getLockStatus = fromMaybe Nothing <$$> getLockStatus'
+
+getLockStatus' :: LockFile -> IO (Maybe (Maybe (ProcessID, FileLock)))
+getLockStatus' lockfile = go =<< catchMaybeIO open
+  where
+	open = openFd lockfile ReadOnly Nothing defaultFileFlags
+	go Nothing = return Nothing
+	go (Just h) = do
+		ret <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
+		closeFd h
+		return (Just ret)
+
+dropLock :: LockHandle -> IO ()
+dropLock (LockHandle fd) = closeFd fd

Utility/LockFile/Windows.hs

@@ -5,7 +5,7 @@
  - License: BSD-2-clause
  -}
 
-module Utility.WinLock (
+module Utility.LockFile.Windows (
 	lockShared,
 	lockExclusive,
 	dropLock,
@@ -17,9 +17,6 @@ import System.Win32.Types
 import System.Win32.File
 import Control.Concurrent
 
-{- Locking is exclusive, and prevents the file from being opened for read
- - or write by any other process. So for advisory locking of a file, a
- - different LockFile should be used. -}
 type LockFile = FilePath
 
 type LockHandle = HANDLE
@@ -30,7 +27,11 @@ lockShared :: LockFile -> IO (Maybe LockHandle)
 lockShared = openLock fILE_SHARE_READ
 
 {- Tries to take an exclusive lock on a file. Fails if another process has
- - a shared or exclusive lock. -}
+ - a shared or exclusive lock.
+ -
+ - Note that exclusive locking also prevents the file from being opened for
+ - read or write by any other progess. So for advisory locking of a file's
+ - content, a different LockFile should be used. -}
 lockExclusive :: LockFile -> IO (Maybe LockHandle)
 lockExclusive = openLock fILE_SHARE_NONE
 
@@ -44,15 +45,20 @@ lockExclusive = openLock fILE_SHARE_NONE
  - Note that createFile busy-waits to try to avoid failing when some other
  - process briefly has a file open. But that would make checking locks
  - much more expensive, so is not done here. Thus, the use of c_CreateFile.
+ -
+ - Also, passing Nothing for SECURITY_ATTRIBUTES ensures that the lock file
+ - is not inheerited by any child process.
  -}
 openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle)
 openLock sharemode f = do
 	h <- withTString f $ \c_f ->
-		c_CreateFile c_f gENERIC_READ sharemode (maybePtr Nothing)
+		c_CreateFile c_f gENERIC_READ sharemode security_attributes
 			oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing)
 	return $ if h == iNVALID_HANDLE_VALUE
 		then Nothing
 		else Just h
+  where
+	security_attributes = maybePtr Nothing
 
 dropLock :: LockHandle -> IO ()
 dropLock = closeHandle

Utility/Url.hs

@@ -6,11 +6,14 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 
 module Utility.Url (
 	URLString,
 	UserAgent,
-	UrlOptions(..),
+	UrlOptions,
+	mkUrlOptions,
 	check,
 	checkBoth,
 	exists,
@@ -25,6 +28,7 @@ import Network.HTTP.Conduit
 import Network.HTTP.Types
 import Data.Default
 import qualified Data.CaseInsensitive as CI
+import qualified Data.ByteString as B
 import qualified Data.ByteString.UTF8 as B8
 
 import qualified Build.SysConfig
@@ -39,11 +43,39 @@ data UrlOptions = UrlOptions
 	{ userAgent :: Maybe UserAgent
 	, reqHeaders :: Headers
 	, reqParams :: [CommandParam]
+#if MIN_VERSION_http_conduit(2,0,0)
+	, applyRequest :: Request -> Request
+#else
+	, applyRequest :: forall m. Request m -> Request m
+#endif
 	}
 
 instance Default UrlOptions
   where
-	def = UrlOptions Nothing [] []
+	def = UrlOptions Nothing [] [] id
+
+mkUrlOptions :: Maybe UserAgent -> Headers -> [CommandParam] -> UrlOptions
+mkUrlOptions useragent reqheaders reqparams =
+	UrlOptions useragent reqheaders reqparams applyrequest
+  where
+	applyrequest = \r -> r { requestHeaders = requestHeaders r ++ addedheaders }
+	addedheaders = uaheader ++ otherheaders
+	uaheader = case useragent of
+		Nothing -> []
+		Just ua -> [(hUserAgent, B8.fromString ua)]
+	otherheaders = map toheader reqheaders
+	toheader s =
+		let (h, v) = separate (== ':') s
+		    h' = CI.mk (B8.fromString h)
+		in case v of
+			(' ':v') -> (h', B8.fromString v')
+			_ -> (h', B8.fromString v)
+
+addUserAgent :: UrlOptions -> [CommandParam] -> [CommandParam]
+addUserAgent uo ps = case userAgent uo of
+	Nothing -> ps
+	-- --user-agent works for both wget and curl commands
+	Just ua -> ps ++ [Param "--user-agent", Param ua] 
 
 {- Checks that an url exists and could be successfully downloaded,
  - also checking that its size, if available, matches a specified size. -}
@@ -105,7 +137,7 @@ exists url uo = case parseURIRelaxed url of
 				(responseHeaders resp)
 	
 	existsconduit req = withManager $ \mgr -> do
-			let req' = (addUrlOptions uo req) { method = methodHead }
+			let req' = headRequest (applyRequest uo req)
 			resp <- http req' mgr
 			-- forces processing the response before the
 			-- manager is closed
@@ -115,11 +147,19 @@ exists url uo = case parseURIRelaxed url of
 			liftIO $ closeManager mgr
 			return ret
 
--- works for both wget and curl commands
-addUserAgent :: UrlOptions -> [CommandParam] -> [CommandParam]
-addUserAgent uo ps = case userAgent uo of
-	Nothing -> ps
-	Just ua -> ps ++ [Param "--user-agent", Param ua] 
+#if MIN_VERSION_http_conduit(2,0,0)
+headRequest :: Request -> Request
+#else
+headRequest :: Request m -> Request m
+#endif
+headRequest r = r
+	{ method = methodHead
+	-- remove defaut Accept-Encoding header, to get actual,
+	-- not gzip compressed size.
+	, requestHeaders = (hAcceptEncoding, B.empty) :
+		filter (\(h, _) -> h /= hAcceptEncoding)
+		(requestHeaders r)
+	}
 
 addUrlOptions :: UrlOptions -> Request -> Request
 addUrlOptions uo r = r { requestHeaders = requestHeaders r ++ uaheader ++ otherheaders}
@@ -187,3 +227,14 @@ download' quiet url file uo =
 {- Allows for spaces and other stuff in urls, properly escaping them. -}
 parseURIRelaxed :: URLString -> Maybe URI
 parseURIRelaxed = parseURI . escapeURIString isAllowedInURI
+
+hAcceptEncoding :: CI.CI B.ByteString
+hAcceptEncoding = "Accept-Encoding"
+
+#if ! MIN_VERSION_http_types(0,7,0)
+hContentLength :: CI.CI B.ByteString
+hContentLength = "Content-Length"
+
+hUserAgent :: CI.CI B.ByteString
+hUserAgent = "User-Agent"
+#endif