Merge branch 'master' into tasty-tests

Conflicts:
	Test.hs

27 files changed, 1019 insertions, 134 deletions

diff --git a/Utility/Base64.hs b/Utility/Base64.hs
index ec660108a..0c6c8677a 100644
--- a/Utility/Base64.hs
+++ b/Utility/Base64.hs
@@ -7,7 +7,7 @@
 
 module Utility.Base64 (toB64, fromB64Maybe, fromB64) where
 
-import Codec.Binary.Base64
+import "dataenc" Codec.Binary.Base64
 import Data.Bits.Utils
 import Control.Applicative
 import Data.Maybe
diff --git a/Utility/Batch.hs b/Utility/Batch.hs
index c3c34bf27..035a2eb04 100644
--- a/Utility/Batch.hs
+++ b/Utility/Batch.hs
@@ -9,10 +9,17 @@
 
 module Utility.Batch where
 
+import Common
+#ifndef mingw32_HOST_OS
+import qualified Build.SysConfig
+#endif
+
 #if defined(linux_HOST_OS) || defined(__ANDROID__)
 import Control.Concurrent.Async
 import System.Posix.Process
 #endif
+import qualified Control.Exception as E
+import System.Process (env)
 
 {- Runs an operation, at batch priority.
  -
@@ -38,3 +45,47 @@ batch a = a
 
 maxNice :: Int
 maxNice = 19
+
+{- Converts a command to run niced. -}
+toBatchCommand :: (String, [CommandParam]) -> (String, [CommandParam])
+toBatchCommand (command, params) = (command', params')
+  where
+#ifndef mingw32_HOST_OS
+	commandline = unwords $ map shellEscape $ command : toCommand params
+	nicedcommand
+		| Build.SysConfig.nice = "nice " ++ commandline
+		| otherwise = commandline
+	command' = "sh"
+	params' =
+		[ Param "-c"
+		, Param $ "exec " ++ nicedcommand
+		]
+#else
+	command' = command
+	params' = params
+#endif
+
+{- Runs a command in a way that's suitable for batch jobs that can be
+ - interrupted.
+ -
+ - The command is run niced. If the calling thread receives an async
+ - exception, it sends the command a SIGTERM, and after the command
+ - finishes shuttting down, it re-raises the async exception. -}
+batchCommand :: String -> [CommandParam] -> IO Bool
+batchCommand command params = batchCommandEnv command params Nothing
+
+batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
+batchCommandEnv command params environ = do
+	(_, _, _, pid) <- createProcess $ p { env = environ }
+	r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode)
+	case r of
+		Right ExitSuccess -> return True
+		Right _ -> return False
+		Left asyncexception -> do
+			terminateProcess pid
+			void $ waitForProcess pid
+			E.throwIO asyncexception
+  where
+  	(command', params') = toBatchCommand (command, params)
+  	p = proc command' $ toCommand params'
+
diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs
index 2f942769a..12beb235a 100644
--- a/Utility/Daemon.hs
+++ b/Utility/Daemon.hs
@@ -16,6 +16,7 @@ import Utility.LogFile
 
 #ifndef mingw32_HOST_OS
 import System.Posix
+import Control.Concurrent.Async
 #else
 import System.PosixCompat
 #endif
@@ -46,7 +47,9 @@ daemonize logfd pidfile changedirectory a = do
 		nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
 		redir nullfd stdInput
 		redirLog logfd
-		a
+		{- forkProcess masks async exceptions; unmask them inside
+		 - the action. -}
+		wait =<< asyncWithUnmask (\unmask -> unmask a)
 		out
 	out = exitImmediately ExitSuccess
 #else
diff --git a/Utility/Data.hs b/Utility/Data.hs
new file mode 100644
index 000000000..359258296
--- /dev/null
+++ b/Utility/Data.hs
@@ -0,0 +1,17 @@
+{- utilities for simple data types
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Data where
+
+{- First item in the list that is not Nothing. -}
+firstJust :: Eq a => [Maybe a] -> Maybe a
+firstJust ms = case dropWhile (== Nothing) ms of
+	[] -> Nothing
+	(md:_) -> md
+
+eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe = either (const Nothing) Just
diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs
index d28381fae..5231286fc 100644
--- a/Utility/DirWatcher.hs
+++ b/Utility/DirWatcher.hs
@@ -1,10 +1,10 @@
 {- generic directory watching interface
  -
- - Uses inotify, or kqueue, or fsevents to watch a directory
+ - Uses inotify, or kqueue, or fsevents, or win32-notify to watch a directory
  - (and subdirectories) for changes, and runs hooks for different
  - sorts of events as they occur.
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -27,11 +27,15 @@ import Control.Concurrent
 import qualified Utility.FSEvents as FSEvents
 import qualified System.OSX.FSEvents as FSEvents
 #endif
+#if WITH_WIN32NOTIFY
+import qualified Utility.Win32Notify as Win32Notify
+import qualified System.Win32.Notify as Win32Notify
+#endif
 
 type Pruner = FilePath -> Bool
 
 canWatch :: Bool
-#if (WITH_INOTIFY || WITH_KQUEUE || WITH_FSEVENTS)
+#if (WITH_INOTIFY || WITH_KQUEUE || WITH_FSEVENTS || WITH_WIN32NOTIFY)
 canWatch = True
 #else
 #if defined linux_HOST_OS
@@ -47,7 +51,7 @@ canWatch = False
  - OTOH, with kqueue, often only one event is received, indicating the most
  - recent state of the file. -}
 eventsCoalesce :: Bool
-#if WITH_INOTIFY
+#if (WITH_INOTIFY || WITH_WIN32NOTIFY)
 eventsCoalesce = False
 #else
 #if (WITH_KQUEUE || WITH_FSEVENTS)
@@ -68,7 +72,7 @@ eventsCoalesce = undefined
  - still being written to, and then no add event will be received once the
  - writer closes it. -}
 closingTracked :: Bool
-#if (WITH_INOTIFY || WITH_FSEVENTS)
+#if (WITH_INOTIFY || WITH_FSEVENTS || WITH_WIN32NOTIFY)
 closingTracked = True
 #else
 #if WITH_KQUEUE
@@ -83,7 +87,7 @@ closingTracked = undefined
  - Fsevents generates events when an existing file is reopened and rewritten,
  - but not necessarily when it's opened once and modified repeatedly. -}
 modifyTracked :: Bool
-#if (WITH_INOTIFY || WITH_FSEVENTS)
+#if (WITH_INOTIFY || WITH_FSEVENTS || WITH_WIN32NOTIFY)
 modifyTracked = True
 #else
 #if WITH_KQUEUE
@@ -119,27 +123,35 @@ watchDir :: FilePath -> Pruner -> WatchHooks -> (IO FSEvents.EventStream -> IO F
 watchDir dir prune hooks runstartup =
 	runstartup $ FSEvents.watchDir dir prune hooks
 #else
+#if WITH_WIN32NOTIFY
+type DirWatcherHandle = Win32Notify.WatchManager
+watchDir :: FilePath -> Pruner -> WatchHooks -> (IO Win32Notify.WatchManager -> IO Win32Notify.WatchManager) -> IO DirWatcherHandle
+watchDir dir prune hooks runstartup =
+	runstartup $ Win32Notify.watchDir dir prune hooks
+#else
 type DirWatcherHandle = ()
 watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle
 watchDir = undefined
 #endif
 #endif
 #endif
+#endif
 
-#if WITH_INOTIFY
 stopWatchDir :: DirWatcherHandle -> IO ()
+#if WITH_INOTIFY
 stopWatchDir = INotify.killINotify
 #else
 #if WITH_KQUEUE
-stopWatchDir :: DirWatcherHandle -> IO ()
 stopWatchDir = killThread
 #else
 #if WITH_FSEVENTS
-stopWatchDir :: DirWatcherHandle -> IO ()
 stopWatchDir = FSEvents.eventStreamDestroy
 #else
-stopWatchDir :: DirWatcherHandle -> IO ()
+#if WITH_WIN32NOTIFY
+stopWatchDir = Win32Notify.killWatchManager
+#else
 stopWatchDir = undefined
 #endif
 #endif
 #endif
+#endif
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 13e6168cb..4918d20be 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -38,15 +38,20 @@ dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
  - and lazily. If the directory does not exist, no exception is thrown,
  - instead, [] is returned. -}
 dirContentsRecursive :: FilePath -> IO [FilePath]
