summaryrefslogtreecommitdiff
path: root/KeyRing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'KeyRing.hs')
-rw-r--r--KeyRing.hs118
1 files changed, 102 insertions, 16 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index c595d77..3268070 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -9,6 +9,7 @@ module KeyRing where
9import System.Environment 9import System.Environment
10import Control.Monad 10import Control.Monad
11import Data.Maybe 11import Data.Maybe
12import Data.Either
12import Data.Char 13import Data.Char
13import Data.Ord 14import Data.Ord
14import Data.List 15import Data.List
@@ -84,6 +85,9 @@ data FileType = KeyRingFile PassWordFile
84 85
85data RefType = ConstRef | MutableRef (Maybe Initializer) 86data RefType = ConstRef | MutableRef (Maybe Initializer)
86 87
88isMutable (MutableRef {}) = True
89isMutable _ = False
90
87initializer (MutableRef x) = x 91initializer (MutableRef x) = x
88initializer _ = Nothing 92initializer _ = Nothing
89 93
@@ -236,7 +240,7 @@ data KikiCondition a = KikiSuccess a
236 | BadPassphrase 240 | BadPassphrase
237 | FailedToMakeSignature 241 | FailedToMakeSignature
238 | CantFindHome 242 | CantFindHome
239 | AmbiguousKeySpec 243 | AmbiguousKeySpec FilePath
240 | CannotImportMasterKey 244 | CannotImportMasterKey
241 deriving ( Functor, Show ) 245 deriving ( Functor, Show )
242 246
@@ -266,6 +270,9 @@ keyPacket (KeyData k _ _ _) = packet k
266 270
267keyMappedPacket (KeyData k _ _ _) = k 271keyMappedPacket (KeyData k _ _ _) = k
268 272
273subkeyPacket (SubKey k _ ) = packet k
274subkeyMappedPacket (SubKey k _ ) = k
275
269 276
270usage (NotationDataPacket 277usage (NotationDataPacket
271 { human_readable = True 278 { human_readable = True
@@ -544,6 +551,20 @@ selectKey0 wantPublic (spec,mtag) db = do
544 zs = snd $ seek_key subspec ys1 551 zs = snd $ seek_key subspec ys1
545 listToMaybe zs 552 listToMaybe zs
546 553
554selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)]
555selectAll wantPublic (spec,mtag) db = do
556 let Message ps = flattenKeys wantPublic db
557 ys = snd $ seek_key spec ps
558 y <- take 1 ys
559 case mtag of
560 Nothing -> return (y,Nothing)
561 Just tag ->
562 let search ys1 = do
563 let zs = snd $ seek_key (KeyTag y tag) ys1
564 z <- take 1 zs
565 (y,Just z):search (drop 1 zs)
566 in search (drop 1 ys)
567
547seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) 568seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
548seek_key (KeyGrip grip) sec = (pre, subs) 569seek_key (KeyGrip grip) sec = (pre, subs)
549 where 570 where
@@ -747,7 +768,7 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
747 (listToMaybe parsedkey) $ \key -> do 768 (listToMaybe parsedkey) $ \key -> do
748 let (m0,tailms) = splitAt 1 ms 769 let (m0,tailms) = splitAt 1 ms
749 if (not (null tailms) || null m0) 770 if (not (null tailms) || null m0)
750 then return AmbiguousKeySpec 771 then return $ AmbiguousKeySpec fname
751 else doImportG doDecrypt db m0 tag fname key 772 else doImportG doDecrypt db m0 tag fname key
752 773
753doImportG 774doImportG
@@ -919,8 +940,6 @@ writeRingKeys krd db wk secring pubring = do
919 let ks = Map.elems db 940 let ks = Map.elems db
920 isring (KeyRingFile {}) = True 941 isring (KeyRingFile {}) = True
921 isring _ = False 942 isring _ = False
922 isMutable (MutableRef {}) = True
923 isMutable _ = False
924 fs = do 943 fs = do
925 (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) 944 (f,(rtyp,ftyp)) <- Map.toList (kFiles krd)
926 guard (isring ftyp) 945 guard (isring ftyp)
@@ -960,6 +979,49 @@ writeRingKeys krd db wk secring pubring = do
960 return $ KikiSuccess report 979 return $ KikiSuccess report
961 980
962 981
982{-
983getSubkeysForExport kk subspec db = do
984 kd <- maybeToList $ Map.lookup kk db
985 subkeysForExport subspec kd
986-}
987
988subkeysForExport subspec (KeyData key _ _ subkeys) = do
989 let subs tag = do
990 e <- Map.elems subkeys
991 guard $ doSearch key tag e
992 return $ subkeyPacket e
993 maybe [packet key] subs subspec
994 where
995 doSearch key tag (SubKey sub_mp sigtrusts) =
996 let (_,v,_) = findTag tag
997 (packet key)
998 (packet sub_mp)
999 sigtrusts
1000 in fmap fst v==Just True
1001
1002writePEMKeys :: KeyDB
1003 -> [(FilePath,Maybe String,[Packet],Maybe Initializer)]
1004 -> IO (KikiCondition [(FilePath,KikiReportAction)])
1005writePEMKeys db exports = do
1006 ds <- mapM decryptKeys exports
1007 let ds' = map functorToEither ds
1008 if null (lefts ds')
1009 then do
1010 rs <- mapM (uncurry $ writeKeyToFile False "PEM")
1011 (rights ds')
1012 return $ KikiSuccess (concat rs)
1013 else do
1014 return (head $ lefts ds')
1015 where
1016 doDecrypt = todo
1017 writeKeyToFile = todo -- writeKeyToFile False "PEM" fname pun
1018
1019 decryptKeys (fname,subspec,[p],_) = do
1020 pun <- doDecrypt p
1021 flip (maybe $ return BadPassphrase) pun $ \pun -> do
1022 return $ KikiSuccess (fname,pun)
1023
1024
963runKeyRing :: KeyRingData -> IO (KikiResult KeyRingRuntime) 1025runKeyRing :: KeyRingData -> IO (KikiResult KeyRingRuntime)
964runKeyRing keyring = do 1026runKeyRing keyring = do
965 homedir <- getHomeDir (homeSpec keyring) 1027 homedir <- getHomeDir (homeSpec keyring)
@@ -999,17 +1061,39 @@ runKeyRing keyring = do
999 f <- resolveInputFile secring pubring f 1061 f <- resolveInputFile secring pubring f
1000 return (f,t) 1062 return (f,t)
1001 1063
1002 1064 let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do
1003 -- create nonexistent files via external commands
1004 externals_ret <- do
1005 let cmds = do
1006 (fname,(rtyp,ftyp)) <- nonexistents 1065 (fname,(rtyp,ftyp)) <- nonexistents
1007 cmd <- maybeToList (initializer rtyp) 1066 guard $ isMutable rtyp
1008 (topspec,subspec) <- fmap (parseSpec $ maybe "" id grip) 1067 (topspec,subspec) <- fmap (parseSpec $ maybe "" id grip)
1009 $ getUsage ftyp 1068 $ getUsage ftyp
1010 let ms = map fst $ filterMatches topspec (Map.toList db) 1069 -- ms will contain duplicates if a top key has multiple matching
1011 guard $ isNothing $ selectPublicKey (topspec,subspec) db 1070 -- subkeys. This is intentional.
1012 return (fname,subspec,ms,cmd) 1071 let -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db
1072 -- ms = filterMatches topspec $ Map.toList db
1073 ns = do
1074 (kk,kd) <- filterMatches topspec $ Map.toList db
1075 return (kk , subkeysForExport subspec kd)
1076 return (fname,subspec,ns,initializer rtyp)
1077 (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
1078 notmissing
1079 exports = map (\(f,subspec,ns,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0
1080
1081
1082 ambiguity (f,topspec,subspec,_) = do
1083 return $ KikiResult (AmbiguousKeySpec f) []
1084
1085 ifnotnull (x:xs) f g = f x
1086 ifnotnull _ f g = g
1087
1088 ifnotnull ambiguous ambiguity $ do
1089
1090 -- create nonexistent files via external commands
1091 externals_ret <- do
1092 let cmds = mapMaybe getcmd missing
1093 where
1094 getcmd (fname,subspec,ms,mcmd) = do
1095 cmd <- mcmd
1096 return (fname,subspec,ms,cmd)
1013 rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do 1097 rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do
1014 e <- systemEnv [ ("file",fname) 1098 e <- systemEnv [ ("file",fname)
1015 , ("usage",maybe "" id subspec) ] 1099 , ("usage",maybe "" id subspec) ]
@@ -1019,11 +1103,11 @@ runKeyRing keyring = do
1019 ExitSuccess -> return (tup,ExternallyGeneratedFile) 1103 ExitSuccess -> return (tup,ExternallyGeneratedFile)
1020 1104
1021 v <- foldM importPEMKey (KikiSuccess (db,[])) $ do 1105 v <- foldM importPEMKey (KikiSuccess (db,[])) $ do
1022 (tup,r) <- rs 1106 ((f,subspec,ms,cmd),r) <- rs
1023 guard $ case r of 1107 guard $ case r of
1024 ExternallyGeneratedFile -> True 1108 ExternallyGeneratedFile -> True
1025 _ -> False 1109 _ -> False
1026 return tup 1110 return (f,subspec,map fst ms,cmd)
1027 1111
1028 try v $ \(db,import_rs) -> do 1112 try v $ \(db,import_rs) -> do
1029 return $ KikiSuccess (db, map (\((f,_,_,_),r)->(f,r)) rs 1113 return $ KikiSuccess (db, map (\((f,_,_,_),r)->(f,r)) rs
@@ -1037,7 +1121,8 @@ runKeyRing keyring = do
1037 r <- writeRingKeys keyring db wk secring pubring 1121 r <- writeRingKeys keyring db wk secring pubring
1038 try' r $ \report_rings -> do 1122 try' r $ \report_rings -> do
1039 1123
1040 -- todo writePEMKeys 1124 r <- writePEMKeys db exports
1125 try' r $ \report_pems -> do
1041 1126
1042 let rt = KeyRingRuntime 1127 let rt = KeyRingRuntime
1043 { rtPubring = pubring 1128 { rtPubring = pubring
@@ -1049,7 +1134,8 @@ runKeyRing keyring = do
1049 $ concat [ report_imports 1134 $ concat [ report_imports
1050 , report_externals 1135 , report_externals
1051 , report_wallets 1136 , report_wallets
1052 , report_rings ] 1137 , report_rings
1138 , report_pems ]
1053 1139
1054 forM_ lked $ \(Just lk, fname) -> dotlock_release lk 1140 forM_ lked $ \(Just lk, fname) -> dotlock_release lk
1055 1141