Added --check-servers mode, which is useful both at the command line to see what servers keysafe knows about, and as a cron job.

This commit was sponsored by Jake Vosloo on Patreon.

5 files changed, 54 insertions, 3 deletions

diff --git a/CHANGELOG b/CHANGELOG
index 40fe268..1557009 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -12,6 +12,8 @@ keysafe (0.20160923) UNRELEASED; urgency=medium
     by Marek Isalski at Faelix. Currently located in UK, but planned move
     to CH. Currently at Alternate level until verification is complete.
   * Server: --motd can be used to provide a Message Of The Day.
+  * Added --check-servers mode, which is useful both at the command line
+    to see what servers keysafe knows about, and as a cron job.
 
  -- Joey Hess <id@joeyh.name>  Fri, 23 Sep 2016 10:40:55 -0400
 
diff --git a/CmdLine.hs b/CmdLine.hs
index 6c5bafd..702c97d 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -31,7 +31,7 @@ data CmdLine = CmdLine
 	, chaffMaxDelay :: Maybe Seconds
 	}
 
-data Mode = Backup | Restore | UploadQueued | AutoStart | Server | BackupServer FilePath | RestoreServer FilePath | Chaff HostName | Benchmark | Test
+data Mode = Backup | Restore | UploadQueued | AutoStart | Server | BackupServer FilePath | RestoreServer FilePath | Chaff HostName | CheckServers | Benchmark | Test
 	deriving (Show)
 
 data ServerConfig = ServerConfig
@@ -135,6 +135,10 @@ parseMode =
 		<> metavar "HOSTNAME"
 		<> help "Upload random data to a keysafe server."
 		)
+	<|> flag' CheckServers
+		( long "check-servers"
+		<> help "Tries to connect to each server in the server list. Displays the server's MOTD, and the amount of data stored on it. Prints message to stderr and exits nonzero if any of the servers are not accessible."
+		)
 	<|> flag' Benchmark
 		( long "benchmark"
 		<> help "Benchmark speed of keysafe's cryptographic primitives."
diff --git a/HTTP/Client.hs b/HTTP/Client.hs
index f13620e..50c5906 100644
--- a/HTTP/Client.hs
+++ b/HTTP/Client.hs
@@ -76,7 +76,7 @@ serverRequest'
 serverRequest' srv a = go Nothing (serverUrls srv)
   where
 	go lasterr [] = return $ Left $
-		maybe "no available servers" (\err -> "server failure: " ++ show err) lasterr
+		maybe "no known address" (\err -> "server failure: " ++ show err) lasterr
 	go _ (url:urls) = do
 		manager <- torableManager
 		res <- runExceptT $ a manager url
diff --git a/Types/Server.hs b/Types/Server.hs
index 785dd24..5caf9db 100644
--- a/Types/Server.hs
+++ b/Types/Server.hs
@@ -21,7 +21,7 @@ data ServerAddress = ServerAddress HostName Port
 
 -- | Name used in queuing uploads to the server. Should remain stable
 -- across keysafe versions.
-newtype ServerName = ServerName String
+newtype ServerName = ServerName { fromServerName :: String }
 	deriving (Show, Eq, Ord, Generic)
 
 instance ToJSON ServerName
diff --git a/keysafe.hs b/keysafe.hs
index 7306a29..d27f87a 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -19,10 +19,14 @@ import Cost
 import SecretKey
 import Share
 import Storage
+import Servers
 import Types.Server
 import BackupLog
 import AutoStart
+import HTTP
 import HTTP.Server
+import HTTP.Client
+import HTTP.ProofOfWork
 import ServerBackup
 import qualified Gpg
 import Data.Maybe
@@ -31,10 +35,12 @@ import Data.Time.Calendar
 import Data.Monoid
 import Data.List
 import Control.DeepSeq
+import Control.Concurrent.Async
 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 ()
@@ -80,6 +86,7 @@ dispatch cmdline ui tunables possibletunables = do
 	go (CmdLine.Chaff hn) _ = storeChaff hn
 		(CmdLine.serverPort (CmdLine.serverConfig cmdline))
 		(CmdLine.chaffMaxDelay cmdline)
+	go CmdLine.CheckServers _ = checkServers
 	go CmdLine.Benchmark _ =
 		benchmarkTunables tunables
 	go CmdLine.Test _ =
@@ -401,3 +408,41 @@ autoStart cmdline tunables ui = do
 					=<< Gpg.getSecretKey kid
 				else storeBackupLog
 					=<< mkBackupLog (BackupSkipped (GpgKey kid))
+
+checkServers :: IO ()
+checkServers = do
+	putStrLn $ "Checking " ++ show (length networkServers) ++ " servers concurrently; please wait..."
+	results <- mapConcurrently check networkServers
+	mapM_ display results
+	case filter failed results of
+		[] -> return ()
+		l
+			| length l == length networkServers ->
+				error "Failed to connect to any servers. Perhaps TOR is not running?"
+			| otherwise -> 
+				error $ "Failed to connect to some servers: "
+					++ show (map (sn . fst) l)
+  where
+	check s = do
+		m <- serverRequest' s motd
+		c <- serverRequest s Left Right NoPOWIdent countObjects
+		case (m, c) of
+			(Right (Motd mt), Right (CountResult cr)) ->
+				return (s, Right (mt, cr))
+			(Left e, _) -> return (s, Left e)
+			(_, Left e) -> return (s, Left e)
+			(_, Right (CountFailure e)) -> return (s, Left e)
+
+	display (s, v) = do
+		putStrLn $ "* " ++ 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
+
+	failed (_, Left _) = True
+	failed _ = False
+
+	sn = fromServerName . serverName