summaryrefslogtreecommitdiff
path: root/KeyRing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'KeyRing.hs')
-rw-r--r--KeyRing.hs171
1 files changed, 121 insertions, 50 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index 50702ae..0bf3e32 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -131,7 +131,7 @@ import Data.Text.Encoding ( encodeUtf8 )
131import qualified Data.Map as Map 131import qualified Data.Map as Map
132import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile 132import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile
133 , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt 133 , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt
134 , index ) 134 , index, break, pack )
135import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, putStr ) 135import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, putStr )
136import qualified Codec.Binary.Base32 as Base32 136import qualified Codec.Binary.Base32 as Base32
137import qualified Codec.Binary.Base64 as Base64 137import qualified Codec.Binary.Base64 as Base64
@@ -249,6 +249,7 @@ type Initializer = String
249data FileType = KeyRingFile 249data FileType = KeyRingFile
250 | PEMFile 250 | PEMFile
251 | WalletFile 251 | WalletFile
252 | DNSPresentation
252 | Hosts 253 | Hosts
253 254
254-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected 255-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected
@@ -335,9 +336,10 @@ isring :: FileType -> Bool
335isring (KeyRingFile {}) = True 336isring (KeyRingFile {}) = True
336isring _ = False 337isring _ = False
337 338
338ispem :: FileType -> Bool 339isSecretKeyFile :: FileType -> Bool
339ispem (PEMFile {}) = True 340isSecretKeyFile PEMFile = True
340ispem _ = False 341isSecretKeyFile DNSPresentation = True
342isSecretKeyFile _ = False
341 343
342{- 344{-
343pwfile :: FileType -> Maybe InputFile 345pwfile :: FileType -> Maybe InputFile
@@ -1183,13 +1185,13 @@ cachedContents maybePrompt ctx fd = do
1183 writeIORef ref (Just pw) 1185 writeIORef ref (Just pw)
1184 return pw 1186 return pw
1185 1187
1186importPEMKey :: 1188importSecretKey ::
1187 (MappedPacket -> IO (KikiCondition Packet)) 1189 (MappedPacket -> IO (KikiCondition Packet))
1188 -> KikiCondition 1190 -> KikiCondition
1189 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) 1191 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
1190 -> (FilePath, Maybe [Char], [KeyKey], t) 1192 -> (FilePath, Maybe [Char], [KeyKey], FileType, t)
1191 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 1193 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
1192importPEMKey doDecrypt db' tup = do 1194importSecretKey doDecrypt db' tup = do
1193 try db' $ \(db',report0) -> do 1195 try db' $ \(db',report0) -> do
1194 r <- doImport doDecrypt 1196 r <- doImport doDecrypt
1195 db' 1197 db'
@@ -1423,7 +1425,7 @@ buildKeyDB ctx grip0 keyring = do
1423 (n,stream) <- Map.toList $ opFiles keyring 1425 (n,stream) <- Map.toList $ opFiles keyring
1424 grip <- maybeToList grip 1426 grip <- maybeToList grip
1425 n <- resolveInputFile ctx n 1427 n <- resolveInputFile ctx n
1426 guard $ spillable stream && ispem (typ stream) 1428 guard $ spillable stream && isSecretKeyFile (typ stream)
1427 let us = mapMaybe usageFromFilter [fill stream,spill stream] 1429 let us = mapMaybe usageFromFilter [fill stream,spill stream]
1428 usage <- take 1 us 1430 usage <- take 1 us
1429 guard $ all (==usage) $ drop 1 us 1431 guard $ all (==usage) $ drop 1 us
@@ -1431,9 +1433,9 @@ buildKeyDB ctx grip0 keyring = do
1431 let (topspec,subspec) = parseSpec grip usage 1433 let (topspec,subspec) = parseSpec grip usage
1432 ms = map fst $ filterMatches topspec (Map.toList db) 1434 ms = map fst $ filterMatches topspec (Map.toList db)
1433 cmd = initializer stream 1435 cmd = initializer stream
1434 return (n,subspec,ms,cmd) 1436 return (n,subspec,ms,typ stream, cmd)
1435 imports <- filterM (\(n,_,_,_) -> doesFileExist n) pems 1437 imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems
1436 db <- foldM (importPEMKey doDecrypt) (KikiSuccess (db,[])) imports 1438 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports
1437 try db $ \(db,reportPEMs) -> do 1439 try db $ \(db,reportPEMs) -> do
1438 1440
1439 r <- mergeHostFiles keyring db ctx 1441 r <- mergeHostFiles keyring db ctx
@@ -1551,26 +1553,43 @@ decodeBlob cert =
1551 bs = pcertBlob cert 1553 bs = pcertBlob cert
1552 key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert 1554 key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert
1553 1555
1556extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey
1557extractRSAKeyFields kvs = do
1558 let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs
1559 n <- lookup "Modulus" kvs'
1560 e <- lookup "PublicExponent" kvs'
1561 d <- lookup "PrivateExponent" kvs'
1562 p <- lookup "Prime1" kvs' -- p
1563 q <- lookup "Prime2" kvs' -- q
1564 dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1)
1565 dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1)
1566 u <- lookup "Coefficient" kvs'
1567 {-
1568 case (d,p,dmodp1) of
1569 (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return ()
1570 _ -> error "dmodp fail!"
1571 case (d,q,dmodqminus1) of
1572 (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return ()
1573 _ -> error "dmodq fail!"
1574 -}
1575 return $ RSAPrivateKey
1576 { rsaN = n
1577 , rsaE = e
1578 , rsaD = d
1579 , rsaP = p
1580 , rsaQ = q
1581 , rsaDmodP1 = dmodp1
1582 , rsaDmodQminus1 = dmodqminus1
1583 , rsaCoefficient = u }
1584 where
1585 parseField blob = MPI <$> m
1586 where m = bigendian <$> Base64.decode (Char8.unpack blob)
1554 1587
1555readSecretPEMFile :: InputFile -> IO [SecretPEMData] 1588 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
1556readSecretPEMFile fname = do 1589 where
1557 -- warn $ fname ++ ": reading ..." 1590 nlen = length bs
1558 let ctx = InputFileContext "" "" 1591
1559 -- Note: The key's timestamp is included in it's fingerprint. 1592rsaToPGP stamp rsa = SecretKeyPacket
1560 -- Therefore, we should attempt to preserve it.
1561 stamp <- getInputFileTime ctx fname
1562 input <- readInputFileL ctx fname
1563 let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
1564 pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
1565 $ pemParser $ Just "RSA PRIVATE KEY"
1566 cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
1567 $ pemParser $ Just "CERTIFICATE"
1568 parseRSAPrivateKey dta = do
1569 let e = decodeASN1 DER dta
1570 asn1 <- either (const $ mzero) return e
1571 rsa <- either (const mzero) (return . fst) (fromASN1 asn1)
1572 let _ = rsa :: RSAPrivateKey
1573 return $ PEMPacket $ SecretKeyPacket
1574 { version = 4 1593 { version = 4
1575 , timestamp = fromTime stamp -- toEnum (fromEnum stamp) 1594 , timestamp = fromTime stamp -- toEnum (fromEnum stamp)
1576 , key_algorithm = RSA 1595 , key_algorithm = RSA
@@ -1590,6 +1609,52 @@ readSecretPEMFile fname = do
1590 , encrypted_data = "" 1609 , encrypted_data = ""
1591 , is_subkey = True 1610 , is_subkey = True
1592 } 1611 }
1612
1613readSecretDNSFile :: InputFile -> IO Packet
1614readSecretDNSFile fname = do
1615 let ctx = InputFileContext "" ""
1616 stamp <- getInputFileTime ctx fname
1617 input <- readInputFileL ctx fname
1618 let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1)
1619 . Char8.break (==':'))
1620 $ Char8.lines input
1621 alg = maybe RSA parseAlg $ lookup "Algorithm" kvs
1622 parseAlg spec = case Char8.words spec of
1623 nstr:_ -> case read (Char8.unpack nstr) :: Int of
1624 2 -> DH
1625 3 -> DSA -- SHA1
1626 5 -> RSA -- SHA1
1627 6 -> DSA -- NSEC3-SHA1 (RFC5155)
1628 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155)
1629 8 -> RSA -- SHA256
1630 10 -> RSA -- SHA512 (RFC5702)
1631 -- 12 -> GOST
1632 13 -> ECDSA -- P-256 SHA256 (RFC6605)
1633 14 -> ECDSA -- P-384 SHA384 (RFC6605)
1634 _ -> RSA
1635 case alg of
1636 RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs
1637
1638
1639readSecretPEMFile :: InputFile -> IO [SecretPEMData]
1640readSecretPEMFile fname = do
1641 -- warn $ fname ++ ": reading ..."
1642 let ctx = InputFileContext "" ""
1643 -- Note: The key's timestamp is included in it's fingerprint.
1644 -- Therefore, we should attempt to preserve it.
1645 stamp <- getInputFileTime ctx fname
1646 input <- readInputFileL ctx fname
1647 let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
1648 pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
1649 $ pemParser $ Just "RSA PRIVATE KEY"
1650 cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
1651 $ pemParser $ Just "CERTIFICATE"
1652 parseRSAPrivateKey dta = do
1653 let e = decodeASN1 DER dta
1654 asn1 <- either (const $ mzero) return e
1655 rsa <- either (const mzero) (return . fst) (fromASN1 asn1)
1656 let _ = rsa :: RSAPrivateKey
1657 return $ PEMPacket $ rsaToPGP stamp rsa
1593 dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta 1658 dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
1594 mergeDate (_,obj) (Left tm) = (fromTime tm,obj) 1659 mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
1595 mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key') 1660 mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
@@ -1603,22 +1668,28 @@ doImport
1603 :: Ord k => 1668 :: Ord k =>
1604 (MappedPacket -> IO (KikiCondition Packet)) 1669 (MappedPacket -> IO (KikiCondition Packet))
1605 -> Map.Map k KeyData 1670 -> Map.Map k KeyData
1606 -> (FilePath, Maybe [Char], [k], t) 1671 -> (FilePath, Maybe [Char], [k], FileType, t)
1607 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) 1672 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
1608doImport doDecrypt db (fname,subspec,ms,_) = do 1673doImport doDecrypt db (fname,subspec,ms,typ,_) = do
1609 flip (maybe $ return CannotImportMasterKey) 1674 flip (maybe $ return CannotImportMasterKey)
1610 subspec $ \tag -> do 1675 subspec $ \tag -> do
1611 ps <- readSecretPEMFile (ArgFile fname) 1676 (certs,keys) <- case typ of
1612 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) 1677 PEMFile -> do
1613 = partition (isJust . spemCert) ps 1678 ps <- readSecretPEMFile (ArgFile fname)
1679 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
1680 = partition (isJust . spemCert) ps
1681 return (certs,keys)
1682 DNSPresentation -> do
1683 p <- readSecretDNSFile (ArgFile fname)
1684 return ([],[p])
1614 -- TODO Probably we need to move to a new design where signature 1685 -- TODO Probably we need to move to a new design where signature
1615 -- packets are merged into the database in one phase with null 1686 -- packets are merged into the database in one phase with null
1616 -- signatures, and then the signatures are made in the next phase. 1687 -- signatures, and then the signatures are made in the next phase.
1617 -- This would let us merge annotations (like certificates) from 1688 -- This would let us merge annotations (like certificates) from
1618 -- seperate files. 1689 -- seperate files.
1619 foldM (importPEMKey tag certs) (KikiSuccess (db,[])) keys 1690 foldM (importKey tag certs) (KikiSuccess (db,[])) keys
1620 where 1691 where
1621 importPEMKey tag certs prior key = do 1692 importKey tag certs prior key = do
1622 try prior $ \(db,report) -> do 1693 try prior $ \(db,report) -> do
1623 let (m0,tailms) = splitAt 1 ms 1694 let (m0,tailms) = splitAt 1 ms
1624 if (not (null tailms) || null m0) 1695 if (not (null tailms) || null m0)
@@ -2187,10 +2258,10 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do
2187 f <- resolveInputFile ctx f 2258 f <- resolveInputFile ctx f
2188 return (f,t) 2259 return (f,t)
2189 2260
2190 let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do 2261 let (missing,notmissing) = partition (\(_,_,ns,_,_)->null (ns >>= snd)) $ do
2191 (fname,stream) <- nonexistents 2262 (fname,stream) <- nonexistents
2192 guard $ isMutable stream 2263 guard $ isMutable stream
2193 guard $ ispem (typ stream) 2264 guard $ isSecretKeyFile (typ stream)
2194 usage <- usageFromFilter (fill stream) -- TODO: Error if no result? 2265 usage <- usageFromFilter (fill stream) -- TODO: Error if no result?
2195 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage 2266 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
2196 -- ms will contain duplicates if a top key has multiple matching 2267 -- ms will contain duplicates if a top key has multiple matching
@@ -2200,12 +2271,12 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do
2200 ns = do 2271 ns = do
2201 (kk,kd) <- filterMatches topspec $ Map.toList db 2272 (kk,kd) <- filterMatches topspec $ Map.toList db
2202 return (kk , subkeysForExport subspec kd) 2273 return (kk , subkeysForExport subspec kd)
2203 return (fname,subspec,ns,initializer stream) 2274 return (fname,subspec,ns,(typ stream),initializer stream)
2204 (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) 2275 (exports0,ambiguous) = partition (\(_,_,ns,_,_)->null $ drop 1 $ (ns>>=snd))
2205 notmissing 2276 notmissing
2206 exports = map (\(f,subspec,ns,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0 2277 exports = map (\(f,subspec,ns,typ,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0
2207 2278
2208 ambiguity (f,topspec,subspec,_) = do 2279 ambiguity (f,topspec,subspec,_,_) = do
2209 return $ AmbiguousKeySpec f 2280 return $ AmbiguousKeySpec f
2210 2281
2211 ifnotnull (x:xs) f g = f x 2282 ifnotnull (x:xs) f g = f x
@@ -2217,10 +2288,10 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do
2217 do 2288 do
2218 let cmds = mapMaybe getcmd missing 2289 let cmds = mapMaybe getcmd missing
2219 where 2290 where
2220 getcmd (fname,subspec,ms,mcmd) = do 2291 getcmd (fname,subspec,ms,typ,mcmd) = do
2221 cmd <- mcmd 2292 cmd <- mcmd
2222 return (fname,subspec,ms,cmd) 2293 return (fname,subspec,ms,typ,cmd)
2223 rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do 2294 rs <- forM cmds $ \tup@(fname,subspec,ms,typ,cmd) -> do
2224 e <- systemEnv [ ("file",fname) 2295 e <- systemEnv [ ("file",fname)
2225 , ("usage",fromMaybe "" subspec) ] 2296 , ("usage",fromMaybe "" subspec) ]
2226 cmd 2297 cmd
@@ -2228,16 +2299,16 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do
2228 ExitFailure num -> return (tup,FailedExternal num) 2299 ExitFailure num -> return (tup,FailedExternal num)
2229 ExitSuccess -> return (tup,ExternallyGeneratedFile) 2300 ExitSuccess -> return (tup,ExternallyGeneratedFile)
2230 2301
2231 v <- foldM (importPEMKey decrypt) 2302 v <- foldM (importSecretKey decrypt)
2232 (KikiSuccess (db,[])) $ do 2303 (KikiSuccess (db,[])) $ do
2233 ((f,subspec,ms,cmd),r) <- rs 2304 ((f,subspec,ms,typ,cmd),r) <- rs
2234 guard $ case r of 2305 guard $ case r of
2235 ExternallyGeneratedFile -> True 2306 ExternallyGeneratedFile -> True
2236 _ -> False 2307 _ -> False
2237 return (f,subspec,map fst ms,cmd) 2308 return (f,subspec,map fst ms,typ,cmd)
2238 2309
2239 try v $ \(db,import_rs) -> do 2310 try v $ \(db,import_rs) -> do
2240 return $ KikiSuccess ((db,exports), map (\((f,_,_,_),r)->(f,r)) rs 2311 return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs
2241 ++ import_rs) 2312 ++ import_rs)
2242{- 2313{-
2243interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData 2314interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData