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.

1 files changed, 45 insertions, 0 deletions

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