From 73a310ce49c91f0884d05a8d2cd8c96c3c5447d3 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sat, 20 May 2017 17:09:28 -0400
Subject: developer keyring verification

* gpg keyrings in /usr/share/debug-me/ will be checked
  to see if a connecting person is a known developer of software
  installed on the system, and so implicitly trusted already.
  Software packages/projects can install keyrings to that location.
  (Thanks to Sean Whitton for the idea.)
* make install will install /usr/share/debug-me/debug-me_developer.gpg,
  which contains the key of Joey Hess. (stack and cabal installs don't
  include this file because they typically don't install system-wide)
* debug-me.cabal: Added dependency on time.

This commit was sponsored by Francois Marier on Patreon.
---
 Gpg/Keyring.hs | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 Gpg/Wot.hs     |  5 +++-
 2 files changed, 77 insertions(+), 1 deletion(-)
 create mode 100644 Gpg/Keyring.hs

(limited to 'Gpg')

diff --git a/Gpg/Keyring.hs b/Gpg/Keyring.hs
new file mode 100644
index 0000000..a0fa242
--- /dev/null
+++ b/Gpg/Keyring.hs
@@ -0,0 +1,73 @@
+{- Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+-- | Gpg keyrings for debug-me
+
+module Gpg.Keyring where
+
+import Gpg
+import qualified Gpg.Wot
+
+import System.FilePath
+import Data.Char
+import System.Directory
+import Data.Time.Clock
+import Data.Time.Format
+import System.Process
+import System.Exit
+
+keyringDir :: FilePath
+keyringDir = "/usr/share/debug-me/keyring"
+
+data Keyring = Keyring FilePath UTCTime
+
+keyringToDeveloperDesc :: Maybe (Gpg.Wot.WotStats) -> Keyring -> String
+keyringToDeveloperDesc mws (Keyring f mtime) =
+	name ++ " is " ++ desc ++ " \t(as of " ++ showtime mtime ++ ")"
+  where
+	name = maybe "This person" Gpg.Wot.wotStatName mws
+	desc = map sanitize $ dropExtension $ takeFileName f
+	sanitize '_' = ' '
+	sanitize c
+		| isAlphaNum c || c `elem` "-+" = c
+		| otherwise = '?'
+	showtime = formatTime defaultTimeLocale "%c"
+
+findKeyringsContaining :: GpgKeyId -> IO [Keyring]
+findKeyringsContaining k = 
+	go [] . map (keyringDir </>) =<< getDirectoryContents keyringDir
+  where
+	go c [] = return c
+	go c (f:fs) = do
+		isfile <- doesFileExist f
+		if isfile && takeExtension f == ".gpg"
+			then do
+				inkeyring <- isInKeyring k f
+				if inkeyring
+					then do
+						mtime <- getModificationTime f
+						let keyring = Keyring f mtime
+						go (keyring : c) fs
+					else go c fs
+			else go c fs
+
+-- | Check if the gpg key is included in the keyring file.
+--
+-- Similar to gpgv, this does not check if the key is revoked or expired,
+-- only if it's included in the keyring.
+isInKeyring :: GpgKeyId -> FilePath -> IO Bool
+isInKeyring (GpgKeyId k) f = do
+	-- gpg assumes non-absolute keyring files are relative to ~/.gnupg/
+	absf <- makeAbsolute f
+	let p = proc "gpg"
+		-- Avoid reading any keyrings except the specified one.
+		[ "--no-options"
+		, "--no-default-keyring"
+		, "--no-auto-check-trustdb"
+		, "--keyring", absf
+		, "--list-key", k
+		]
+	(exitcode, _, _) <- readCreateProcessWithExitCode p ""
+	return (exitcode == ExitSuccess)
diff --git a/Gpg/Wot.hs b/Gpg/Wot.hs
index b29ccc7..2a6d541 100644
--- a/Gpg/Wot.hs
+++ b/Gpg/Wot.hs
@@ -107,7 +107,7 @@ describeWot (Just ws) (StrongSetAnalysis ss)
 		, theirname ++ " is probably a real person."
 		]
   where
-	theirname = stripEmail (uid (key ws))
+	theirname = wotStatName ws
 	sigs = cross_sigs ws ++ other_sigs ws
 	bestconnectedsigs = sortOn rank sigs
 describeWot Nothing _ =
@@ -115,5 +115,8 @@ describeWot Nothing _ =
 	, "Their identity cannot be verified!"
 	]
 
+wotStatName :: WotStats -> String
+wotStatName ws = stripEmail (uid (key ws))
+
 stripEmail :: String -> String
 stripEmail = unwords . takeWhile (not . ("<" `isPrefixOf`)) . words
-- 
cgit v1.2.3