Functional add command for adding subkeys to a gpg keyring.

1 files 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