diff options
-rw-r--r-- | KeyRing.hs | 91 | ||||
-rw-r--r-- | kiki.hs | 32 |
2 files changed, 60 insertions, 63 deletions
@@ -6,6 +6,8 @@ | |||
6 | {-# LANGUAGE DoAndIfThenElse #-} | 6 | {-# LANGUAGE DoAndIfThenElse #-} |
7 | module KeyRing | 7 | module KeyRing |
8 | ( runKeyRing | 8 | ( runKeyRing |
9 | , StreamInfo(..) | ||
10 | , KeyFilter(..) | ||
9 | , KeyRingOperation(..) | 11 | , KeyRingOperation(..) |
10 | , KikiResult(..) | 12 | , KikiResult(..) |
11 | , KikiCondition(..) | 13 | , KikiCondition(..) |
@@ -15,7 +17,6 @@ module KeyRing | |||
15 | , KeyRingRuntime(..) | 17 | , KeyRingRuntime(..) |
16 | , InputFile(..) | 18 | , InputFile(..) |
17 | , FileType(..) | 19 | , FileType(..) |
18 | , RefType(..) | ||
19 | , importPublic | 20 | , importPublic |
20 | , importSecret | 21 | , importSecret |
21 | , subkeysOnly | 22 | , subkeysOnly |
@@ -172,10 +173,10 @@ data Access = AutoAccess -- ^ secret or public as appropriate based on existing | |||
172 | | Sec -- ^ secret information | 173 | | Sec -- ^ secret information |
173 | | Pub -- ^ public information | 174 | | Pub -- ^ public information |
174 | 175 | ||
176 | -- | TODO: Implement keyfilters other than KF_None and KF_All | ||
177 | -- This should make kImports obsolete. | ||
175 | data KeyFilter = KF_None | KF_Match String | KF_Subkeys | KF_Authentic | KF_All | 178 | data KeyFilter = KF_None | KF_Match String | KF_Subkeys | KF_Authentic | KF_All |
176 | 179 | ||
177 | -- | TODO: This should replace the element type of kFiles | ||
178 | -- and kImports will be obsolete. | ||
179 | data StreamInfo = StreamInfo | 180 | data StreamInfo = StreamInfo |
180 | { access :: Access | 181 | { access :: Access |
181 | , typ :: FileType | 182 | , typ :: FileType |
@@ -183,22 +184,10 @@ data StreamInfo = StreamInfo | |||
183 | , spill :: KeyFilter | 184 | , spill :: KeyFilter |
184 | , initializer :: Maybe String } | 185 | , initializer :: Maybe String } |
185 | 186 | ||
186 | -- | RefType is perhaps not a good name for this... | 187 | |
187 | -- It is sort of like a read/write flag, although | 188 | isMutable :: StreamInfo -> Bool |
188 | -- semantically, it is indicating the intention of | 189 | isMutable stream | KF_None <- fill stream = False |
189 | -- an action and not just the access level of an | 190 | isMutable _ = True |
190 | -- object. | ||
191 | data RefType = ConstRef | ||
192 | -- ^ merge into database but do not update | ||
193 | | MutableRef (Maybe Initializer) | ||
194 | -- ^ sync into database | ||
195 | -- update dabase and also update file | ||
196 | -- Initializer is a shell command that creates | ||
197 | -- the file; eg, ssh-keygen | ||
198 | |||
199 | isMutable :: RefType -> Bool | ||
200 | isMutable (MutableRef {}) = True | ||
201 | isMutable _ = False | ||
202 | 191 | ||
203 | isring :: FileType -> Bool | 192 | isring :: FileType -> Bool |
204 | isring (KeyRingFile {}) = True | 193 | isring (KeyRingFile {}) = True |
@@ -212,10 +201,6 @@ iswallet :: FileType -> Bool | |||
212 | iswallet (WalletFile {}) = True | 201 | iswallet (WalletFile {}) = True |
213 | iswallet _ = False | 202 | iswallet _ = False |
214 | 203 | ||
215 | rtyp_initializer :: RefType -> Maybe Initializer | ||
216 | rtyp_initializer (MutableRef x) = x | ||
217 | rtyp_initializer _ = Nothing | ||
218 | |||
219 | getUsage :: | 204 | getUsage :: |
220 | MonadPlus m => FileType -> m UsageTag | 205 | MonadPlus m => FileType -> m UsageTag |
221 | getUsage (PEMFile usage) = return usage | 206 | getUsage (PEMFile usage) = return usage |
@@ -239,7 +224,7 @@ noManip :: KeyRingRuntime -> KeyData -> [PacketUpdate] | |||
239 | noManip _ _ = [] | 224 | noManip _ _ = [] |
240 | 225 | ||
241 | data KeyRingOperation = KeyRingOperation | 226 | data KeyRingOperation = KeyRingOperation |
242 | { kFiles :: Map.Map InputFile (RefType,FileType) | 227 | { kFiles :: Map.Map InputFile StreamInfo |
243 | , kImports :: Map.Map InputFile (KeyRingRuntime -> KeyData -> Maybe Bool) | 228 | , kImports :: Map.Map InputFile (KeyRingRuntime -> KeyData -> Maybe Bool) |
244 | -- ^ | 229 | -- ^ |
245 | -- Indicates what pgp master keys get written to which keyring files. | 230 | -- Indicates what pgp master keys get written to which keyring files. |
@@ -265,10 +250,10 @@ resolveInputFile secring pubring = resolve | |||
265 | filesToLock :: | 250 | filesToLock :: |
266 | KeyRingOperation -> FilePath -> FilePath -> [FilePath] | 251 | KeyRingOperation -> FilePath -> FilePath -> [FilePath] |
267 | filesToLock k secring pubring = do | 252 | filesToLock k secring pubring = do |
268 | (f,(rtyp,ftyp)) <- Map.toList (kFiles k) | 253 | (f,stream) <- Map.toList (kFiles k) |
269 | case rtyp of | 254 | case fill stream of |
270 | ConstRef -> [] | 255 | KF_None -> [] |
271 | MutableRef {} -> resolveInputFile secring pubring f | 256 | _ -> resolveInputFile secring pubring f |
272 | 257 | ||
273 | 258 | ||
274 | -- kret :: a -> KeyRingOperation a | 259 | -- kret :: a -> KeyRingOperation a |
@@ -860,8 +845,8 @@ mergeHostFiles krd db secring pubring = do | |||
860 | ishosts Hosts = True | 845 | ishosts Hosts = True |
861 | ishosts _ = False | 846 | ishosts _ = False |
862 | files istyp = do | 847 | files istyp = do |
863 | (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) | 848 | (f,stream) <- Map.toList (kFiles krd) |
864 | guard (istyp ftyp) | 849 | guard (istyp $ typ stream) |
865 | resolveInputFile secring pubring f | 850 | resolveInputFile secring pubring f |
866 | 851 | ||
867 | hostdbs0 <- mapM (fmap Hosts.decode . L.readFile) hns | 852 | hostdbs0 <- mapM (fmap Hosts.decode . L.readFile) hns |
@@ -915,11 +900,12 @@ writeHostsFiles | |||
915 | -> IO [(FilePath, KikiReportAction)] | 900 | -> IO [(FilePath, KikiReportAction)] |
916 | writeHostsFiles krd secring pubring (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do | 901 | writeHostsFiles krd secring pubring (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do |
917 | let hns = files isMutableHosts | 902 | let hns = files isMutableHosts |
918 | isMutableHosts (MutableRef _,Hosts) = True | 903 | isMutableHosts stream | KF_None <- fill stream = False |
919 | isMutableHosts _ = False | 904 | isMutableHosts stream | Hosts <- typ stream = True |
905 | isMutableHosts _ = False | ||
920 | files istyp = do | 906 | files istyp = do |
921 | (f,typ) <- Map.toList (kFiles krd) | 907 | (f,stream) <- Map.toList (kFiles krd) |
922 | guard (istyp typ) | 908 | guard (istyp stream) |
923 | resolveInputFile secring pubring f | 909 | resolveInputFile secring pubring f |
924 | 910 | ||
925 | -- 3. add hostnames from gpg for addresses not in U | 911 | -- 3. add hostnames from gpg for addresses not in U |
@@ -955,8 +941,8 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do | |||
955 | let | 941 | let |
956 | 942 | ||
957 | files isring = do | 943 | files isring = do |
958 | (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring) | 944 | (f,stream) <- Map.toList (kFiles keyring) |
959 | guard (isring ftyp) | 945 | guard (isring $ typ stream) |
960 | resolveInputFile secring pubring f | 946 | resolveInputFile secring pubring f |
961 | 947 | ||
962 | readp n = fmap (n,) (readPacketsFromFile n) | 948 | readp n = fmap (n,) (readPacketsFromFile n) |
@@ -1007,12 +993,12 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do | |||
1007 | 993 | ||
1008 | -- PEM files | 994 | -- PEM files |
1009 | let pems = do | 995 | let pems = do |
1010 | (n,(rtyp,ftyp)) <- Map.toList $ kFiles keyring | 996 | (n,stream) <- Map.toList $ kFiles keyring |
1011 | grip <- maybeToList grip | 997 | grip <- maybeToList grip |
1012 | (topspec,subspec) <- fmap (parseSpec grip) $ getUsage ftyp | 998 | (topspec,subspec) <- fmap (parseSpec grip) $ getUsage (typ stream) |
1013 | n <- resolveInputFile secring pubring n | 999 | n <- resolveInputFile secring pubring n |
1014 | let ms = map fst $ filterMatches topspec (Map.toList db) | 1000 | let ms = map fst $ filterMatches topspec (Map.toList db) |
1015 | cmd = rtyp_initializer rtyp | 1001 | cmd = initializer stream |
1016 | return (n,subspec,ms,cmd) | 1002 | return (n,subspec,ms,cmd) |
1017 | imports <- filterM (\(n,_,_,_) -> doesFileExist n) pems | 1003 | imports <- filterM (\(n,_,_,_) -> doesFileExist n) pems |
1018 | db <- foldM (importPEMKey doDecrypt) (KikiSuccess (db,[])) imports | 1004 | db <- foldM (importPEMKey doDecrypt) (KikiSuccess (db,[])) imports |
@@ -1238,11 +1224,12 @@ writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiConditio | |||
1238 | writeWalletKeys krd db wk = do | 1224 | writeWalletKeys krd db wk = do |
1239 | let cs = db `coinKeysOwnedBy` wk | 1225 | let cs = db `coinKeysOwnedBy` wk |
1240 | -- export wallet keys | 1226 | -- export wallet keys |
1241 | isMutableWallet (MutableRef {}) (WalletFile {}) = True | 1227 | isMutableWallet stream | KF_None <- fill stream = False |
1242 | isMutableWallet _ _ = False | 1228 | isMutableWallet stream | WalletFile {} <- typ stream = True |
1229 | isMutableWallet _ = False | ||
1243 | files pred = do | 1230 | files pred = do |
1244 | (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) | 1231 | (f,stream) <- Map.toList (kFiles krd) |
1245 | guard (pred rtyp ftyp) | 1232 | guard (pred stream) |
1246 | resolveInputFile "" "" f | 1233 | resolveInputFile "" "" f |
1247 | let writeWallet report n = do | 1234 | let writeWallet report n = do |
1248 | let cs' = do | 1235 | let cs' = do |
@@ -1319,10 +1306,10 @@ writeRingKeys krd rt {- db wk secring pubring -} = do | |||
1319 | pubring = rtPubring rt | 1306 | pubring = rtPubring rt |
1320 | let s = do | 1307 | let s = do |
1321 | (f,f0,mutable) <- do | 1308 | (f,f0,mutable) <- do |
1322 | (f0,(rtyp,ftyp)) <- Map.toList (kFiles krd) | 1309 | (f0,stream) <- Map.toList (kFiles krd) |
1323 | guard (isring ftyp) | 1310 | guard (isring $ typ stream) |
1324 | f <- resolveInputFile secring pubring f0 | 1311 | f <- resolveInputFile secring pubring f0 |
1325 | return (f,f0,isMutable rtyp) | 1312 | return (f,f0,isMutable stream) |
1326 | let x = do | 1313 | let x = do |
1327 | let wanted kd@(KeyData p _ _ _) | 1314 | let wanted kd@(KeyData p _ _ _) |
1328 | = mplus (fmap originallyPublic $ Map.lookup f $ locations p) | 1315 | = mplus (fmap originallyPublic $ Map.lookup f $ locations p) |
@@ -1468,9 +1455,9 @@ makeMemoizingDecrypter operation secring pubring = do | |||
1468 | -- TODO: head will throw an exception if a File Descriptor operation | 1455 | -- TODO: head will throw an exception if a File Descriptor operation |
1469 | -- file is present. We probably should change OriginMap to use InputFile | 1456 | -- file is present. We probably should change OriginMap to use InputFile |
1470 | -- instead of FilePath. | 1457 | -- instead of FilePath. |
1471 | Traversable.mapM (cachedContents secring pubring . fromJust . pwfile . snd) | 1458 | Traversable.mapM (cachedContents secring pubring . fromJust . pwfile . typ) |
1472 | (Map.mapKeys (head . resolveInputFile secring pubring) | 1459 | (Map.mapKeys (head . resolveInputFile secring pubring) |
1473 | $ Map.filter (isJust . pwfile . snd) $ kFiles operation) | 1460 | $ Map.filter (isJust . pwfile . typ) $ kFiles operation) |
1474 | unkeysRef <- newIORef Map.empty | 1461 | unkeysRef <- newIORef Map.empty |
1475 | return $ doDecrypt unkeysRef pws | 1462 | return $ doDecrypt unkeysRef pws |
1476 | where | 1463 | where |
@@ -1574,10 +1561,10 @@ initializeMissingPEMFiles operation secring pubring grip decrypt db = do | |||
1574 | return (f,t) | 1561 | return (f,t) |
1575 | 1562 | ||
1576 | let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do | 1563 | let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do |
1577 | (fname,(rtyp,ftyp)) <- nonexistents | 1564 | (fname,stream) <- nonexistents |
1578 | guard $ isMutable rtyp | 1565 | guard $ isMutable stream |
1579 | (topspec,subspec) <- fmap (parseSpec $ fromMaybe "" grip) | 1566 | (topspec,subspec) <- fmap (parseSpec $ fromMaybe "" grip) |
1580 | $ getUsage ftyp | 1567 | $ getUsage $ typ stream |
1581 | -- ms will contain duplicates if a top key has multiple matching | 1568 | -- ms will contain duplicates if a top key has multiple matching |
1582 | -- subkeys. This is intentional. | 1569 | -- subkeys. This is intentional. |
1583 | let -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db | 1570 | let -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db |
@@ -1585,7 +1572,7 @@ initializeMissingPEMFiles operation secring pubring grip decrypt db = do | |||
1585 | ns = do | 1572 | ns = do |
1586 | (kk,kd) <- filterMatches topspec $ Map.toList db | 1573 | (kk,kd) <- filterMatches topspec $ Map.toList db |
1587 | return (kk , subkeysForExport subspec kd) | 1574 | return (kk , subkeysForExport subspec kd) |
1588 | return (fname,subspec,ns,rtyp_initializer rtyp) | 1575 | return (fname,subspec,ns,initializer stream) |
1589 | (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) | 1576 | (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) |
1590 | notmissing | 1577 | notmissing |
1591 | exports = map (\(f,subspec,ns,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0 | 1578 | exports = map (\(f,subspec,ns,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0 |
@@ -808,22 +808,24 @@ sync bExport bImport bSecret cmdarg args_raw = do | |||
808 | let keypairs = catMaybes keypairs0 | 808 | let keypairs = catMaybes keypairs0 |
809 | homespec = join . take 1 <$> Map.lookup "--homedir" margs | 809 | homespec = join . take 1 <$> Map.lookup "--homedir" margs |
810 | passfd = fmap (FileDesc . read) passphrase_fd | 810 | passfd = fmap (FileDesc . read) passphrase_fd |
811 | reftyp = if bExport then MutableRef Nothing | 811 | reftyp = if bExport then KF_All |
812 | else ConstRef | 812 | else KF_None |
813 | pems = flip map keypairs | 813 | pems = flip map keypairs |
814 | $ \(usage,path,cmd) -> | 814 | $ \(usage,path,cmd) -> |
815 | let cmd' = mfilter (not . null) (Just cmd) | 815 | let cmd' = mfilter (not . null) (Just cmd) |
816 | in if bExport | 816 | in if bExport |
817 | then (ArgFile path, (MutableRef cmd', PEMFile usage)) | 817 | then (ArgFile path, StreamInfo { fill = KF_All |
818 | , typ = PEMFile usage | ||
819 | , initializer = cmd' }) | ||
818 | else if isNothing cmd' | 820 | else if isNothing cmd' |
819 | then (ArgFile path, (ConstRef, PEMFile usage)) | 821 | then (ArgFile path, buildStreamInfo KF_None (PEMFile usage)) |
820 | else error "Unexpected PEM file initializer." | 822 | else error "Unexpected PEM file initializer." |
821 | walts = map (\fname -> (ArgFile fname, (reftyp, WalletFile))) | 823 | walts = map (\fname -> (ArgFile fname, buildStreamInfo reftyp WalletFile)) |
822 | wallets | 824 | wallets |
823 | rings = map (\fname -> (ArgFile fname, (reftyp, KeyRingFile passfd))) | 825 | rings = map (\fname -> (ArgFile fname, buildStreamInfo reftyp (KeyRingFile passfd))) |
824 | keyrings_ | 826 | keyrings_ |
825 | hosts = maybe [] (map decorate) $ Map.lookup "--hosts" margs | 827 | hosts = maybe [] (map decorate) $ Map.lookup "--hosts" margs |
826 | where decorate fname = (ArgFile fname, (reftyp, Hosts)) | 828 | where decorate fname = (ArgFile fname, buildStreamInfo reftyp Hosts) |
827 | importStyle = maybe (\_ _ -> subkeysOnly) | 829 | importStyle = maybe (\_ _ -> subkeysOnly) |
828 | (\f rt kd -> f rt kd >> importPublic) | 830 | (\f rt kd -> f rt kd >> importPublic) |
829 | $ mplus import_f importifauth_f | 831 | $ mplus import_f importifauth_f |
@@ -832,10 +834,15 @@ sync bExport bImport bSecret cmdarg args_raw = do | |||
832 | return $ \rt kd -> Just () | 834 | return $ \rt kd -> Just () |
833 | importifauth_f = do Map.lookup "--import-if-authentic" margs | 835 | importifauth_f = do Map.lookup "--import-if-authentic" margs |
834 | return guardAuthentic | 836 | return guardAuthentic |
837 | buildStreamInfo rtyp ftyp = StreamInfo { typ = ftyp, fill = rtyp } | ||
835 | kikiOp = KeyRingOperation | 838 | kikiOp = KeyRingOperation |
836 | { kFiles = Map.fromList $ | 839 | { kFiles = Map.fromList $ |
837 | [ ( HomeSec, (if bSecret && bImport then MutableRef Nothing else ConstRef, KeyRingFile passfd) ) | 840 | [ ( HomeSec, buildStreamInfo (if bSecret && bImport then KF_All |
838 | , ( HomePub, (if bImport then MutableRef Nothing else ConstRef, KeyRingFile Nothing) ) | 841 | else KF_None) |
842 | (KeyRingFile passfd) ) | ||
843 | , ( HomePub, buildStreamInfo (if bImport then KF_All | ||
844 | else KF_None) | ||
845 | (KeyRingFile Nothing) ) | ||
839 | ] | 846 | ] |
840 | ++ rings | 847 | ++ rings |
841 | ++ if bSecret then pems else [] | 848 | ++ if bSecret then pems else [] |
@@ -929,10 +936,13 @@ kiki "show" args = do | |||
929 | rings = [] | 936 | rings = [] |
930 | hosts = [] | 937 | hosts = [] |
931 | walts = [] | 938 | walts = [] |
939 | streaminfo = StreamInfo { fill = KF_None | ||
940 | , typ = KeyRingFile passfd | ||
941 | } | ||
932 | kikiOp = KeyRingOperation | 942 | kikiOp = KeyRingOperation |
933 | { kFiles = Map.fromList $ | 943 | { kFiles = Map.fromList $ |
934 | [ ( HomeSec, (ConstRef, KeyRingFile passfd) ) | 944 | [ ( HomeSec, streaminfo ) |
935 | , ( HomePub, (ConstRef, KeyRingFile Nothing) ) | 945 | , ( HomePub, streaminfo ) |
936 | ] | 946 | ] |
937 | ++ rings | 947 | ++ rings |
938 | ++ pems | 948 | ++ pems |