diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-04-29 12:23:29 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-04-29 13:07:48 -0400 |
commit | 237b94f6c687675215f78fba28d7e003a2b9ab7d (patch) | |
tree | e4c2c6144e1d5563218b8686cee508146a1370c8 /Gpg | |
parent | 46245781f26d49037102a4c74001f47a345fa567 (diff) | |
download | debug-me-237b94f6c687675215f78fba28d7e003a2b9ab7d.tar.gz |
add Gpg web of trust parser
Diffstat (limited to 'Gpg')
-rw-r--r-- | Gpg/Wot.hs | 109 |
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 |