diff options
| -rw-r--r-- | Gpg.hs | 39 | ||||
| -rw-r--r-- | Gpg/Wot.hs | 109 | ||||
| -rw-r--r-- | TODO | 6 | ||||
| -rw-r--r-- | debug-me.cabal | 4 |
4 files changed, 148 insertions, 10 deletions
@@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings, RankNTypes, DeriveGeneric #-} - module Gpg where import Val @@ -10,11 +8,15 @@ import Crypto import Data.ByteArray (convert) import qualified Data.ByteString as B import System.IO +import System.Posix.IO hiding (createPipe) import System.Process import System.Exit import Data.List import Control.Exception import System.Directory +import Control.Concurrent.Async + +newtype GpgKeyId = GpgKeyId String newtype GpgSign = GpgSign Bool @@ -47,13 +49,20 @@ gpgSign pk = do ExitSuccess -> return $ GpgSigned pk sig ExitFailure _ -> error "gpg failed" --- | Verify the gpg signature. The key will be retrieved from a keyserver --- if possible. Gpg outputs to stderr information about who signed the +-- | Verify the gpg signature and return the keyid that signed it. +-- Also makes sure that the gpg signed data is the hash of the +-- debug-me PublicKey. +-- +-- The gpg key will be retrieved from a keyserver if necessary. +-- +-- Gpg outputs to stderr information about who signed the -- data, so that will be visible to the user when eg, prompting -- them if they want to accept a connection from that person. -gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO Bool -gpgVerify _ (UnSigned _) = return False -gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do +gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO (Maybe GpgKeyId) +gpgVerify _ (UnSigned _) = return Nothing +gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do + (statusreadh, statuswriteh) <- createPipe + statuswritefd <- handleToFd statuswriteh -- This relies on gpgSign using --clearsign, so on successful -- verification, the JSON encoded PublicKey is output to gpg's -- stdout. @@ -62,14 +71,17 @@ gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do { std_in = CreatePipe , std_out = CreatePipe } + closeFd statuswritefd B.hPut hin sig hClose hin hSetBinaryMode hout True - signeddata <- B.hGetContents hout + (signeddata, gpgkeyid) <- B.hGetContents hout + `concurrently` (parseStatusFd <$> hGetContents statusreadh) st <- waitForProcess pid return $ case st of - ExitFailure _ -> False - ExitSuccess -> val (hashValue (hash pk)) == signeddata + ExitSuccess + | val (hashValue (hash pk)) == signeddata -> gpgkeyid + _ -> Nothing where extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts then gpgopts @@ -81,3 +93,10 @@ defaultKeyServers = [ "pool.sks-keyservers.net" , "pgpkeys.mit.edu" ] + +parseStatusFd :: String -> Maybe GpgKeyId +parseStatusFd = go . map words . lines + where + go [] = Nothing + go ((_:"VALIDSIG":keyid:_):_) = Just (GpgKeyId keyid) + go (_:rest) = go rest 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 @@ -1,3 +1,9 @@ +* GPG WoT is checked by querying pgp.cs.uu.nl, could use wotsap if it's + locally installed. However, the version of wotsap in debian only supports + short, insecure keyids, so is less secure than using the server. +* Once we have a WoT path, we could download each gpg key in the path and + verify the path. This would avoid trusting pgp.cs.uu.nl not to be evil. + Not done yet, partly because downloading a lot of gpg keys is expensive. * Multiple --downloads at the same time or close together fail with "thread blocked indefinitely in an STM transaction" Also see it occasionally with --debug. diff --git a/debug-me.cabal b/debug-me.cabal index 5ffb183..0aa58d2 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -63,11 +63,14 @@ Executable debug-me , filepath (>= 1.4) , directory (>= 1.3) , containers (>= 0.5) + , unordered-containers (>= 0.2) , unbounded-delays (>= 0.1) , memory (>= 0.13) , warp (>= 3.2) , wai (>= 3.2) , http-types (>= 0.9) + , http-client (>= 0.4) + , http-client-tls (>= 0.2) , websockets (>= 0.11.1) , wai-websockets (>= 3.0) , uuid (>= 1.3) @@ -82,6 +85,7 @@ Executable debug-me DotDir Graphviz Gpg + Gpg.Wot Hash JSON Log |