diff options
| -rw-r--r-- | Benchmark.hs | 29 | ||||
| -rw-r--r-- | CHANGELOG | 2 | ||||
| -rw-r--r-- | Output.hs | 33 | ||||
| -rw-r--r-- | Storage.hs | 11 | ||||
| -rw-r--r-- | Tests.hs | 11 | ||||
| -rw-r--r-- | UI/NonInteractive.hs | 16 | ||||
| -rw-r--r-- | UI/Readline.hs | 73 | ||||
| -rw-r--r-- | keysafe.cabal | 1 | ||||
| -rw-r--r-- | keysafe.hs | 18 |
9 files changed, 111 insertions, 83 deletions
diff --git a/Benchmark.hs b/Benchmark.hs index 66436fe..33efb46 100644 --- a/Benchmark.hs +++ b/Benchmark.hs @@ -8,6 +8,7 @@ module Benchmark where import Types +import Output import Tunables import ExpensiveHash import HTTP.ProofOfWork @@ -86,33 +87,33 @@ benchmarkPoW rounds seconds = do benchmarkTunables :: Tunables -> IO () benchmarkTunables tunables = do - putStrLn "/proc/cpuinfo:" - putStrLn =<< readFile "/proc/cpuinfo" + say "/proc/cpuinfo:" + say =<< readFile "/proc/cpuinfo" - putStrLn "Benchmarking 1000 rounds of proof of work hash..." - print =<< benchmarkExpensiveHash 1000 (proofOfWorkHashTunable 0) + say "Benchmarking 1000 rounds of proof of work hash..." + display =<< benchmarkExpensiveHash 1000 (proofOfWorkHashTunable 0) - putStrLn "Benchmarking 60 rounds of 1 second proofs of work..." - print =<< benchmarkPoW 60 (Seconds 1) + say "Benchmarking 60 rounds of 1 second proofs of work..." + display =<< benchmarkPoW 60 (Seconds 1) - putStrLn "Benchmarking 10 rounds of 8 second proofs of work..." - print =<< benchmarkPoW 10 (Seconds 8) + say "Benchmarking 10 rounds of 8 second proofs of work..." + display =<< benchmarkPoW 10 (Seconds 8) -- Rather than run all 256 rounds of this hash, which would -- probably take on the order of 1 hour, run only 16, and scale -- the expected cost accordingly. let normalrounds = 256 * randomSaltBytes (keyEncryptionKeyTunable tunables) - putStrLn $ "Benchmarking 16/" ++ show normalrounds ++ " rounds of key encryption key hash..." + say $ "Benchmarking 16/" ++ show normalrounds ++ " rounds of key encryption key hash..." r <- benchmarkExpensiveHash' 16 (keyEncryptionKeyHash $ keyEncryptionKeyTunable tunables) (mapCost (/ (fromIntegral normalrounds / 16)) $ randomSaltBytesBruteForceCost $ keyEncryptionKeyTunable tunables) - print r - putStrLn $ "Estimated time for " ++ show normalrounds ++ " rounds of key encryption key hash..." - print $ BenchmarkResult + display r + say $ "Estimated time for " ++ show normalrounds ++ " rounds of key encryption key hash..." + display $ BenchmarkResult { expectedBenchmark = mapCost (* 16) (expectedBenchmark r) , actualBenchmark = mapCost (* 16) (actualBenchmark r) } - putStrLn "Benchmarking 1 round of name generation hash..." - print =<< benchmarkExpensiveHash 1 + say "Benchmarking 1 round of name generation hash..." + display =<< benchmarkExpensiveHash 1 (nameGenerationHash $ nameGenerationTunable tunables) @@ -16,6 +16,8 @@ keysafe (0.20160923) UNRELEASED; urgency=medium to see what servers keysafe knows about, and as a cron job. * Server: Round number of objects down to the nearest thousand, to avoid leaking too much data about when objects are uploaded to servers. + * Filter out escape sequences and any other unusual characters when + writing all messages to the console. -- Joey Hess <id@joeyh.name> Fri, 23 Sep 2016 10:40:55 -0400 diff --git a/Output.hs b/Output.hs new file mode 100644 index 0000000..f655d0a --- /dev/null +++ b/Output.hs @@ -0,0 +1,33 @@ +-- All console output in keysafe should go via this module; +-- avoid using putStrLn, print, etc directly. + +module Output (ask, progress, say, warn, display) where + +import System.IO +import Data.Char + +ask :: String -> IO () +ask s = do + putStr (escape s) + hFlush stdout + +progress :: String -> IO () +progress = ask + +say :: String -> IO () +say = putStrLn . escape + +warn :: String -> IO () +warn = hPutStrLn stderr . escape + +display :: Show s => s -> IO () +display = say . show + +-- | Prevent malicious escape sequences etc in a string +-- from being output to the console. +escape :: String -> String +escape = concatMap go + where + go c = if isPrint c || isSpace c + then [c] + else "\\" ++ show (ord c) @@ -11,6 +11,7 @@ import Types import Types.Storage import Types.Server import Types.Cost +import Output import Share import Storage.Local import Storage.Network @@ -19,7 +20,6 @@ import Tunables import Data.Maybe import Data.List import Data.Monoid -import System.IO import System.FilePath import Control.Monad import Crypto.Random @@ -176,8 +176,8 @@ tryUploadQueued d = do storeChaff :: HostName -> Port -> Maybe Seconds -> IO () storeChaff hn port delayseconds = forever $ do - putStrLn $ "Sending chaff to " ++ hn ++ " (press ctrl-c to stop)" - putStrLn "Legend: + = successful upload, ! = upload failure" + say $ "Sending chaff to " ++ hn ++ " (press ctrl-c to stop)" + say "Legend: + = successful upload, ! = upload failure" rng <- (cprgCreate <$> createEntropyPool) :: IO SystemRNG let (randomname, rng') = cprgGenerate 128 rng -- It's ok the use the testModeTunables here because @@ -202,7 +202,6 @@ storeChaff hn port delayseconds = forever $ do let i = S.toList is !! (n - 1) r <- storeShare server i share case r of - StoreSuccess -> putStr "+" - _ -> putStr "!" - hFlush stdout + StoreSuccess -> progress "+" + _ -> progress "!" go sis' rng' n @@ -8,6 +8,7 @@ module Tests where import Types +import Output import Tunables import Encryption import Share @@ -16,7 +17,6 @@ import Storage.Local import Control.Exception import System.Directory import System.Posix.Temp -import System.IO import qualified Data.ByteString.UTF8 as BU8 import qualified Data.ByteString as B import qualified Data.Set as S @@ -36,22 +36,21 @@ testFailed = return . Left runTest :: Test -> IO Bool runTest (d, t) = do - putStr $ "testing: " ++ show d ++ " ..." - hFlush stdout + progress $ "testing: " ++ show d ++ " ..." r <- t case r of Right () -> do - putStrLn "ok" + say "ok" return True Left e -> do - putStrLn $ "failed: " ++ show e + say $ "failed: " ++ show e return False runTests :: IO () runTests = do r <- mapM runTest tests if all (== True) r - then putStrLn "All tests succeeded." + then say "All tests succeeded." else error "Tests failed. Report a bug!" tests :: [Test] diff --git a/UI/NonInteractive.hs b/UI/NonInteractive.hs index f0010eb..cd96254 100644 --- a/UI/NonInteractive.hs +++ b/UI/NonInteractive.hs @@ -6,7 +6,7 @@ module UI.NonInteractive (noninteractiveUI) where import Types.UI -import System.IO +import Output import Control.Exception noninteractiveUI :: UI @@ -22,21 +22,19 @@ noninteractiveUI = UI } myShowError :: Desc -> IO () -myShowError desc = hPutStrLn stderr $ "Error: " ++ desc +myShowError desc = warn $ "Error: " ++ desc myShowInfo :: Title -> Desc -> IO () -myShowInfo _title desc = putStrLn desc +myShowInfo _title desc = say desc myPrompt :: Title -> Desc -> x -> IO a myPrompt _title desc _ = do - putStrLn desc + say desc error "Not running at a terminal and zenity is not installed; cannot interact with user." myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a myWithProgress _title desc a = bracket_ setup cleanup (a sendpercent) where - setup = putStrLn desc - sendpercent p = do - putStr (show p ++ "% ") - hFlush stdout - cleanup = putStrLn "done" + setup = say desc + sendpercent p = progress (show p ++ "% ") + cleanup = say "done" diff --git a/UI/Readline.hs b/UI/Readline.hs index 7f19f67..16e4923 100644 --- a/UI/Readline.hs +++ b/UI/Readline.hs @@ -7,11 +7,11 @@ module UI.Readline (readlineUI) where import Types.UI import Types +import Output import System.Console.Readline import System.Posix.Terminal import System.Posix.IO import Control.Exception -import System.IO import Data.List import Data.Char import Text.Read @@ -33,23 +33,23 @@ readlineUI = UI myShowError :: Desc -> IO () myShowError desc = do - hPutStrLn stderr $ "Error: " ++ desc + warn $ "Error: " ++ desc _ <- readline "[Press Enter]" - putStrLn "" + say "" myShowInfo :: Title -> Desc -> IO () myShowInfo title desc = do showTitle title - putStrLn desc - putStrLn "" + say desc + say "" myPromptQuestion :: Title -> Desc -> Question -> IO Bool myPromptQuestion title desc question = bracket_ setup cleanup go where setup = do showTitle title - putStrLn desc - cleanup = putStrLn "" + say desc + cleanup = say "" go = do mresp <- readline $ question ++ " [y/n] " case mresp of @@ -59,7 +59,7 @@ myPromptQuestion title desc question = bracket_ setup cleanup go | "n" `isPrefixOf` (map toLower s) -> return False _ -> do - putStrLn "Please enter 'y' or 'n'" + say "Please enter 'y' or 'n'" go myPromptName :: Title -> Desc -> Maybe Name -> (Name -> Maybe Problem) -> IO (Maybe Name) @@ -68,8 +68,8 @@ myPromptName title desc suggested checkproblem = where setup = do showTitle title - putStrLn desc - cleanup = putStrLn "" + say desc + cleanup = say "" go = do case suggested of Nothing -> return () @@ -81,10 +81,10 @@ myPromptName title desc suggested checkproblem = let n = Name $ BU8.fromString s case checkproblem n of Nothing -> do - putStrLn "" + say "" return $ Just n Just problem -> do - putStrLn problem + say problem go Nothing -> return Nothing @@ -93,33 +93,31 @@ myPromptPassword confirm title desc = bracket setup cleanup (const prompt) where setup = do showTitle title - putStrLn desc + say desc origattr <- getTerminalAttributes stdInput let newattr = origattr `withoutMode` EnableEcho setTerminalAttributes stdInput newattr Immediately return origattr cleanup origattr = do setTerminalAttributes stdInput origattr Immediately - putStrLn "" + say "" prompt = do - putStr "Enter password> " - hFlush stdout + ask "Enter password> " p1 <- getLine - putStrLn "" + say "" if confirm then promptconfirm p1 else return $ mkpassword p1 promptconfirm p1 = do - putStr "Confirm password> " - hFlush stdout + ask "Confirm password> " p2 <- getLine - putStrLn "" + say "" if p1 /= p2 then do - putStrLn "Passwords didn't match, try again..." + say "Passwords didn't match, try again..." prompt else do - putStrLn "" + say "" return $ mkpassword p1 mkpassword = Just . Password . BU8.fromString @@ -127,25 +125,24 @@ myPromptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId) myPromptKeyId _ _ [] = return Nothing myPromptKeyId title desc l = do showTitle title - putStrLn desc - putStrLn "" + say desc + say "" forM_ nl $ \(n, ((Name name), (KeyId kid))) -> - putStrLn $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ T.unpack kid ++ ")" + say $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ T.unpack kid ++ ")" prompt where nl = zip [1 :: Integer ..] l prompt = do - putStr "Enter number> " - hFlush stdout + ask "Enter number> " r <- getLine - putStrLn "" + say "" case readMaybe r of Just n | n > 0 && n <= length l -> do - putStrLn "" + say "" return $ Just $ snd (l !! pred n) _ -> do - putStrLn $ "Enter a number from 1 to " ++ show (length l) + say $ "Enter a number from 1 to " ++ show (length l) prompt myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a @@ -153,16 +150,14 @@ myWithProgress title desc a = bracket_ setup cleanup (a sendpercent) where setup = do showTitle title - putStrLn desc - sendpercent p = do - putStr (show p ++ "% ") - hFlush stdout + say desc + sendpercent p = ask (show p ++ "% ") cleanup = do - putStrLn "done" - putStrLn "" + say "done" + say "" showTitle :: Title -> IO () showTitle title = do - putStrLn title - putStrLn (replicate (length title) '-') - putStrLn "" + say title + say (replicate (length title) '-') + say "" diff --git a/keysafe.cabal b/keysafe.cabal index 538a694..ff2d48d 100644 --- a/keysafe.cabal +++ b/keysafe.cabal @@ -97,6 +97,7 @@ Executable keysafe HTTP.ProofOfWork HTTP.Server HTTP.RateLimit + Output SecretKey Serialization ServerBackup @@ -11,6 +11,7 @@ import Types import Tunables import qualified CmdLine import UI +import Output import Encryption import Entropy import Benchmark @@ -40,7 +41,6 @@ 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 -import System.IO import System.Posix.User (userGecos, getUserEntryForID, getEffectiveUserID) main :: IO () @@ -411,9 +411,9 @@ autoStart cmdline tunables ui = do checkServers :: IO () checkServers = do - putStrLn $ "Checking " ++ show (length networkServers) ++ " servers concurrently; please wait..." + say $ "Checking " ++ show (length networkServers) ++ " servers concurrently; please wait..." results <- mapConcurrently check networkServers - mapM_ display results + mapM_ displayresult results case filter failed results of [] -> return () l @@ -433,14 +433,14 @@ checkServers = do (_, Left e) -> return (s, Left e) (_, Right (CountFailure e)) -> return (s, Left e) - display (s, v) = do - putStrLn $ "* " ++ sn s ++ " -- " ++ serverDesc s + displayresult (s, v) = do + say $ "* " ++ sn s ++ " -- " ++ serverDesc s case v of Right (mt, cr) -> do - putStrLn $ " MOTD: " ++ T.unpack mt - putStrLn $ " object count: " ++ show cr - Left e -> hPutStrLn stderr $ - " failed to get connect to " ++ sn s ++ ": " ++ e + say $ " MOTD: " ++ T.unpack mt + say $ " object count: " ++ show cr + Left e -> warn $ + " failed to connect to " ++ sn s ++ ": " ++ e failed (_, Left _) = True failed _ = False |