summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--KeyRing.hs58
1 files changed, 49 insertions, 9 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index 0bf3e32..7369acf 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -126,13 +126,13 @@ import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
126import Data.ASN1.BinaryEncoding ( DER(..) ) 126import Data.ASN1.BinaryEncoding ( DER(..) )
127import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds ) 127import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds )
128import Data.Time.Clock ( UTCTime ) 128import Data.Time.Clock ( UTCTime )
129import Data.Bits ( Bits ) 129import Data.Bits ( Bits, shiftR )
130import Data.Text.Encoding ( encodeUtf8 ) 130import 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, break, pack ) 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, singleton, unfoldr, reverse )
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
138#if !defined(VERSION_cryptonite) 138#if !defined(VERSION_cryptonite)
@@ -2058,8 +2058,8 @@ rsaPrivateKeyFromPacket _ = Nothing
2058 2058
2059 2059
2060writeKeyToFile :: 2060writeKeyToFile ::
2061 Bool -> String -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)] 2061 Bool -> FileType -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)]
2062writeKeyToFile False "PEM" fname packet = do 2062writeKeyToFile False PEMFile fname packet = do
2063 case key_algorithm packet of 2063 case key_algorithm packet of
2064 RSA -> do 2064 RSA -> do
2065 flip (maybe (return [])) 2065 flip (maybe (return []))
@@ -2079,25 +2079,64 @@ writeKeyToFile False "PEM" fname packet = do
2079 return [(fname, ExportedSubkey)] 2079 return [(fname, ExportedSubkey)]
2080 algo -> return [(fname, UnableToExport algo $ fingerprint packet)] 2080 algo -> return [(fname, UnableToExport algo $ fingerprint packet)]
2081 2081
2082writeKeyToFile False DNSPresentation fname packet = do
2083 case key_algorithm packet of
2084 RSA -> do
2085 flip (maybe (return []))
2086 (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey
2087 $ \rsa -> do
2088 let -- asn1 = toASN1 rsa []
2089 -- bs = encodeASN1 DER asn1
2090 -- dta = Base64.encode (L.unpack bs)
2091 b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i)
2092 where
2093 MPI i = ac rsa
2094 i2bs_unsized :: Integer -> S.ByteString
2095 i2bs_unsized 0 = S.singleton 0
2096 i2bs_unsized i = S.reverse $ S.unfoldr go i
2097 where go i' = if i' <= 0 then Nothing
2098 else Just (fromIntegral i', (i' `shiftR` 8))
2099 output = unlines
2100 [ "Private-key-format: v1.2"
2101 , "Algorithm: 8 (RSASHA256)"
2102 , "Modulus: " ++ b64 rsaN rsa
2103 , "PublicExponent: " ++ b64 rsaE rsa
2104 , "PrivateExponent: " ++ b64 rsaD rsa
2105 , "Prime1: " ++ b64 rsaP rsa
2106 , "Prime2: " ++ b64 rsaQ rsa
2107 , "Exponent1: " ++ b64 rsaDmodP1 rsa
2108 , "Exponent2: " ++ b64 rsaDmodQminus1 rsa
2109 , "Coefficient: " ++ b64 rsaCoefficient rsa
2110 ]
2111 stamp = toEnum . fromEnum $ timestamp packet
2112 handleIO_ (return [(fname, FailedFileWrite)]) $ do
2113 saved_mask <- setFileCreationMask 0o077
2114 -- Note: The key's timestamp is included in it's fingerprint.
2115 -- Therefore, we should attempt to preserve it.
2116 writeStamped (InputFileContext "" "") fname stamp output
2117 setFileCreationMask saved_mask
2118 return [(fname, ExportedSubkey)]
2119 algo -> return [(fname, UnableToExport algo $ fingerprint packet)]
2120
2082writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet)) 2121writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet))
2083 -> KeyDB 2122 -> KeyDB
2084 -> [(FilePath,Maybe String,[MappedPacket],Maybe Initializer)] 2123 -> [(FilePath,Maybe String,[MappedPacket],FileType,Maybe Initializer)]
2085 -> IO (KikiCondition [(FilePath,KikiReportAction)]) 2124 -> IO (KikiCondition [(FilePath,KikiReportAction)])
2086writePEMKeys doDecrypt db exports = do 2125writePEMKeys doDecrypt db exports = do
2087 ds <- mapM decryptKeys exports 2126 ds <- mapM decryptKeys exports
2088 let ds' = map functorToEither ds 2127 let ds' = map functorToEither ds
2089 if null (lefts ds') 2128 if null (lefts ds')
2090 then do 2129 then do
2091 rs <- mapM (\(f,p) -> writeKeyToFile False "PEM" (ArgFile f) p) 2130 rs <- mapM (\(f,typ,p) -> writeKeyToFile False typ (ArgFile f) p)
2092 (rights ds') 2131 (rights ds')
2093 return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs) 2132 return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs)
2094 else do 2133 else do
2095 return (head $ lefts ds') 2134 return (head $ lefts ds')
2096 where 2135 where
2097 decryptKeys (fname,subspec,[p],_) = do 2136 decryptKeys (fname,subspec,[p],typ,_) = do
2098 pun <- doDecrypt p 2137 pun <- doDecrypt p
2099 try pun $ \pun -> do 2138 try pun $ \pun -> do
2100 return $ KikiSuccess (fname,pun) 2139 return $ KikiSuccess (fname,typ,pun)
2101 2140
2102makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext 2141makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
2103 -> Map.Map KeyKey MappedPacket 2142 -> Map.Map KeyKey MappedPacket
@@ -2249,6 +2288,7 @@ initializeMissingPEMFiles ::
2249 -> IO (KikiCondition ( (KeyDB,[( FilePath 2288 -> IO (KikiCondition ( (KeyDB,[( FilePath
2250 , Maybe String 2289 , Maybe String
2251 , [MappedPacket] 2290 , [MappedPacket]
2291 , FileType
2252 , Maybe Initializer)]) 2292 , Maybe Initializer)])
2253 , [(FilePath,KikiReportAction)])) 2293 , [(FilePath,KikiReportAction)]))
2254initializeMissingPEMFiles operation ctx grip decrypt db = do 2294initializeMissingPEMFiles operation ctx grip decrypt db = do
@@ -2274,7 +2314,7 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do
2274 return (fname,subspec,ns,(typ stream),initializer stream) 2314 return (fname,subspec,ns,(typ stream),initializer stream)
2275 (exports0,ambiguous) = partition (\(_,_,ns,_,_)->null $ drop 1 $ (ns>>=snd)) 2315 (exports0,ambiguous) = partition (\(_,_,ns,_,_)->null $ drop 1 $ (ns>>=snd))
2276 notmissing 2316 notmissing
2277 exports = map (\(f,subspec,ns,typ,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0 2317 exports = map (\(f,subspec,ns,typ,cmd) -> (f,subspec,ns >>= snd,typ,cmd)) exports0
2278 2318
2279 ambiguity (f,topspec,subspec,_,_) = do 2319 ambiguity (f,topspec,subspec,_,_) = do
2280 return $ AmbiguousKeySpec f 2320 return $ AmbiguousKeySpec f