summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/KeyRing.hs53
-rw-r--r--lib/Kiki.hs56
2 files changed, 76 insertions, 33 deletions
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 4e83d80..bc881f2 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -110,6 +110,7 @@ module KeyRing
110 , writeKeyToFile 110 , writeKeyToFile
111 , resolveForReport 111 , resolveForReport
112 , KeyKey -- needed for Type sigs 112 , KeyKey -- needed for Type sigs
113 , makeMemoizingDecrypter
113 ) where 114 ) where
114 115
115import System.Environment 116import System.Environment
@@ -405,7 +406,7 @@ data KeyRingRuntime = KeyRingRuntime
405 -- 'KeyRingFile'. If 'AutoAccess' was specified 406 -- 'KeyRingFile'. If 'AutoAccess' was specified
406 -- for a file, this 'Map.Map' will indicate the 407 -- for a file, this 'Map.Map' will indicate the
407 -- detected value that was used by the algorithm. 408 -- detected value that was used by the algorithm.
408 , rtPassphrases :: PacketDecrypter 409 , rtPassphrases :: PacketTranscoder
409 } 410 }
410 411
411-- | Roster-entry level actions 412-- | Roster-entry level actions
@@ -1460,8 +1461,7 @@ generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1460 if null subs 1461 if null subs
1461 then do 1462 then do
1462 newkey <- generateKey genparam 1463 newkey <- generateKey genparam
1463 let doDecrypt = transcode (Unencrypted,S2K 100 "") 1464 kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey
1464 kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey
1465 try kdr $ \(newkd,report) -> do 1465 try kdr $ \(newkd,report) -> do
1466 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) 1466 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
1467 else do 1467 else do
@@ -1469,14 +1469,14 @@ generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1469generateSubkey _ kd _ = return kd 1469generateSubkey _ kd _ = return kd
1470 1470
1471importSecretKey :: 1471importSecretKey ::
1472 (PacketDecrypter) 1472 (PacketTranscoder)
1473 -> KikiCondition 1473 -> KikiCondition
1474 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) 1474 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
1475 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) 1475 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
1476 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 1476 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
1477importSecretKey doDecrypt db' tup = do 1477importSecretKey transcode db' tup = do
1478 try db' $ \(db',report0) -> do 1478 try db' $ \(db',report0) -> do
1479 r <- doImport doDecrypt 1479 r <- doImport transcode
1480 db' 1480 db'
1481 tup 1481 tup
1482 try r $ \(db'',report) -> do 1482 try r $ \(db'',report) -> do
@@ -1692,7 +1692,7 @@ buildKeyDB ctx grip0 keyring = do
1692 , rtWorkingKey = wk 1692 , rtWorkingKey = wk
1693 , rtRingAccess = accs 1693 , rtRingAccess = accs
1694 , rtKeyDB = Map.empty 1694 , rtKeyDB = Map.empty
1695 , rtPassphrases = doDecrypt 1695 , rtPassphrases = transcode
1696 } 1696 }
1697 -- autosigns and deletes 1697 -- autosigns and deletes
1698 transformed0 <- 1698 transformed0 <-
@@ -1723,7 +1723,7 @@ buildKeyDB ctx grip0 keyring = do
1723 -- Wallets 1723 -- Wallets
1724 let importWalletKey wk db' (top,fname,sub,tag) = do 1724 let importWalletKey wk db' (top,fname,sub,tag) = do
1725 try db' $ \(db',report0) -> do 1725 try db' $ \(db',report0) -> do
1726 r <- doImportG doDecrypt 1726 r <- doImportG transcode
1727 db' 1727 db'
1728 (fmap keykey $ maybeToList wk) 1728 (fmap keykey $ maybeToList wk)
1729 [mkUsage tag] 1729 [mkUsage tag]
@@ -1739,6 +1739,7 @@ buildKeyDB ctx grip0 keyring = do
1739 (_,sub,(_,m)) <- xs 1739 (_,sub,(_,m)) <- xs
1740 (tag,top) <- Map.toList m 1740 (tag,top) <- Map.toList m
1741 return (top,fname,sub,tag) 1741 return (top,fname,sub,tag)
1742
1742 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys 1743 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
1743 try db $ \(db,reportWallets) -> do 1744 try db $ \(db,reportWallets) -> do
1744 1745
@@ -1758,7 +1759,7 @@ buildKeyDB ctx grip0 keyring = do
1758 cmd = initializer stream 1759 cmd = initializer stream
1759 return (n,subspec,ms,stream, cmd) 1760 return (n,subspec,ms,stream, cmd)
1760 imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems 1761 imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems
1761 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports 1762 db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports
1762 try db $ \(db,reportPEMs) -> do 1763 try db $ \(db,reportPEMs) -> do
1763 1764
1764 -- generate keys 1765 -- generate keys
@@ -2011,11 +2012,11 @@ readSecretPEMFile fname = do
2011 return $ dta 2012 return $ dta
2012 2013
2013doImport 2014doImport
2014 :: (PacketDecrypter) 2015 :: PacketTranscoder
2015 -> Map.Map KeyKey KeyData 2016 -> Map.Map KeyKey KeyData
2016 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) 2017 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
2017 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 2018 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
2018doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do 2019doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
2019 flip (maybe $ return CannotImportMasterKey) 2020 flip (maybe $ return CannotImportMasterKey)
2020 subspec $ \tag -> do 2021 subspec $ \tag -> do
2021 (certs,keys) <- case typ of 2022 (certs,keys) <- case typ of
@@ -2049,26 +2050,31 @@ doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
2049 , notation_value = Char8.unpack bs } 2050 , notation_value = Char8.unpack bs }
2050 datedKey = key { timestamp = fromTime $ minimum dates } 2051 datedKey = key { timestamp = fromTime $ minimum dates }
2051 dates = fromTime (timestamp key) : map pcertTimestamp certs 2052 dates = fromTime (timestamp key) : map pcertTimestamp certs
2052 r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey 2053 r <- doImportG transcode db m0 (mkUsage tag:blobs) fname datedKey
2053 try r $ \(db',report') -> do 2054 try r $ \(db',report') -> do
2054 return $ KikiSuccess (db',report++report') 2055 return $ KikiSuccess (db',report++report')
2055 2056
2056doImportG 2057doImportG
2057 :: (PacketDecrypter) 2058 :: PacketTranscoder
2058 -> Map.Map KeyKey KeyData 2059 -> Map.Map KeyKey KeyData
2059 -> [KeyKey] -- m0, only head is used 2060 -> [KeyKey] -- m0, only head is used
2060 -> [SignatureSubpacket] -- tags 2061 -> [SignatureSubpacket] -- tags
2061 -> FilePath 2062 -> FilePath
2062 -> Packet 2063 -> Packet
2063 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 2064 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
2064doImportG doDecrypt db m0 tags fname key = do 2065doImportG transcode db m0 tags fname key = do
2065 let kk = head m0 2066 let kk = head m0
2066 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db 2067 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
2067 kdr <- insertSubkey doDecrypt kk kd tags fname key 2068 kdr <- insertSubkey transcode kk kd tags fname key
2068 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) 2069 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
2069 2070
2070insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do 2071insertSubkey transcode kk (KeyData top topsigs uids subs) tags fname key0 = do
2072 let topcipher = symmetric_algorithm $ packet top
2073 tops2k = s2k $ packet top
2074 key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0
2075 try key' $ \key -> do
2071 let subkk = keykey key 2076 let subkk = keykey key
2077 doDecrypt = transcode (Unencrypted,S2K 100 "")
2072 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) 2078 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
2073 []) 2079 [])
2074 ( (False,) . addOrigin ) 2080 ( (False,) . addOrigin )
@@ -2123,7 +2129,9 @@ insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
2123 (xs',minsig,ys') = findTag tags wk key subsigs 2129 (xs',minsig,ys') = findTag tags wk key subsigs
2124 doInsert mbsig = do 2130 doInsert mbsig = do
2125 -- NEW SUBKEY BINDING SIGNATURE 2131 -- NEW SUBKEY BINDING SIGNATURE
2126 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig 2132 -- XXX: Here I assume that key0 is the unencrypted version
2133 -- of subkey_p. TODO: Check this assumption.
2134 sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} tags mbsig
2127 try sig' $ \(sig',report) -> do 2135 try sig' $ \(sig',report) -> do
2128 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] 2136 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
2129 let subs' = Map.insert subkk 2137 let subs' = Map.insert subkk
@@ -2567,7 +2575,9 @@ makeMemoizingDecrypter operation ctx keys = do
2567 -- combine the packet with it's unspilled version before 2575 -- combine the packet with it's unspilled version before
2568 -- attempting to decrypt it. 2576 -- attempting to decrypt it.
2569 pw <- getpw 2577 pw <- getpw
2570 let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp) 2578 let wkun = fromMaybe wk $ do
2579 guard $ symmetric_algorithm (packet mp) /= Unencrypted
2580 decryptSecretKey pw (packet mp)
2571 case symmetric_algorithm wkun of 2581 case symmetric_algorithm wkun of
2572 Unencrypted -> do 2582 Unencrypted -> do
2573 writeIORef unkeysRef (Map.insert kk wkun unkeys) 2583 writeIORef unkeysRef (Map.insert kk wkun unkeys)
@@ -2723,7 +2733,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
2723 ExitFailure num -> return (tup,FailedExternal num) 2733 ExitFailure num -> return (tup,FailedExternal num)
2724 ExitSuccess -> return (tup,ExternallyGeneratedFile) 2734 ExitSuccess -> return (tup,ExternallyGeneratedFile)
2725 2735
2726 v <- foldM (importSecretKey decrypt) 2736 v <- foldM (importSecretKey transcode)
2727 (KikiSuccess (db,[])) $ do 2737 (KikiSuccess (db,[])) $ do
2728 ((f,subspec,ms,stream,cmd),r) <- rs 2738 ((f,subspec,ms,stream,cmd),r) <- rs
2729 guard $ case r of 2739 guard $ case r of
@@ -2964,7 +2974,7 @@ runKeyRing operation = do
2964 , rtWorkingKey = fmap packet wk 2974 , rtWorkingKey = fmap packet wk
2965 , rtKeyDB = db 2975 , rtKeyDB = db
2966 , rtRingAccess = accs 2976 , rtRingAccess = accs
2967 , rtPassphrases = decrypt 2977 , rtPassphrases = transcode
2968 } 2978 }
2969 2979
2970 -- Maybe add signatures, delete subkeys 2980 -- Maybe add signatures, delete subkeys
@@ -3171,11 +3181,12 @@ readPacketsFromWallet wk fname = do
3171 timestamp <- getInputFileTime ctx fname 3181 timestamp <- getInputFileTime ctx fname
3172 input <- readInputFileL ctx fname 3182 input <- readInputFileL ctx fname
3173 let (ks,_) = slurpWIPKeys timestamp input 3183 let (ks,_) = slurpWIPKeys timestamp input
3184 {-
3174 unless (null ks) $ do 3185 unless (null ks) $ do
3175 -- decrypt wk 3186 -- decrypt wk
3176 -- create sigs 3187 -- create sigs
3177 -- return key/sig pairs 3188 -- return key/sig pairs
3178 return () 3189 return () -}
3179 return $ do 3190 return $ do
3180 wk <- maybeToList wk 3191 wk <- maybeToList wk
3181 guard (not $ null ks) 3192 guard (not $ null ks)
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index f1bb27d..ef7b913 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -126,7 +126,13 @@ importAndRefresh root cmn = do
126 old_umask <- setFileCreationMask(0o077); 126 old_umask <- setFileCreationMask(0o077);
127 -- Generate secring.gpg if it does not exist... 127 -- Generate secring.gpg if it does not exist...
128 gotsec <- doesFileExist secring 128 gotsec <- doesFileExist secring
129 when (not gotsec) $ do 129
130 let passfd = cap_passfd cmn
131
132 pwds <-
133 if gotsec
134 then return []
135 else do
130 {- ssh-keygen to create master key... 136 {- ssh-keygen to create master key...
131 let mkpath = home ++ "/master-key" 137 let mkpath = home ++ "/master-key"
132 mkdirFor mkpath 138 mkdirFor mkpath
@@ -139,12 +145,35 @@ importAndRefresh root cmn = do
139 HomeSec 145 HomeSec
140 ( encode $ Message [mk { is_subkey = False }] ) 146 ( encode $ Message [mk { is_subkey = False }] )
141 -} 147 -}
142 master <- (\k -> k { is_subkey = False }) <$> generateKey (GenRSA $ 4096 `div` 8 ) 148 master_un <- (\k -> k { is_subkey = False }) <$> generateKey (GenRSA $ 4096 `div` 8 )
143 mkdirFor secring 149 let default_cipher = (CAST5, IteratedSaltedS2K SHA1 4073382889203176146 7864320)
144 writeInputFileL (InputFileContext secring pubring) 150 ctx = InputFileContext secring pubring
145 HomeSec 151 passwordop = KeyRingOperation
146 $ encode $ Message [master { is_subkey = False}] 152 { opFiles = Map.empty
147 153 , opPassphrases = do pfd <- maybeToList passfd
154 return $ PassphraseSpec Nothing Nothing pfd
155 , opHome = homespec
156 , opTransforms = []
157 }
158 transcoder <- makeMemoizingDecrypter passwordop ctx Map.empty
159 master0 <- transcoder default_cipher $ MappedPacket master_un Map.empty
160 case master0 of
161 KikiSuccess master -> do
162 mkdirFor secring
163 writeInputFileL ctx
164 HomeSec
165 $ encode $ Message [master { is_subkey = False}]
166 putStrLn "Wrote master key"
167 return [PassphraseMemoizer transcoder]
168 er -> do
169 hPutStrLn stderr ("warning: " ++ errorString er)
170 hPutStrLn stderr "warning: keys will not be encrypted.";
171 mkdirFor secring
172 writeInputFileL ctx
173 HomeSec
174 $ encode $ Message [master_un { is_subkey = False}]
175 putStrLn "Wrote master key"
176 return []
148 gotpub <- doesFileExist pubring 177 gotpub <- doesFileExist pubring
149 when (not gotpub) $ do 178 when (not gotpub) $ do
150 mkdirFor pubring 179 mkdirFor pubring
@@ -168,8 +197,7 @@ importAndRefresh root cmn = do
168 197
169 -- First, we ensure that the tor key exists and is imported 198 -- First, we ensure that the tor key exists and is imported
170 -- so that we know where to put the strongswan key. 199 -- so that we know where to put the strongswan key.
171 let passfd = cap_passfd cmn 200 let strm = StreamInfo { typ = KeyRingFile
172 strm = StreamInfo { typ = KeyRingFile
173 , fill = KF_None 201 , fill = KF_None
174 , spill = KF_All 202 , spill = KF_All
175 , access = AutoAccess 203 , access = AutoAccess
@@ -200,8 +228,8 @@ importAndRefresh root cmn = do
200 , ( ArgFile sshcpath, (peminfo 2048 "ssh-client") ) 228 , ( ArgFile sshcpath, (peminfo 2048 "ssh-client") )
201 , ( ArgFile sshspath, (peminfo 2048 "ssh-server") ) 229 , ( ArgFile sshspath, (peminfo 2048 "ssh-server") )
202 ] 230 ]
203 , opPassphrases = do pfd <- maybeToList passfd 231 , opPassphrases = pwds ++ do pfd <- maybeToList passfd
204 return $ PassphraseSpec Nothing Nothing pfd 232 return $ PassphraseSpec Nothing Nothing pfd
205 , opHome = homespec 233 , opHome = homespec
206 , opTransforms = [] 234 , opTransforms = []
207 } 235 }
@@ -304,7 +332,11 @@ refreshCache rt rootdir = do
304 let my_ks :: [Packet] 332 let my_ks :: [Packet]
305 my_ks = getSecret "ipsec" 333 my_ks = getSecret "ipsec"
306 case my_ks of 334 case my_ks of
307 sec:_ -> do report <- writeKeyToFile streaminfo { typ = PEMFile 335 se0:_ -> do sc1 <- rtPassphrases rt (Unencrypted,S2K 100 "") $ MappedPacket se0 Map.empty
336 let sec = case sc1 of
337 KikiSuccess s -> s
338 _ -> se0
339 report <- writeKeyToFile streaminfo { typ = PEMFile
308 , access = Sec 340 , access = Sec
309 , spill = KF_All 341 , spill = KF_All
310 } 342 }