-dirContentsRecursive topdir = dirContentsRecursive' [topdir]
+dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) topdir
 
-dirContentsRecursive' :: [FilePath] -> IO [FilePath]
-dirContentsRecursive' [] = return []
-dirContentsRecursive' (dir:dirs) = unsafeInterleaveIO $ do
-	(files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir)
-	files' <- dirContentsRecursive' (dirs' ++ dirs)
-	return (files ++ files')
+{- Skips directories whose basenames match the skipdir. -}
+dirContentsRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
+dirContentsRecursiveSkipping skipdir topdir = go [topdir]
   where
+  	go [] = return []
+	go (dir:dirs)
+		| skipdir (takeFileName dir) = go dirs
+		| otherwise = unsafeInterleaveIO $ do
+			(files, dirs') <- collect [] []
+				=<< catchDefaultIO [] (dirContents dir)
+			files' <- go (dirs' ++ dirs)
+			return (files ++ files')
 	collect files dirs' [] = return (reverse files, reverse dirs')
 	collect files dirs' (entry:entries)
 		| dirCruft entry = collect files dirs' entries
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
index 3835d741d..cf2c615c7 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -14,6 +14,7 @@ import qualified Control.Exception as E
 import Control.Applicative
 import Control.Monad
 import System.IO.Error (isDoesNotExistError)
+import Utility.Data
 
 {- Catches IO errors and returns a Bool -}
 catchBoolIO :: IO Bool -> IO Bool
@@ -54,5 +55,5 @@ tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)
 
 {- Catches only DoesNotExist exceptions, and lets all others through. -}
 tryWhenExists :: IO a -> IO (Maybe a)
-tryWhenExists a = either (const Nothing) Just <$>
+tryWhenExists a = eitherToMaybe <$>
 	tryJust (guard . isDoesNotExistError) a
diff --git a/Utility/ExternalSHA.hs b/Utility/ExternalSHA.hs
index 21241d302..adbde795a 100644
--- a/Utility/ExternalSHA.hs
+++ b/Utility/ExternalSHA.hs
@@ -1,6 +1,7 @@
 {- Calculating a SHA checksum with an external command.
  -
- - This is often faster than using Haskell libraries.
+ - This is typically a bit faster than using Haskell libraries,
+ - by around 1% to 10%. Worth it for really big files.
  -
  - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
  -
diff --git a/Utility/Format.hs b/Utility/Format.hs
index 97a966ac1..e7a27515e 100644
--- a/Utility/Format.hs
+++ b/Utility/Format.hs
@@ -15,7 +15,7 @@ module Utility.Format (
 ) where
 
 import Text.Printf (printf)
-import Data.Char (isAlphaNum, isOctDigit, isSpace, chr, ord)
+import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord)
 import Data.Maybe (fromMaybe)
 import Data.Word (Word8)
 import Data.List (isPrefixOf)
@@ -101,7 +101,7 @@ empty (Const "") = True
 empty _ = False
 
 {- Decodes a C-style encoding, where \n is a newline, \NNN is an octal
- - encoded character, etc.
+ - encoded character, and \xNN is a hex encoded character.
  -}
 decode_c :: FormatString -> FormatString
 decode_c [] = []
@@ -114,7 +114,12 @@ decode_c s = unescape ("", s)
 	  where
 		pair = span (/= e) v
 	isescape x = x == e
-	-- \NNN is an octal encoded character
+	handle (x:'x':n1:n2:rest)
+		| isescape x && allhex = (fromhex, rest)
+	  where
+	  	allhex = isHexDigit n1 && isHexDigit n2
+		fromhex = [chr $ readhex [n1, n2]]
+		readhex h = Prelude.read $ "0x" ++ h :: Int
 	handle (x:n1:n2:n3:rest)
 		| isescape x && alloctal = (fromoctal, rest)
 	  where
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index 81180148e..a2baa74dc 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -11,6 +11,7 @@ module Utility.Gpg where
 
 import Control.Applicative
 import Control.Concurrent
+import qualified Data.Map as M
 
 import Common
 import qualified Build.SysConfig as SysConfig
@@ -23,8 +24,11 @@ import Utility.Env
 #else
 import Utility.Tmp
 #endif
+import Utility.Format (decode_c)
 
-newtype KeyIds = KeyIds [String]
+type KeyId = String
+
+newtype KeyIds = KeyIds { keyIds :: [KeyId] }
 	deriving (Ord, Eq)
 
 {- If a specific gpg command was found at configure time, use it.
@@ -32,6 +36,10 @@ newtype KeyIds = KeyIds [String]
 gpgcmd :: FilePath
 gpgcmd = fromMaybe "gpg" SysConfig.gpg
 
+-- Generate an argument list to asymetrically encrypt to the given recipients.
+pkEncTo :: [String] -> [CommandParam]
+pkEncTo = concatMap (\r -> [Param "--recipient", Param r])
+
 stdParams :: [CommandParam] -> IO [String]
 stdParams params = do
 #ifndef mingw32_HOST_OS
@@ -48,9 +56,23 @@ stdParams params = do
 	return $ defaults ++ toCommand params
 #endif
   where
-	-- be quiet, even about checking the trustdb
+	-- Be quiet, even about checking the trustdb.
 	defaults = ["--quiet", "--trust-model", "always"]
 
+{- Usual options for symmetric / public-key encryption. -}
+stdEncryptionParams :: Bool -> [CommandParam]
+stdEncryptionParams symmetric =
+	[ enc symmetric
+	, Param "--force-mdc"
+	, Param "--no-textmode"
+	]
+  where
+	enc True = Param "--symmetric"
+	-- Force gpg to only encrypt to the specified recipients, not
+	-- configured defaults. Recipients are assumed to be specified in
+	-- elsewhere.
+	enc False = Params "--encrypt --no-encrypt-to --no-default-recipient"
+
 {- Runs gpg with some params and returns its stdout, strictly. -}
 readStrict :: [CommandParam] -> IO String
 readStrict params = do
@@ -71,10 +93,11 @@ pipeStrict params input = do
 		hClose to
 		hGetContentsStrict from
 
-{- Runs gpg with some parameters. First sends it a passphrase via
- - --passphrase-fd. Then runs a feeder action that is passed a handle and
- - should write to it all the data to input to gpg. Finally, runs
- - a reader action that is passed a handle to gpg's output. 
+{- Runs gpg with some parameters. First sends it a passphrase (unless it
+ - is empty) via '--passphrase-fd'. Then runs a feeder action that is
+ - passed a handle and should write to it all the data to input to gpg.
+ - Finally, runs a reader action that is passed a handle to gpg's
+ - output.
  -
  - Runs gpg in batch mode; this is necessary to avoid gpg 2.x prompting for
  - the passphrase.
@@ -92,20 +115,23 @@ feedRead params passphrase feeder reader = do
 		hClose toh
 	let Fd pfd = frompipe
 	let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]
-
-	params' <- stdParams $ [Param "--batch"] ++ passphrasefd ++ params
-	closeFd frompipe `after` go params'
+	closeFd frompipe `after` go (passphrasefd ++ params)
 #else
 	-- store the passphrase in a temp file for gpg
 	withTmpFile "gpg" $ \tmpfile h -> do
 		hPutStr h passphrase
 		hClose h
 		let passphrasefile = [Param "--passphrase-file", File tmpfile]
-		params' <- stdParams $ [Param "--batch"] ++ passphrasefile ++ params
-		go params'
+		go $ passphrasefile ++ params
 #endif
   where
-	go params' = withBothHandles createProcessSuccess (proc gpgcmd params')
+	go params' = pipeLazy params' feeder reader
+
+{- Like feedRead, but without passphrase. -}
+pipeLazy :: [CommandParam] -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a
+pipeLazy params feeder reader = do
+	params' <- stdParams $ Param "--batch" : params
+	withBothHandles createProcessSuccess (proc gpgcmd params')
 		$ \(to, from) -> do
 			void $ forkIO $ do
 				feeder to
@@ -116,17 +142,70 @@ feedRead params passphrase feeder reader = do
  - a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of
  - GnuPG's manpage.) -}
 findPubKeys :: String -> IO KeyIds
-findPubKeys for = KeyIds . parse <$> readStrict params
+findPubKeys for = KeyIds . parse . lines <$> readStrict params
   where
 	params = [Params "--with-colons --list-public-keys", Param for]
-	parse = catMaybes . map (keyIdField . split ":") . lines
+	parse = catMaybes . map (keyIdField . split ":")
 	keyIdField ("pub":_:_:_:f:_) = Just f
 	keyIdField _ = Nothing
 
+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
+  where
+  	params = [Params "--with-colons --list-secret-keys --fixed-list-mode"]
+	parse = extract [] Nothing . map (split ":")
+	extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) =
+		extract ((keyid, decode_c userid):c) Nothing rest
+	extract c (Just keyid) rest =
+		extract ((keyid, ""):c) Nothing rest
+	extract c _ [] = c
+	extract c _ (("sec":_:_:_:keyid:_):rest) =
+		extract c (Just keyid) rest
+	extract c k (_:rest) =
+		extract c k rest
+
+type Passphrase = String
+type Size = Int
+data KeyType = Algo Int | DSA | RSA
+
+{- The maximum key size that gpg currently offers in its UI when
+ - making keys. -}
+maxRecommendedKeySize :: Size
+maxRecommendedKeySize = 4096
+
+{- Generates a secret key using the experimental batch mode.
+ - The key is added to the secret key ring.
+ - Can take a very long time, depending on system entropy levels.
+ -}
+genSecretKey :: KeyType -> Passphrase -> UserId -> Size -> IO ()
+genSecretKey keytype passphrase userid keysize =
+	withHandle StdinHandle createProcessSuccess (proc gpgcmd params) feeder
+  where
+	params = ["--batch", "--gen-key"]
+  	feeder h = do
+		hPutStr h $ unlines $ catMaybes
+			[ Just $  "Key-Type: " ++ 
+				case keytype of
+					DSA -> "DSA"
+					RSA -> "RSA"
+					Algo n -> show n
+			, Just $ "Key-Length: " ++ show keysize
+			, Just $ "Name-Real: " ++ userid
+			, Just $ "Expire-Date: 0"
+			, if null passphrase
+				then Nothing
+				else Just $ "Passphrase: " ++ passphrase
+			]
+		hClose h
+
 {- Creates a block of high-quality random data suitable to use as a cipher.
  - It is armored, to avoid newlines, since gpg only reads ciphers up to the
  - first newline. -}
-genRandom :: Bool -> Int -> IO String
+genRandom :: Bool -> Size -> IO String
 genRandom highQuality size = checksize <$> readStrict
 	[ Params params
 	, Param $ show randomquality
@@ -260,3 +339,41 @@ testTestHarness = do
 	keys <- testHarness $ findPubKeys testKeyId
 	return $ KeyIds [testKeyId] == keys
 #endif
+
+#ifndef mingw32_HOST_OS
+checkEncryptionFile :: FilePath -> Maybe KeyIds -> IO Bool
+checkEncryptionFile filename keys =
+	checkGpgPackets keys =<< readStrict params
+  where
+	params = [Params "--list-packets --list-only", File filename]
+
+checkEncryptionStream :: String -> Maybe KeyIds -> IO Bool
+checkEncryptionStream stream keys =
+	checkGpgPackets keys =<< pipeStrict params stream
+  where
+	params = [Params "--list-packets --list-only"]
+
+{- Parses an OpenPGP packet list, and checks whether data is
+ - symmetrically encrypted (keys is Nothing), or encrypted to some
+ - public key(s).
+ - /!\ The key needs to be in the keyring! -}
+checkGpgPackets :: Maybe KeyIds -> String -> IO Bool
+checkGpgPackets keys str = do
+	let (asym,sym) = partition (pubkeyEncPacket `isPrefixOf`) $
+			filter (\l' -> pubkeyEncPacket `isPrefixOf` l' ||
+				symkeyEncPacket `isPrefixOf` l') $
+			takeWhile (/= ":encrypted data packet:") $
+			lines str
+	case (keys,asym,sym) of
+		(Nothing, [], [_]) -> return True
+		(Just (KeyIds ks), ls, []) -> do
+			-- Find the master key associated with the
+			-- encryption subkey.
+			ks' <- concat <$> mapM (keyIds <$$> findPubKeys)
+					[ k | k:"keyid":_ <- map (reverse . words) ls ]
+			return $ sort (nub ks) == sort (nub ks')
+		_ -> return False
+  where
+	pubkeyEncPacket = ":pubkey enc packet: "
+	symkeyEncPacket = ":symkey enc packet: "
+#endif
diff --git a/Utility/Gpg/Types.hs b/Utility/Gpg/Types.hs
deleted file mode 100644
index d45707207..000000000
--- a/Utility/Gpg/Types.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{- gpg data types
- -
- - Copyright 2013 guilhem <guilhem@fripost.org>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Utility.Gpg.Types where
-
-import Utility.SafeCommand
-import Types.GitConfig
-import Types.Remote
-
-{- GnuPG options. -}
-type GpgOpt = String
-newtype GpgOpts = GpgOpts [GpgOpt]
-
-toParams :: GpgOpts -> [CommandParam]
-toParams (GpgOpts opts) = map Param opts
-
-class LensGpgOpts a where
-	getGpgOpts :: a -> GpgOpts
-
-{- Extract the GnuPG options from a Remote Git Config. -}
-instance LensGpgOpts RemoteGitConfig where
-	getGpgOpts = GpgOpts . remoteAnnexGnupgOptions
-
-{- Extract the GnuPG options from a Remote. -}
-instance LensGpgOpts (RemoteA a) where
-	getGpgOpts = getGpgOpts . gitconfig
diff --git a/Utility/Hash.hs b/Utility/Hash.hs
new file mode 100644
index 000000000..cecc6af3e
--- /dev/null
+++ b/Utility/Hash.hs
@@ -0,0 +1,69 @@
+{- Convenience wrapper around cryptohash.
+ - Falls back to SHA if it's not available.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Hash (
+	sha1,
+	sha224,
+	sha256,
+	sha384,
+	sha512,
+#ifdef WITH_CRYPTOHASH
+	skein256,
+	skein512,
+#endif
+	prop_hashes_stable
+) where
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Char8 as C8
+
+#ifndef WITH_CRYPTOHASH
+import Data.Digest.Pure.SHA
+#else
+import Crypto.Hash
+
+sha1 :: L.ByteString -> Digest SHA1
+sha1 = hashlazy
+
+sha224 :: L.ByteString -> Digest SHA224
+sha224 = hashlazy
+
+sha256 :: L.ByteString -> Digest SHA256
+sha256 = hashlazy
+
+sha384 :: L.ByteString -> Digest SHA384
+sha384 = hashlazy
+
+sha512 :: L.ByteString -> Digest SHA512
+sha512 = hashlazy
+
+-- sha3 is not yet fully standardized
+--sha3 :: L.ByteString -> Digest SHA3
+--sha3 = hashlazy
+
+skein256 :: L.ByteString -> Digest Skein256_256
+skein256 = hashlazy
+
+skein512 :: L.ByteString -> Digest Skein512_512
+skein512 = hashlazy
+
+#endif
+
+{- Check that all the hashes continue to hash the same. -}
+prop_hashes_stable :: Bool
+prop_hashes_stable = all (\(hasher, result) -> hasher foo == result)
+	[ (show . sha1, "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33")
+	, (show . sha224, "0808f64e60d58979fcb676c96ec938270dea42445aeefcd3a4e6f8db")
+	, (show . sha256, "2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae")
+	, (show . sha384, "98c11ffdfdd540676b1a137cb1a22b2a70350c9a44171d6b1180c6be5cbb2ee3f79d532c8a1dd9ef2e8e08e752a3babb")
+	, (show . sha512, "f7fbba6e0636f890e56fbbf3283e524c6fa3204ae298382d624741d0dc6638326e282c41be5e4254d8820772c5518a2c5a8c0c7f7eda19594a7eb539453e1ed7")
+#ifdef WITH_CRYPTOHASH
+	, (show . skein256, "a04efd9a0aeed6ede40fe5ce0d9361ae7b7d88b524aa19917b9315f1ecf00d33")
+	, (show . skein512, "fd8956898113510180aa4658e6c0ac85bd74fb47f4a4ba264a6b705d7a8e8526756e75aecda12cff4f1aca1a4c2830fbf57f458012a66b2b15a3dd7d251690a7")
+#endif
+	]
+  where
+	foo = L.fromChunks [C8.pack "foo"]
diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs
index 038d1228e..644e6fbab 100644
--- a/Utility/HumanTime.hs
+++ b/Utility/HumanTime.hs
@@ -1,26 +1,86 @@
 {- Time for humans.
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Utility.HumanTime where
+module Utility.HumanTime (
+	Duration(..),
+	durationToPOSIXTime,
+	parseDuration,
+	fromDuration,
+	prop_duration_roundtrips
+) where
 
 import Utility.PartialPrelude
+import Utility.Applicative
+import Utility.QuickCheck
 
 import Data.Time.Clock.POSIX (POSIXTime)
+import Data.Char
+import Control.Applicative
+import qualified Data.Map as M
 
-{- Parses a human-input time duration, of the form "5h" or "1m". -}
-parseDuration :: String -> Maybe POSIXTime
-parseDuration s = do
-	num <- readish s :: Maybe Integer
-	units <- findUnits =<< lastMaybe s
-	return $ fromIntegral num * units
+newtype Duration = Duration { durationSeconds :: Integer }
+  deriving (Eq, Ord, Read, Show)
+
+durationToPOSIXTime :: Duration -> POSIXTime
+durationToPOSIXTime = fromIntegral . durationSeconds
+
+{- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -}
+parseDuration :: String -> Maybe Duration
+parseDuration = Duration <$$> go 0
+  where
+  	go n [] = return n
+  	go n s = do
+		num <- readish s :: Maybe Integer
+		case dropWhile isDigit s of
+			(c:rest) -> do
+				u <- M.lookup c unitmap
+				go (n + num * u) rest
+			_ -> return $ n + num
+
+fromDuration :: Duration -> String
+fromDuration Duration { durationSeconds = d }
+	| d == 0 = "0s"
+	| otherwise = concat $ map showunit $ go [] units d
   where
-	findUnits 's' = Just 1
-	findUnits 'm' = Just 60
-	findUnits 'h' = Just $ 60 * 60
-	findUnits 'd' = Just $ 60 * 60 * 24
-	findUnits 'y' = Just $ 60 * 60 * 24 * 365
-	findUnits _ = Nothing
+	showunit (u, n)
+		| n > 0 = show n ++ [u]
+		| otherwise = ""
+	go c [] _ = reverse c
+	go c ((u, n):us) v =
+		let (q,r) = v `quotRem` n
+		in go ((u, q):c) us r
+
+units :: [(Char, Integer)]
+units = 
+	[ ('y', ysecs)
+	, ('d', dsecs)
+	, ('h', hsecs)
+	, ('m', msecs)
+	, ('s', 1)
+	]
+
+unitmap :: M.Map Char Integer
+unitmap = M.fromList units
+
+ysecs :: Integer
+ysecs = dsecs * 365
+
+dsecs :: Integer
+dsecs = hsecs * 24
+
+hsecs :: Integer
+hsecs = msecs * 60
+
+msecs :: Integer
+msecs = 60
+
+-- Durations cannot be negative.
+instance Arbitrary Duration where
+	arbitrary = Duration <$> nonNegative arbitrary
+
+prop_duration_roundtrips :: Duration -> Bool
+prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d
diff --git a/Utility/INotify.hs b/Utility/INotify.hs
index e9071d906..ffdad8be3 100644
--- a/Utility/INotify.hs
+++ b/Utility/INotify.hs
@@ -54,11 +54,12 @@ watchDir i dir ignored hooks
 		-- scan come before real inotify events.
 		lock <- newLock
 		let handler event = withLock lock (void $ go event)
-		void (addWatch i watchevents dir handler)
-			`catchIO` failedaddwatch
-		withLock lock $
-			mapM_ scan =<< filter (not . dirCruft) <$>
-				getDirectoryContents dir
+		flip catchNonAsync failedwatch $ do
+			void (addWatch i watchevents dir handler)
+				`catchIO` failedaddwatch
+			withLock lock $
+				mapM_ scan =<< filter (not . dirCruft) <$>
+					getDirectoryContents dir
   where
 	recurse d = watchDir i d ignored hooks
 
@@ -149,12 +150,14 @@ watchDir i dir ignored hooks
 		-- disk full error.
 		| isFullError e =
 			case errHook hooks of
-				Nothing -> throw e
+				Nothing -> error $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")"
 				Just hook -> tooManyWatches hook dir
 		-- The directory could have been deleted.
 		| isDoesNotExistError e = return ()
 		| otherwise = throw e
 
+	failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ dir ++ " (" ++ show e ++ ")"
+
 tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO ()
 tooManyWatches hook dir = do
 	sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer)
diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs
index 8037c61c8..46ca87bd9 100644
--- a/Utility/InodeCache.hs
+++ b/Utility/InodeCache.hs
@@ -49,6 +49,9 @@ instance Eq InodeCacheKey where
 inodeCacheToKey :: InodeComparisonType -> InodeCache -> InodeCacheKey 
 inodeCacheToKey ct (InodeCache prim) = InodeCacheKey ct prim
 
+inodeCacheToMtime :: InodeCache -> EpochTime
+inodeCacheToMtime (InodeCache (InodeCachePrim _ _ mtime)) = mtime
+
 showInodeCache :: InodeCache -> String
 showInodeCache (InodeCache (InodeCachePrim inode size mtime)) = unwords
 	[ show inode
diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs
index 6d6b353f2..63009f723 100644
--- a/Utility/Lsof.hs
+++ b/Utility/Lsof.hs
@@ -26,8 +26,8 @@ data ProcessInfo = ProcessInfo ProcessID CmdLine
 {- lsof is not in PATH on all systems, so SysConfig may have the absolute
  - path where the program was found. Make sure at runtime that lsof is
  - available, and if it's not in PATH, adjust PATH to contain it. -}
-setupLsof :: IO ()
-setupLsof = do
+setup :: IO ()
+setup = do
 	let cmd = fromMaybe "lsof" SysConfig.lsof
 	when (isAbsolute cmd) $ do
 		path <- getSearchPath
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 804a9e487..a2c9c8184 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -29,7 +29,7 @@ hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s
 readFileStrict :: FilePath -> IO String
 readFileStrict = readFile >=> \s -> length s `seq` return s
 
-{- Like break, but the character matching the condition is not included
+{- Like break, but the item matching the condition is not included
  - in the second result list.
  -
  - separate (== ':') "foo:bar" = ("foo", "bar")
diff --git a/Utility/Monad.hs b/Utility/Monad.hs
index b66419f76..1ba43c5f8 100644
--- a/Utility/Monad.hs
+++ b/Utility/Monad.hs
@@ -8,7 +8,7 @@
 module Utility.Monad where
 
 import Data.Maybe
-import Control.Monad (liftM)
+import Control.Monad
 
 {- Return the first value from a list, if any, satisfying the given
  - predicate -}
diff --git a/Utility/Path.hs b/Utility/Path.hs
index 79e8e8089..b6214b247 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -14,6 +14,7 @@ import System.FilePath
 import System.Directory
 import Data.List
 import Data.Maybe
+import Data.Char
 import Control.Applicative
 
 #ifdef mingw32_HOST_OS
@@ -236,3 +237,18 @@ fileNameLengthLimit dir = do
 		else return $ minimum [l, 255]
   where
 #endif
+
+{- Given a string that we'd like to use as the basis for FilePath, but that
+ - was provided by a third party and is not to be trusted, returns the closest
+ - sane FilePath.
+ -
+ - All spaces and punctuation are replaced with '_', except for '.'
+ - "../" will thus turn into ".._", which is safe.
+ -}
+sanitizeFilePath :: String -> FilePath
+sanitizeFilePath = map sanitize
+  where
+  	sanitize c
+		| c == '.' = c
+		| isSpace c || isPunctuation c || c == '/' = '_'
+		| otherwise = c
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 8ea632120..398e8a352 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -44,8 +44,10 @@ import qualified Control.Exception as E
 import Control.Monad
 #ifndef mingw32_HOST_OS
 import System.Posix.IO
-import Data.Maybe
+#else
+import Control.Applicative
 #endif
+import Data.Maybe
 
 import Utility.Misc
 import Utility.Exception
@@ -72,17 +74,17 @@ readProcessEnv cmd args environ =
 		, env = environ
 		}
 
-{- Writes a string to a process on its stdin, 
+{- Runs an action to write to a process on its stdin, 
  - returns its output, and also allows specifying the environment.
  -}
 writeReadProcessEnv
 	:: FilePath
 	-> [String]
 	-> Maybe [(String, String)]
-	-> String
+	-> (Maybe (Handle -> IO ()))
 	-> (Maybe (Handle -> IO ()))
 	-> IO String
-writeReadProcessEnv cmd args environ input adjusthandle = do
+writeReadProcessEnv cmd args environ writestdin adjusthandle = do
 	(Just inh, Just outh, _, pid) <- createProcess p
 
 	maybe (return ()) (\a -> a inh) adjusthandle
@@ -94,7 +96,7 @@ writeReadProcessEnv cmd args environ input adjusthandle = do
 	_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()
 
 	-- now write and flush any input
-	when (not (null input)) $ do hPutStr inh input; hFlush inh
+	maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
 	hClose inh -- done with stdin
 
 	-- wait on the output
@@ -161,6 +163,8 @@ createBackgroundProcess p a = a =<< createProcess p
  - whether it succeeded or failed. -}
 processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
 #ifndef mingw32_HOST_OS
+{- This implementation interleves stdout and stderr in exactly the order
+ - the process writes them. -}
 processTranscript cmd opts input = do
 	(readf, writef) <- createPipe
 	readh <- fdToHandle readf
@@ -173,10 +177,7 @@ processTranscript cmd opts input = do
 			}
 	hClose writeh
 
-	-- fork off a thread to start consuming the output
-	transcript <- hGetContents readh
-	outMVar <- newEmptyMVar
-	_ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()
+	get <- mkreader readh
 
 	-- now write and flush any input
 	case input of
@@ -188,15 +189,46 @@ processTranscript cmd opts input = do
 			hClose inh
 		Nothing -> return ()
 
-	-- wait on the output
-	takeMVar outMVar
-	hClose readh
+	transcript <- get
 
 	ok <- checkSuccessProcess pid
 	return (transcript, ok)
 #else
-processTranscript = error "processTranscript TODO"
+{- This implementation for Windows puts stderr after stdout. -}
+processTranscript cmd opts input = do
+	p@(_, _, _, pid) <- createProcess $
+		(proc cmd opts)
+			{ std_in = if isJust input then CreatePipe else Inherit
+			, std_out = CreatePipe
+			, std_err = CreatePipe
+			}
+
+	getout <- mkreader (stdoutHandle p)
+	geterr <- mkreader (stderrHandle p)
+
+	case input of
+		Just s -> do
+			let inh = stdinHandle p
+			unless (null s) $ do
+				hPutStr inh s
+				hFlush inh
+			hClose inh
+		Nothing -> return ()
+	
+	transcript <- (++) <$> getout <*> geterr
+	ok <- checkSuccessProcess pid
+	return (transcript, ok)
 #endif
+  where
+	mkreader h = do
+		s <- hGetContents h
+		v <- newEmptyMVar
+		void $ forkIO $ do
+			void $ E.evaluate (length s)
+			putMVar v ()
+		return $ do
+			takeMVar v
+			return s
 
 {- Runs a CreateProcessRunner, on a CreateProcess structure, that
  - is adjusted to pipe only from/to a single StdHandle, and passes
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
index 078b10c8b..82af09f3d 100644
--- a/Utility/QuickCheck.hs
+++ b/Utility/QuickCheck.hs
@@ -43,3 +43,6 @@ instance Arbitrary FileOffset where
 
 nonNegative :: (Num a, Ord a) => Gen a -> Gen a
 nonNegative g = g `suchThat` (>= 0)
+
+positive :: (Num a, Ord a) => Gen a -> Gen a
+positive g = g `suchThat` (> 0)
diff --git a/Utility/Quvi.hs b/Utility/Quvi.hs
new file mode 100644
index 000000000..5df1a4da7
--- /dev/null
+++ b/Utility/Quvi.hs
@@ -0,0 +1,81 @@
+{- querying quvi (import qualified)
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Utility.Quvi where
+
+import Common
+import Utility.Url
+
+import Data.Aeson
+import Data.ByteString.Lazy.UTF8 (fromString)
+
+data Page = Page
+	{ pageTitle :: String
+	, pageLinks :: [Link]
+	} deriving (Show)
+
+data Link = Link
+	{ linkSuffix :: String
+	, linkUrl :: URLString
+	} deriving (Show)
+
+instance FromJSON Page where
+	parseJSON (Object v) = Page
+		<$> v .: "page_title"
+		<*> v .: "link"
+	parseJSON _ = mzero
+
+instance FromJSON Link where
+	parseJSON (Object v) = Link
+		<$> v .: "file_suffix"
+		<*> v .: "url"
+	parseJSON _ = mzero
+
+type Query a = [CommandParam] -> URLString -> IO a
+
+{- Throws an error when quvi is not installed. -}
+forceQuery :: Query (Maybe Page)
+forceQuery ps url = query' ps url `catchNonAsync` onerr
+  where
+	onerr _ = ifM (inPath "quvi")
+		( error "quvi failed"
+		, error "quvi is not installed"
+		)
+
+{- Returns Nothing if the page is not a video page, or quvi is not
+ - installed. -}
+query :: Query (Maybe Page)
+query ps url = flip catchNonAsync (const $ return Nothing) (query' ps url)
+
+query' :: Query (Maybe Page)
+query' ps url = decode . fromString
+	<$> readProcess "quvi" (toCommand $ ps ++ [Param url])
+
+queryLinks :: Query [URLString]
+queryLinks ps url = maybe [] (map linkUrl . pageLinks) <$> query ps url
+
+{- Checks if quvi can still find a download link for an url.
+ - If quvi is not installed, returns False. -}
+check :: Query Bool
+check ps url = maybe False (not . null . pageLinks) <$> query ps url
+
+{- Checks if an url is supported by quvi, without hitting it, or outputting
+ - anything. Also returns False if quvi is not installed. -}
+supported :: URLString -> IO Bool
+supported url = boolSystem "quvi" [Params "-v mute --support", Param url]
+
+quiet :: CommandParam
+quiet = Params "-v quiet"
+
+noredir :: CommandParam
+noredir = Params "-e -resolve"
+
+{- Only return http results, not streaming protocols. -}
+httponly :: CommandParam
+httponly = Params "-c http"
diff --git a/Utility/SRV.hs b/Utility/SRV.hs
index 0a77191c4..a2ee704f7 100644
--- a/Utility/SRV.hs
+++ b/Utility/SRV.hs
@@ -67,8 +67,14 @@ lookupSRV (SRV srv) = initResolver [] $ \resolver -> do
 lookupSRV (SRV srv) = do
 	seed <- makeResolvSeed defaultResolvConf
 	r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv
-	return $ maybe [] (orderHosts . map tohosts) r
+	return $
+#if MIN_VERSION_dns(1,0,0)
+		either (const []) use r
+#else
+		maybe [] use r
+#endif
   where
+  	use = orderHosts . map tohosts
 	tohosts (priority, weight, port, hostname) =
 		( (priority, weight)
 		, (B8.toString hostname, PortNumber $ fromIntegral port)
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
new file mode 100644
index 000000000..acbee70ff
--- /dev/null
+++ b/Utility/Scheduled.hs
@@ -0,0 +1,350 @@
+{- scheduled activities
+ - 
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Scheduled (
+	Schedule(..),
+	Recurrance(..),
+	ScheduledTime(..),
+	NextTime(..),
+	nextTime,
+	fromSchedule,
+	fromScheduledTime,
+	toScheduledTime,
+	fromRecurrance,
+	toRecurrance,
+	toSchedule,
+	parseSchedule,
+	prop_schedule_roundtrips
+) where
+
+import Common
+import Utility.QuickCheck
+
+import Data.Time.Clock
+import Data.Time.LocalTime
+import Data.Time.Calendar
+import Data.Time.Calendar.WeekDate
+import Data.Time.Calendar.OrdinalDate
+import Data.Tuple.Utils
+import Data.Char
+
+{- Some sort of scheduled event. -}
+data Schedule = Schedule Recurrance ScheduledTime
+  deriving (Eq, Read, Show, Ord)
+
+data Recurrance
+	= Daily
+	| Weekly (Maybe WeekDay)
+	| Monthly (Maybe MonthDay)
+	| Yearly (Maybe YearDay)
+	-- Days, Weeks, or Months of the year evenly divisible by a number.
+	-- (Divisible Year is years evenly divisible by a number.)
+	| Divisible Int Recurrance
+  deriving (Eq, Read, Show, Ord)
+
+type WeekDay = Int
+type MonthDay = Int
+type YearDay = Int
+
+data ScheduledTime
+	= AnyTime
+	| SpecificTime Hour Minute
+  deriving (Eq, Read, Show, Ord)
+
+type Hour = Int
+type Minute = Int
+
+{- Next time a Schedule should take effect. The NextTimeWindow is used
+ - when a Schedule is allowed to start at some point within the window. -}
+data NextTime
+	= NextTimeExactly LocalTime
+	| NextTimeWindow LocalTime LocalTime
+  deriving (Eq, Read, Show)
+
+startTime :: NextTime -> LocalTime
+startTime (NextTimeExactly t) = t
+startTime (NextTimeWindow t _) = t
+
+nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)
+nextTime schedule lasttime = do
+	now <- getCurrentTime
+	tz <- getTimeZone now
+	return $ calcNextTime schedule lasttime $ utcToLocalTime tz now
+
+{- Calculate the next time that fits a Schedule, based on the
+ - last time it occurred, and the current time. -}
+calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
+calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime
+	| scheduledtime == AnyTime = do
+		next <- findfromtoday True
+		return $ case next of
+			NextTimeWindow _ _ -> next
+			NextTimeExactly t -> window (localDay t) (localDay t)
+	| otherwise = NextTimeExactly . startTime <$> findfromtoday False
+  where
+  	findfromtoday anytime = findfrom recurrance afterday today
+	  where
+	  	today = localDay currenttime
+		afterday = sameaslastday || toolatetoday
+		toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
+		sameaslastday = lastday == Just today
+	lastday = localDay <$> lasttime
+	nexttime = case scheduledtime of
+		AnyTime -> TimeOfDay 0 0 0
+		SpecificTime h m -> TimeOfDay h m 0
+	exactly d = NextTimeExactly $ LocalTime d nexttime
+	window startd endd = NextTimeWindow
+		(LocalTime startd nexttime)
+		(LocalTime endd (TimeOfDay 23 59 0))
+	findfrom r afterday day = case r of
+		Daily
+			| afterday -> Just $ exactly $ addDays 1 day
+			| otherwise -> Just $ exactly day
+		Weekly Nothing
+			| afterday -> skip 1
+			| otherwise -> case (wday <$> lastday, wday day) of
+				(Nothing, _) -> Just $ window day (addDays 6 day)
+				(Just old, curr)
+					| old == curr -> Just $ window day (addDays 6 day)
+					| otherwise -> skip 1
+		Monthly Nothing
+			| afterday -> skip 1
+			| maybe True (\old -> mnum day > mday old && mday day >= (mday old `mod` minmday)) lastday ->
+				-- Window only covers current month,
+				-- in case there is a Divisible requirement.
+				Just $ window day (endOfMonth day)
+			| otherwise -> skip 1
+		Yearly Nothing
+			| afterday -> skip 1
+			| maybe True (\old -> ynum day > ynum old && yday day >= (yday old `mod` minyday)) lastday ->
+				Just $ window day (endOfYear day)
+			| otherwise -> skip 1
+		Weekly (Just w)
+			| w < 0 || w > maxwday -> Nothing
+			| w == wday day -> if afterday
+				then Just $ exactly $ addDays 7 day
+				else Just $ exactly day
+			| otherwise -> Just $ exactly $
+				addDays (fromIntegral $ (w - wday day) `mod` 7) day
+		Monthly (Just m)
+			| m < 0 || m > maxmday -> Nothing
+			-- TODO can be done more efficiently than recursing
+			| m == mday day -> if afterday
+				then skip 1
+				else Just $ exactly day
+			| otherwise -> skip 1
+		Yearly (Just y)
+			| y < 0 || y > maxyday -> Nothing
+			| y == yday day -> if afterday
+				then skip 365
+				else Just $ exactly day
+			| otherwise -> skip 1
+		Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)
+		Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)
+		Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)
+		Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing
+		Divisible _ r'@(Divisible _ _) -> findfrom r' afterday day
+	  where
+	  	skip n = findfrom r False (addDays n day)
+	  	handlediv n r' getval mmax
+			| n > 0 && maybe True (n <=) mmax =
+				findfromwhere r' (divisible n . getval) afterday day
+			| otherwise = Nothing
+	findfromwhere r p afterday day
+		| maybe True (p . getday) next = next
+		| otherwise = maybe Nothing (findfromwhere r p True . getday) next
+	  where
+		next = findfrom r afterday day
+		getday = localDay . startTime
+	divisible n v = v `rem` n == 0
+
+endOfMonth :: Day -> Day
+endOfMonth day =
+	let (y,m,_d) = toGregorian day
+	in fromGregorian y m (gregorianMonthLength y m)
+
+endOfYear :: Day -> Day
+endOfYear day =
+	let (y,_m,_d) = toGregorian day
+	in endOfMonth (fromGregorian y maxmnum 1)
+
+-- extracting various quantities from a Day
+wday :: Day -> Int
+wday = thd3 . toWeekDate
+wnum :: Day -> Int
+wnum = snd3 . toWeekDate
+mday :: Day -> Int
+mday = thd3 . toGregorian
+mnum :: Day -> Int
+mnum = snd3 . toGregorian
+yday :: Day -> Int
+yday = snd . toOrdinalDate
+ynum :: Day -> Int
+ynum = fromIntegral . fst . toOrdinalDate
+
+{- Calendar max and mins. -}
+maxyday :: Int
+maxyday = 366 -- with leap days
+minyday :: Int
+minyday = 365
+maxwnum :: Int
+maxwnum = 53 -- some years have more than 52
+maxmday :: Int
+maxmday = 31
+minmday :: Int
+minmday = 28
+maxmnum :: Int
+maxmnum = 12
+maxwday :: Int
+maxwday = 7
+
+fromRecurrance :: Recurrance -> String
+fromRecurrance (Divisible n r) =
+	fromRecurrance' (++ "s divisible by " ++ show n) r
+fromRecurrance r = fromRecurrance' ("every " ++) r
+
+fromRecurrance' :: (String -> String) -> Recurrance -> String
+fromRecurrance' a Daily = a "day"
+fromRecurrance' a (Weekly n) = onday n (a "week")
+fromRecurrance' a (Monthly n) = onday n (a "month")
+fromRecurrance' a (Yearly n) = onday n (a "year")
+fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used
+
+onday :: Maybe Int -> String -> String
+onday (Just n) s = "on day " ++ show n ++ " of " ++ s
+onday Nothing s = s
+
+toRecurrance :: String -> Maybe Recurrance
+toRecurrance s = case words s of
+	("every":"day":[]) -> Just Daily
+	("on":"day":sd:"of":"every":something:[]) -> withday sd something
+	("every":something:[]) -> noday something
+	("days":"divisible":"by":sn:[]) -> 
+		Divisible <$> getdivisor sn <*> pure Daily
+	("on":"day":sd:"of":something:"divisible":"by":sn:[]) -> 
+		Divisible
+			<$> getdivisor sn
+			<*> withday sd something
+	("every":something:"divisible":"by":sn:[]) -> 
+		Divisible
+			<$> getdivisor sn
+			<*> noday something
+	(something:"divisible":"by":sn:[]) -> 
+		Divisible
+			<$> getdivisor sn
+			<*> noday something
+	_ -> Nothing
+  where
+	constructor "week" = Just Weekly
+	constructor "month" = Just Monthly
+	constructor "year" = Just Yearly
+	constructor u
+		| "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u
+		| otherwise = Nothing
+  	withday sd u = do
+		c <- constructor u
+		d <- readish sd
+		Just $ c (Just d)
+	noday u = do
+		c <- constructor u
+		Just $ c Nothing
+	getdivisor sn = do
+		n <- readish sn
+		if n > 0
+			then Just n
+			else Nothing
+
+fromScheduledTime :: ScheduledTime -> String
+fromScheduledTime AnyTime = "any time"
+fromScheduledTime (SpecificTime h m) = 
+	show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm
+  where
+  	pad n s = take (n - length s) (repeat '0') ++ s
+	(h', ampm)
+		| h == 0 = (12, "AM")
+		| h < 12 = (h, "AM")
+		| h == 12 = (h, "PM")
+		| otherwise = (h - 12, "PM")
+
+toScheduledTime :: String -> Maybe ScheduledTime
+toScheduledTime "any time" = Just AnyTime
+toScheduledTime v = case words v of
+	(s:ampm:[])
+		| map toUpper ampm == "AM" ->
+			go s h0
+		| map toUpper ampm == "PM" ->
+			go s (\h -> (h0 h) + 12)
+		| otherwise -> Nothing
+	(s:[]) -> go s id
+	_ -> Nothing
+  where
+  	h0 h
+		| h == 12 = 0
+		| otherwise = h
+  	go :: String -> (Int -> Int) -> Maybe ScheduledTime
+	go s adjust =
+		let (h, m) = separate (== ':') s
+		in SpecificTime
+			<$> (adjust <$> readish h)
+			<*> if null m then Just 0 else readish m
+
+fromSchedule :: Schedule -> String
+fromSchedule (Schedule recurrance scheduledtime) = unwords
+	[ fromRecurrance recurrance
+	, "at"
+	, fromScheduledTime scheduledtime
+	]
+
+toSchedule :: String -> Maybe Schedule
+toSchedule = eitherToMaybe . parseSchedule
+
+parseSchedule :: String -> Either String Schedule
+parseSchedule s = do
+	r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right
+		(toRecurrance recurrance)
+	t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right
+		(toScheduledTime scheduledtime)
+	Right $ Schedule r t
+  where
+	(rws, tws) = separate (== "at") (words s)
+	recurrance = unwords rws
+	scheduledtime = unwords tws
+
+instance Arbitrary Schedule where
+	arbitrary = Schedule <$> arbitrary <*> arbitrary
+
+instance Arbitrary ScheduledTime where
+	arbitrary = oneof
+		[ pure AnyTime
+		, SpecificTime 
+			<$> choose (0, 23)
+			<*> choose (1, 59)
+		]
+
+instance Arbitrary Recurrance where
+	arbitrary = oneof
+		[ pure Daily
+		, Weekly <$> arbday
+		, Monthly <$> arbday
+		, Yearly <$> arbday
+		, Divisible
+			<$> positive arbitrary
+			<*> oneof -- no nested Divisibles
+				[ pure Daily
+				, Weekly <$> arbday
+				, Monthly <$> arbday
+				, Yearly <$> arbday
+				]
+		]
+	  where
+	  	arbday = oneof
+			[ Just <$> nonNegative arbitrary
+			, pure Nothing
+			]
+
+prop_schedule_roundtrips :: Schedule -> Bool
+prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s
diff --git a/Utility/Url.hs b/Utility/Url.hs
index 508b9eeb4..97296c920 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -9,7 +9,9 @@
 
 module Utility.Url (
 	URLString,
+	UserAgent,
 	check,
+	checkBoth,
 	exists,
 	download,
 	downloadQuiet
@@ -27,14 +29,22 @@ type URLString = String
 
 type Headers = [String]
 
+type UserAgent = String
+
 {- Checks that an url exists and could be successfully downloaded,
  - also checking that its size, if available, matches a specified size. -}
-check :: URLString -> Headers -> Maybe Integer -> IO Bool
-check url headers expected_size = handle <$> exists url headers
+checkBoth :: URLString -> Headers -> Maybe Integer -> Maybe UserAgent -> IO Bool
+checkBoth url headers expected_size ua = do
+	v <- check url headers expected_size ua
+	return (fst v && snd v)
+check :: URLString -> Headers -> Maybe Integer -> Maybe UserAgent -> IO (Bool, Bool)
+check url headers expected_size = handle <$$> exists url headers
   where
-	handle (False, _) = False
-	handle (True, Nothing) = True
-	handle (True, s) = expected_size == s
+	handle (False, _) = (False, False)
+	handle (True, Nothing) = (True, True)
+	handle (True, s) = case expected_size of
+		Just _ -> (True, expected_size == s)
+		Nothing -> (True, True)
 
 {- Checks that an url exists and could be successfully downloaded,
  - also returning its size if available. 
@@ -44,8 +54,8 @@ check url headers expected_size = handle <$> exists url headers
  - Uses curl otherwise, when available, since curl handles https better
  - than does Haskell's Network.Browser.
  -}
-exists :: URLString -> Headers -> IO (Bool, Maybe Integer)
-exists url headers = case parseURIRelaxed url of
+exists :: URLString -> Headers -> Maybe UserAgent -> IO (Bool, Maybe Integer)
+exists url headers ua = case parseURIRelaxed url of
 	Just u
 		| uriScheme u == "file:" -> do
 			s <- catchMaybeIO $ getFileStatus (unEscapeString $ uriPath u)
@@ -54,12 +64,12 @@ exists url headers = case parseURIRelaxed url of
 				Nothing -> dne
 		| otherwise -> if Build.SysConfig.curl
 			then do
-				output <- readProcess "curl" curlparams
+				output <- readProcess "curl" $ toCommand curlparams
 				case lastMaybe (lines output) of
 					Just ('2':_:_) -> return (True, extractsize output)
 					_ -> dne
 			else do
-				r <- request u headers HEAD
+				r <- request u headers HEAD ua
 				case rspCode r of
 					(2,_,_) -> return (True, size r)
 					_ -> return (False, Nothing)
@@ -67,13 +77,12 @@ exists url headers = case parseURIRelaxed url of
   where
 	dne = return (False, Nothing)
 
-	curlparams = 
-		[ "-s"
-		, "--head"
-		, "-L"
-		, url
-		, "-w", "%{http_code}"
-		] ++ concatMap (\h -> ["-H", h]) headers
+	curlparams = addUserAgent ua $
+		[ Param "-s"
+		, Param "--head"
+		, Param "-L", Param url
+		, Param "-w", Param "%{http_code}"
+		] ++ concatMap (\h -> [Param "-H", Param h]) headers
 
 	extractsize s = case lastMaybe $ filter ("Content-Length:" `isPrefixOf`) (lines s) of
 		Just l -> case lastMaybe $ words l of
@@ -83,6 +92,11 @@ exists url headers = case parseURIRelaxed url of
 
 	size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders
 
+-- works for both wget and curl commands
+addUserAgent :: Maybe UserAgent -> [CommandParam] -> [CommandParam]
+addUserAgent Nothing ps = ps
+addUserAgent (Just ua) ps = ps ++ [Param "--user-agent", Param ua] 
+
 {- Used to download large files, such as the contents of keys.
  -
  - Uses wget or curl program for its progress bar. (Wget has a better one,
@@ -90,15 +104,15 @@ exists url headers = case parseURIRelaxed url of
  - would not be appropriate to test at configure time and build support
  - for only one in.
  -}
-download :: URLString -> Headers -> [CommandParam] -> FilePath -> IO Bool
+download :: URLString -> Headers -> [CommandParam] -> FilePath -> Maybe UserAgent -> IO Bool
 download = download' False
 
 {- No output, even on error. -}
-downloadQuiet :: URLString -> Headers -> [CommandParam] -> FilePath -> IO Bool
+downloadQuiet :: URLString -> Headers -> [CommandParam] -> FilePath -> Maybe UserAgent -> IO Bool
 downloadQuiet = download' True
 
-download' :: Bool -> URLString -> Headers -> [CommandParam] -> FilePath -> IO Bool
-download' quiet url headers options file = 
+download' :: Bool -> URLString -> Headers -> [CommandParam] -> FilePath -> Maybe UserAgent -> IO Bool
+download' quiet url headers options file ua = 
 	case parseURIRelaxed url of
 		Just u
 			| uriScheme u == "file:" -> do
@@ -110,7 +124,7 @@ download' quiet url headers options file =
 		_ -> return False
   where
 	headerparams = map (\h -> Param $ "--header=" ++ h) headers
-	wget = go "wget" $ headerparams ++ quietopt "-q" ++ [Params "-c -O"]
+	wget = go "wget" $ headerparams ++ quietopt "-q" ++ [Params "--clobber -c -O"]
 	{- Uses the -# progress display, because the normal
 	 - one is very confusing when resuming, showing
 	 - the remainder to download as the whole file,
@@ -119,7 +133,7 @@ download' quiet url headers options file =
 	curl = go "curl" $ headerparams ++ quietopt "-s" ++
 		[Params "-f -L -C - -# -o"]
 	go cmd opts = boolSystem cmd $
-		options++opts++[File file, File url]
+		addUserAgent ua $ options++opts++[File file, File url]
 	quietopt s
 		| quiet = [Param s]
 		| otherwise = []
@@ -134,13 +148,14 @@ download' quiet url headers options file =
  - Unfortunately, does not handle https, so should only be used
  - when curl is not available.
  -}
-request :: URI -> Headers -> RequestMethod -> IO (Response String)
-request url headers requesttype = go 5 url
+request :: URI -> Headers -> RequestMethod -> Maybe UserAgent -> IO (Response String)
+request url headers requesttype ua = go 5 url
   where
 	go :: Int -> URI -> IO (Response String)
 	go 0 _ = error "Too many redirects "
 	go n u = do
 		rsp <- Browser.browse $ do
+			maybe noop Browser.setUserAgent ua
 			Browser.setErrHandler ignore
 			Browser.setOutHandler ignore
 			Browser.setAllowRedirects False
diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs
index f3c0d3a6b..421dadb39 100644
--- a/Utility/WebApp.hs
+++ b/Utility/WebApp.hs
@@ -12,6 +12,7 @@ module Utility.WebApp where
 import Common
 import Utility.Tmp
 import Utility.FileMode
+import Utility.Hash
 
 import qualified Yesod
 import qualified Network.Wai as Wai
@@ -23,8 +24,7 @@ import System.Log.Logger
 import qualified Data.CaseInsensitive as CI
 import Network.Socket
 import Control.Exception
-import Crypto.Random
-import Data.Digest.Pure.SHA
+import "crypto-api" Crypto.Random
 import qualified Web.ClientSession as CS
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy.UTF8 as L8
@@ -214,7 +214,7 @@ genRandomToken = do
 	return $
 		case genBytes 512 g of
 			Left e -> error $ "failed to generate secret token: " ++ show e
-			Right (s, _) -> showDigest $ sha512 $ L.fromChunks [s]
+			Right (s, _) -> show $ sha512 $ L.fromChunks [s]
 
 {- A Yesod isAuthorized method, which checks the auth cgi parameter
  - against a token extracted from the Yesod application.
diff --git a/Utility/Win32Notify.hs b/Utility/Win32Notify.hs
new file mode 100644
index 000000000..edde5309c
--- /dev/null
+++ b/Utility/Win32Notify.hs
@@ -0,0 +1,65 @@
+{- Win32-notify interface
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Win32Notify where
+
+import Common hiding (isDirectory)
+import Utility.DirWatcher.Types
+
+import System.Win32.Notify
+import qualified System.PosixCompat.Files as Files
+
+watchDir :: FilePath -> (FilePath -> Bool) -> WatchHooks -> IO WatchManager
+watchDir dir ignored hooks = do
+	scan dir
+	wm <- initWatchManager
+	void $ watchDirectory wm dir True [Create, Delete, Modify, Move] handle
+	return wm
+  where
+	handle evt
+		| ignoredPath ignored (filePath evt) = noop
+		| otherwise = case evt of
+			(Deleted _ _)
+				| isDirectory evt -> runhook delDirHook Nothing
+				| otherwise -> runhook delHook Nothing
+			(Created _ _)
+				| isDirectory evt -> noop
+				| otherwise -> runhook addHook Nothing
+			(Modified _ _)
+				| isDirectory evt -> noop
+				{- Add hooks are run when a file is modified for 
+				 - compatability with INotify, which calls the add
+				 - hook when a file is closed, and so tends to call
+				 - both add and modify for file modifications. -}
+				| otherwise -> do
+					runhook addHook Nothing
+					runhook modifyHook Nothing
+	  where
+		runhook h s = maybe noop (\a -> a (filePath evt) s) (h hooks)
+
+	scan d = unless (ignoredPath ignored d) $
+		mapM_ go =<< dirContentsRecursive d
+	  where		
+		go f
+			| ignoredPath ignored f = noop
+			| otherwise = do
+				ms <- getstatus f
+				case ms of
+					Nothing -> noop
+					Just s
+						| Files.isRegularFile s ->
+							runhook addHook ms
+						| otherwise ->
+							noop
+		  where
+			runhook h s = maybe noop (\a -> a f s) (h hooks)
+		
+	getstatus = catchMaybeIO . getFileStatus
+
+{- Check each component of the path to see if it's ignored. -}
+ignoredPath :: (FilePath -> Bool) -> FilePath -> Bool
+ignoredPath ignored = any ignored . map dropTrailingPathSeparator . splitPath