packages feed

keysafe 0.20160914 → 0.20160922

raw patch · 34 files changed

+1005/−271 lines, 34 filesdep +exceptionsdep +unix-compat

Dependencies added: exceptions, unix-compat

Files

+ AutoStart.hs view
@@ -0,0 +1,42 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module AutoStart where++import Utility.FreeDesktop+import System.Info+import System.Environment+import System.Directory++installAutoStartFile :: IO ()+installAutoStartFile = go =<< autoStartFile+  where+	go (Just f) = case os of+		"linux" -> installFdoAutoStart f+		"freebsd" -> installFdoAutoStart f+		_ -> return ()+	go Nothing = return ()++isAutoStartFileInstalled :: IO Bool+isAutoStartFileInstalled = maybe (pure False) doesFileExist =<< autoStartFile++autoStartFile :: IO (Maybe FilePath)+autoStartFile = case os of+	"linux" -> Just . autoStartPath "keysafe" <$> userConfigDir+	_ -> return Nothing++installFdoAutoStart :: FilePath -> IO ()+installFdoAutoStart f = do+	command <- getExecutablePath+	writeDesktopMenuFile (fdoAutostart command) f++fdoAutostart :: FilePath -> DesktopEntry+fdoAutostart command = genDesktopEntry+        "Keysafe"+        "Autostart"+        False+        (command ++ " --autostart")+        Nothing+        []
+ BackupLog.hs view
@@ -0,0 +1,98 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE DeriveGeneric, BangPatterns #-}++module BackupLog where++import Types+import Types.Server+import Types.Cost+import Utility.UserInfo+import GHC.Generics+import Data.Time.Clock.POSIX+import Data.Aeson+import Data.Maybe+import System.FilePath+import System.Directory+import System.Posix.Files+import qualified Data.ByteString.Lazy as B++data BackupLog = BackupLog +	{ logDate :: POSIXTime+	, logEvent :: BackupEvent+	}+	deriving (Show, Generic)++instance ToJSON BackupLog+instance FromJSON BackupLog++-- | Log of a backup.+--+-- If an attacker cracks the user's system and finds this stored+-- on it, it should not help them recover keys from keysafe.+-- +-- That's why the Name used is not included; as knowing the name lets+-- an attacker download shards and start password cracking.+--+-- Including the password entropy does let an attacker avoid trying+-- weak passwords and go right to passwords that are strong enough, but+-- this should only half the password crack time at worst.+data BackupEvent +	= BackupSkipped SecretKeySource +	| BackupMade+		{ backupServers :: [ServerName]+		, backupSecretKeySource :: SecretKeySource+		, backupPasswordEntropy :: Int+		}+	deriving (Show, Generic)++matchesSecretKeySource :: SecretKeySource -> BackupLog -> Bool+matchesSecretKeySource a (BackupLog _ (BackupSkipped b)) = a == b+matchesSecretKeySource a (BackupLog _ (BackupMade { backupSecretKeySource = b })) = a == b++instance ToJSON BackupEvent+instance FromJSON BackupEvent++mkBackupLog :: BackupEvent -> IO BackupLog+mkBackupLog evt = BackupLog+	<$> getPOSIXTime+	<*> pure evt++backupMade :: [Server] -> SecretKeySource -> Entropy UnknownPassword -> BackupEvent+backupMade servers sks (Entropy n) = BackupMade+	{ backupServers = map serverName servers+	, backupSecretKeySource = sks+	, backupPasswordEntropy = n+	}++backupLogFile :: IO FilePath+backupLogFile = do+	home <- myHomeDir+	return $ home </> ".keysafe/backup.log"++readBackupLogs :: IO [BackupLog]+readBackupLogs = do+	f <- backupLogFile+	e <- doesFileExist f+	if e+		then fromMaybe [] . decode <$> B.readFile f+		else return []++storeBackupLog :: BackupLog -> IO ()+storeBackupLog r = do+	!rs <- readBackupLogs+	f <- backupLogFile+	let d = takeDirectory f+	createDirectoryIfMissing True d+	setFileMode d $+		ownerReadMode+			`unionFileModes` ownerWriteMode+			`unionFileModes` ownerExecuteMode+	setPermissions d +		$ setOwnerReadable True +			$ setOwnerWritable True +				$ setOwnerExecutable True emptyPermissions+	B.writeFile f $ encode (r:rs)
− BackupRecord.hs 
@@ -1,79 +0,0 @@-{- Copyright 2016 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--{-# LANGUAGE DeriveGeneric, BangPatterns #-}--module BackupRecord where--import Types-import Types.Cost-import Types.Server-import GHC.Generics-import Data.Time.Clock.POSIX-import Data.Aeson-import Data.Maybe-import System.FilePath-import System.Directory-import System.Posix.User-import System.Posix.Files-import qualified Data.ByteString.Lazy as B---- | Record of a backup.------ If an attacker cracks the user's system and finds this stored--- on it, it should not help them recover keys from keysafe.--- --- That's why the Name used is not included; as knowing the name lets--- an attacker download shards and start password cracking.------ Including the password entropy does let an attacker avoid trying--- weak passwords and go right to passwords that are strong enough, but--- this should only half the password crack time at worst.-data BackupRecord = BackupRecord-	{ backupDate :: POSIXTime-	, backupServers :: [HostName]-	, secretKeySource :: String-	, passwordEntropy :: Int-	} deriving (Show, Generic)---- BackupRecord is serialized as JSON.-instance ToJSON BackupRecord-instance FromJSON BackupRecord--mkBackupRecord :: [Server] -> SecretKeySource -> Entropy UnknownPassword -> IO BackupRecord-mkBackupRecord servers sks (Entropy n) = BackupRecord-	<$> getPOSIXTime-	<*> pure (map serverName servers)-	<*> pure (show sks)-	<*> pure n--backupRecordFile :: IO FilePath-backupRecordFile = do-	u <- getUserEntryForID =<< getEffectiveUserID-	return $ homeDirectory u </> ".keysafe/backup.log"--readBackupRecords :: IO [BackupRecord]-readBackupRecords = do-	f <- backupRecordFile-	e <- doesFileExist f-	if e-		then fromMaybe [] . decode <$> B.readFile f-		else return []--storeBackupRecord :: BackupRecord -> IO ()-storeBackupRecord r = do-	!rs <- readBackupRecords-	f <- backupRecordFile-	let d = takeDirectory f-	createDirectoryIfMissing True d-	setFileMode d $-		ownerReadMode-			`unionFileModes` ownerWriteMode-			`unionFileModes` ownerExecuteMode-	setPermissions d -		$ setOwnerReadable True -			$ setOwnerWritable True -				$ setOwnerExecutable True emptyPermissions-	B.writeFile f $ encode (r:rs)
Benchmark.hs view
@@ -14,6 +14,7 @@ import Cost import Serialization () import qualified Data.ByteString.UTF8 as BU8+import qualified Data.Text as T import qualified Crypto.Argon2 as Argon2 import Data.Time.Clock import Control.DeepSeq@@ -24,11 +25,8 @@ data BenchmarkResult t = BenchmarkResult { expectedBenchmark :: t, actualBenchmark :: t }  instance Show (BenchmarkResult (Cost op)) where-	show br = "   expected: " ++ showtime (expectedBenchmark br) ++ "s"-		++ "\tactual: " ++ showtime (actualBenchmark br) ++ "s"-	  where-		showtime (CPUCost (Seconds s) _) = -			show (fromRational s :: Double)+	show br = "   expected: " ++ show (expectedBenchmark br) ++ "s"+		++ "\tactual: " ++ show (actualBenchmark br) ++ "s"  benchmarkExpensiveHash :: Int -> ExpensiveHashTunable -> IO (BenchmarkResult (Cost CreationOp)) benchmarkExpensiveHash rounds tunables =@@ -44,10 +42,11 @@ 	forM_ [1..rounds] $ \n -> do 		-- Must vary the data being hashed to avoid laziness 		-- caching hash results.-		let base = BU8.fromString (show n)+		let base = T.pack (show n)+		let baseb = BU8.fromString (show n) 		let ExpensiveHash _ t = expensiveHash tunables 			(Salt (GpgKey (KeyId (base <> "dummy"))))-			(base <> "himom")+			(baseb <> "himom") 		t `deepseq` return () 	end <- getCurrentTime 	let diff = floor (end `diffUTCTime` start) :: Integer
CHANGELOG view
@@ -1,3 +1,23 @@+keysafe (0.20160922) unstable; urgency=medium++  * Keysafe now knows about 3 servers, although only 1 is currently in+    operation. It will queue uploads to the other 2 servers until+    they are added in a later keysafe release.+  * Added --autostart mode, and make both keysafe --backup and +    the Makefile install a FDO desktop autostart file to use it.+  * In --autostart mode, retry any queued uploads.+  * In --autostart mode, check for gpg keys that have not been+    backed up, and offer to back them up. Only ask once per key.+  * Changed format of ~/.keysafe/backup.log+  * Server: Reduce number of buckets in rate limiter, avoiding ones with very low+    proof of work.+  * Server: Make rate limiter adapt to ongoing load more quickly -- every 15+    minutes instead of every 60.+  * Server: Added --backup-server and --restore-server to aid in backing +    up keysafe servers with minimal information leakage.++ -- Joey Hess <id@joeyh.name>  Thu, 22 Sep 2016 15:10:56 -0400+ keysafe (0.20160914) unstable; urgency=medium    * Fix bug that prevented keysafe --server from running when there was no
CmdLine.hs view
@@ -12,6 +12,7 @@ import qualified Gpg import Options.Applicative import qualified Data.ByteString.UTF8 as BU8+import qualified Data.Text as T import System.Directory import Network.Wai.Handler.Warp (Port) @@ -28,7 +29,7 @@ 	, serverConfig :: ServerConfig 	} -data Mode = Backup | Restore | UploadQueued | Server | Chaff HostName | Benchmark | Test+data Mode = Backup | Restore | UploadQueued | AutoStart | Server | BackupServer FilePath | RestoreServer FilePath | Chaff HostName | Benchmark | Test 	deriving (Show)  data ServerConfig = ServerConfig@@ -39,7 +40,7 @@  parse :: Parser CmdLine parse = CmdLine-	<$> optional (backup <|> restore <|> uploadqueued <|> server <|> chaff <|> benchmark <|> test)+	<$> optional parseMode 	<*> optional (gpgswitch <|> fileswitch) 	<*> localstorageswitch 	<*> localstoragedirectoryopt@@ -48,38 +49,9 @@ 	<*> optional (ShareParams <$> totalobjects <*> neededobjects) 	<*> nameopt 	<*> othernameopt-	<*> serverconfig+	<*> parseServerConfig   where-	backup = flag' Backup-		( long "backup"-		<> help "Store a secret key in keysafe."-		)-	restore = flag' Restore-		( long "restore"-		<> help "Retrieve a secret key from keysafe."-		)-	uploadqueued = flag' UploadQueued-		( long "uploadqueued"-		<> help "Upload any data to servers that was queued by a previous --backup run."-		)-	server = flag' Server-		( long "server"-		<> help "Run as a keysafe server, accepting objects and storing them to ~/.keysafe/objects/local/"-		)-	chaff = Chaff <$> strOption-		( long "chaff"-		<> metavar "HOSTNAME"-		<> help "Upload random data to a keysafe server."-		)-	benchmark = flag' Benchmark-		( long "benchmark"-		<> help "Benchmark speed of keysafe's cryptographic primitives."-		)-	test = flag' Test-		( long "test"-		<> help "Run test suite."-		)-	gpgswitch = GpgKey . KeyId . BU8.fromString <$> strOption+	gpgswitch = GpgKey . KeyId . T.pack <$> strOption 		( long "gpgkeyid" 		<> metavar "KEYID" 		<> help "Specify keyid of gpg key to back up or restore. (When this option is used to back up a key, it must also be used at restore time.)"@@ -126,28 +98,76 @@ 		<> metavar "N" 		<> help "Specify other name used for key backup/restore, avoiding the usual prompt." 		)-	serverconfig = ServerConfig-		<$> option auto-			( long "port"-			<> metavar "P"-			<> value 80-			<> showDefault-			<> help "Port for server to listen on."-			)-		<*> option str-			( long "address"-			<> metavar "A"-			<> value "127.0.0.1"-			<> showDefault-			<> help "Address for server to bind to. (Use \"*\" to bind to all addresses.)"-			)-		<*> option auto-			( long "months-to-fill-half-disk"-			<> metavar "N"-			<> value 12-			<> showDefault-			<> help "Server rate-limits requests and requires proof of work, to avoid too many objects being stored. This is an lower bound on how long it could possibly take for half of the current disk space to be filled."-			)++parseMode :: Parser Mode+parseMode = +	flag' Backup+		( long "backup"+		<> help "Store a secret key in keysafe."+		)+	<|> flag' Restore+		( long "restore"+		<> help "Retrieve a secret key from keysafe."+		)+	<|> flag' UploadQueued+		( long "uploadqueued"+		<> help "Upload any data to servers that was queued by a previous --backup run."+		)+	<|> flag' AutoStart+		( long "autostart"+		<> help "Run automatically on login by desktop autostart file."+		)+	<|> flag' Server+		( long "server"+		<> help "Run as a keysafe server, accepting objects and storing them to ~/.keysafe/objects/local/"+		)+	<|> BackupServer <$> strOption+		( long "backup-server"+		<> metavar "BACKUPDIR"+		<> help "Run on a server, populates the directory with a gpg encrypted backup of all objects stored in the --store-directory. This is designed to be rsynced offsite (with --delete) to back up the a keysafe server with minimal information leakage."+		)+	<|> RestoreServer <$> strOption+		( long "restore-server"+		<> metavar "BACKUPDIR"+		<> help "Restore all objects present in the gpg-encrypted backups in the specified directory."+		)+	<|> Chaff <$> strOption+		( long "chaff"+		<> metavar "HOSTNAME"+		<> help "Upload random data to a keysafe server."+		)+	<|> flag' Benchmark+		( long "benchmark"+		<> help "Benchmark speed of keysafe's cryptographic primitives."+		)+	<|> flag' Test+		( long "test"+		<> help "Run test suite."+		)++parseServerConfig :: Parser ServerConfig+parseServerConfig = ServerConfig+	<$> option auto+		( long "port"+		<> metavar "P"+		<> value 80+		<> showDefault+		<> help "Port for server to listen on."+		)+	<*> option str+		( long "address"+		<> metavar "A"+		<> value "127.0.0.1"+		<> showDefault+		<> help "Address for server to bind to. (Use \"*\" to bind to all addresses.)"+		)+	<*> option auto+		( long "months-to-fill-half-disk"+		<> metavar "N"+		<> value 12+		<> showDefault+		<> help "Server rate-limits requests and requires proof of work, to avoid too many objects being stored. This is an lower bound on how long it could possibly take for half of the current disk space to be filled."+		)  get :: IO CmdLine get = execParser opts
Gpg.hs view
@@ -15,19 +15,20 @@ import System.Exit import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BU8+import qualified Data.Text as T  -- | Pick gpg secret key to back up. -- -- If there is only one gpg secret key, -- the choice is obvious. Otherwise prompt the user with a list. getKeyToBackup :: UI -> IO SecretKey-getKeyToBackup ui = go =<< Gpg.listSecretKeys+getKeyToBackup ui = go =<< listSecretKeys   where 	go [] = do 		showError ui "You have no gpg secret keys to back up." 		error "Aborting on no gpg secret keys."-	go [(_, kid)] = Gpg.getSecretKey kid-	go l = maybe (error "Canceled") Gpg.getSecretKey+	go [(_, kid)] = getSecretKey kid+	go l = maybe (error "Canceled") getSecretKey 		=<< promptKeyId ui "Pick gpg secret key" 			"Pick gpg secret key to back up:" l @@ -51,7 +52,7 @@ 		extract c (Just keyid) rest 	extract c k (_:rest) = 		extract c k rest-	mk (userid, keyid) = (Name (BU8.fromString userid), KeyId (BU8.fromString keyid))+	mk (userid, keyid) = (Name (BU8.fromString userid), KeyId (T.pack keyid))  getSecretKey :: KeyId -> IO SecretKey getSecretKey (KeyId kid) = do@@ -63,7 +64,7 @@ 		ExitSuccess -> return secretkey 		_ -> error "gpg --export-secret-key failed"   where-	ps = ["--batch", "--export-secret-key", BU8.toString kid]+	ps = ["--batch", "--export-secret-key", T.unpack kid]  writeSecretKey :: SecretKey -> IO () writeSecretKey (SecretKey b) = do
HTTP/Client.hs view
@@ -64,23 +64,25 @@ 					(Just $ genProofOfWork req p) 					(Seconds timeleft - generationTime req) +-- A new Manager is allocated for each request, rather than reusing+-- any connection. This is a feature; it makes correlation attacks+-- harder because the server can't tell if two connections+-- accessing different objects came from the same user, except by+-- comparing IP addresses (which are masked somewhat by using tor). serverRequest' 	:: Server 	-> (Manager -> BaseUrl -> ExceptT ServantError IO r) 	-> IO (Either String r)-serverRequest' srv a = do-	-- A new Manager is allocated for each request, rather than reusing-	-- any connection. This is a feature; it makes correlation attacks-	-- harder because the server can't tell if two connections-	-- accessing different objects came from the same user, except by-	-- comparing IP addresses (which are masked somewhat by using tor).-	manager <- torableManager-	res <- runExceptT $ a manager url-	return $ case res of-		Left err -> Left $ "server failure: " ++ show err-		Right r -> Right r+serverRequest' srv a = go Nothing (serverUrls srv)   where-	url = serverUrl srv+	go lasterr [] = return $ Left $+		maybe "no available servers" (\err -> "server failure: " ++ show err) lasterr+	go _ (url:urls) = do+		manager <- torableManager+		res <- runExceptT $ a manager url+		case res of+			Left err -> go (Just err) urls+			Right r -> return (Right r)  -- | HTTP Manager supporting tor .onion and regular hosts torableManager :: IO Manager@@ -94,7 +96,7 @@ 			regular <- managerRawConnection defaultManagerSettings 			regular addr host port -torConnection :: HostName -> Port -> IO Connection+torConnection :: String -> Port -> IO Connection torConnection onionaddress p = do 	(socket, _) <- socksConnect torsockconf socksaddr 	socketConnection socket 8192
HTTP/ProofOfWork.hs view
@@ -86,7 +86,7 @@  mkProofOfWorkRequirement :: Seconds -> Maybe (RequestID -> ProofOfWorkRequirement) mkProofOfWorkRequirement (Seconds n)-	| lz < 1 = Nothing+	| lz < 1 || n <= 1 = Nothing 	| otherwise = Just $ ProofOfWorkRequirement lz its   where 	lz = floor (logBase 2 (fromRational (max 1 (n / s))) :: Double)
HTTP/RateLimit.hs view
@@ -392,14 +392,14 @@ 	delay (1000000 * intervalsecs) 	checkRequestRate cfg storedir ratelimiter logger intervalsecs   where-	intervalsecs = 60*60+	intervalsecs = 60*15  checkRequestRate :: ServerConfig -> Maybe LocalStorageDirectory -> RateLimiter -> Logger -> Integer -> IO () checkRequestRate cfg storedir ratelimiter logger intervalsecs = do 	let storesize = maximum knownObjectSizes 	n <- liftIO $ atomically $ swapTMVar (requestCounter ratelimiter) 0 	let maxstoredinterval = n * fromIntegral storesize-	let maxstoredthismonth = maxstoredinterval * (intervalsecs `div` (60*60)) * 24 * 31+	let maxstoredthismonth = maxstoredinterval * (intervalsecs * 24*31 `div` (60*60)) 	freespace <- diskFree <$> localDiskUsage storedir 	let target = monthsToFillHalfDisk cfg 	let estimate = if maxstoredthismonth <= 0 @@ -407,7 +407,7 @@ 		else freespace `div` maxstoredthismonth `div` 2 	logStdout logger $ unlines 		[ "rate limit check"-		, "  free disk space:" ++ showBytes freespace+		, "  free disk space: " ++ showBytes freespace 		, "  number of requests since last check: " ++ show n 		, "  estimated max incoming data in the next month: " ++ showBytes maxstoredthismonth 		, "  estimate min " ++ show estimate ++ " months to fill half of disk"
HTTP/Server.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -module HTTP.Server (runServer) where+module HTTP.Server (runServer, serverStorage) where  import HTTP import HTTP.ProofOfWork@@ -29,7 +29,7 @@  data ServerState = ServerState 	{ obscurerRequest :: TMVar ()-	, storageDirectory :: Maybe LocalStorageDirectory+	, storage :: Storage 	, rateLimiter :: RateLimiter 	, logger :: Logger 	}@@ -39,7 +39,7 @@ 	l <- newLogger 	ServerState 		<$> newEmptyTMVarIO-		<*> pure d+		<*> pure (serverStorage d) 		<*> newRateLimiter cfg d l 		<*> pure l @@ -52,8 +52,8 @@ 	settings = setHost host $ setPort (serverPort cfg) $ defaultSettings  	host = fromString (serverAddress cfg) -serverStorage :: ServerState -> Storage-serverStorage st = localStorage (storageDir $ storageDirectory st) "server"+serverStorage :: Maybe LocalStorageDirectory -> Storage+serverStorage d = localStorage (storageDir d) "server"  app :: ServerState -> Application app st = serve userAPI (server st)@@ -72,7 +72,7 @@  getObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> Handler (POWGuarded StorableObject) getObject st i pow = rateLimit (rateLimiter st) (logger st) pow i $ do-	r <- liftIO $ retrieveShare (serverStorage st) dummyShareNum i+	r <- liftIO $ retrieveShare (storage st) dummyShareNum i 	liftIO $ requestObscure st 	case r of 		RetrieveSuccess (Share _n o) -> return o@@ -82,7 +82,7 @@ putObject st i pow o = rateLimit (rateLimiter st) (logger st) pow i $ do 	if validObjectsize o 		then do-			r <- liftIO $ storeShare (serverStorage st) i (Share dummyShareNum o)+			r <- liftIO $ storeShare (storage st) i (Share dummyShareNum o) 			liftIO $ requestObscure st 			return r 		else return $ StoreFailure "invalid object size"@@ -94,7 +94,7 @@  countObjects :: ServerState -> Maybe ProofOfWork -> Handler (POWGuarded CountResult) countObjects st pow = rateLimit (rateLimiter st) (logger st) pow NoPOWIdent $-	liftIO $ countShares $ serverStorage st+	liftIO $ countShares $ storage st  -- | 1 is a dummy value; the server does not know the actual share numbers. dummyShareNum :: ShareNum@@ -105,7 +105,7 @@ -- the thread runs a maximum of once per half-hour. obscurerThread :: ServerState -> IO () obscurerThread st = do-	_ <- obscureShares (serverStorage st)+	_ <- obscureShares (storage st) 	logStdout (logger st) "obscured shares" 	delay (1000000*60*30) 	_ <- atomically $ takeTMVar (obscurerRequest st)
INSTALL view
@@ -18,7 +18,7 @@ ## System-wide installation  This installs keysafe in /usr/bin, and includes the man page, -desktop file, systemd service file, etc.+desktop file, autostart file, systemd service file, etc.  Start by installing the dependencies as shown in Quick installation.
Makefile view
@@ -30,3 +30,7 @@ 	install -m 0644 keysafe.service $(PREFIX)/lib/systemd/system/keysafe.service 	install -d $(PREFIX)/usr/share/applications/ 	install -m 0644 keysafe.desktop $(PREFIX)/usr/share/applications/keysafe.desktop+	install -d $(PREFIX)/etc/xdg/autostart/+	install -m 0644 keysafe.autostart $(PREFIX)/etc/xdg/autostart/keysafe.desktop++.PHONY: keysafe
Serialization.hs view
@@ -12,6 +12,7 @@ import Raaz.Core.Encode import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BU8+import qualified Data.Text as T import Data.Monoid import Data.Word @@ -19,7 +20,7 @@ -- For example "gpg C910D9222512E3C7", or "file path". instance Encodable SecretKeySource where 	toByteString (GpgKey (KeyId b)) =-		"gpg" <> B.singleton sepChar <> b+		"gpg" <> B.singleton sepChar <> BU8.fromString (T.unpack b) 	toByteString (KeyFile f) = 		"file" <> B.singleton sepChar <> BU8.fromString f 	fromByteString b = case B.break (== sepChar) b of@@ -28,7 +29,7 @@ 			| otherwise ->  				let i = B.drop 1 rest 				in case t of-					"gpg" -> Just $ GpgKey (KeyId i)+					"gpg" -> Just $ GpgKey (KeyId (T.pack (BU8.toString i))) 					"file" -> Just $ KeyFile (BU8.toString i) 					_ -> Nothing
+ ServerBackup.hs view
@@ -0,0 +1,62 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module ServerBackup where++import Storage+import Storage.Local+import HTTP.Server+import System.Process+import System.FilePath+import System.Directory+import Data.List+import Control.Monad+import Data.Time.Clock.POSIX++-- | Storing all shards in one gpg encrypted file avoids a problem with+-- modern incremental backup programs such as obnam: Access to an obnam+-- repository allows one to see the date when a chunk first enters the+-- repository, which can allow dating when objects were first stored+-- in keysafe, and so help in a correlation attack.+--+-- Of course, it's not at all efficient for offsite backups!+backupServer :: Maybe LocalStorageDirectory -> FilePath -> IO ()+backupServer lsd d = do+	let storage = serverStorage lsd+	_ <- obscureShares storage+	topdir <- storageTopDir lsd+	createDirectoryIfMissing True d+	dest <- backupFile d <$> getPOSIXTime+	callCommand ("tar -C " ++ topdir ++ " -c . | gpg --encrypt --default-recipient-self > " ++ dest)+	-- Keep the past 7 backup files, in case an object file somehow+	-- gets deleted, this avoids the backup losing it too.+	-- These backup files can be used to determine eg, what day+	-- chunks were uploaded to the server, which is why only a few +	-- are kept.+	pruneOldBackups d 7++restoreServer :: Maybe LocalStorageDirectory -> FilePath -> IO ()+restoreServer lsd d = do+	topdir <- storageTopDir lsd+	bs <- findBackups d+	forM_ bs $ \b ->+		callCommand ("gpg --decrypt " ++ b ++ " | tar -C " ++ topdir ++ " -x")+	let storage = serverStorage lsd+	_ <- obscureShares storage+	return ()++findBackups :: FilePath -> IO [FilePath]+findBackups d = map (d </>) . filter isBackup <$> getDirectoryContents d++pruneOldBackups :: FilePath -> Int -> IO ()+pruneOldBackups d keep = do+	fs <- findBackups d+	mapM_ removeFile (drop keep (reverse (sort fs)))++isBackup :: FilePath -> Bool+isBackup f = "keysafe-backup" `isPrefixOf` f++backupFile :: FilePath -> POSIXTime -> FilePath+backupFile d t = d </> "keysafe-backup." ++ show t ++ ".gpg"
Servers.hs view
@@ -8,14 +8,20 @@ import Types.Server import Servant.Client -serverUrl :: Server -> BaseUrl-serverUrl srv = BaseUrl Http (serverName srv) (serverPort srv) ""+serverUrls :: Server -> [BaseUrl]+serverUrls srv = map go (serverAddress srv)+  where+	go (ServerAddress addr port) = BaseUrl Http addr port "" --- | These can be either tor .onion addresses, or regular hostnames.--- Using tor is highly recommended, to avoid correlation attacks.-networkServers :: IO [Server]-networkServers = return -	[ Server "vzgrspuxbtnlrtup.onion" 4242 -- keysafe.joeyh.name-	, Server "localhost" 4242-	, Server "localhost" 4242+networkServers :: [Server]+networkServers =+	[ Server (ServerName "keysafe.joeyh.name")+		[ServerAddress "vzgrspuxbtnlrtup.onion" 4242]+	-- Purism server is not yet deployed, but planned.+	, Server (ServerName "keysafe.puri.sm")+		[]+	-- Unknown yet who will provide this server, but allocate it now+	-- so keysafe can start queuing uploads to it.+	, Server (ServerName "thirdserver")+		[] 	]
Storage.hs view
@@ -26,10 +26,9 @@ import qualified Data.Set as S import Network.Wai.Handler.Warp (Port) -allStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations-allStorageLocations d = do-	servers <- networkServers-	return $ StorageLocations $ map (networkStorage d) servers+networkStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations+networkStorageLocations d = StorageLocations $ +	map (networkStorage d) networkServers  localStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations localStorageLocations d = StorageLocations $@@ -91,13 +90,14 @@ -- Assumes that each location only contains one share. So, once a -- share has been found on a location, can avoid asking that location -- for any other shares.-retrieveShares :: StorageLocations -> ShareIdents -> UpdateProgress -> IO (S.Set Share, ShareIdents)+retrieveShares :: StorageLocations -> ShareIdents -> UpdateProgress -> IO (S.Set Share, ShareIdents, [Server]) retrieveShares (StorageLocations locs) sis updateprogress = do 	let (is, sis') = nextShareIdents sis 	let want = zip [1..] (S.toList is) 	(shares, usedlocs, _unusedlocs) <- go locs [] want [] 	_ <- mapM_ obscureShares usedlocs-	return (S.fromList shares, sis')+	let usedservers = mapMaybe getServer usedlocs+	return (S.fromList shares, sis', usedservers)   where 	go unusedlocs usedlocs [] shares = return (shares, usedlocs, unusedlocs) 	go [] usedlocs _ shares = return (shares, usedlocs, [])@@ -120,14 +120,14 @@ 				go (unusedlocs++[loc]) usedlocs' rest shares'  -- | Returns descriptions of any failures.-uploadQueued :: Maybe LocalStorageDirectory -> IO [String]-uploadQueued d = do-	StorageLocations locs <- allStorageLocations d+tryUploadQueued :: Maybe LocalStorageDirectory -> IO [String]+tryUploadQueued d = do 	results <- forM locs $ \loc -> case uploadQueue loc of 		Nothing -> return [] 		Just q -> moveShares q loc 	return $ processresults (concat results) []   where+	StorageLocations locs = networkStorageLocations d 	processresults [] c = nub c 	processresults (StoreSuccess:rs) c = processresults rs c 	processresults (StoreFailure e:rs) c = processresults rs (e:c)@@ -145,13 +145,14 @@ 	-- Prefix "random chaff" to the name to avoid ever using a name 	-- that a real user might want to use. 	let sis = shareIdents testModeTunables (Name $ "random chaff:" <> randomname) (KeyFile "random")-	mapConcurrently (go sis rng' (concat (repeat knownObjectSizes)))+	mapConcurrently (go sis rng') 		[1..totalObjects (shareParams testModeTunables)]   where-	server = networkStorage Nothing $ Server hn port-	go _ _ [] _ = return ()-	go sis rng (s:sizes) n = do-		let (b, rng') = cprgGenerate s rng+	server = networkStorage Nothing $ Server (ServerName hn) +		[ServerAddress hn port]+	objsize = objectSize defaultTunables * shareOverhead defaultTunables+	go sis rng n = do+		let (b, rng') = cprgGenerate objsize rng 		let share = Share 0 (StorableObject b) 		let (is, sis') = nextShareIdents sis 		let i = S.toList is !! (n - 1)@@ -160,4 +161,4 @@ 			StoreSuccess -> putStr "+" 			_ -> putStr "!" 		hFlush stdout-		go sis' rng' sizes n+		go sis' rng' n
Storage/Local.hs view
@@ -6,6 +6,7 @@ module Storage.Local 	( localStorage 	, storageDir+	, storageTopDir 	, testStorageDir 	, localDiskUsage 	) where@@ -13,21 +14,22 @@ import Types import Types.Storage import Serialization ()+import Utility.UserInfo+import Utility.Exception import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as U8 import Data.Monoid import Data.List import Data.Maybe-import System.Posix.User import System.IO import System.Directory import System.Posix import System.FilePath import Raaz.Core.Encode import Control.DeepSeq-import Control.Exception import Control.Monad import System.DiskSpace+import Control.Exception (IOException)  type GetShareDir = Section -> IO FilePath @@ -98,7 +100,7 @@ move :: Section -> GetShareDir -> Storage -> IO [StoreResult] move section getsharedir storage = do 	dir <- getsharedir section-	fs <- map (dir </>) <$> getDirectoryContents dir+	fs <- map (dir </>) <$> catchDefaultIO [] (getDirectoryContents dir) 	rs <- forM fs $ \f -> case fromShareFile f of 		Nothing -> return Nothing 		Just i -> Just <$> go f i@@ -142,18 +144,19 @@  storageDir :: Maybe LocalStorageDirectory -> GetShareDir storageDir Nothing (Section section) = do-	u <- getUserEntryForID =<< getEffectiveUserID-	return $ homeDirectory u </> dotdir </> section+	home <- myHomeDir+	return $ home </> dotdir </> section storageDir (Just (LocalStorageDirectory d)) (Section section) = 	pure $ d </> section +storageTopDir :: Maybe LocalStorageDirectory -> IO FilePath+storageTopDir lsd = storageDir lsd (Section ".")+ testStorageDir :: FilePath -> GetShareDir testStorageDir tmpdir = storageDir (Just (LocalStorageDirectory tmpdir))  localDiskUsage :: Maybe LocalStorageDirectory -> IO DiskUsage-localDiskUsage lsd = do-	dir <- storageDir lsd (Section ".")-	getDiskUsage dir+localDiskUsage lsd = getDiskUsage =<< storageTopDir lsd  -- | The takeFileName ensures that, if the StorableObjectIdent somehow -- contains a path (eg starts with "../" or "/"), it is not allowed
Storage/Network.hs view
@@ -25,9 +25,11 @@ 	, countShares = count server 	, moveShares = move server 	, uploadQueue = Just $ localStorage (storageDir localdir)-		("uploadqueue" </> serverName server)+		("uploadqueue" </> name) 	, getServer = Just server 	}+  where+	ServerName name = serverName server  store :: Server -> StorableObjectIdent -> Share -> IO StoreResult store srv i (Share _n o) =
TODO view
@@ -1,11 +1,10 @@ Soon: -* Implement the different categories of servers in the server list. * Get some keysafe servers set up.-* Run --uploadqueued periodically (systemd timer or desktop autostart?)  Later: +* Implement the different categories of servers in the server list. * improve restore progress bar points (update after every hash try) * If we retrieved enough shares successfully, but decrypt failed, must   be a wrong password, so prompt for re-entry and retry with those shares.@@ -18,6 +17,9 @@   and rejects passwords that would cost less than $N to crack at current   rates. This should add a combo box to the password entry form in the   GUI to let the user adjust the $N there.+* In backup, only upload to N-1 servers immediately, and delay the rest+  for up to several days, with some uploads of chaff, to prevent+  collaborating evil servers from correlating related shards. * Add some random padding to http requests and responses, to make it   harder for traffic analysis to tell that it's keysafe traffic.
Tests.hs view
@@ -98,7 +98,7 @@  	restore storagelocations = do 		let sis = shareIdents tunables name secretkeysource-		(shares, sis') <- retrieveShares storagelocations sis (return ())+		(shares, sis', _) <- retrieveShares storagelocations sis (return ()) 		let candidatekeys = candidateKeyEncryptionKeys tunables name password 		case combineShares tunables [shares] of 			Left e -> testFailed e@@ -112,7 +112,7 @@ 				then testSuccess 				else testFailed "restore yielded different value than was backed up" 		DecryptIncomplete kek -> do-			(nextshares, sis') <- retrieveShares storagelocations sis (return ())+			(nextshares, sis', _) <- retrieveShares storagelocations sis (return ()) 			let shares = firstshares ++ [nextshares] 			case combineShares tunables shares of 				Left e -> testFailed e
Types.hs view
@@ -9,9 +9,11 @@  import Types.Cost import qualified Data.ByteString as B+import qualified Data.Text as T import Data.String import Control.DeepSeq import GHC.Generics (Generic)+import Data.Aeson  -- | keysafe stores secret keys. newtype SecretKey = SecretKey B.ByteString@@ -53,11 +55,17 @@  -- | Source of the secret key stored in keysafe. data SecretKeySource = GpgKey KeyId | KeyFile FilePath-	deriving (Show)+	deriving (Show, Eq, Generic) +instance ToJSON SecretKeySource+instance FromJSON SecretKeySource+ -- | The keyid is any value that is unique to a private key, and can be -- looked up somehow without knowing the private key. -- -- A gpg keyid is the obvious example.-data KeyId = KeyId B.ByteString-	deriving (Show)+data KeyId = KeyId T.Text+	deriving (Show, Eq, Generic)++instance ToJSON KeyId+instance FromJSON KeyId
Types/Cost.hs view
@@ -14,7 +14,10 @@ 	deriving (Show, Eq, Ord)  newtype Seconds = Seconds Rational-	deriving (Num, Fractional, Eq, Ord, Show)+	deriving (Num, Fractional, Eq, Ord)++instance Show Seconds where+	show (Seconds n) = show (fromRational n :: Double) ++ "s"  -- | How many CPU cores a single run of an operation can be divided amoung. newtype Divisibility = Divisibility Integer
Types/Server.hs view
@@ -3,14 +3,33 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE DeriveGeneric #-}+ module Types.Server where +import Data.Aeson+import GHC.Generics import Network.Wai.Handler.Warp (Port)  type HostName = String +-- | Server address can use either tor .onion addresses, or regular+-- hostnames. Using tor is highly recommended, to avoid correlation+-- attacks.+data ServerAddress = ServerAddress HostName Port+	deriving (Show, Eq, Ord)++-- | Name used in queuing uploads to the server. Should remain stable+-- across keysafe versions.+newtype ServerName = ServerName String+	deriving (Show, Eq, Ord, Generic)++instance ToJSON ServerName+instance FromJSON ServerName+	 data Server = Server-	{ serverName :: HostName-	, serverPort :: Port+	{ serverName :: ServerName+	, serverAddress :: [ServerAddress]+	-- ^ A server may have multiple addresses, or no current address. 	}-	deriving (Show)+	deriving (Show, Eq, Ord)
UI/Readline.hs view
@@ -17,6 +17,7 @@ import Text.Read import Control.Monad import qualified Data.ByteString.UTF8 as BU8+import qualified Data.Text as T  readlineUI :: UI readlineUI = UI@@ -129,7 +130,7 @@ 	putStrLn desc 	putStrLn "" 	forM_ nl $ \(n, ((Name name), (KeyId kid))) ->-		putStrLn $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ BU8.toString kid ++ ")"+		putStrLn $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ T.unpack kid ++ ")" 	prompt   where 	nl = zip [1 :: Integer ..] l
UI/Zenity.hs view
@@ -15,6 +15,7 @@ import System.Directory import System.Exit import qualified Data.ByteString.UTF8 as BU8+import qualified Data.Text as T  zenityUI :: UI zenityUI = UI@@ -37,7 +38,7 @@ 	go = runZenity 		[ "--error" 		, "--title", "keysafe"-		, "--text", "Error: " ++ desc+		, "--text", "Error: " ++ escape desc 		] 	cleanup h = do 		_ <- waitZenity h@@ -49,7 +50,7 @@ 	go = runZenity 		[ "--info" 		, "--title", title-		, "--text", desc+		, "--text", escape desc 		] 	cleanup h = do 		_ <- waitZenity h@@ -60,7 +61,7 @@ 	h <- runZenity 		[ "--question" 		, "--title", title-		, "--text",  desc ++ "\n" ++ question+		, "--text",  escape $ desc ++ "\n" ++ question 		] 	(_, ok) <- waitZenity h 	return ok@@ -72,7 +73,7 @@ 		h <- runZenity 			[ "--entry" 			, "--title", title-			, "--text", desc ++ "\n" ++ extradesc+			, "--text", escape $ desc ++ "\n" ++ extradesc 			, "--entry-text", case suggested of 				Nothing -> "" 				Just (Name b) -> BU8.toString b@@ -93,7 +94,7 @@ 		h <- runZenity $ 			[ "--forms" 			, "--title", title-			, "--text", desc ++ "\n" ++ extradesc ++ "\n"+			, "--text", escape $ desc ++ "\n" ++ extradesc ++ "\n" 			, "--separator", "\BEL" 			, "--add-password", "Enter password" 			] ++ if confirm@@ -116,18 +117,18 @@ 	h <- runZenity $ 		[ "--list" 		, "--title", title-		, "--text", desc+		, "--text", escape desc 		, "--column", "gpg secret key name" 		, "--column", "keyid" 		, "--print-column", "ALL" 		, "--separator", "\BEL" 		, "--width", "500"-		] ++ concatMap (\(Name n, KeyId kid) -> [BU8.toString n, BU8.toString kid]) l+		] ++ concatMap (\(Name n, KeyId kid) -> [BU8.toString n, T.unpack kid]) l 	(ret, ok) <- waitZenity h 	if ok 		then do 			let (_n, _:kid) = break (== '\BEL') ret-			return $ Just (KeyId (BU8.fromString kid))+			return $ Just (KeyId (T.pack kid)) 		else return Nothing  myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a@@ -137,7 +138,7 @@ 		h <- runZenity 			[ "--progress" 			, "--title", title-			, "--text", desc+			, "--text", escape desc 			, "--auto-close" 			, "--auto-kill" 			]@@ -169,3 +170,14 @@ 	ret <- hGetContents hout 	exit <- waitForProcess ph 	return (takeWhile (/= '\n') ret, exit == ExitSuccess)++-- Zenity parses --text as html and will choke on invalid tags+-- and '&' used outside a html entity. We don't want to use html, so+-- escape these things.+escape :: String -> String+escape = concatMap esc +  where+	esc '&' = "&amp;"+	esc '<' = "&lt;"+	esc '>' = "&gt;"+	esc c = [c]
+ Utility/Data.hs view
@@ -0,0 +1,19 @@+{- utilities for simple data types+ -+ - Copyright 2013 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# OPTIONS_GHC -fno-warn-tabs #-}++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
+ Utility/Env.hs view
@@ -0,0 +1,84 @@+{- portable environment variables+ -+ - Copyright 2013 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Env where++#ifdef mingw32_HOST_OS+import Utility.Exception+import Control.Applicative+import Data.Maybe+import Prelude+import qualified System.Environment as E+import qualified System.SetEnv+#else+import qualified System.Posix.Env as PE+#endif++getEnv :: String -> IO (Maybe String)+#ifndef mingw32_HOST_OS+getEnv = PE.getEnv+#else+getEnv = catchMaybeIO . E.getEnv+#endif++getEnvDefault :: String -> String -> IO String+#ifndef mingw32_HOST_OS+getEnvDefault = PE.getEnvDefault+#else+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var+#endif++getEnvironment :: IO [(String, String)]+#ifndef mingw32_HOST_OS+getEnvironment = PE.getEnvironment+#else+getEnvironment = E.getEnvironment+#endif++{- Sets an environment variable. To overwrite an existing variable,+ - overwrite must be True.+ -+ - On Windows, setting a variable to "" unsets it. -}+setEnv :: String -> String -> Bool -> IO ()+#ifndef mingw32_HOST_OS+setEnv var val overwrite = PE.setEnv var val overwrite+#else+setEnv var val True = System.SetEnv.setEnv var val+setEnv var val False = do+	r <- getEnv var+	case r of+		Nothing -> setEnv var val True+		Just _ -> return ()+#endif++unsetEnv :: String -> IO ()+#ifndef mingw32_HOST_OS+unsetEnv = PE.unsetEnv+#else+unsetEnv = System.SetEnv.unsetEnv+#endif++{- Adds the environment variable to the input environment. If already+ - present in the list, removes the old value.+ -+ - This does not really belong here, but Data.AssocList is for some reason+ - buried inside hxt.+ -}+addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)]+addEntry k v l = ( (k,v) : ) $! delEntry k l++addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)]+addEntries = foldr (.) id . map (uncurry addEntry) . reverse++delEntry :: Eq k => k -> [(k, v)] -> [(k, v)]+delEntry _ []   = []+delEntry k (x@(k1,_) : rest)+	| k == k1 = rest+	| otherwise = ( x : ) $! delEntry k rest
+ Utility/Exception.hs view
@@ -0,0 +1,113 @@+{- Simple IO exception handling (and some more)+ -+ - Copyright 2011-2015 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Exception (+	module X,+	catchBoolIO,+	catchMaybeIO,+	catchDefaultIO,+	catchMsgIO,+	catchIO,+	tryIO,+	bracketIO,+	catchNonAsync,+	tryNonAsync,+	tryWhenExists,+	catchIOErrorType,+	IOErrorType(..),+	catchPermissionDenied,+) where++import Control.Monad.Catch as X hiding (Handler)+import qualified Control.Monad.Catch as M+import Control.Exception (IOException, AsyncException)+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+import Control.Exception (SomeAsyncException)+#endif+#endif+import Control.Monad+import Control.Monad.IO.Class (liftIO, MonadIO)+import System.IO.Error (isDoesNotExistError, ioeGetErrorType)+import GHC.IO.Exception (IOErrorType(..))++import Utility.Data++{- Catches IO errors and returns a Bool -}+catchBoolIO :: MonadCatch m => m Bool -> m Bool+catchBoolIO = catchDefaultIO False++{- Catches IO errors and returns a Maybe -}+catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)+catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just)++{- Catches IO errors and returns a default value. -}+catchDefaultIO :: MonadCatch m => a -> m a -> m a+catchDefaultIO def a = catchIO a (const $ return def)++{- Catches IO errors and returns the error message. -}+catchMsgIO :: MonadCatch m => m a -> m (Either String a)+catchMsgIO a = do+	v <- tryIO a+	return $ either (Left . show) Right v++{- catch specialized for IO errors only -}+catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a+catchIO = M.catch++{- try specialized for IO errors only -}+tryIO :: MonadCatch m => m a -> m (Either IOException a)+tryIO = M.try++{- bracket with setup and cleanup actions lifted to IO.+ -+ - Note that unlike catchIO and tryIO, this catches all exceptions. -}+bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a+bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)++{- Catches all exceptions except for async exceptions.+ - This is often better to use than catching them all, so that+ - ThreadKilled and UserInterrupt get through.+ -}+catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a+catchNonAsync a onerr = a `catches`+	[ M.Handler (\ (e :: AsyncException) -> throwM e)+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+	, M.Handler (\ (e :: SomeAsyncException) -> throwM e)+#endif+#endif+	, M.Handler (\ (e :: SomeException) -> onerr e)+	]++tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)+tryNonAsync a = go `catchNonAsync` (return . Left)+  where+	go = do+		v <- a+		return (Right v)++{- Catches only DoesNotExist exceptions, and lets all others through. -}+tryWhenExists :: MonadCatch m => m a -> m (Maybe a)+tryWhenExists a = do+	v <- tryJust (guard . isDoesNotExistError) a+	return (eitherToMaybe v)++{- Catches only IO exceptions of a particular type.+ - Ie, use HardwareFault to catch disk IO errors. -}+catchIOErrorType :: MonadCatch m => IOErrorType -> (IOException -> m a) -> m a -> m a+catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching+  where+	onlymatching e+		| ioeGetErrorType e == errtype = onmatchingerr e+		| otherwise = throwM e++catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a+catchPermissionDenied = catchIOErrorType PermissionDenied
+ Utility/FreeDesktop.hs view
@@ -0,0 +1,147 @@+{- Freedesktop.org specifications+ -+ - http://standards.freedesktop.org/basedir-spec/latest/+ - http://standards.freedesktop.org/desktop-entry-spec/latest/+ - http://standards.freedesktop.org/menu-spec/latest/+ - http://standards.freedesktop.org/icon-theme-spec/latest/+ -+ - Copyright 2012 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.FreeDesktop (+	DesktopEntry,	+	genDesktopEntry,+	buildDesktopMenuFile,+	writeDesktopMenuFile,+	desktopMenuFilePath,+	autoStartPath,+	iconDir,+	iconFilePath,+	systemDataDir,+	systemConfigDir,+	userDataDir,+	userConfigDir,+	userDesktopDir+) where++import Utility.Exception+import Utility.UserInfo++import System.Environment+import System.FilePath+import System.Directory+import System.Process+import Data.List+import Data.Maybe+import Control.Applicative+import Prelude++type DesktopEntry = [(Key, Value)]++type Key = String++data Value = StringV String | BoolV Bool | NumericV Float | ListV [Value]++toString :: Value -> String+toString (StringV s) = s+toString (BoolV b)+	| b = "true"+	| otherwise = "false"+toString (NumericV f) = show f+toString (ListV l)+	| null l = ""+	| otherwise = (intercalate ";" $ map (concatMap escapesemi . toString) l) ++ ";"+  where+	escapesemi ';' = "\\;"+	escapesemi c = [c]++genDesktopEntry :: String -> String -> Bool -> FilePath -> Maybe String -> [String] -> DesktopEntry+genDesktopEntry name comment terminal program icon categories = catMaybes+	[ item "Type" StringV "Application"+	, item "Version" NumericV 1.0+	, item "Name" StringV name+	, item "Comment" StringV comment+	, item "Terminal" BoolV terminal+	, item "Exec" StringV program+	, maybe Nothing (item "Icon" StringV) icon+	, item "Categories" ListV (map StringV categories)+	]+  where+	item x c y = Just (x, c y)++buildDesktopMenuFile :: DesktopEntry -> String+buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n"+  where+	keyvalue (k, v) = k ++ "=" ++ toString v++writeDesktopMenuFile :: DesktopEntry -> String -> IO ()+writeDesktopMenuFile d file = do+	createDirectoryIfMissing True (takeDirectory file)+	writeFile file $ buildDesktopMenuFile d++{- Path to use for a desktop menu file, in either the systemDataDir or+ - the userDataDir -}+desktopMenuFilePath :: String -> FilePath -> FilePath+desktopMenuFilePath basename datadir = +	datadir </> "applications" </> desktopfile basename++{- Path to use for a desktop autostart file, in either the systemDataDir+ - or the userDataDir -}+autoStartPath :: String -> FilePath -> FilePath+autoStartPath basename configdir =+	configdir </> "autostart" </> desktopfile basename++{- Base directory to install an icon file, in either the systemDataDir+ - or the userDatadir. -}+iconDir :: FilePath -> FilePath+iconDir datadir = datadir </> "icons" </> "hicolor"++{- Filename of an icon, given the iconDir to use.+ -+ - The resolution is something like "48x48" or "scalable". -}+iconFilePath :: FilePath -> String -> FilePath -> FilePath+iconFilePath file resolution icondir =+	icondir </> resolution </> "apps" </> file++desktopfile :: FilePath -> FilePath+desktopfile f = f ++ ".desktop"++{- Directory used for installation of system wide data files.. -}+systemDataDir :: FilePath+systemDataDir = "/usr/share"++{- Directory used for installation of system wide config files. -}+systemConfigDir :: FilePath+systemConfigDir = "/etc/xdg"++{- Directory for user data files. -}+userDataDir :: IO FilePath+userDataDir = xdgEnvHome "DATA_HOME" ".local/share"++{- Directory for user config files. -}+userConfigDir :: IO FilePath+userConfigDir = xdgEnvHome "CONFIG_HOME" ".config"++{- Directory for the user's Desktop, may be localized. + -+ - This is not looked up very fast; the config file is in a shell format+ - that is best parsed by shell, so xdg-user-dir is used, with a fallback+ - to ~/Desktop. -}+userDesktopDir :: IO FilePath+userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir)+  where+	parse s = case lines <$> s of+		Just (l:_) -> Just l+		_ -> Nothing+	xdg_user_dir = catchMaybeIO $ readProcess "xdg-user-dir" ["DESKTOP"] []+	fallback = xdgEnvHome "DESKTOP_DIR" "Desktop"++xdgEnvHome :: String -> String -> IO String+xdgEnvHome envbase homedef = do+	home <- myHomeDir+	catchDefaultIO (home </> homedef) $+		getEnv $ "XDG_" ++ envbase
+ Utility/UserInfo.hs view
@@ -0,0 +1,62 @@+{- user info+ -+ - Copyright 2012 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.UserInfo (+	myHomeDir,+	myUserName,+	myUserGecos,+) where++import Utility.Env+import Utility.Data++import System.PosixCompat+import Control.Applicative+import Prelude++{- Current user's home directory.+ -+ - getpwent will fail on LDAP or NIS, so use HOME if set. -}+myHomeDir :: IO FilePath+myHomeDir = either error return =<< myVal env homeDirectory+  where+#ifndef mingw32_HOST_OS+	env = ["HOME"]+#else+	env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin+#endif++{- Current user's user name. -}+myUserName :: IO (Either String String)+myUserName = myVal env userName+  where+#ifndef mingw32_HOST_OS+	env = ["USER", "LOGNAME"]+#else+	env = ["USERNAME", "USER", "LOGNAME"]+#endif++myUserGecos :: IO (Maybe String)+-- userGecos crashes on Android and is not available on Windows.+#if defined(__ANDROID__) || defined(mingw32_HOST_OS)+myUserGecos = return Nothing+#else+myUserGecos = eitherToMaybe <$> myVal [] userGecos+#endif++myVal :: [String] -> (UserEntry -> String) -> IO (Either String String)+myVal envvars extract = go envvars+  where+#ifndef mingw32_HOST_OS+	go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID)+#else+	go [] = return $ Left ("environment not set: " ++ show envvars)+#endif+	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v
+ keysafe.autostart view
@@ -0,0 +1,9 @@+[Desktop Entry]+Type=Application+Version=1.0+Name=Keysafe+Comment=Autostart+Terminal=false+Exec=keysafe --autostart+Categories=+
keysafe.cabal view
@@ -1,5 +1,5 @@ Name: keysafe-Version: 0.20160914+Version: 0.20160922 Cabal-Version: >= 1.8 Maintainer: Joey Hess <joey@kitenet.net> Author: Joey Hess@@ -24,6 +24,7 @@   keysafe.1   keysafe.service   keysafe.desktop+  keysafe.autostart   Makefile  Executable keysafe@@ -69,12 +70,15 @@     , SafeSemaphore == 0.10.*     , crypto-random == 0.0.*     , async == 2.1.*+    , unix-compat == 0.4.*+    , exceptions == 0.8.*     -- Temporarily inlined due to FTBFS bug     -- https://github.com/ocharles/argon2/issues/2     -- argon2 == 1.1.*   Extra-Libraries: argon2   Other-Modules:-    BackupRecord+    AutoStart+    BackupLog     Benchmark     ByteStrings     Crypto.Argon2.FFI@@ -93,6 +97,7 @@     HTTP.RateLimit     SecretKey     Serialization+    ServerBackup     Servers     Share     Storage@@ -109,6 +114,11 @@     UI.Readline     UI.NonInteractive     UI.Zenity+    Utility.Data+    Utility.Env+    Utility.Exception+    Utility.FreeDesktop+    Utility.UserInfo  source-repository head   type: git
keysafe.hs view
@@ -19,14 +19,19 @@ import SecretKey import Share import Storage-import BackupRecord+import Types.Server+import BackupLog+import AutoStart import HTTP.Server+import ServerBackup import qualified Gpg import Data.Maybe import Data.Time.Clock import Data.Time.Calendar import Data.Monoid+import Data.List import Control.DeepSeq+import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Set as S@@ -43,35 +48,35 @@ 				"Keysafe is running in test mode. This is not secure, and should not be used with real secret keys!" 			return (mkt testModeTunables, [mkt testModeTunables]) 		else return (mkt defaultTunables, map (mkt . snd) knownTunings)-	storagelocations <- if CmdLine.localstorage cmdline-		then pure $ localStorageLocations (CmdLine.localstoragedirectory cmdline)-		else allStorageLocations (CmdLine.localstoragedirectory cmdline)-	dispatch cmdline ui storagelocations tunables possibletunables+	dispatch cmdline ui tunables possibletunables -dispatch :: CmdLine.CmdLine -> UI -> StorageLocations -> Tunables -> [Tunables] -> IO ()-dispatch cmdline ui storagelocations tunables possibletunables = do+dispatch :: CmdLine.CmdLine -> UI -> Tunables -> [Tunables] -> IO ()+dispatch cmdline ui tunables possibletunables = do 	mode <- CmdLine.selectMode cmdline 	go mode (CmdLine.secretkeysource cmdline)   where 	go CmdLine.Backup (Just secretkeysource) =-		backup cmdline storagelocations ui tunables secretkeysource+		backup cmdline ui tunables secretkeysource 			=<< getSecretKey secretkeysource 	go CmdLine.Restore (Just secretkeydest) =-		restore cmdline storagelocations ui possibletunables secretkeydest+		restore cmdline ui possibletunables secretkeydest 	go CmdLine.Backup Nothing =-		backup cmdline storagelocations ui tunables Gpg.anyKey+		backup cmdline ui tunables Gpg.anyKey 			=<< Gpg.getKeyToBackup ui 	go CmdLine.Restore Nothing =-		restore cmdline storagelocations ui possibletunables Gpg.anyKey-	go CmdLine.UploadQueued _ = do-		problems <- uploadQueued (CmdLine.localstoragedirectory cmdline)-		if null problems-			then return ()-			else showError ui ("Problem uploading queued data to servers:\n\n" ++ unlines problems ++ "\n\nYour secret keys have not yet been backed up.")+		restore cmdline ui possibletunables Gpg.anyKey+	go CmdLine.UploadQueued _ =+		uploadQueued ui (CmdLine.localstoragedirectory cmdline)+	go CmdLine.AutoStart _ =+		autoStart cmdline tunables ui 	go (CmdLine.Server) _ = 		runServer 			(CmdLine.localstoragedirectory cmdline) 			(CmdLine.serverConfig cmdline)+	go (CmdLine.BackupServer d) _ =+		backupServer (CmdLine.localstoragedirectory cmdline) d+	go (CmdLine.RestoreServer d) _ =+		restoreServer (CmdLine.localstoragedirectory cmdline) d 	go (CmdLine.Chaff hn) _ = storeChaff hn 		(CmdLine.serverPort (CmdLine.serverConfig cmdline)) 	go CmdLine.Benchmark _ =@@ -79,8 +84,9 @@ 	go CmdLine.Test _ = 		runTests -backup :: CmdLine.CmdLine -> StorageLocations -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO ()-backup cmdline storagelocations ui tunables secretkeysource secretkey = do+backup :: CmdLine.CmdLine -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO ()+backup cmdline ui tunables secretkeysource secretkey = do+	installAutoStartFile 	username <- userName 	Name theirname <- case CmdLine.name cmdline of 		Just n -> pure n@@ -107,13 +113,16 @@ 				_ <- esk `deepseq` addpercent 25 				_ <- sis `seq` addpercent 25 				let step = 50 `div` sum (map S.size shares)-				storeShares storagelocations sis shares (addpercent step)-		backuprecord <- mkBackupRecord (mapMaybe getServer locs) secretkeysource passwordentropy+				storeShares (cmdLineStorageLocations cmdline) sis shares (addpercent step)+		backuplog <- mkBackupLog $ backupMade (mapMaybe getServer locs) secretkeysource passwordentropy 		case r of 			StoreSuccess -> do-				storeBackupRecord backuprecord+				storeBackupLog backuplog 				if queued-					then showInfo ui "Backup queued" "Some data was not sucessfully uploaded to servers, and has been queued for later upload. Run keysafe --uploadqueued at a later point to finish the backup."+					then do+						willautostart <- isAutoStartFileInstalled+						showInfo ui "Backup queued" $ "Some data was not sucessfully uploaded to servers, and has been queued for later upload."+							++ if willautostart then "" else " Run keysafe --uploadqueued at a later point to finish the backup." 					else showInfo ui "Backup success" "Your secret key was successfully encrypted and backed up." 			StoreFailure s -> showError ui ("There was a problem storing your encrypted secret key: " ++ s) 			StoreAlreadyExists -> do@@ -126,9 +135,7 @@ 		password <- fromMaybe (error "Aborting on no password")  			<$> promptPassword ui True "Enter password" passworddesc 		kek <- genKeyEncryptionKey tunables name password-		username <- userName-		let badwords = concatMap namewords [name, username]-		let passwordentropy = calcPasswordEntropy password badwords+		passwordentropy <- getPasswordEntropy password name 		let crackcost = estimateAttackCost spotAWS $ 			estimateBruteforceOf kek passwordentropy 		let mincost = Dollars 100000@@ -145,7 +152,6 @@ 				if ok 					then return (kek, passwordentropy) 					else promptpassword name-	namewords (Name nb) = words (BU8.toString nb) 	keydesc = case secretkeysource of 		GpgKey _ -> "gpg secret key" 		KeyFile _ -> "secret key"@@ -198,8 +204,8 @@ 	, "A place you like to visit." 	] -restore :: CmdLine.CmdLine -> StorageLocations -> UI -> [Tunables] -> SecretKeySource -> IO ()-restore cmdline storagelocations ui possibletunables secretkeydest = do+restore :: CmdLine.CmdLine -> UI -> [Tunables] -> SecretKeySource -> IO ()+restore cmdline ui possibletunables secretkeydest = do 	cores <- fromMaybe 1 <$> getNumCores 	username <- userName 	Name theirname <- case CmdLine.name cmdline of@@ -220,7 +226,7 @@ 	r <- downloadInitialShares storagelocations ui mksis possibletunables 	case r of 		Nothing -> showError ui "No shares could be downloaded. Perhaps you entered the wrong name?"-		Just (tunables, shares, sis) -> do+		Just (tunables, shares, sis, usedservers) -> do 			let candidatekeys = candidateKeyEncryptionKeys tunables name password 			let cost = getCreationCost candidatekeys  				<> castCost (getDecryptionCost candidatekeys)@@ -229,26 +235,34 @@ 				Right esk -> do 					final <- withProgress ui "Decrypting" 						(decryptdesc cost cores) $ \setpercent ->-							go tunables [shares] sis setpercent $+							go tunables [shares] usedservers sis setpercent $ 								tryDecrypt candidatekeys esk-					final+					final =<< getPasswordEntropy password name   where-	go tunables firstshares sis setpercent r = case r of-		DecryptFailed -> return $+	storagelocations = cmdLineStorageLocations cmdline+	go tunables firstshares firstusedservers sis setpercent r = case r of+		DecryptFailed -> return $ \_ -> 			showError ui "Decryption failed! Probably you entered the wrong password." 		DecryptSuccess secretkey -> do 			_ <- setpercent 100 			writeSecretKey secretkeydest secretkey-			return $+			return $ \passwordentropy -> do 				showInfo ui "Success" "Your secret key was successfully restored!"+				-- Since the key was restored, we know it's+				-- backed up; log that.+				backuplog <- mkBackupLog $ +					backupMade firstusedservers secretkeydest passwordentropy+				storeBackupLog backuplog 		DecryptIncomplete kek -> do 			-- Download shares for another chunk.-			(nextshares, sis') <- retrieveShares storagelocations sis (return ())+			(nextshares, sis', nextusedservers) +				<- retrieveShares storagelocations sis (return ()) 			let shares = firstshares ++ [nextshares]+			let usedservers = nub (firstusedservers ++ nextusedservers) 			case combineShares tunables shares of-				Left e -> return $ showError ui e+				Left e -> return $ \_ -> showError ui e 				Right esk -> -					go tunables shares sis' setpercent $+					go tunables shares usedservers sis' setpercent $ 						decrypt kek esk 	namedesc = unlines 		[ "When you backed up your secret key, you entered some information."@@ -282,7 +296,7 @@ 	-> UI 	-> (Tunables -> ShareIdents) 	-> [Tunables]-	-> IO (Maybe (Tunables, S.Set Share, ShareIdents))+	-> IO (Maybe (Tunables, S.Set Share, ShareIdents, [Server])) downloadInitialShares storagelocations ui mksis possibletunables = do 	cores <- fromMaybe 1 <$> getNumCores 	withProgressIncremental ui "Downloading encrypted data" (message cores) $ \addpercent -> do@@ -296,10 +310,10 @@ 		addpercent 50 		let m = totalObjects (shareParams tunables) 		let step = 50 `div` m-		(shares, sis') <- retrieveShares storagelocations sis (addpercent step)+		(shares, sis', usedservers) <- retrieveShares storagelocations sis (addpercent step) 		if S.null shares 			then go othertunables addpercent-			else return $ Just (tunables, shares, sis')+			else return $ Just (tunables, shares, sis', usedservers)  	possiblesis = map mksis possibletunables 	message cores = unlines@@ -321,3 +335,52 @@ userName = do 	u <- getUserEntryForID =<< getEffectiveUserID 	return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u)++cmdLineStorageLocations :: CmdLine.CmdLine -> StorageLocations+cmdLineStorageLocations cmdline+	| CmdLine.localstorage cmdline = localStorageLocations lsd+	| otherwise = networkStorageLocations lsd+  where+	lsd = CmdLine.localstoragedirectory cmdline++getPasswordEntropy :: Password -> Name -> IO (Entropy UnknownPassword)+getPasswordEntropy password name = do+	username <- userName+	let badwords = concatMap namewords [name, username]+	return $ calcPasswordEntropy password badwords+  where+	namewords (Name nb) = words (BU8.toString nb)++uploadQueued :: UI -> Maybe LocalStorageDirectory -> IO ()+uploadQueued ui d = do+	problems <- tryUploadQueued d+	if null problems+		then return ()+		else showError ui ("Problem uploading queued data to servers:\n\n" ++ unlines problems ++ "\n\nYour secret keys have not yet been backed up.")++autoStart :: CmdLine.CmdLine -> Tunables -> UI -> IO ()+autoStart cmdline tunables ui = do+	-- Upload queued first, before making any more backups that might+	-- queue more.+	uploadQueued ui (CmdLine.localstoragedirectory cmdline)++	-- Ask about backing up any gpg secret key that has not been backed up+	-- or asked about before. If there are multiple secret keys, only+	-- the first one is asked about, to avoid flooding with prompts+	-- if the user for some reason generated a lot of secret keys.+	ls <- readBackupLogs+	ks <- Gpg.listSecretKeys+	case filter (\(_, k) -> not $ any (matchesSecretKeySource (GpgKey k)) ls) ks of+		[] -> return ()+		((Name n,kid@(KeyId kt)):_) -> do+			let kdesc = if length ks < 2+				then "gpg secret key "+				else "gpg secret key for " ++ BU8.toString n ++ " (" ++ T.unpack kt ++ ") "+			ans <- promptQuestion ui ("Back up gpg secret key?")+				("Your " ++ kdesc ++ " has not been backed up by keysafe yet.\n\nKeysafe can securely back up the secret key to the cloud, protected with a password.\n")+				"Do you want to back up the gpg secret key now?"+			if ans+				then backup cmdline ui tunables (GpgKey kid)+					=<< Gpg.getSecretKey kid+				else storeBackupLog+					=<< mkBackupLog (BackupSkipped (GpgKey kid))