add Gpg web of trust parser

1 files changed, 109 insertions, 0 deletions

diff --git a/Gpg/Wot.hs b/Gpg/Wot.hs
new file mode 100644
index 0000000..fc7b8a4
--- /dev/null
+++ b/Gpg/Wot.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+-- | Gpg web of trust checking, using wotsap's JSON output
+
+module Gpg.Wot where
+
+import Gpg
+import JSON
+
+import Network.HTTP.Client
+import Network.HTTP.Client.TLS
+import Data.List
+import qualified Data.HashMap.Strict as M
+import qualified Data.Text as T
+
+data WotStats = WotStats
+	{ key :: Node
+	, cross_sigs :: [Node]
+	, key_signed :: [Node]
+	, other_sigs :: [Node]
+	}
+	deriving (Show, Generic)
+
+data WotPath = WotPath
+	{ from :: Node
+	, to :: Node
+	, xpaths :: [[Node]]
+	}
+	deriving (Show, Generic)
+
+data Node = Node
+	{ kid :: String
+	, msd :: Double
+	, rank :: Integer
+	, uid :: String
+	}
+	deriving (Show, Generic)
+
+-- | wotsap's json has some upper-case fields; lowercase field for parsing
+jsonLower :: Value -> Value
+jsonLower (Object o) = Object . M.fromList . map lowerPair . M.toList $ o
+  where
+	lowerPair (k, v) = (T.toLower k, v)
+jsonLower x = x
+
+instance FromJSON WotStats where
+	parseJSON = genericParseJSON defaultOptions . jsonLower
+
+instance FromJSON WotPath where
+	parseJSON = genericParseJSON defaultOptions . jsonLower
+
+instance FromJSON Node where
+	parseJSON = genericParseJSON defaultOptions . jsonLower
+
+wotServer :: String
+wotServer = "https://pgp.cs.uu.nl/"
+
+downloadWotStats :: GpgKeyId -> IO (Maybe WotStats)
+downloadWotStats (GpgKeyId k) = do
+	manager <- newTlsManager
+	request <- parseRequest url
+	response <- httpLbs request manager
+	return $ decode (responseBody response)
+  where
+	url = wotServer ++ "/stats/" ++ k ++ ".json"
+
+downloadWotPath :: GpgKeyId -> GpgKeyId -> IO (Maybe WotPath)
+downloadWotPath (GpgKeyId fromid) (GpgKeyId toid) = do
+	manager <- newTlsManager
+	request <- parseRequest url
+	response <- httpLbs request manager
+	return $ decode (responseBody response)
+  where
+	url = wotServer ++ "/paths/" ++ fromid ++ "/to/" ++ toid ++ ".json"
+
+-- | A key that is known to be in the strong set.
+--
+-- This could be any key in the gpg strong set. Currently, it's
+-- Joey Hess's key, which is in the strong set and belongs to the author of
+-- this program, which the user must implicitly trust since they're running
+-- it. But any key in the strong set would work as well; this is only used
+-- to determine if other keys have a path into the strong set.
+knownKeyInStrongSet :: GpgKeyId
+knownKeyInStrongSet = GpgKeyId "E85A5F63B31D24C1EBF0D81CC910D9222512E3C7"
+
+newtype StrongSetAnalysis = StrongSetAnalysis Bool
+
+isInStrongSet :: GpgKeyId -> IO StrongSetAnalysis
+isInStrongSet k = maybe (StrongSetAnalysis False) (const $ StrongSetAnalysis True)
+	<$> downloadWotPath k knownKeyInStrongSet
+
+describeWot :: WotStats -> StrongSetAnalysis -> String
+describeWot ws (StrongSetAnalysis ss)
+	| ss == False = theirname ++ "'s identity cannot be verified!"
+	| otherwise = unlines $
+		[ theirname ++ "'s identity has been verified by as many as "
+			++ show (length sigs) ++ " people, including:"
+		, intercalate ", " $ take 10 $ map (stripEmail . uid) bestconnectedsigs
+		, ""
+		, theirname ++ " is probably a real person."
+		]
+  where
+	theirname = stripEmail (uid (key ws))
+	sigs = cross_sigs ws ++ other_sigs ws
+	nsigs = length sigs
+	bestconnectedsigs = sortOn rank sigs
+
+stripEmail :: String -> String
+stripEmail = unwords . takeWhile (not . ("<" `isPrefixOf`)) . words