Merge branch 'master' into no-xmpp

24 files changed, 612 insertions, 101 deletions

diff --git a/Utility/AuthToken.hs b/Utility/AuthToken.hs
new file mode 100644
index 000000000..191b4f5c9
--- /dev/null
+++ b/Utility/AuthToken.hs
@@ -0,0 +1,99 @@
+{- authentication tokens
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.AuthToken (
+	AuthToken,
+	toAuthToken,
+	fromAuthToken,
+	nullAuthToken,
+	genAuthToken,
+	AllowedAuthTokens,
+	allowedAuthTokens,
+	isAllowedAuthToken,
+) where
+
+import qualified Utility.SimpleProtocol as Proto
+import Utility.Hash
+
+import Data.SecureMem
+import Data.Maybe
+import Data.Char
+import Data.Byteable
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.ByteString.Lazy as L
+import "crypto-api" Crypto.Random
+
+-- | An AuthToken is stored in secue memory, with constant time comparison.
+--
+-- It can have varying length, depending on the security needs of the
+-- application.
+--
+-- To avoid decoding issues, and presentation issues, the content
+-- of an AuthToken is limited to ASCII characters a-z, and 0-9.
+-- This is enforced by all exported AuthToken constructors.
+newtype AuthToken = AuthToken SecureMem
+	deriving (Show, Eq)
+
+allowedChar :: Char -> Bool
+allowedChar c = isAsciiUpper c || isAsciiLower c || isDigit c
+
+instance Proto.Serializable AuthToken where
+	serialize = T.unpack . fromAuthToken
+	deserialize = toAuthToken . T.pack
+
+fromAuthToken :: AuthToken -> T.Text
+fromAuthToken (AuthToken t ) = TE.decodeLatin1 (toBytes t)
+
+-- | Upper-case characters are lower-cased to make them fit in the allowed
+-- character set. This allows AuthTokens to be compared effectively
+-- case-insensitively. 
+--
+-- Returns Nothing if any disallowed characters are present.
+toAuthToken :: T.Text -> Maybe AuthToken
+toAuthToken t
+	| all allowedChar s = Just $ AuthToken $ 
+		secureMemFromByteString $ TE.encodeUtf8 $ T.pack s
+	| otherwise = Nothing
+  where
+	s = map toLower $ T.unpack t
+
+-- | The empty AuthToken, for those times when you don't want any security.
+nullAuthToken :: AuthToken
+nullAuthToken = AuthToken $ secureMemFromByteString $ TE.encodeUtf8 T.empty
+
+-- | Generates an AuthToken of a specified length. This is done by
+-- generating a random bytestring, hashing it with sha2 512, and truncating
+-- to the specified length.
+--
+-- That limits the maximum length to 128, but with 512 bytes of entropy,
+-- that should be sufficient for any application.
+genAuthToken :: Int -> IO AuthToken
+genAuthToken len = do
+	g <- newGenIO :: IO SystemRandom
+	return $
+		case genBytes 512 g of
+			Left e -> error $ "failed to generate auth token: " ++ show e
+			Right (s, _) -> fromMaybe (error "auth token encoding failed") $
+				toAuthToken $ T.pack $ take len $
+					show $ sha2_512 $ L.fromChunks [s]
+
+-- | For when several AuthTokens are allowed to be used.
+newtype AllowedAuthTokens = AllowedAuthTokens [AuthToken]
+
+allowedAuthTokens :: [AuthToken] -> AllowedAuthTokens
+allowedAuthTokens = AllowedAuthTokens
+
+-- | Note that every item in the list is checked, even if the first one
+-- is allowed, so that comparison is constant-time.
+isAllowedAuthToken :: AuthToken -> AllowedAuthTokens -> Bool
+isAllowedAuthToken t (AllowedAuthTokens l) = go False l
+  where
+	go ok [] = ok
+	go ok (i:is)
+		| t == i = go True is
+		| otherwise = go ok is
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index 94d5ac3bc..2bae40fba 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -47,10 +47,10 @@ start' s = do
 	rawMode to
 	return $ CoProcessState pid to from s
   where
-	rawMode h = do
-		fileEncoding h
 #ifdef mingw32_HOST_OS
-		hSetNewlineMode h noNewlineTranslation
+	rawMode h = hSetNewlineMode h noNewlineTranslation
+#else
+	rawMode _ = return ()
 #endif
 
 stop :: CoProcessHandle -> IO ()
diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs
index 3cc2eb261..5c0ea4169 100644
--- a/Utility/Daemon.hs
+++ b/Utility/Daemon.hs
@@ -111,7 +111,7 @@ lockPidFile pidfile = do
 #endif
 
 alreadyRunning :: IO ()
-alreadyRunning = error "Daemon is already running."
+alreadyRunning = giveup "Daemon is already running."
 
 {- Checks if the daemon is running, by checking that the pid file
  - is locked by the same process that is listed in the pid file.
@@ -135,7 +135,7 @@ checkDaemon pidfile = bracket setup cleanup go
 	check _ Nothing = Nothing
 	check (Just (pid, _)) (Just pid')
 		| pid == pid' = Just pid
-		| otherwise = error $
+		| otherwise = giveup $
 			"stale pid in " ++ pidfile ++ 
 			" (got " ++ show pid' ++ 
 			"; expected " ++ show pid ++ " )"
diff --git a/Utility/DirWatcher/FSEvents.hs b/Utility/DirWatcher/FSEvents.hs
index a07139c44..d7472d490 100644
--- a/Utility/DirWatcher/FSEvents.hs
+++ b/Utility/DirWatcher/FSEvents.hs
@@ -17,7 +17,7 @@ import Data.Bits ((.&.))
 watchDir :: FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO EventStream
 watchDir dir ignored scanevents hooks = do
 	unlessM fileLevelEventsSupported $
-		error "Need at least OSX 10.7.0 for file-level FSEvents"
+		giveup "Need at least OSX 10.7.0 for file-level FSEvents"
 	scan dir
 	eventStreamCreate [dir] 1.0 True True True dispatch
   where
diff --git a/Utility/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs
index 4d11b95a8..1890b8af5 100644
--- a/Utility/DirWatcher/INotify.hs
+++ b/Utility/DirWatcher/INotify.hs
@@ -152,7 +152,7 @@ watchDir i dir ignored scanevents hooks
 		-- disk full error.
 		| isFullError e =
 			case errHook hooks of
-				Nothing -> error $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")"
+				Nothing -> giveup $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")"
 				Just hook -> tooManyWatches hook dir
 		-- The directory could have been deleted.
 		| isDoesNotExistError e = return ()
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
index 0ffc7103f..67c2e85d8 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -1,6 +1,6 @@
 {- Simple IO exception handling (and some more)
  -
- - Copyright 2011-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -10,6 +10,7 @@
 
 module Utility.Exception (
 	module X,
+	giveup,
 	catchBoolIO,
 	catchMaybeIO,
 	catchDefaultIO,
@@ -40,6 +41,21 @@ import GHC.IO.Exception (IOErrorType(..))
 
 import Utility.Data
 
+{- Like error, this throws an exception. Unlike error, if this exception
+ - is not caught, it won't generate a backtrace. So use this for situations
+ - where there's a problem that the user is excpected to see in some
+ - circumstances. -}
+giveup :: [Char] -> a
+#ifdef MIN_VERSION_base
+#if MIN_VERSION_base(4,9,0)
+giveup = errorWithoutStackTrace
+#else
+giveup = error
+#endif
+#else
+giveup = error
+#endif
+
 {- Catches IO errors and returns a Bool -}
 catchBoolIO :: MonadCatch m => m Bool -> m Bool
 catchBoolIO = catchDefaultIO False
diff --git a/Utility/ExternalSHA.hs b/Utility/ExternalSHA.hs
index e581697ae..7b0882004 100644
--- a/Utility/ExternalSHA.hs
+++ b/Utility/ExternalSHA.hs
@@ -14,7 +14,6 @@ module Utility.ExternalSHA (externalSHA) where
 
 import Utility.SafeCommand
 import Utility.Process
-import Utility.FileSystemEncoding
 import Utility.Misc
 import Utility.Exception
 
@@ -30,7 +29,6 @@ externalSHA command shasize file = do
 		Left _ -> Left (command ++ " failed")
   where
 	readsha args = withHandle StdoutHandle createProcessSuccess p $ \h -> do
-		fileEncoding h
 		output  <- hGetContentsStrict h
 		hClose h
 		return output
diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
index eab98337a..be43ace95 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -1,6 +1,6 @@
 {- GHC File system encoding handling.
  -
- - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2016 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -9,7 +9,7 @@
 {-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.FileSystemEncoding (
-	fileEncoding,
+	useFileSystemEncoding,
 	withFilePath,
 	md5FilePath,
 	decodeBS,
@@ -19,7 +19,6 @@ module Utility.FileSystemEncoding (
 	encodeW8NUL,
 	decodeW8NUL,
 	truncateFilePath,
-	setConsoleEncoding,
 ) where
 
 import qualified GHC.Foreign as GHC
@@ -39,19 +38,30 @@ import qualified Data.ByteString.Lazy.UTF8 as L8
 
 import Utility.Exception
 
-{- Sets a Handle to use the filesystem encoding. This causes data
- - written or read from it to be encoded/decoded the same
- - as ghc 7.4 does to filenames etc. This special encoding
- - allows "arbitrary undecodable bytes to be round-tripped through it".
+{- Makes all subsequent Handles that are opened, as well as stdio Handles,
+ - use the filesystem encoding, instead of the encoding of the current
+ - locale.
+ -
+ - The filesystem encoding allows "arbitrary undecodable bytes to be
+ - round-tripped through it". This avoids encoded failures when data is not
+ - encoded matching the current locale.
+ -
+ - Note that code can still use hSetEncoding to change the encoding of a
+ - Handle. This only affects the default encoding.
  -}
-fileEncoding :: Handle -> IO ()
+useFileSystemEncoding :: IO ()
+useFileSystemEncoding = do
 #ifndef mingw32_HOST_OS
-fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding
+	e <- Encoding.getFileSystemEncoding
 #else
-{- The file system encoding does not work well on Windows,
- - and Windows only has utf FilePaths anyway. -}
-fileEncoding h = hSetEncoding h Encoding.utf8
+	{- The file system encoding does not work well on Windows,
+	 - and Windows only has utf FilePaths anyway. -}
+	let e = Encoding.utf8
 #endif
+	hSetEncoding stdin e
+	hSetEncoding stdout e
+	hSetEncoding stderr e
+	Encoding.setLocaleEncoding e	
 
 {- Marshal a Haskell FilePath into a NUL terminated C string using temporary
  - storage. The FilePath is encoded using the filesystem encoding,
@@ -165,10 +175,3 @@ truncateFilePath n = reverse . go [] n . L8.fromString
 					else go (c:coll) (cnt - x') (L8.drop 1 bs)
 			_ -> coll
 #endif
-
-{- This avoids ghc's output layer crashing on invalid encoded characters in
- - filenames when printing them out. -}
-setConsoleEncoding :: IO ()
-setConsoleEncoding = do
-	fileEncoding stdout
-	fileEncoding stderr
diff --git a/Utility/Glob.hs b/Utility/Glob.hs
index 98ffe751b..119ea4834 100644
--- a/Utility/Glob.hs
+++ b/Utility/Glob.hs
@@ -12,6 +12,8 @@ module Utility.Glob (
 	matchGlob
 ) where
 
+import Utility.Exception
+
 import System.Path.WildMatch
 
 import "regex-tdfa" Text.Regex.TDFA
@@ -26,7 +28,7 @@ compileGlob :: String -> GlobCase -> Glob
 compileGlob glob globcase = Glob $
 	case compile (defaultCompOpt {caseSensitive = casesentitive}) defaultExecOpt regex of
 		Right r -> r
-		Left _ -> error $ "failed to compile regex: " ++ regex
+		Left _ -> giveup $ "failed to compile regex: " ++ regex
   where
 	regex = '^':wildToRegex glob
 	casesentitive = case globcase of
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index 21171b6fb..118515222 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -253,7 +253,7 @@ genRandom cmd highQuality size = checksize <$> readStrict cmd params
 			then s
 			else shortread len
 
-	shortread got = error $ unwords
+	shortread got = giveup $ unwords
 		[ "Not enough bytes returned from gpg", show params
 		, "(got", show got, "; expected", show expectedlength, ")"
 		]
diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index 6a3e86a3f..bc8ddfe6b 100644
--- a/Utility/LockFile/PidLock.hs
+++ b/Utility/LockFile/PidLock.hs
@@ -210,7 +210,7 @@ waitLock (Seconds timeout) lockfile = go timeout
 			=<< tryLock lockfile
 		| otherwise = do
 			hPutStrLn stderr $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile
-			error $ "Gave up waiting for possibly stale pid lock file " ++ lockfile
+			giveup $ "Gave up waiting for possibly stale pid lock file " ++ lockfile
 
 dropLock :: LockHandle -> IO ()
 dropLock (LockHandle lockfile _ sidelock) = do
diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs
index 433b7c679..27d34b592 100644
--- a/Utility/Lsof.hs
+++ b/Utility/Lsof.hs
@@ -47,9 +47,8 @@ queryDir path = query ["+d", path]
  -}
 query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)]
 query opts =
-	withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do
-		fileEncoding h
-		parse <$> hGetContentsStrict h
+	withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $
+		parse <$$> hGetContentsStrict
   where
 	p = proc "lsof" ("-F0can" : opts)
 
diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs
new file mode 100644
index 000000000..e217dcdca
--- /dev/null
+++ b/Utility/MagicWormhole.hs
@@ -0,0 +1,158 @@
+{- Magic Wormhole integration
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.MagicWormhole (
+	Code,
+	mkCode,
+	toCode,
+	fromCode,
+	validCode,
+	CodeObserver,
+	CodeProducer,
+	mkCodeObserver,
+	mkCodeProducer,
+	waitCode,
+	sendCode,
+	WormHoleParams,
+	sendFile,
+	receiveFile,
+	isInstalled,
+) where
+
+import Utility.Process
+import Utility.SafeCommand
+import Utility.Monad
+import Utility.Misc
+import Utility.Env
+import Utility.Path
+
+import System.IO
+import System.Exit
+import Control.Concurrent
+import Control.Exception
+import Data.Char
+import Data.List
+
+-- | A Magic Wormhole code.
+newtype Code = Code String
+	deriving (Eq, Show)
+
+-- | Smart constructor for Code
+mkCode :: String -> Maybe Code
+mkCode s
+	| validCode s = Just (Code s)
+	| otherwise = Nothing
+
+-- | Tries to fix up some common mistakes in a homan-entered code.
+toCode :: String -> Maybe Code
+toCode s = mkCode $ intercalate "-" $ words s
+
+fromCode :: Code -> String
+fromCode (Code s) = s
+
+-- | Codes have the form number-word-word and may contain 2 or more words.
+validCode :: String -> Bool
+validCode s = 
+	let (n, r) = separate (== '-') s
+	    (w1, w2) = separate (== '-') r
+	in and
+		[ not (null n)
+		, all isDigit n
+		, not (null w1)
+		, not (null w2)
+		, not $ any isSpace s
+		]
+
+newtype CodeObserver = CodeObserver (MVar Code)
+
+newtype CodeProducer = CodeProducer (MVar Code)
+
+mkCodeObserver :: IO CodeObserver
+mkCodeObserver = CodeObserver <$> newEmptyMVar
+
+mkCodeProducer :: IO CodeProducer
+mkCodeProducer = CodeProducer <$> newEmptyMVar
+
+waitCode :: CodeObserver -> IO Code
+waitCode (CodeObserver o) = takeMVar o
+
+sendCode :: CodeProducer -> Code -> IO ()
+sendCode (CodeProducer p) = putMVar p
+
+type WormHoleParams = [CommandParam]
+
+-- | Sends a file. Once the send is underway, and the Code has been
+-- generated, it will be sent to the CodeObserver. (This may not happen,
+-- eg if there's a network problem).
+--
+-- Currently this has to parse the output of wormhole to find the code.
+-- To make this as robust as possible, avoids looking for any particular
+-- output strings, and only looks for the form of a wormhole code
+-- (number-word-word). 
+--
+-- Note that, if the filename looks like "foo 1-wormhole-code bar", when
+-- that is output by wormhole, it will look like it's output a wormhole code.
+--
+-- A request to make the code available in machine-parsable form is here:
+-- https://github.com/warner/magic-wormhole/issues/104
+sendFile :: FilePath -> CodeObserver -> WormHoleParams -> IO Bool
+sendFile f (CodeObserver observer) ps = do
+	-- Work around stupid stdout buffering behavior of python.
+	-- See https://github.com/warner/magic-wormhole/issues/108
+	environ <- addEntry "PYTHONUNBUFFERED" "1" <$> getEnvironment
+	runWormHoleProcess p { env = Just environ} $ \_hin hout ->
+		findcode =<< words <$> hGetContents hout
+  where
+	p = wormHoleProcess (Param "send" : ps ++ [File f])
+	findcode [] = return False
+	findcode (w:ws) = case mkCode w of
+		Just code -> do
+			putMVar observer code
+			return True
+		Nothing -> findcode ws
+
+-- | Receives a file. Once the receive is under way, the Code will be
+-- read from the CodeProducer, and fed to wormhole on stdin.
+receiveFile :: FilePath -> CodeProducer -> WormHoleParams -> IO Bool
+receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout -> do
+	Code c <- takeMVar producer
+	hPutStrLn hin c
+	hFlush hin
+	return True
+  where
+	p = wormHoleProcess $
+		[ Param "receive"
+		, Param "--accept-file"
+		, Param "--output-file"
+		, File f
+		] ++ ps
+
+wormHoleProcess :: WormHoleParams -> CreateProcess
+wormHoleProcess = proc "wormhole" . toCommand
+
+runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> IO Bool) ->  IO Bool
+runWormHoleProcess p consumer = 
+	bracketOnError setup (\v -> cleanup v <&&> return False) go
+  where
+	setup = do
+		(Just hin, Just hout, Nothing, pid)
+			<- createProcess p
+				{ std_in = CreatePipe
+				, std_out = CreatePipe
+				}
+		return (hin, hout, pid)
+	cleanup (hin, hout, pid) = do
+		r <- waitForProcess pid
+		hClose hin
+		hClose hout
+		return $ case r of
+			ExitSuccess -> True
+			ExitFailure _ -> False
+	go h@(hin, hout, _) = consumer hin hout <&&> cleanup h
+
+isInstalled :: IO Bool
+isInstalled = inPath "wormhole"
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index 440aa3f07..e21e18cf1 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -1,11 +1,11 @@
 {- Metered IO and actions
  -
- - Copyright 2012-2106 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2016 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
 
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeSynonymInstances, BangPatterns #-}
 
 module Utility.Metered where
 
@@ -85,12 +85,15 @@ streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h
 
 {- Writes a ByteString to a Handle, updating a meter as it's written. -}
 meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO ()
-meteredWrite meterupdate h = go zeroBytesProcessed . L.toChunks 
+meteredWrite meterupdate h = void . meteredWrite' meterupdate h
+
+meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed
+meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks 
   where
-	go _ [] = return ()
+	go sofar [] = return sofar
 	go sofar (c:cs) = do
 		S.hPut h c
-		let sofar' = addBytesProcessed sofar $ S.length c
+		let !sofar' = addBytesProcessed sofar $ S.length c
 		meterupdate sofar'
 		go sofar' cs
 
@@ -112,30 +115,30 @@ offsetMeterUpdate base offset = \n -> base (offset `addBytesProcessed` n)
  - meter updates, so use caution.
  -}
 hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString
-hGetContentsMetered h = hGetUntilMetered h (const True)
+hGetContentsMetered h = hGetMetered h Nothing
 
-{- Reads from the Handle, updating the meter after each chunk.
+{- Reads from the Handle, updating the meter after each chunk is read.
+ -
+ - Stops at EOF, or when the requested number of bytes have been read.
+ - Closes the Handle at EOF, but otherwise leaves it open.
  -
  - Note that the meter update is run in unsafeInterleaveIO, which means that
  - it can be run at any time. It's even possible for updates to run out
  - of order, as different parts of the ByteString are consumed.
- -
- - Stops at EOF, or when keepgoing evaluates to False.
- - Closes the Handle at EOF, but otherwise leaves it open.
  -}
-hGetUntilMetered :: Handle -> (Integer -> Bool) -> MeterUpdate -> IO L.ByteString
-hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed
+hGetMetered :: Handle -> Maybe Integer -> MeterUpdate -> IO L.ByteString
+hGetMetered h wantsize meterupdate = lazyRead zeroBytesProcessed
   where
 	lazyRead sofar = unsafeInterleaveIO $ loop sofar
 
 	loop sofar = do
-		c <- S.hGet h defaultChunkSize
+		c <- S.hGet h (nextchunksize (fromBytesProcessed sofar))
 		if S.null c
 			then do
 				hClose h
 				return $ L.empty
 			else do
-				let sofar' = addBytesProcessed sofar (S.length c)
+				let !sofar' = addBytesProcessed sofar (S.length c)
 				meterupdate sofar'
 				if keepgoing (fromBytesProcessed sofar')
 					then do
@@ -145,6 +148,18 @@ hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed
 						cs <- lazyRead sofar'
 						return $ L.append (L.fromChunks [c]) cs
 					else return $ L.fromChunks [c]
+	
+	keepgoing n = case wantsize of
+		Nothing -> True
+		Just sz -> n < sz
+	
+	nextchunksize n = case wantsize of
+		Nothing -> defaultChunkSize
+		Just sz -> 
+			let togo = sz - n
+			in if togo < toInteger defaultChunkSize
+				then fromIntegral togo
+				else defaultChunkSize
 
 {- Same default chunk size Lazy ByteStrings use. -}
 defaultChunkSize :: Int
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index ebb42576b..4498c0a03 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -10,9 +10,6 @@
 
 module Utility.Misc where
 
-import Utility.FileSystemEncoding
-import Utility.Monad
-
 import System.IO
 import Control.Monad
 import Foreign
@@ -35,20 +32,6 @@ hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s
 readFileStrict :: FilePath -> IO String
 readFileStrict = readFile >=> \s -> length s `seq` return s
 
-{-  Reads a file strictly, and using the FileSystemEncoding, so it will
- -  never crash on a badly encoded file. -}
-readFileStrictAnyEncoding :: FilePath -> IO String
-readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do
-	fileEncoding h
-	hClose h `after` hGetContentsStrict h
-
-{- Writes a file, using the FileSystemEncoding so it will never crash
- - on a badly encoded content string. -}
-writeFileAnyEncoding :: FilePath -> String -> IO ()
-writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do
-	fileEncoding h
-	hPutStr h content
-
 {- Like break, but the item matching the condition is not included
  - in the second result list.
  -
diff --git a/Utility/Quvi.hs b/Utility/Quvi.hs
index 09f74968b..d33d79bb8 100644
--- a/Utility/Quvi.hs
+++ b/Utility/Quvi.hs
@@ -79,8 +79,8 @@ forceQuery :: Query (Maybe Page)
 forceQuery v ps url = query' v ps url `catchNonAsync` onerr
   where
 	onerr e = ifM (inPath "quvi")
-		( error ("quvi failed: " ++ show e)
-		, error "quvi is not installed"
+		( giveup ("quvi failed: " ++ show e)
+		, giveup "quvi is not installed"
 		)
 
 {- Returns Nothing if the page is not a video page, or quvi is not
@@ -153,11 +153,8 @@ httponly :: QuviParams
 httponly Quvi04 = [Param "-c", Param "http"]
 httponly _ = [] -- No way to do it with 0.9?
 
-{- Both versions of quvi will output utf-8 encoded data even when
- - the locale doesn't support it. -}
 readQuvi :: [String] -> IO String
 readQuvi ps = withHandle StdoutHandle createProcessSuccess p $ \h -> do
-	fileEncoding h
 	r <- hGetContentsStrict h
 	hClose h
 	return r
diff --git a/Utility/Shell.hs b/Utility/Shell.hs
index 860ee11dd..7adb65128 100644
--- a/Utility/Shell.hs
+++ b/Utility/Shell.hs
@@ -48,9 +48,8 @@ findShellCommand f = do
 #ifndef mingw32_HOST_OS
 	defcmd
 #else
-	l <- catchDefaultIO Nothing $ withFile f ReadMode $ \h -> do
-		fileEncoding h
-		headMaybe . lines <$> hGetContents h
+	l <- catchDefaultIO Nothing $ withFile f ReadMode $
+		headMaybe . lines <$$> hGetContents h
 	case l of
 		Just ('#':'!':rest) -> case words rest of
 			[] -> defcmd
diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs
index 708f590e7..7ab3c8c77 100644
--- a/Utility/SimpleProtocol.hs
+++ b/Utility/SimpleProtocol.hs
@@ -1,10 +1,13 @@
 {- Simple line-based protocols.
  -
- - Copyright 2013-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2016 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
 
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Utility.SimpleProtocol (
 	Sendable(..),
 	Receivable(..),
@@ -17,10 +20,12 @@ module Utility.SimpleProtocol (
 	parse2,
 	parse3,
 	dupIoHandles,
+	getProtocolLine,
 ) where
 
 import Data.Char
 import GHC.IO.Handle
+import System.Exit (ExitCode(..))
 
 import Common
 
@@ -44,6 +49,16 @@ class Serializable a where
 	serialize :: a -> String
 	deserialize :: String -> Maybe a
 
+instance Serializable [Char] where
+	serialize = id
+	deserialize = Just
+
+instance Serializable ExitCode where
+	serialize ExitSuccess = "0"
+	serialize (ExitFailure n) = show n
+	deserialize "0" = Just ExitSuccess
+	deserialize s = ExitFailure <$> readish s
+
 {- Parsing the parameters of messages. Using the right parseN ensures
  - that the string is split into exactly the requested number of words,
  - which allows the last parameter of a message to contain arbitrary
@@ -88,3 +103,26 @@ dupIoHandles = do
 	nullh `hDuplicateTo` stdin
 	stderr `hDuplicateTo` stdout
 	return (readh, writeh)
+
+{- Reads a line, but to avoid super-long lines eating memory, returns
+ - Nothing if 32 kb have been read without seeing a '\n'
+ -
+ - If there is a '\r' before the '\n', it is removed, to support
+ - systems using "\r\n" at ends of lines 
+ -
+ - This implementation is not super efficient, but as long as the Handle
+ - supports buffering, it avoids reading a character at a time at the
+ - syscall level.
+ -}
+getProtocolLine :: Handle -> IO (Maybe String)
+getProtocolLine h = go (32768 :: Int) []
+  where
+	go 0 _ = return Nothing
+	go n l = do
+		c <- hGetChar h
+		if c == '\n'
+			then return $ Just $ reverse $ 
+				case l of
+					('\r':rest) -> rest
+					_ -> l
+			else go (n-1) (c:l)
diff --git a/Utility/Su.hs b/Utility/Su.hs
new file mode 100644
index 000000000..44a95c39f
--- /dev/null
+++ b/Utility/Su.hs
@@ -0,0 +1,53 @@
+{- su to root
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.Su where
+
+import Common
+import Utility.Env
+
+import System.Posix.Terminal
+
+-- Runs a command as root, fairly portably.
+--
+-- Does not use sudo commands if something else is available, because
+-- the user may not be in sudoers and we couldn't differentiate between
+-- that and the command failing. Although, some commands like gksu
+-- decide based on the system's configuration whether sudo should be used.
+runAsRoot :: String -> [CommandParam] -> IO Bool
+runAsRoot cmd ps = go =<< firstM (inPath . fst) =<< selectcmds
+  where
+	go Nothing = return False
+	go (Just (cmd', ps')) = boolSystem cmd' ps'
+
+	selectcmds = ifM (inx <||> (not <$> atconsole))
+		( return (graphicalcmds ++ consolecmds)
+		, return consolecmds
+		)
+	
+	inx = isJust <$> getEnv "DISPLAY"
+	atconsole = queryTerminal stdInput
+
+	-- These will only work when the user is logged into a desktop.
+	graphicalcmds =
+		[ ("gksu", [Param shellcmd])
+		, ("kdesu", [Param shellcmd])
+		-- Available in Debian's menu package; knows about lots of
+		-- ways to gain root.
+		, ("su-to-root", [Param "-X", Param "-c", Param shellcmd])
+		-- OSX native way to run a command as root, prompts in GUI
+		, ("osascript", [Param "-e", Param ("do shell script \"" ++ shellcmd ++ "\" with administrator privileges")])
+		]
+	
+	-- These will only work when run in a console.
+	consolecmds = 
+		[ ("su", [Param "-c", Param shellcmd])
+		, ("sudo", [Param cmd] ++ ps)
+		, ("su-to-root", [Param "-c", Param shellcmd])
+		]
+	
+	shellcmd = unwords $ map shellEscape (cmd:toCommand ps)
diff --git a/Utility/SystemDirectory.hs b/Utility/SystemDirectory.hs
index 3dd44d199..b9040fe13 100644
--- a/Utility/SystemDirectory.hs
+++ b/Utility/SystemDirectory.hs
@@ -13,4 +13,4 @@ module Utility.SystemDirectory (
 	module System.Directory
 ) where
 
-import System.Directory hiding (isSymbolicLink)
+import System.Directory hiding (isSymbolicLink, getFileSize)
diff --git a/Utility/Tor.hs b/Utility/Tor.hs
new file mode 100644
index 000000000..4e7c0ef43
--- /dev/null
+++ b/Utility/Tor.hs
@@ -0,0 +1,163 @@
+{- tor interface
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Tor where
+
+import Common
+import Utility.ThreadScheduler
+import Utility.FileMode
+
+import System.PosixCompat.Types
+import Data.Char
+import Network.Socket
+import Network.Socks5
+import qualified Data.ByteString.UTF8 as BU8
+import qualified System.Random as R
+
+type OnionPort = Int
+
+newtype OnionAddress = OnionAddress String
+	deriving (Show, Eq)
+
+type OnionSocket = FilePath
+
+-- | A unique identifier for a hidden service.
+type UniqueIdent = String
+
+-- | Name of application that is providing a hidden service.
+type AppName = String
+
+connectHiddenService :: OnionAddress -> OnionPort -> IO Socket
+connectHiddenService (OnionAddress address) port = do
+	(s, _) <- socksConnect torsockconf socksaddr
+	return s
+  where
+	torsocksport = 9050
+	torsockconf = defaultSocksConf "127.0.0.1" torsocksport
+	socksdomain = SocksAddrDomainName (BU8.fromString address)
+	socksaddr = SocksAddress socksdomain (fromIntegral port)
+
+-- | Adds a hidden service connecting to localhost, using some kind
+-- of unique identifier.
+--
+-- This will only work if run as root, and tor has to already be running.
+--
+-- Picks a random high port number for the hidden service that is not
+-- used by any other hidden service. Returns the hidden service's
+-- onion address, port, and the unix socket file to use.
+-- 
+-- If there is already a hidden service for the specified unique
+-- identifier, returns its information without making any changes.
+addHiddenService :: AppName -> UserID -> UniqueIdent -> IO (OnionAddress, OnionPort)
+addHiddenService appname uid ident = do
+	prepHiddenServiceSocketDir appname uid ident
+	ls <- lines <$> readFile torrc
+	let portssocks = mapMaybe (parseportsock . separate isSpace) ls
+	case filter (\(_, s) -> s == sockfile) portssocks of
+		((p, _s):_) -> waithiddenservice 1 p
+		_ -> do
+			highports <- R.getStdRandom mkhighports
+			let newport = Prelude.head $
+				filter (`notElem` map fst portssocks) highports
+			writeFile torrc $ unlines $
+				ls ++
+				[ ""
+				, "HiddenServiceDir " ++ hiddenServiceDir appname uid ident
+				, "HiddenServicePort " ++ show newport ++ 
+					" unix:" ++ sockfile
+				]
+			-- Reload tor, so it will see the new hidden
+			-- service and generate the hostname file for it.
+			reloaded <- anyM (uncurry boolSystem)
+				[ ("systemctl", [Param "reload", Param "tor"])
+				, ("service", [Param "tor", Param "reload"])
+				]
+			unless reloaded $
+				giveup "failed to reload tor, perhaps the tor service is not running"
+			waithiddenservice 120 newport
+  where
+	parseportsock ("HiddenServicePort", l) = do
+		p <- readish $ takeWhile (not . isSpace) l
+		return (p, drop 1 (dropWhile (/= ':') l))
+	parseportsock _ = Nothing
+	
+	sockfile = hiddenServiceSocketFile appname uid ident
+
+	-- An infinite random list of high ports.
+	mkhighports g = 
+		let (g1, g2) = R.split g
+		in (R.randomRs (1025, 65534) g1, g2)
+
+	waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort)
+	waithiddenservice 0 _ = giveup "tor failed to create hidden service, perhaps the tor service is not running"
+	waithiddenservice n p = do
+		v <- tryIO $ readFile $ hiddenServiceHostnameFile appname uid ident
+		case v of
+			Right s | ".onion\n" `isSuffixOf` s ->
+				return (OnionAddress (takeWhile (/= '\n') s), p)
+			_ -> do
+				threadDelaySeconds (Seconds 1)
+				waithiddenservice (n-1) p
+
+-- | A hidden service directory to use.
+--
+-- Has to be inside the torLibDir so tor can create it.
+--
+-- Has to end with "uid_ident" so getHiddenServiceSocketFile can find it.
+hiddenServiceDir :: AppName -> UserID -> UniqueIdent -> FilePath
+hiddenServiceDir appname uid ident = torLibDir </> appname ++ "_" ++ show uid ++ "_" ++ ident
+
+hiddenServiceHostnameFile :: AppName -> UserID -> UniqueIdent -> FilePath
+hiddenServiceHostnameFile appname uid ident = hiddenServiceDir appname uid ident </> "hostname"
+
+-- | Location of the socket for a hidden service.
+--
+-- This has to be a location that tor can read from, and that the user
+-- can write to. Since torLibDir is locked down, it can't go in there.
+--
+-- Note that some unix systems limit socket paths to 92 bytes long.
+-- That should not be a problem if the UniqueIdent is around the length of
+-- a UUID, and the AppName is short.
+hiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> FilePath
+hiddenServiceSocketFile appname uid ident = varLibDir </> appname </> show uid ++ "_" ++ ident </> "s"
+
+-- | Parse torrc, to get the socket file used for a hidden service with
+-- the specified UniqueIdent.
+getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe FilePath)
+getHiddenServiceSocketFile _appname uid ident = 
+	parse . map words . lines <$> catchDefaultIO "" (readFile torrc)
+  where
+	parse [] = Nothing
+	parse (("HiddenServiceDir":hsdir:[]):("HiddenServicePort":_hsport:hsaddr:[]):rest)
+		| "unix:" `isPrefixOf` hsaddr && hasident hsdir =
+			Just (drop (length "unix:") hsaddr)
+		| otherwise = parse rest
+	parse (_:rest) = parse rest
+
+	-- Don't look for AppName in the hsdir, because it didn't used to
+	-- be included.
+	hasident hsdir = (show uid ++ "_" ++ ident) `isSuffixOf` takeFileName hsdir
+
+-- | Sets up the directory for the socketFile, with appropriate
+-- permissions. Must run as root.
+prepHiddenServiceSocketDir :: AppName -> UserID -> UniqueIdent -> IO ()
+prepHiddenServiceSocketDir appname uid ident = do
+	createDirectoryIfMissing True d
+	setOwnerAndGroup d uid (-1)
+	modifyFileMode d $
+		addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode]
+  where
+	d = takeDirectory $ hiddenServiceSocketFile appname uid ident
+
+torrc :: FilePath
+torrc = "/etc/tor/torrc"
+
+torLibDir :: FilePath
+torLibDir = "/var/lib/tor"
+
+varLibDir :: FilePath
+varLibDir = "/var/lib"
diff --git a/Utility/Url.hs b/Utility/Url.hs
index 9b68871dd..a4523d73f 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -303,7 +303,7 @@ download' quiet url file uo = do
 	 - it was asked to write to a file elsewhere. -}
 	go cmd opts = withTmpDir "downloadurl" $ \tmp -> do
 		absfile <- absPath file
-		let ps = addUserAgent uo $ reqParams uo++opts++[File absfile, File url]
+		let ps = addUserAgent uo $ opts++reqParams uo++[File absfile, File url]
 		boolSystem' cmd ps $ \p -> p { cwd = Just tmp }
 	
 	quietopt s
@@ -350,8 +350,16 @@ hUserAgent = "User-Agent"
  -
  - > catchJust (matchStatusCodeException (== notFound404))
  -}
+#if MIN_VERSION_http_client(0,5,0)
+matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException
+matchStatusCodeException want e@(HttpExceptionRequest _ (StatusCodeException r _))
+	| want (responseStatus r) = Just e
+	| otherwise = Nothing
+matchStatusCodeException _ _ = Nothing
+#else
 matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException
 matchStatusCodeException want e@(StatusCodeException s _ _)
 	| want s = Just e
 	| otherwise = Nothing
 matchStatusCodeException _ _ = Nothing
+#endif
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index ec0b0d0b2..dd66c331e 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -16,6 +16,7 @@ module Utility.UserInfo (
 
 import Utility.Env
 import Utility.Data
+import Utility.Exception
 
 import System.PosixCompat
 import Control.Applicative
@@ -25,7 +26,7 @@ import Prelude
  -
  - getpwent will fail on LDAP or NIS, so use HOME if set. -}
 myHomeDir :: IO FilePath
-myHomeDir = either error return =<< myVal env homeDirectory
+myHomeDir = either giveup return =<< myVal env homeDirectory
   where
 #ifndef mingw32_HOST_OS
 	env = ["HOME"]
diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs
index 63ca33520..a90772b10 100644
--- a/Utility/WebApp.hs
+++ b/Utility/WebApp.hs
@@ -12,7 +12,7 @@ module Utility.WebApp where
 import Common
 import Utility.Tmp
 import Utility.FileMode
-import Utility.Hash
+import Utility.AuthToken
 
 import qualified Yesod
 import qualified Network.Wai as Wai
@@ -23,7 +23,6 @@ import qualified Data.CaseInsensitive as CI
 import Network.Socket
 import "crypto-api" Crypto.Random
 import qualified Web.ClientSession as CS
-import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString as B
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
@@ -31,8 +30,6 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromText)
 import Blaze.ByteString.Builder (Builder)
 import Control.Arrow ((***))
 import Control.Concurrent
-import Data.SecureMem
-import Data.Byteable
 #ifdef __ANDROID__
 import Data.Endian
 #endif
@@ -159,24 +156,6 @@ webAppSessionBackend _ = do
 		Just . Yesod.clientSessionBackend key . fst
 			<$> Yesod.clientSessionDateCacher timeout
 
-type AuthToken = SecureMem
-
-toAuthToken :: T.Text -> AuthToken
-toAuthToken = secureMemFromByteString . TE.encodeUtf8
-
-fromAuthToken :: AuthToken -> T.Text
-fromAuthToken = TE.decodeLatin1 . toBytes
-
-{- Generates a random sha2_512 string, encapsulated in a SecureMem,
- - suitable to be used for an authentication secret. -}
-genAuthToken :: IO AuthToken
-genAuthToken = do
-	g <- newGenIO :: IO SystemRandom
-	return $
-		case genBytes 512 g of
-			Left e -> error $ "failed to generate auth token: " ++ show e
-			Right (s, _) -> toAuthToken $ T.pack $ show $ sha2_512 $ L.fromChunks [s]
-
 {- A Yesod isAuthorized method, which checks the auth cgi parameter
  - against a token extracted from the Yesod application.
  -
@@ -193,7 +172,7 @@ checkAuthToken extractAuthToken r predicate
 		webapp <- Yesod.getYesod
 		req <- Yesod.getRequest
 		let params = Yesod.reqGetParams req
-		if (toAuthToken <$> lookup "auth" params) == Just (extractAuthToken webapp)
+		if (toAuthToken =<< lookup "auth" params) == Just (extractAuthToken webapp)
 			then return Yesod.Authorized
 			else Yesod.sendResponseStatus unauthorized401 ()