summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--KeyRing.hs91
-rw-r--r--kiki.hs32
2 files changed, 60 insertions, 63 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index ac92b14..4e6c512 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -6,6 +6,8 @@
6{-# LANGUAGE DoAndIfThenElse #-} 6{-# LANGUAGE DoAndIfThenElse #-}
7module KeyRing 7module 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.
175data KeyFilter = KF_None | KF_Match String | KF_Subkeys | KF_Authentic | KF_All 178data 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.
179data StreamInfo = StreamInfo 180data 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 188isMutable :: StreamInfo -> Bool
188-- semantically, it is indicating the intention of 189isMutable stream | KF_None <- fill stream = False
189-- an action and not just the access level of an 190isMutable _ = True
190-- object.
191data 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
199isMutable :: RefType -> Bool
200isMutable (MutableRef {}) = True
201isMutable _ = False
202 191
203isring :: FileType -> Bool 192isring :: FileType -> Bool
204isring (KeyRingFile {}) = True 193isring (KeyRingFile {}) = True
@@ -212,10 +201,6 @@ iswallet :: FileType -> Bool
212iswallet (WalletFile {}) = True 201iswallet (WalletFile {}) = True
213iswallet _ = False 202iswallet _ = False
214 203
215rtyp_initializer :: RefType -> Maybe Initializer
216rtyp_initializer (MutableRef x) = x
217rtyp_initializer _ = Nothing
218
219getUsage :: 204getUsage ::
220 MonadPlus m => FileType -> m UsageTag 205 MonadPlus m => FileType -> m UsageTag
221getUsage (PEMFile usage) = return usage 206getUsage (PEMFile usage) = return usage
@@ -239,7 +224,7 @@ noManip :: KeyRingRuntime -> KeyData -> [PacketUpdate]
239noManip _ _ = [] 224noManip _ _ = []
240 225
241data KeyRingOperation = KeyRingOperation 226data 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
265filesToLock :: 250filesToLock ::
266 KeyRingOperation -> FilePath -> FilePath -> [FilePath] 251 KeyRingOperation -> FilePath -> FilePath -> [FilePath]
267filesToLock k secring pubring = do 252filesToLock 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)]
916writeHostsFiles krd secring pubring (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do 901writeHostsFiles 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
1238writeWalletKeys krd db wk = do 1224writeWalletKeys 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
diff --git a/kiki.hs b/kiki.hs
index f5e3863..d9e12b6 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -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