From 57b0915f92f5590c1d1716f23264f7aa73966976 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 4 May 2017 17:04:36 -0400
Subject: forgot to add!

---
 CHANGELOG |   5 +++
 Verify.hs | 107 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 112 insertions(+)
 create mode 100644 CHANGELOG
 create mode 100644 Verify.hs

diff --git a/CHANGELOG b/CHANGELOG
new file mode 100644
index 0000000..4a5f90f
--- /dev/null
+++ b/CHANGELOG
@@ -0,0 +1,5 @@
+debug-me (1.20170505) unstable; urgency=medium
+
+  * First release of debug-me.
+
+ -- Joey Hess <id@joeyh.name>  Thu, 04 May 2017 17:03:19 -0400
diff --git a/Verify.hs b/Verify.hs
new file mode 100644
index 0000000..b2f3805
--- /dev/null
+++ b/Verify.hs
@@ -0,0 +1,107 @@
+{- Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Verify (verify) where
+
+import Types
+import Log
+import CmdLine
+import Crypto
+import Gpg
+import Hash
+import PrevActivity
+
+import Control.Concurrent.STM
+import Data.Maybe
+
+verify :: VerifyOpts -> IO ()
+verify opts = go 1 startState =<< streamLog (verifyLogFile opts)
+  where
+	go _ _ [] = putStrLn "Log file verified. All signatures and hashes are valid."
+	go lineno st (Right lmsg:rest) = do
+		-- The log may have hashes removed, as it went over the
+		-- wire; restore hashes.
+		let ra = mkRecentActivity st
+		msg <- atomically $ restoreHashes ra $ 
+				MissingHashes $ loggedMessage lmsg
+
+		-- Learn session keys before verifying signatures.
+		st' <- case msg of
+			User (ControlMessage (Control { control = SessionKey sk })) ->
+				addSessionKey lineno sk st
+			Developer (ControlMessage (Control { control = SessionKey sk })) ->
+				addSessionKey lineno sk st
+			_ -> return st
+
+		case (verifySigned (sigVerifier st') msg, verifyHashChain msg st') of
+			(True, True) -> return ()
+			(False, _) -> lineError lineno 
+				"Failed to verify message signature."
+			(_, False) -> lineError lineno
+				"Invalid hash chain."
+
+		go (succ lineno) (addPrevHash msg st') rest
+	go lineno _ (Left l:_) = lineError lineno $
+		"Failed to parse a line of the log: " ++ l
+
+lineError :: Integer -> String -> a
+lineError lineno err = error $ "Line " ++ show lineno ++ ": " ++ err
+
+data State = State
+	{ sigVerifier :: SigVerifier
+	, prevHashes :: [Hash]
+	}
+	deriving (Show)
+
+startState :: State
+startState = State
+	{ sigVerifier = mempty
+	, prevHashes = mempty -- ^ in reverse order
+	}
+
+mkRecentActivity :: State -> RecentActivity
+mkRecentActivity st = return (sigVerifier st, prevHashes st)
+
+addSessionKey :: Integer -> PerhapsSigned PublicKey -> State -> IO State
+addSessionKey lineno p@(GpgSigned pk _ _) st = do
+	mkid <- gpgVerify p
+	case mkid of
+		Nothing -> lineError lineno "Bad GnuPG signature."
+		Just _ -> do
+			putStrLn "The person above participated in the debug-me session."
+			addSessionKey lineno (UnSigned pk) st
+addSessionKey _lineno (UnSigned pk) st = do
+	let v = mkSigVerifier pk
+	return $ st { sigVerifier = sigVerifier st `mappend` v }
+
+-- | Add the hash of the message to the state.
+addPrevHash :: AnyMessage -> State -> State
+addPrevHash am s = case mh of
+	Just h -> s { prevHashes = h : prevHashes s }
+	Nothing -> s
+  where
+	mh = case am of
+		User (ActivityMessage m) -> Just (hash m)
+		User (ControlMessage _) -> Nothing
+		Developer (ActivityMessage m) -> Just (hash m)
+		Developer (ControlMessage _) -> Nothing
+
+-- | Verify that prevActivity and prevEntered point to previously
+-- seen hashes.
+--
+-- While Role.User and Role.Developer enforce rules about which
+-- hashes they may point to, here we don't check such rules. If the log
+-- continues with other messages referring to this one, then this message
+-- must have met the rules, and if it did not, then this message is
+-- irrelevant.
+verifyHashChain :: AnyMessage -> State -> Bool
+verifyHashChain am s = case am of
+	User (ControlMessage _) -> True
+	Developer (ControlMessage _) -> True
+	User (ActivityMessage m) -> checkm m
+	Developer (ActivityMessage m) -> checkm m
+  where
+	checkm m = all (\h -> h `elem` prevHashes s)
+		(catMaybes [prevActivity m, prevEntered m])
-- 
cgit v1.2.3