summaryrefslogtreecommitdiff
path: root/KeyRing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'KeyRing.hs')
-rw-r--r--KeyRing.hs108
1 files changed, 62 insertions, 46 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index b6f16ca..0522fdb 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -96,7 +96,18 @@ data FileType = KeyRingFile (Maybe PassWordFile)
96 | PEMFile UsageTag 96 | PEMFile UsageTag
97 | WalletFile -- (Maybe UsageTag) 97 | WalletFile -- (Maybe UsageTag)
98 98
99data RefType = ConstRef | MutableRef (Maybe Initializer) 99-- | RefType is perhaps not a good name for this...
100-- It is sort of like a read/write flag, although
101-- semantically, it is indicating the intention of
102-- an action and not just the access level of an
103-- object.
104data RefType = ConstRef
105 -- ^ merge into database but do not update
106 | MutableRef (Maybe Initializer)
107 -- ^ sync into database
108 -- update dabase and also update file
109 -- Initializer is a shell command that creates
110 -- the file; eg, ssh-keygen
100 111
101isMutable (MutableRef {}) = True 112isMutable (MutableRef {}) = True
102isMutable _ = False 113isMutable _ = False
@@ -127,22 +138,15 @@ data KeyRingRuntime = KeyRingRuntime
127 138
128data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a) 139data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a)
129 140
130data SubKeyKey = SubKeyKey KeyKey | UIDKey String 141-- | TODO: Packet Update should have deletiong action
131 deriving (Eq,Ord) 142-- and any other kind of roster entry level
132 143-- action.
133data PacketUpdate = InducerSignature [SignatureSubpacket] 144data PacketUpdate = InducerSignature String [SignatureSubpacket]
134 145
135data KeyRingAddress a = KeyRingAddress 146noManip :: KeyRingRuntime -> KeyData -> [PacketUpdate]
136 { topkeyAddress :: KeyKey 147noManip _ _ = []
137 , subkeyAddress :: SubKeyKey
138 , keyringAddressed :: a
139 }
140 deriving Functor
141 148
142noManip :: KeyRingRuntime -> [KeyRingAddress PacketUpdate] 149data KeyRingOperation = KeyRingOperation
143noManip = const []
144
145data KeyRingData = KeyRingData
146 { kFiles :: Map.Map InputFile (RefType,FileType) 150 { kFiles :: Map.Map InputFile (RefType,FileType)
147 , kImports :: Map.Map InputFile (KeyRingRuntime -> KeyData -> Maybe Bool) 151 , kImports :: Map.Map InputFile (KeyRingRuntime -> KeyData -> Maybe Bool)
148 -- ^ 152 -- ^
@@ -153,7 +157,7 @@ data KeyRingData = KeyRingData
153 -- Note that subkeys will always be imported if their owner key is 157 -- Note that subkeys will always be imported if their owner key is
154 -- already in the ring. 158 -- already in the ring.
155 -- TODO: Even if their signatures are bad? 159 -- TODO: Even if their signatures are bad?
156 , kManip :: KeyRingRuntime -> [KeyRingAddress PacketUpdate] 160 , kManip :: KeyRingRuntime -> KeyData -> [PacketUpdate]--[KeyRingAddress PacketUpdate]
157 , homeSpec :: Maybe String 161 , homeSpec :: Maybe String
158 } 162 }
159 163
@@ -173,8 +177,8 @@ filesToLock k secring pubring = do
173 MutableRef {} -> resolveInputFile secring pubring f 177 MutableRef {} -> resolveInputFile secring pubring f
174 178
175 179
176-- kret :: a -> KeyRingData a 180-- kret :: a -> KeyRingOperation a
177-- kret x = KeyRingData Map.empty Nothing (KeyRingAction x) 181-- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x)
178 182
179data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) 183data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
180data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show 184data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show
@@ -682,7 +686,7 @@ importPEMKey doDecrypt db' tup = do
682 return $ KikiSuccess (db'', report0 ++ report) 686 return $ KikiSuccess (db'', report0 ++ report)
683 687
684buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet)) 688buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet))
685 -> FilePath -> FilePath -> Maybe String -> KeyRingData 689 -> FilePath -> FilePath -> Maybe String -> KeyRingOperation
686 -> IO (KikiCondition ((KeyDB,Maybe String,Maybe Packet),[(FilePath,KikiReportAction)])) 690 -> IO (KikiCondition ((KeyDB,Maybe String,Maybe Packet),[(FilePath,KikiReportAction)]))
687buildKeyDB doDecrypt secring pubring grip0 keyring = do 691buildKeyDB doDecrypt secring pubring grip0 keyring = do
688 let 692 let
@@ -954,7 +958,7 @@ walletImportFormat idbyte k = secret_base58_foo
954 (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d) 958 (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d)
955 seckey = S.cons idbyte bigendian 959 seckey = S.cons idbyte bigendian
956 960
957writeWalletKeys :: KeyRingData -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)]) 961writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)])
958writeWalletKeys krd db wk = do 962writeWalletKeys krd db wk = do
959 let cs = db `coinKeysOwnedBy` wk 963 let cs = db `coinKeysOwnedBy` wk
960 -- export wallet keys 964 -- export wallet keys
@@ -1019,7 +1023,7 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
1019 guard $ matchSpec (KeyGrip fp) elm 1023 guard $ matchSpec (KeyGrip fp) elm
1020 return $ keyPacket (snd elm) 1024 return $ keyPacket (snd elm)
1021 1025
1022writeRingKeys :: KeyRingData -> KeyRingRuntime 1026writeRingKeys :: KeyRingOperation -> KeyRingRuntime
1023 {- 1027 {-
1024 -> KeyDB -> Maybe Packet 1028 -> KeyDB -> Maybe Packet
1025 -> FilePath -> FilePath 1029 -> FilePath -> FilePath
@@ -1200,13 +1204,15 @@ doDecrypt unkeysRef pws mp = do
1200 (return . KikiSuccess) 1204 (return . KikiSuccess)
1201 $ Map.lookup kk unkeys 1205 $ Map.lookup kk unkeys
1202 1206
1207{-
1203interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData 1208interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData
1204interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" 1209interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
1205interpretManip kd manip = return kd 1210interpretManip kd manip = return kd
1211-}
1206 1212
1207runKeyRing :: KeyRingData -> IO (KikiResult KeyRingRuntime) 1213runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
1208runKeyRing keyring = do 1214runKeyRing operation = do
1209 homedir <- getHomeDir (homeSpec keyring) 1215 homedir <- getHomeDir (homeSpec operation)
1210 let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) 1216 let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b)
1211 -- FIXME: try' should probably accept a list of KikiReportActions. 1217 -- FIXME: try' should probably accept a list of KikiReportActions.
1212 -- This would be useful for reporting on disk writes that have already 1218 -- This would be useful for reporting on disk writes that have already
@@ -1216,7 +1222,7 @@ runKeyRing keyring = do
1216 Left e -> return $ KikiResult e [] 1222 Left e -> return $ KikiResult e []
1217 Right wkun -> body wkun 1223 Right wkun -> body wkun
1218 try' homedir $ \(homedir,secring,pubring,grip0) -> do 1224 try' homedir $ \(homedir,secring,pubring,grip0) -> do
1219 let tolocks = filesToLock keyring secring pubring 1225 let tolocks = filesToLock operation secring pubring
1220 lks <- forM tolocks $ \f -> do 1226 lks <- forM tolocks $ \f -> do
1221 lk <- dotlock_create f 0 1227 lk <- dotlock_create f 0
1222 v <- flip (maybe $ return Nothing) lk $ \lk -> do 1228 v <- flip (maybe $ return Nothing) lk $ \lk -> do
@@ -1231,23 +1237,23 @@ runKeyRing keyring = do
1231 else do 1237 else do
1232 1238
1233 pws <- 1239 pws <-
1234 -- TODO: head will throw an exception if a File Descriptor keyring 1240 -- TODO: head will throw an exception if a File Descriptor operation
1235 -- file is present. We probably should change OriginMap to use InputFile 1241 -- file is present. We probably should change OriginMap to use InputFile
1236 -- instead of FilePath. 1242 -- instead of FilePath.
1237 Traversable.mapM (cachedContents secring pubring . fromJust . pwfile . snd) 1243 Traversable.mapM (cachedContents secring pubring . fromJust . pwfile . snd)
1238 (Map.mapKeys (head . resolveInputFile secring pubring) 1244 (Map.mapKeys (head . resolveInputFile secring pubring)
1239 $ Map.filter (isJust . pwfile . snd) $ kFiles keyring) 1245 $ Map.filter (isJust . pwfile . snd) $ kFiles operation)
1240 1246
1241 unkeysRef <- newIORef Map.empty 1247 unkeysRef <- newIORef Map.empty
1242 1248
1243 -- merge all keyrings, PEM files, and wallets 1249 -- merge all keyrings, PEM files, and wallets
1244 bresult <- buildKeyDB (doDecrypt unkeysRef pws) secring pubring grip0 keyring 1250 bresult <- buildKeyDB (doDecrypt unkeysRef pws) secring pubring grip0 operation
1245 1251
1246 try' bresult $ \((db,grip,wk),report_imports) -> do 1252 try' bresult $ \((db,grip,wk),report_imports) -> do
1247 1253
1248 nonexistents <- 1254 nonexistents <-
1249 filterM (fmap not . doesFileExist . fst) 1255 filterM (fmap not . doesFileExist . fst)
1250 $ do (f,t) <- Map.toList (kFiles keyring) 1256 $ do (f,t) <- Map.toList (kFiles operation)
1251 f <- resolveInputFile secring pubring f 1257 f <- resolveInputFile secring pubring f
1252 return (f,t) 1258 return (f,t)
1253 1259
@@ -1314,7 +1320,11 @@ runKeyRing keyring = do
1314 1320
1315 try' externals_ret $ \(db,report_externals) -> do 1321 try' externals_ret $ \(db,report_externals) -> do
1316 1322
1317 let manips0 = kManip keyring rt 1323 db <- let perform kd (InducerSignature uid subpaks) = error "todo"
1324 in Traversable.mapM (\kd -> foldM perform kd (kManip operation rt kd)) db
1325
1326{-
1327 let manips0 = kManip operation rt
1318 manips :: Map.Map KeyKey [KeyRingAddress PacketUpdate] 1328 manips :: Map.Map KeyKey [KeyRingAddress PacketUpdate]
1319 manips = Map.fromList $ do 1329 manips = Map.fromList $ do
1320 ms <- groupBy ((==EQ) .: comparing topkeyAddress) 1330 ms <- groupBy ((==EQ) .: comparing topkeyAddress)
@@ -1329,11 +1339,12 @@ runKeyRing keyring = do
1329 foldM interpretManip kd ms 1339 foldM interpretManip kd ms
1330 1340
1331 db' <- Traversable.mapM doManips db 1341 db' <- Traversable.mapM doManips db
1342-}
1332 1343
1333 r <- writeWalletKeys keyring db wk 1344 r <- writeWalletKeys operation db wk
1334 try' r $ \report_wallets -> do 1345 try' r $ \report_wallets -> do
1335 1346
1336 r <- writeRingKeys keyring rt -- db wk secring pubring 1347 r <- writeRingKeys operation rt -- db wk secring pubring
1337 try' r $ \report_rings -> do 1348 try' r $ \report_rings -> do
1338 1349
1339 r <- writePEMKeys (doDecrypt unkeysRef pws) db exports 1350 r <- writePEMKeys (doDecrypt unkeysRef pws) db exports
@@ -1708,6 +1719,11 @@ type SigAndTrust = ( MappedPacket
1708 1719
1709type KeyKey = [ByteString] 1720type KeyKey = [ByteString]
1710data SubKey = SubKey MappedPacket [SigAndTrust] 1721data SubKey = SubKey MappedPacket [SigAndTrust]
1722
1723-- | This is a roster entry, it's poorly named
1724-- but we are keeping the name around until
1725-- we're sure we wont be cutting and pasting
1726-- code with master any more
1711data KeyData = KeyData MappedPacket -- main key 1727data KeyData = KeyData MappedPacket -- main key
1712 [SigAndTrust] -- sigs on main key 1728 [SigAndTrust] -- sigs on main key
1713 (Map.Map String ([SigAndTrust],OriginMap)) -- uids 1729 (Map.Map String ([SigAndTrust],OriginMap)) -- uids
@@ -1938,8 +1954,8 @@ flattenUid fname ispub (str,(sigs,om)) =
1938 1954
1939{- 1955{-
1940data Kiki a = 1956data Kiki a =
1941 SinglePass (KeyRingData -> KeyRingAction a) 1957 SinglePass (KeyRingOperation -> KeyRingAction a)
1942 | forall b. MultiPass (KeyRingData -> KeyRingAction b) 1958 | forall b. MultiPass (KeyRingOperation -> KeyRingAction b)
1943 (Kiki (b -> a)) 1959 (Kiki (b -> a))
1944 1960
1945fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b 1961fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b
@@ -1960,13 +1976,13 @@ instance Monad Kiki where
1960 k >>= f = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k 1976 k >>= f = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k
1961 where (.:) = (.) . (.) 1977 where (.:) = (.) . (.)
1962 1978
1963eval :: KeyRingRuntime -> Kiki a -> KeyRingData -> a 1979eval :: KeyRingRuntime -> Kiki a -> KeyRingOperation -> a
1964eval rt (SinglePass f) kd = 1980eval rt (SinglePass f) kd =
1965 case f kd of KeyRingAction v -> v 1981 case f kd of KeyRingAction v -> v
1966 RunTimeAction g -> g rt 1982 RunTimeAction g -> g rt
1967eval rt (MultiPass p kk) kd = eval rt kk kd $ eval rt (SinglePass p) kd 1983eval rt (MultiPass p kk) kd = eval rt kk kd $ eval rt (SinglePass p) kd
1968 1984
1969eval' :: Kiki (KeyRingData -> a) -> Kiki a 1985eval' :: Kiki (KeyRingOperation -> a) -> Kiki a
1970eval' k@(SinglePass pass) = SinglePass pass' 1986eval' k@(SinglePass pass) = SinglePass pass'
1971 where 1987 where
1972 pass' kd = case pass kd of 1988 pass' kd = case pass kd of
@@ -1981,9 +1997,9 @@ eval' k@(MultiPass p kk) = MultiPass p kk'
1981 1997
1982 1998
1983{- 1999{-
1984fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v})) 2000fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = KeyRingAction v}))
1985 = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) } 2001 = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) }
1986fmapWithRT g (SinglePass d@(KeyRingData { kAction = RunTimeAction f})) 2002fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = RunTimeAction f}))
1987 = SinglePass $ d { kAction = RunTimeAction f' } 2003 = SinglePass $ d { kAction = RunTimeAction f' }
1988 where f' rt = g rt (f rt) 2004 where f' rt = g rt (f rt)
1989fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk) 2005fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk)
@@ -1992,10 +2008,10 @@ fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk)
1992 2008
1993 2009
1994data Kiki a = 2010data Kiki a =
1995 SinglePass { passInfo :: KeyRingData 2011 SinglePass { passInfo :: KeyRingOperation
1996 , rtAction :: KeyRingAction a } 2012 , rtAction :: KeyRingAction a }
1997 | forall b. 2013 | forall b.
1998 MultiPass { passInfo :: KeyRingData 2014 MultiPass { passInfo :: KeyRingOperation
1999 , passAction :: KeyRingAction b 2015 , passAction :: KeyRingAction b
2000 , nextPass :: Kiki (b -> a) 2016 , nextPass :: Kiki (b -> a)
2001 } 2017 }
@@ -2093,8 +2109,8 @@ instance Functor Kiki where
2093-} 2109-}
2094 2110
2095{- 2111{-
2096data Kiki a = SinglePass (KeyRingData a) 2112data Kiki a = SinglePass (KeyRingOperation a)
2097 | forall b. MultiPass (KeyRingData b) (Kiki (b -> a)) 2113 | forall b. MultiPass (KeyRingOperation b) (Kiki (b -> a))
2098 2114
2099instance Functor Kiki where 2115instance Functor Kiki where
2100 fmap f (SinglePass d) = SinglePass $ case kAction d of 2116 fmap f (SinglePass d) = SinglePass $ case kAction d of
@@ -2103,14 +2119,14 @@ instance Functor Kiki where
2103 fmap f (MultiPass p k)= MultiPass p (fmap (f .) k) 2119 fmap f (MultiPass p k)= MultiPass p (fmap (f .) k)
2104 2120
2105eval :: KeyRingRuntime -> Kiki a -> a 2121eval :: KeyRingRuntime -> Kiki a -> a
2106eval rt (SinglePass (KeyRingData { kAction = KeyRingAction v})) = v 2122eval rt (SinglePass (KeyRingOperation { kAction = KeyRingAction v})) = v
2107eval rt (SinglePass (KeyRingData { kAction = RunTimeAction f})) = f rt 2123eval rt (SinglePass (KeyRingOperation { kAction = RunTimeAction f})) = f rt
2108eval rt (MultiPass p kk) = eval rt kk $ eval rt (SinglePass p) 2124eval rt (MultiPass p kk) = eval rt kk $ eval rt (SinglePass p)
2109 2125
2110fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b 2126fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b
2111fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v})) 2127fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = KeyRingAction v}))
2112 = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) } 2128 = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) }
2113fmapWithRT g (SinglePass d@(KeyRingData { kAction = RunTimeAction f})) 2129fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = RunTimeAction f}))
2114 = SinglePass $ d { kAction = RunTimeAction f' } 2130 = SinglePass $ d { kAction = RunTimeAction f' }
2115 where f' rt = g rt (f rt) 2131 where f' rt = g rt (f rt)
2116fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk) 2132fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk)