From 0b65ae400ee5f2d04b188c618a5927aa7113d9be Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 30 Oct 2013 18:59:19 -0400 Subject: Functional add command for adding subkeys to a gpg keyring. --- keys.hs | 356 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 346 insertions(+), 10 deletions(-) diff --git a/keys.hs b/keys.hs index 10bec0c..c36a01e 100644 --- a/keys.hs +++ b/keys.hs @@ -25,6 +25,7 @@ import Data.Bits import qualified Data.Text as T import Data.Text.Encoding import qualified Codec.Binary.Base32 as Base32 +import qualified Codec.Binary.Base64 as Base64 import qualified Crypto.Hash.SHA1 as SHA1 import Data.Char (toLower) import qualified Crypto.PubKey.RSA as RSA @@ -44,9 +45,11 @@ import System.Console.CmdArgs -- import System.Posix.Time import Data.Time.Clock.POSIX import System.Posix.IO (fdToHandle,fdRead) +import System.Posix.Files import Data.Monoid ((<>)) +-- import Data.X509 -data RSAPublicKey = RSAKey MPI MPI +data RSAPublicKey = RSAKey MPI MPI deriving Show instance ASN1Object RSAPublicKey where toASN1 (RSAKey (MPI n) (MPI e)) @@ -60,6 +63,77 @@ instance ASN1Object RSAPublicKey where fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format" +data RSAPrivateKey = RSAPrivateKey + { rsaN :: MPI + , rsaE :: MPI + , rsaD :: MPI + , rsaP :: MPI + , rsaQ :: MPI + , rsaDmodP1 :: MPI + , rsaDmodQminus1 :: MPI + , rsaCoefficient :: MPI + } + deriving Show + +{- +RSAPrivateKey ::= SEQUENCE { + version Version, + modulus INTEGER, -- n + publicExponent INTEGER, -- e + privateExponent INTEGER, -- d + prime1 INTEGER, -- p + prime2 INTEGER, -- q + exponent1 INTEGER, -- d mod (p1) + exponent2 INTEGER, -- d mod (q-1) + coefficient INTEGER, -- (inverse of q) mod p + otherPrimeInfos OtherPrimeInfos OPTIONAL +} +-} + +instance ASN1Object RSAPrivateKey where + toASN1 rsa@(RSAPrivateKey {}) + = \xs -> Start Sequence + : IntVal 0 + : mpiVal rsaN + : mpiVal rsaE + : mpiVal rsaD + : mpiVal rsaP + : mpiVal rsaQ + : mpiVal rsaDmodP1 + : mpiVal rsaDmodQminus1 + : mpiVal rsaCoefficient + : End Sequence + : xs + where mpiVal f = IntVal x where MPI x = f rsa + + fromASN1 ( Start Sequence + : IntVal _ -- version + : IntVal n + : IntVal e + : IntVal d + : IntVal p + : IntVal q + : IntVal dmodp1 + : IntVal dmodqminus1 + : IntVal coefficient + : ys) = + Right ( privkey, tail $ dropWhile notend ys) + where + notend (End Sequence) = False + notend _ = True + privkey = RSAPrivateKey + { rsaN = MPI n + , rsaE = MPI e + , rsaD = MPI d + , rsaP = MPI p + , rsaQ = MPI q + , rsaDmodP1 = MPI dmodp1 + , rsaDmodQminus1 = MPI dmodqminus1 + , rsaCoefficient = MPI coefficient + } + fromASN1 _ = + Left "fromASN1: RSAPrivateKey: unexpected format" + rsaKeyFromPacket p@(PublicKeyPacket {}) = do n <- lookup 'n' $ key p e <- lookup 'e' $ key p @@ -93,6 +167,15 @@ secretToPublic pkt@(SecretKeyPacket {}) = } secretToPublic pkt = pkt + +extractPEM typ pem = dta + where + dta = case ys of + _:dta_lines -> Char8.concat dta_lines + [] -> "" + xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem) + ys = takeWhile (/="-----END " <> typ <> "-----") xs + isKey (PublicKeyPacket {}) = True isKey (SecretKeyPacket {}) = True isKey _ = False @@ -117,6 +200,8 @@ isSubkeySignature _ = False isMasterKey k@(PublicKeyPacket {}) = not $ is_subkey k isMasterKey _ = False +now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime + usage (NotationDataPacket { human_readable = True , notation_name = "usage@" @@ -146,6 +231,8 @@ grip k = drop 32 $ fingerprint k smallpr k = drop 24 $ fingerprint k +-- matchpr computes the fingerprint of the given key truncated to +-- be the same lenght as the given fingerprint for comparison. matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp @@ -590,6 +677,46 @@ multiCommand ti choices = trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs +guessKeyFormat 'P' "ssh-client" = "SSH" +guessKeyFormat 'S' "ssh-client" = "PEM" +guessKeyFormat 'S' "ssh-host" = "PEM" +guessKeyFormat _ _ = "PEM" -- "PGP" + +readKeyFromFile False "PEM" fname = do + timestamp <- modificationTime <$> getFileStatus fname + input <- L.readFile fname + let dta = extractPEM "RSA PRIVATE KEY" input + -- Char8.putStrLn $ "dta = " <> dta + let rsa = do + e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta) + asn1 <- either (const Nothing) Just e + k <- either (const Nothing) (Just . fst) (fromASN1 asn1) + let _ = k :: RSAPrivateKey + return k + -- putStrLn $ "rsa = "++ show rsa + return . Message $ do + rsa <- maybeToList rsa + return $ SecretKeyPacket + { version = 4 + , timestamp = toEnum (fromEnum timestamp) + , key_algorithm = RSA + , key = [ -- public fields... + ('n',rsaN rsa) + ,('e',rsaE rsa) + -- secret fields + ,('d',rsaD rsa) + ,('p',rsaQ rsa) -- Note: p & q swapped + ,('q',rsaP rsa) -- Note: p & q swapped + ,('u',rsaCoefficient rsa) + ] + , s2k_useage = 0 + , s2k = S2K 100 "" + , symmetric_algorithm = Unencrypted + , encrypted_data = "" + , is_subkey = True + } +readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) + data Arguments = List { homedir :: Maybe FilePath } | WorkingKey { homedir :: Maybe FilePath } @@ -599,8 +726,25 @@ data Arguments = , output :: FilePath} | Public { homedir :: Maybe FilePath , output :: FilePath} + | Add { homedir :: Maybe FilePath + , passphrase_fd :: Maybe Int + , key_usage :: String + , seckey :: String + , output :: FilePath } + | PemFP { homedir :: Maybe FilePath + , seckey :: String } + | Decrypt { homedir :: Maybe FilePath + , passphrase_fd :: Maybe Int + , output :: FilePath } deriving (Show, Data, Typeable) +getPassphrase cmd = + case passphrase_fd cmd of + Just fd -> do pwh <- fdToHandle (toEnum fd) + fmap trimCR $ S.hGetContents pwh + Nothing -> return "" + + #define HOMEOPTION (def &= explicit &= name "homedir" &= typDir ) main = do @@ -610,9 +754,13 @@ main = do &= auto , WorkingKey HOMEOPTION &= help "Shows the current working key set that will be used to make signatures." + , Public HOMEOPTION + (def &= argPos 1 &= typFile ) + &= help "Extract public keys into the given file." , AutoSign HOMEOPTION (def &= opt ("passphrase"::String) - &= (help . concat) ["file descriptor from" + &= typ "FD" + &= (help . concat) ["file descriptor from " ,"which to read passphrase"]) (def &= argPos 1 &= typFile ) (def &=argPos 2 &= typFile) @@ -620,9 +768,36 @@ main = do [ "Copies the first file to the second while adding" , " signatures for tor-style uids that match" , " cross-certified keys." ] - , Public HOMEOPTION - (def &= argPos 1 &= typFile ) - &= help "Extract public keys into the given file." + , Decrypt HOMEOPTION + (def &= opt ("passphrase"::String) + &= typ "FD" + &= (help . concat) ["file descriptor from " + ,"which to read passphrase"]) + (def &= argPos 1 &= typFile ) + -- (def &= argPos 3 &= typ "PUBLIC-KEY") + &= (help . concat) + [ "Remove password protection from the working keyring" + , " and save the result into the given file."] + , Add HOMEOPTION + (def &= opt ("passphrase"::String) + &= typ "FD" + &= (help . concat) ["file descriptor from " + ,"which to read passphrase"]) + (def &= argPos 1 &= typ "USAGE") + (def &= argPos 2 &= typ "PRIVATE-KEY") + (def &= argPos 3 &= typFile) + -- (def &= argPos 3 &= typ "PUBLIC-KEY") + &= (help . concat) + [ "Add a subkey." + , " USAGE is the usage@ annotation of the subkey." + , " Keys are specified as FMT:FILE where" + , " FMT may be one of following: PEM." + , " Results are written to the given file." ] + + , PemFP HOMEOPTION + (def &= argPos 1 &= typFile ) + &= (help . concat) + [ "Display the fingerprint of a PEM key pair."] ] &= program "keys" &= summary "keys - a pgp key editing utility" @@ -762,6 +937,8 @@ main = do doCmd cmd@(WorkingKey {}) = do (homedir,secring,grip) <- getHomeDir cmd (Message sec) <- readPacketsFromFile secring + -- let s2k' = map s2k (filter isKey sec) + -- putStrLn $ "s2k = " ++ show s2k' putStrLn $ listKeysFiltered (maybeToList grip) sec return () @@ -771,10 +948,7 @@ main = do , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" ) <- getPGPEnviron cmd S8.putStrLn $ "pasphrase_fd = " <> S8.pack (show (passphrase_fd cmd)) - pw <- case passphrase_fd cmd of - Just fd -> do pwh <- fdToHandle (toEnum fd) - fmap trimCR $ S.hGetContents pwh - Nothing -> return "" + pw <- getPassphrase cmd -- putStrLn $ "getPGPEnviron -> " ++ show (homedir,length sec,grip) (Message pub) <- readPacketsFromFile (input cmd) putStrLn $ listKeys pub @@ -800,8 +974,8 @@ main = do isTorID _ = False g <- newGenIO + timestamp <- now -- timestamp <- epochTime - timestamp <- floor <$> Data.Time.Clock.POSIX.getPOSIXTime let xs:xss = groupBy (\_ (b,_)->not b) marked pub' = map (snd . cleanup) xs ++ concatMap (signSelfAuthTorKeys pw (g::SystemRandom) sec grip timestamp) @@ -823,6 +997,161 @@ main = do bs = encode (Message pub) L.writeFile (output cmd) bs + doCmd cmd@(Decrypt {}) = do + ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome + , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg + , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" + ) <- getPGPEnviron cmd + pw <- getPassphrase cmd + + let sec' = map decrypt sec + decrypt k@(SecretKeyPacket {}) = k -- TODO + + L.writeFile (output cmd) (encode $ Message sec') + + {- + let wk = grip >>= find_key fingerprint (Message sec) + case wk of + Nothing -> error "No working key?" + Just wk -> do + putStrLn $ "wk = " ++ fingerprint wk + -} + + doCmd cmd@(Add {}) = do + ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome + , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg + , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" + ) <- getPGPEnviron cmd + pw <- getPassphrase cmd + + flip (maybe (error "No working key?")) grip $ \grip -> do + + let (pre, wk:subs) = seek_key grip sec + wkun = do + k <- decryptSecretKey pw wk + guard (symmetric_algorithm k == Unencrypted) + return k + + flip (maybe (error "Bad passphrase?")) wkun$ \wkun -> do + + let (uids,subkeys) = break isSubkey subs + isSubkey p = isKey p && is_subkey p + + let parseKeySpec hint spec = case break (==':') spec of + (fmt,_:file) -> (fmt,file) + (file,"") -> (guessKeyFormat hint (key_usage cmd), file) + (secfmt,secfile) = parseKeySpec 'S' $ seckey cmd + -- (pubfmt,pubfile) = parseKeySpec 'P' $ pubkey cmd + Message parsedkey <- readKeyFromFile False secfmt secfile + -- -- Message pubkey <- readKeyFromFile True pubfmt pubfile + + -- putStrLn $ "parsedkey = " ++ show (head parsedkey) + -- putStrLn $ "----------" + + {- + let seckeys = filter isSecretKey sec + isSecretKey (SecretKeyPacket {}) = True + isSecretKey _ = False + algos = map symmetric_algorithm seckeys + putStrLn $ show $ symmetric_algorithm wk + putStrLn $ show $ s2k wk + putStrLn $ show $ s2k_useage wk + putStrLn $ PP.ppShow sec + let -- e = encryptSecretKey wk pw (head seckey) + e = head seckey + d = if symmetric_algorithm e /= Unencrypted + then maybeToList $ decryptSecretKey pw e + else [e] + putStrLn $ "e = " ++ show (e) + -} + -- putStrLn $ "wkun = " ++ show wkun + -- putStrLn $ "head subkeys = " ++ show (head subkeys) + + g <- newGenIO + timestamp <- now + + let + new_sig = fst $ sign (Message [wkun]) + (SubkeySignature wk + (head parsedkey) + (sigpackets 0x18 + hashed0 + ( IssuerPacket (fingerprint wk) + : map EmbeddedSignaturePacket (signatures_over back_sig)))) + SHA1 + grip + timestamp + (g::SystemRandom) + sigpackets typ hashed unhashed = return $ + signaturePacket + 4 -- version + typ -- 0x18 subkey binding sig, or 0x19 back-signature + RSA + SHA1 + hashed + unhashed + 0 -- Word16 -- Left 16 bits of the signed hash value + [] -- [MPI] + + hashed0 = + [ KeyFlagsPacket + { certify_keys = True + , sign_data = True + , encrypt_communication = True + , encrypt_storage = True + , split_key = False + , authentication = True + , group_key = False } + , NotationDataPacket + { human_readable = True + , notation_name = "usage@" + , notation_value = key_usage cmd + } + ] + + subgrip = fingerprint (head parsedkey) + + back_sig = fst $ sign (Message parsedkey) + (SubkeySignature wk + (head parsedkey) + (sigpackets 0x19 + hashed0 + [IssuerPacket subgrip])) + SHA1 + subgrip + timestamp + (g::SystemRandom) + + let sec' = pre ++ [wk] ++ uids ++ parsedkey ++ signatures_over new_sig ++ subkeys + putStrLn $ listKeys sec' + + L.writeFile (output cmd) (encode (Message sec')) + + {- + let backsigs = do + sig <- signatures (Message sec') + sigover <- signatures_over sig + subp <- unhashed_subpackets sigover + -- guard (isEmbeddedSignature subp) + subp <- maybeToList (backsig subp) + over <- signatures (Message (filter isKey sec ++ [subp])) + return over + + -- putStrLn $ PP.ppShow backsigs + -} + + return () + + doCmd cmd@(PemFP {}) = do + let parseKeySpec hint spec = case break (==':') spec of + (fmt,_:file) -> (fmt,file) + (file,"") -> (guessKeyFormat hint ("ssh-host"), file) + (secfmt,secfile) = parseKeySpec 'S' $ seckey cmd + Message seckey <- readKeyFromFile False secfmt secfile + -- Message pubkey <- readKeyFromFile True pubfmt pubfile + putStrLn $ fingerprint (head seckey) + + groupBindings pub = @@ -836,3 +1165,10 @@ groupBindings pub = gs = {- filter matchgrip $ -} groupBy sameMaster (sortBy (comparing code) bindings') in gs + +seek_key :: String -> [Packet] -> ([Packet],[Packet]) +seek_key grip sec = (pre, subs) + where + (pre,subs) = break pred sec + pred p@(SecretKeyPacket {}) = matchpr grip p == grip + pred _ = False -- cgit v1.2.3