diff --git a/AutoStart.hs b/AutoStart.hs new file mode 100644 --- /dev/null +++ b/AutoStart.hs @@ -0,0 +1,42 @@ +{- Copyright 2016 Joey Hess + - + - 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 + [] diff --git a/BackupLog.hs b/BackupLog.hs new file mode 100644 --- /dev/null +++ b/BackupLog.hs @@ -0,0 +1,98 @@ +{- Copyright 2016 Joey Hess + - + - 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) diff --git a/BackupRecord.hs b/BackupRecord.hs deleted file mode 100644 --- a/BackupRecord.hs +++ /dev/null @@ -1,79 +0,0 @@ -{- Copyright 2016 Joey Hess - - - - 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) diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -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 diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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 diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -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 diff --git a/Gpg.hs b/Gpg.hs --- a/Gpg.hs +++ b/Gpg.hs @@ -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 diff --git a/HTTP/Client.hs b/HTTP/Client.hs --- a/HTTP/Client.hs +++ b/HTTP/Client.hs @@ -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 diff --git a/HTTP/ProofOfWork.hs b/HTTP/ProofOfWork.hs --- a/HTTP/ProofOfWork.hs +++ b/HTTP/ProofOfWork.hs @@ -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) diff --git a/HTTP/RateLimit.hs b/HTTP/RateLimit.hs --- a/HTTP/RateLimit.hs +++ b/HTTP/RateLimit.hs @@ -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" diff --git a/HTTP/Server.hs b/HTTP/Server.hs --- a/HTTP/Server.hs +++ b/HTTP/Server.hs @@ -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) diff --git a/INSTALL b/INSTALL --- a/INSTALL +++ b/INSTALL @@ -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. diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/Serialization.hs b/Serialization.hs --- a/Serialization.hs +++ b/Serialization.hs @@ -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 diff --git a/ServerBackup.hs b/ServerBackup.hs new file mode 100644 --- /dev/null +++ b/ServerBackup.hs @@ -0,0 +1,62 @@ +{- Copyright 2016 Joey Hess + - + - 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" diff --git a/Servers.hs b/Servers.hs --- a/Servers.hs +++ b/Servers.hs @@ -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") + [] ] diff --git a/Storage.hs b/Storage.hs --- a/Storage.hs +++ b/Storage.hs @@ -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 diff --git a/Storage/Local.hs b/Storage/Local.hs --- a/Storage/Local.hs +++ b/Storage/Local.hs @@ -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 diff --git a/Storage/Network.hs b/Storage/Network.hs --- a/Storage/Network.hs +++ b/Storage/Network.hs @@ -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) = diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -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. diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -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 diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -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 diff --git a/Types/Cost.hs b/Types/Cost.hs --- a/Types/Cost.hs +++ b/Types/Cost.hs @@ -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 diff --git a/Types/Server.hs b/Types/Server.hs --- a/Types/Server.hs +++ b/Types/Server.hs @@ -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) diff --git a/UI/Readline.hs b/UI/Readline.hs --- a/UI/Readline.hs +++ b/UI/Readline.hs @@ -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 diff --git a/UI/Zenity.hs b/UI/Zenity.hs --- a/UI/Zenity.hs +++ b/UI/Zenity.hs @@ -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 '&' = "&" + esc '<' = "<" + esc '>' = ">" + esc c = [c] diff --git a/Utility/Data.hs b/Utility/Data.hs new file mode 100644 --- /dev/null +++ b/Utility/Data.hs @@ -0,0 +1,19 @@ +{- utilities for simple data types + - + - Copyright 2013 Joey Hess + - + - 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 diff --git a/Utility/Env.hs b/Utility/Env.hs new file mode 100644 --- /dev/null +++ b/Utility/Env.hs @@ -0,0 +1,84 @@ +{- portable environment variables + - + - Copyright 2013 Joey Hess + - + - 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 diff --git a/Utility/Exception.hs b/Utility/Exception.hs new file mode 100644 --- /dev/null +++ b/Utility/Exception.hs @@ -0,0 +1,113 @@ +{- Simple IO exception handling (and some more) + - + - Copyright 2011-2015 Joey Hess + - + - 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 diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs new file mode 100644 --- /dev/null +++ b/Utility/FreeDesktop.hs @@ -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 + - + - 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 diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs new file mode 100644 --- /dev/null +++ b/Utility/UserInfo.hs @@ -0,0 +1,62 @@ +{- user info + - + - Copyright 2012 Joey Hess + - + - 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 diff --git a/keysafe.autostart b/keysafe.autostart new file mode 100644 --- /dev/null +++ b/keysafe.autostart @@ -0,0 +1,9 @@ +[Desktop Entry] +Type=Application +Version=1.0 +Name=Keysafe +Comment=Autostart +Terminal=false +Exec=keysafe --autostart +Categories= + diff --git a/keysafe.cabal b/keysafe.cabal --- a/keysafe.cabal +++ b/keysafe.cabal @@ -1,5 +1,5 @@ Name: keysafe -Version: 0.20160914 +Version: 0.20160922 Cabal-Version: >= 1.8 Maintainer: Joey Hess 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 diff --git a/keysafe.hs b/keysafe.hs --- a/keysafe.hs +++ b/keysafe.hs @@ -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))