From bc0458ee540da677a04eeddf9b4e0fe8a8991e93 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 1 Jul 2019 02:37:20 -0400 Subject: Attempted to merge 0bc53f99cfd70f3a18802604d7ef3174d004db4c. I left lib/Kiki.hs out for later. --- kiki.cabal | 2 +- lib/KeyRing.hs | 1316 +----------------------------------------- lib/KeyRing/BuildKeyDB.hs | 1402 ++++++++++----------------------------------- lib/KeyRing/Types.hs | 394 +++++++++++++ lib/PacketTranscoder.hs | 2 +- lib/ScanningParser.hs | 2 + lib/Transforms.hs | 45 +- lib/Types.hs | 337 ----------- 8 files changed, 724 insertions(+), 2776 deletions(-) create mode 100644 lib/KeyRing/Types.hs delete mode 100644 lib/Types.hs diff --git a/kiki.cabal b/kiki.cabal index 186e439..34e31c4 100644 --- a/kiki.cabal +++ b/kiki.cabal @@ -76,7 +76,7 @@ Executable cokiki library hs-source-dirs: lib exposed-modules: KeyRing, - Types, + KeyRing.Types, KeyRing.BuildKeyDB, Kiki, ScanningParser, diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 244f880..69410ad 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs @@ -24,7 +24,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE LambdaCase #-} -module KeyRing (module KeyRing.Types, module KeyRing, module KeyRing.BuildKeyDB) +module KeyRing (module KeyRing.Types, module KeyRing, module KeyRing.BuildKeyDB) where import System.Environment import Control.Monad @@ -123,7 +123,7 @@ import FunctorToMaybe import DotLock import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) import GnuPGAgent as Agent -import KeyRing.BuildKeyDB (accBindings, backsig, buildKeyDB, +import KeyRing.BuildKeyDB {- (accBindings, backsig, buildKeyDB, combineTransforms, concatSort, derRSA, derToBase32, filterMatches, findTag, fingerdress, @@ -148,35 +148,13 @@ import KeyRing.BuildKeyDB (accBindings, backsig, buildKeyDB, secretToPublic, seek_key, selectKey0, selectPublicKey, showPacket, sortByHint, - subkeyMappedPacket, torhash, try, - usage, usageFromFilter, - usageString) + subkeyMappedPacket, torhash, + usageFromFilter) -} -import Types +import KeyRing.Types import PacketTranscoder import Transforms --- DER-encoded elliptic curve ids --- nistp256_id = 0x2a8648ce3d030107 -secp256k1_id :: Integer -secp256k1_id = 0x2b8104000a --- "\x2a\x86\x48\xce\x3d\x03\x01\x07" -{- OID Curve description Curve name - ---------------------------------------------------------------- - 1.2.840.10045.3.1.7 NIST Curve P-256 [FIPS 186-2] "NIST P-256" - 1.3.132.0.34 NIST Curve P-384 [FIPS 186-2] "NIST P-384" - 1.3.132.0.35 NIST Curve P-521 [FIPS 186-2] "NIST P-521" - - Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST - P-521". The hexadecimal representation used in the public and - private key encodings are: - - Curve Name Len Hexadecimal representation of the OID - ---------------------------------------------------------------- - "NIST P-256" 8 0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07 - "NIST P-384" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x22 - "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23 --} data HomeDir = HomeDir { homevar :: String @@ -191,37 +169,16 @@ home = HomeDir , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] } -spillable :: StreamInfo -> Bool -spillable (spill -> KF_None) = False -spillable _ = True - isMutable :: StreamInfo -> Bool isMutable stream | KF_None <- fill stream = False isMutable _ = True -isring :: FileType -> Bool -isring (KeyRingFile {}) = True -isring _ = False - -isSecretKeyFile :: FileType -> Bool -isSecretKeyFile PEMFile = True -isSecretKeyFile DNSPresentation = True -isSecretKeyFile _ = False - {- pwfile :: FileType -> Maybe InputFile pwfile (KeyRingFile f) = f pwfile _ = Nothing -} -iswallet :: FileType -> Bool -iswallet (WalletFile {}) = True -iswallet _ = False - -usageFromFilter :: MonadPlus m => KeyFilter -> m String -usageFromFilter (KF_Match usage) = return usage -usageFromFilter _ = mzero - filesToLock :: KeyRingOperation -> InputFileContext -> [FilePath] @@ -275,76 +232,6 @@ instance ASN1Object PKCS8_RSAPublicKey where fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format" -{- -RSAPrivateKey ::= SEQUENCE { - version Version, - modulus INTEGER, -- n - publicExponent INTEGER, -- e - privateExponent INTEGER, -- d - prime1 INTEGER, -- p - prime2 INTEGER, -- q - exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1) - exponent2 INTEGER, -- d mod (q-1) - coefficient INTEGER, -- (inverse of q) mod p - otherPrimeInfos OtherPrimeInfos OPTIONAL - } --} -data RSAPrivateKey = RSAPrivateKey - { rsaN :: MPI - , rsaE :: MPI - , rsaD :: MPI - , rsaP :: MPI - , rsaQ :: MPI - , rsaDmodP1 :: MPI - , rsaDmodQminus1 :: MPI - , rsaCoefficient :: MPI - } - deriving Show - -instance ASN1Object RSAPrivateKey where - toASN1 rsa@(RSAPrivateKey {}) - = \xs -> Start Sequence - : IntVal 0 - : mpiVal rsaN - : mpiVal rsaE - : mpiVal rsaD - : mpiVal rsaP - : mpiVal rsaQ - : mpiVal rsaDmodP1 - : mpiVal rsaDmodQminus1 - : mpiVal rsaCoefficient - : End Sequence - : xs - where mpiVal f = IntVal x where MPI x = f rsa - - fromASN1 ( Start Sequence - : IntVal _ -- version - : IntVal n - : IntVal e - : IntVal d - : IntVal p - : IntVal q - : IntVal dmodp1 - : IntVal dmodqminus1 - : IntVal coefficient - : ys) = - Right ( privkey, tail $ dropWhile notend ys) - where - notend (End Sequence) = False - notend _ = True - privkey = RSAPrivateKey - { rsaN = MPI n - , rsaE = MPI e - , rsaD = MPI d - , rsaP = MPI p - , rsaQ = MPI q - , rsaDmodP1 = MPI dmodp1 - , rsaDmodQminus1 = MPI dmodqminus1 - , rsaCoefficient = MPI coefficient - } - fromASN1 _ = - Left "fromASN1: RSAPrivateKey: unexpected format" - reportString :: KikiReportAction -> String @@ -369,45 +256,6 @@ x509cert _ = Nothing - -matchSpec :: KeySpec -> KeyData -> Bool -matchSpec (KeyGrip grip) (KeyData p _ _ _) - | matchpr grip (packet p)==grip = True - | otherwise = False - -matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps - where - ps = map (packet .fst) sigs - match p = isSignaturePacket p - && has_tag tag p - && has_issuer key p - has_issuer key p = isJust $ do - issuer <- signature_issuer p - guard $ matchpr issuer key == issuer - has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) - || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) - -matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us - where - us = filter (isInfixOf pat) $ Map.keys uids - - - - -data KeySpec = - KeyGrip String -- fp: - | KeyTag Packet String -- fp:????/t: - | KeyUidMatch String -- u: - deriving Show - -data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum) -data SingleKeySpec = FingerprintMatch String - | SubstringMatch (Maybe MatchingField) String - | EmptyMatch - | AnyMatch - | WorkingKeyMatch - deriving (Show,Eq,Ord) - getStr (FingerprintMatch x) = x getStr (SubstringMatch _ x) = x getStr _ = "" @@ -431,25 +279,6 @@ getStr _ = "" -- (Any of the fields may be left empty.) type Spec = (SingleKeySpec,SingleKeySpec,SingleKeySpec) -parseSingleSpec :: String -> SingleKeySpec -parseSingleSpec "*" = AnyMatch -parseSingleSpec "-" = WorkingKeyMatch -parseSingleSpec "" = EmptyMatch -parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag -parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag -parseSingleSpec ('c':':':tag) = SubstringMatch (Just GroupIDField) tag -parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp -parseSingleSpec str - | is40digitHex str = FingerprintMatch str - | otherwise = SubstringMatch Nothing str - -is40digitHex xs = ys == xs && length ys==40 - where - ys = filter ishex xs - ishex c | '0' <= c && c <= '9' = True - | 'A' <= c && c <= 'F' = True - | 'a' <= c && c <= 'f' = True - ishex c = False data SpecError = SpecENone String | SpecEMissMatch String (Maybe MatchingField) MatchingField @@ -574,43 +403,6 @@ wordsBy c xs = let (b,a) = span (/=c) xs in b:wordsBy c (drop 1 a) - --- | Parse a key specification. --- The first argument is a grip for the default working key. -parseSpec :: String -> String -> (KeySpec,Maybe String) -parseSpec wkgrip spec = - if not slashed - then - case prespec of - AnyMatch -> (KeyGrip "", Nothing) - EmptyMatch -> error "Bad key spec." - WorkingKeyMatch -> (KeyGrip wkgrip, Nothing) - SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag) - SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str) - SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) - FingerprintMatch fp -> (KeyGrip fp, Nothing) - else - case (prespec,postspec) of - (FingerprintMatch fp, SubstringMatch st t) - | st /= Just UserIDField -> (KeyGrip fp, Just t) - (SubstringMatch mt u, _) - | postspec `elem` [AnyMatch,EmptyMatch] - && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing) - (SubstringMatch mt u, SubstringMatch st t) - | mt /= Just KeyTypeField - && st /= Just UserIDField -> (KeyUidMatch u, Just t) - (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec" - (_,FingerprintMatch fp) -> error "todo: support /fp: spec" - (FingerprintMatch fp,_) -> error "todo: support fp:/ spec" - _ -> error "Bad key spec." - where - (preslash,slashon) = break (=='/') spec - slashed = not $ null $ take 1 slashon - postslash = drop 1 slashon - - prespec = parseSingleSpec preslash - postspec = parseSingleSpec postslash - {- - BUGGY parseSpec grip spec = (topspec,subspec) @@ -653,9 +445,6 @@ parseSpec grip spec = (topspec,subspec) -} -filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] -filterMatches spec ks = filter (matchSpec spec . snd) ks - filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' where @@ -686,9 +475,6 @@ filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db -selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db - selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])] selectPublicKeyAndSigs (spec,mtag) db = case mtag of @@ -717,15 +503,6 @@ selectPublicKeyAndSigs (spec,mtag) db = guard hastag return $ (kk, packet sub, map (packet . fst) sigs) -selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectKey0 wantPublic (spec,mtag) db = do - let Message ps = flattenKeys wantPublic db - ys = snd $ seek_key spec ps - flip (maybe (listToMaybe ys)) mtag $ \tag -> do - case ys of - y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 - [] -> Nothing - {- selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] selectAll wantPublic (spec,mtag) db = do @@ -742,50 +519,6 @@ selectAll wantPublic (spec,mtag) db = do in search (drop 1 ys) -} -seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) -seek_key (KeyGrip grip) sec = (pre, subs) - where - (pre,subs) = break pred sec - pred p@(SecretKeyPacket {}) = matchpr grip p == grip - pred p@(PublicKeyPacket {}) = matchpr grip p == grip - pred _ = False - -seek_key (KeyTag key tag) ps - | null bs = (ps, []) - | null qs = - let (as', bs') = seek_key (KeyTag key tag) (tail bs) in - (as ++ (head bs : as'), bs') - | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (\p -> isSignaturePacket p - && has_tag tag p - && isJust (signature_issuer p) - && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) - ps - (rs,qs) = break isKey (reverse as) - - has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) - || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) - -seek_key (KeyUidMatch pat) ps - | null bs = (ps, []) - | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in - (as ++ (head bs : as'), bs') - | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (isInfixOf pat . uidStr) ps - (rs,qs) = break isKey (reverse as) - - uidStr (UserIDPacket s) = s - uidStr _ = "" - - -readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString -readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents -readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents -readInputFileL ctx inp = do - let fname = resolveInputFile ctx inp - fmap L.concat $ mapM L.readFile fname writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs) @@ -829,20 +562,6 @@ writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeF writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either (\h x-> hPutStr h x >> hClose h) writeFile) str -getInputFileTime :: InputFileContext -> InputFile -> IO CTime -getInputFileTime ctx (Pipe fdr fdw) = do - mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr - maybe tryw return mt - where - tryw = do - handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?") - $ modificationTime <$> getFdStatus fdw -getInputFileTime ctx (FileDesc fd) = do - handleIO_ (error $ "&"++show fd++": modificaiton time?") $ - modificationTime <$> getFdStatus fd -getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do - handleIO_ (error $ fname++": modificaiton time?") $ - modificationTime <$> getFileStatus fname {- - This may be useful later. Commented for now as it is not used. @@ -855,104 +574,8 @@ doesInputFileExist ctx f = do -} -generateSubkey :: - PacketTranscoder - -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db - -> (GenerateKeyParams, StreamInfo) - -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) -generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do - try kd' $ \(kd,report0) -> do - let subs = do - SubKey p sigs <- Map.elems $ keySubKeys kd - filter (has_tag tag) $ map (packet . fst) sigs - if null subs - then do - newkey <- generateKey genparam - kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey - try kdr $ \(newkd,report) -> do - return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) - else do - return $ KikiSuccess (kd,report0) -generateSubkey _ kd _ = return kd - -importSecretKey :: - (PacketTranscoder) - -> KikiCondition - (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) - -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) - -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -importSecretKey transcode db' tup = do - try db' $ \(db',report0) -> do - r <- doImport transcode - db' - tup - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) - - -mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext - -> IO - (KikiCondition - ( ( Map.Map [Char8.ByteString] KeyData - , ( [Hosts.Hosts] - , [Hosts.Hosts] - , Hosts.Hosts - , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))] - , [SockAddr])) - , [(FilePath,KikiReportAction)])) -mergeHostFiles krd db ctx = do - let hns = files ishosts - ishosts Hosts = True - ishosts _ = False - files istyp = do - (f,stream) <- Map.toList (opFiles krd) - guard (istyp $ typ stream) - return f - readInputFileL' ctx f = - readInputFileL ctx f - `catch` \e -> do when (not $ isDoesNotExistError e) $ do - return () -- todo report problem - return L.empty - hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns - - let gpgnames = map getHostnames $ Map.elems db - os = do - (addr,(ns,_)) <- gpgnames - n <- ns - return (addr,n) - setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os - -- we ensure .onion names are set properly - hostdbs = map setOnions hostdbs0 - outgoing_names = do - (addr,(_,gns)) <- gpgnames - guard . not $ null gns - guard $ all (null . Hosts.namesForAddress addr) hostdbs0 - return addr - -- putStrLn $ "hostdbs = " ++ show hostdbs - - -- 1. let U = union all the host dbs - -- preserving whitespace and comments of the first - let u0 = foldl' Hosts.plus Hosts.empty hostdbs - -- we filter U to be only finger-dresses - u1 = Hosts.filterAddrs (hasFingerDress db) u0 - - -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h - {- - putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}" - putStrLn $ "--> " ++ show (nf (head hostdbs)) - putStrLn $ "u0 = {\n" ++ show u0 ++ "}" - putStrLn $ "--> " ++ show (nf u0) - putStrLn $ "u1 = {\n" ++ show u1 ++ "}" - putStrLn $ "--> " ++ show (nf u1) - -} - - -- 2. replace gpg annotations with those in U - -- forM use_db - db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db - - return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[]) writeHostsFiles :: KeyRingOperation -> InputFileContext @@ -991,197 +614,7 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do return $ map (first $ resolveForReport $ Just ctx) rs return $ concat rss --- | buildKeyDB --- --- merge all keyrings, PEM files, and wallets into process memory. --- -buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation - -> IO (KikiCondition (({- db -} KeyDB - ,{- grip -} Maybe String - ,{- wk -} Maybe MappedPacket - ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], - {- hostdbs -}[Hosts.Hosts], - {- u1 -}Hosts.Hosts, - {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], - {- outgoing_names -}[SockAddr]) - ,{- accs -} Map.Map InputFile Access - ,{- doDecrypt -} PacketTranscoder - ,{- unspilled -} Map.Map InputFile Message - ) - ,{- report_imports -} [(FilePath,KikiReportAction)])) -buildKeyDB ctx grip0 keyring = do - let files istyp = do - (f,stream) <- Map.toList (opFiles keyring) - guard (istyp $ typ stream) - return f -- resolveInputFile ctx f - ringMap0 = Map.filter (isring . typ) $ opFiles keyring - (genMap,ringMap) = Map.partitionWithKey isgen ringMap0 - where - isgen (Generate _ _) _ = True - isgen _ _ = False - - readp :: InputFile -> StreamInfo -> IO (StreamInfo, Message) - readp f stream = fmap readp0 $ readPacketsFromFile ctx f - where - readp0 ps = (stream { access = acc' }, ps) - where acc' = case access stream of - AutoAccess -> - case ps of - Message ((PublicKeyPacket {}):_) -> Pub - Message ((SecretKeyPacket {}):_) -> Sec - _ -> AutoAccess - acc -> acc - - readw wk n = fmap (n,) (readPacketsFromWallet wk n) - - -- KeyRings (todo: KikiCondition reporting?) - (spilled,mwk,grip,accs,keyqs,unspilled) <- do -#if MIN_VERSION_containers(0,5,0) - ringPackets <- Map.traverseWithKey readp ringMap -#else - ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap -#endif - let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) - - let grip = grip0 `mplus` (fingerprint <$> fstkey) - where - fstkey = do - (_,Message ps) <- Map.lookup HomeSec ringPackets - listToMaybe ps - - -- | spilled - -- ring packets with info available for export - -- | unspilled - -- the rest - (spilled,unspilled) = Map.partition (spillable . fst) ringPackets - - -- | keys - -- process ringPackets, and get a map of fingerprint info to - -- to a packet, remembering it's original file, access. - keys :: Map.Map KeyKey (OriginMapped Query) - mwk :: Maybe MappedPacket - (mwk, keys) = keyQueries grip ringPackets - - -- | accs - -- file access(Sec | Pub) lookup table - accs :: Map.Map InputFile Access - accs = fmap (access . fst) ringPackets - return (spilled,mwk,grip,accs,keys,fmap snd unspilled) - - transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs) - let doDecrypt = transcode (Unencrypted,S2K 100 "") - - let wk = fmap packet mwk - rt0 = KeyRingRuntime { rtPubring = homepubPath ctx - , rtSecring = homesecPath ctx - , rtGrip = grip - , rtWorkingKey = wk - , rtRingAccess = accs - , rtKeyDB = Map.empty - , rtPassphrases = transcode - } - -- autosigns and deletes - transformed0 <- - let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) - trans f (info,ps) = do - let manip = combineTransforms (transforms info) - rt1 = rt0 { rtKeyDB = merge Map.empty f ps } - acc = Just Sec /= Map.lookup f accs - r <- performManipulations doDecrypt rt1 mwk manip - try r $ \(rt2,report) -> do - return $ KikiSuccess (report,rtKeyDB rt2) - -- XXX: Unspilled keys are not obtainable from rtKeyDB. - -- If the working key is marked non spillable, then how - -- would we look up it's UID and such? -#if MIN_VERSION_containers(0,5,0) - in fmap sequenceA $ Map.traverseWithKey trans spilled -#else - in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled -#endif - try transformed0 $ \transformed -> do - let -- | db_rings - all keyrings combined into one - db_rings :: Map.Map KeyKey KeyData - db_rings = Map.foldlWithKey' mergeIt Map.empty transformed - where - mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans - -- | reportTrans - -- events, indexed by file - reportTrans :: [(FilePath, KikiReportAction)] - reportTrans = concat $ Map.elems $ fmap fst transformed - - -- Wallets - let importWalletKey wk db' (top,fname,sub,tag) = do - try db' $ \(db',report0) -> do - r <- doImportG transcode - db' - (fmap keykey $ maybeToList wk) - [mkUsage tag] - fname - sub - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) - - wms <- mapM (readw wk) (files iswallet) - let wallet_keys = do - maybeToList wk - (fname,xs) <- wms - (_,sub,(_,m)) <- xs - (tag,top) <- Map.toList m - return (top,fname,sub,tag) - - db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys - try db $ \(db,reportWallets) -> do - - -- PEM files - let pems = do - (n,stream) <- Map.toList $ opFiles keyring - grip <- maybeToList grip - guard $ spillable stream && isSecretKeyFile (typ stream) - let us = mapMaybe usageFromFilter [fill stream,spill stream] - usage <- take 1 us - guard $ all (==usage) $ drop 1 us - -- TODO: KikiCondition reporting for spill/fill usage mismatch? - -- TODO: parseSpec3 - let (topspec,subspec) = parseSpec grip usage - ms = map fst $ filterMatches topspec (Map.toList db) - cmd = initializer stream - return (n,subspec,ms,stream, cmd) - - imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n - _ -> return True) - pems - db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports - try db $ \(db,reportPEMs) -> do - - -- generate keys - let gens = mapMaybe g $ Map.toList genMap - where g (Generate _ params,v) = Just (params,v) - g _ = Nothing - - db <- generateInternals transcode mwk db gens - try db $ \(db,reportGens) -> do - - r <- mergeHostFiles keyring db ctx - try r $ \((db,hs),reportHosts) -> do - - return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled) - , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) - -generateInternals :: - PacketTranscoder - -> Maybe MappedPacket - -> Map.Map KeyKey KeyData - -> [(GenerateKeyParams,StreamInfo)] - -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -generateInternals transcode mwk db gens = do - case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of - Just kd0 -> do - kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens - try kd $ \(kd,reportGens) -> do - let kk = keykey $ packet $ fromJust mwk - return $ KikiSuccess (Map.insert kk kd db,reportGens) - Nothing -> return $ KikiSuccess (db,[]) unconditionally :: IO (KikiCondition a) -> IO a unconditionally action = do @@ -1190,69 +623,9 @@ unconditionally action = do KikiSuccess x -> return x e -> error $ errorString e -data ParsedCert = ParsedCert - { pcertKey :: Packet - , pcertTimestamp :: UTCTime - , pcertBlob :: L.ByteString - } - deriving (Show,Eq) -data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert - deriving (Show,Eq) - -spemPacket (PEMPacket p) = Just p -spemPacket _ = Nothing - -spemCert (PEMCertificate p) = Just p -spemCert _ = Nothing - -toStrict :: L.ByteString -> S.ByteString -toStrict = foldr1 (<>) . L.toChunks -- No instance for (ASN1Object RSA.PublicKey) -parseCertBlob comp bs = do - asn1 <- either (const Nothing) Just - $ decodeASN1 DER bs - let asn1' = drop 2 asn1 - cert <- either (const Nothing) (Just . fst) (fromASN1 asn1') - let _ = cert :: X509.Certificate - notBefore :: UTCTime -#if MIN_VERSION_x509(1,5,0) - notBefore = toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano - where (vincentTime,_) = X509.certValidity cert -#else - (notBefore,_) = X509.certValidity cert -#endif - case X509.certPubKey cert of - X509.PubKeyRSA key -> do - let withoutkey = - let ekey = toStrict $ encodeASN1 DER (toASN1 key []) - (pre,post) = S.breakSubstring ekey $ toStrict bs - post' = S.drop (S.length ekey) post - len :: Word16 - len = if S.null post then maxBound - else fromIntegral $ S.length pre - in if len < 4096 - then encode len <> GZip.compress (Char8.fromChunks [pre,post']) - else bs - return - ParsedCert { pcertKey = packetFromPublicRSAKey notBefore - (MPI $ RSA.public_n key) - (MPI $ RSA.public_e key) - , pcertTimestamp = notBefore - , pcertBlob = if comp then withoutkey - else bs - } - _ -> Nothing - -packetFromPublicRSAKey notBefore n e = - PublicKeyPacket { version = 4 - , timestamp = round $ utcTimeToPOSIXSeconds notBefore - , key_algorithm = RSA - , key = [('n',n),('e',e)] - , is_subkey = True - , v3_days_of_validity = Nothing - } decodeBlob cert = if 0 /= (bs `L.index` 0) .&. 0x10 @@ -1267,271 +640,9 @@ decodeBlob cert = bs = pcertBlob cert key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert -extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey -extractRSAKeyFields kvs = do - let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs - n <- lookup "Modulus" kvs' - e <- lookup "PublicExponent" kvs' - d <- lookup "PrivateExponent" kvs' - p <- lookup "Prime1" kvs' -- p - q <- lookup "Prime2" kvs' -- q - dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1) - dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1) - u <- lookup "Coefficient" kvs' - {- - case (d,p,dmodp1) of - (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return () - _ -> error "dmodp fail!" - case (d,q,dmodqminus1) of - (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return () - _ -> error "dmodq fail!" - -} - return $ RSAPrivateKey - { rsaN = n - , rsaE = e - , rsaD = d - , rsaP = p - , rsaQ = q - , rsaDmodP1 = dmodp1 - , rsaDmodQminus1 = dmodqminus1 - , rsaCoefficient = u } - where - parseField blob = MPI <$> m -#if defined(VERSION_memory) - where m = bigendian <$> functorToMaybe (convertFromBase Base64 $ Char8.toStrict blob) - bigendian bs = snd $ S.foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs - where - nlen = S.length bs -#elif defined(VERSION_dataenc) - where m = bigendian <$> Base64.decode (Char8.unpack blob) - bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs - where - nlen = length bs -#endif -rsaToPGP stamp rsa = SecretKeyPacket - { version = 4 - , timestamp = fromTime stamp -- toEnum (fromEnum stamp) - , key_algorithm = RSA - , key = [ -- public fields... - ('n',rsaN rsa) - ,('e',rsaE rsa) - -- secret fields - ,('d',rsaD rsa) - ,('p',rsaQ rsa) -- Note: p & q swapped - ,('q',rsaP rsa) -- Note: p & q swapped - ,('u',rsaCoefficient rsa) - ] - -- , ecc_curve = def - , s2k_useage = 0 - , s2k = S2K 100 "" - , symmetric_algorithm = Unencrypted - , encrypted_data = "" - , is_subkey = True - } - -readSecretDNSFile :: InputFile -> IO Packet -readSecretDNSFile fname = do - let ctx = InputFileContext "" "" - stamp <- getInputFileTime ctx fname - input <- readInputFileL ctx fname - let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1) - . Char8.break (==':')) - $ Char8.lines input - alg = maybe RSA parseAlg $ lookup "Algorithm" kvs - parseAlg spec = case Char8.words spec of - nstr:_ -> case read (Char8.unpack nstr) :: Int of - 2 -> DH - 3 -> DSA -- SHA1 - 5 -> RSA -- SHA1 - 6 -> DSA -- NSEC3-SHA1 (RFC5155) - 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155) - 8 -> RSA -- SHA256 - 10 -> RSA -- SHA512 (RFC5702) - -- 12 -> GOST - 13 -> ECDSA -- P-256 SHA256 (RFC6605) - 14 -> ECDSA -- P-384 SHA384 (RFC6605) - _ -> RSA - case alg of - RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs - - -readSecretPEMFile :: InputFile -> IO [SecretPEMData] -readSecretPEMFile fname = do - -- warn $ fname ++ ": reading ..." - let ctx = InputFileContext "" "" - -- Note: The key's timestamp is included in it's fingerprint. - -- Therefore, we should attempt to preserve it. - stamp <- getInputFileTime ctx fname - input <- readInputFileL ctx fname - let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input - pkcs1 = fmap (parseRSAPrivateKey . pemBlob) - $ pemParser $ Just "RSA PRIVATE KEY" - cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob) - $ pemParser $ Just "CERTIFICATE" - parseRSAPrivateKey dta = do - let e = decodeASN1 DER dta - asn1 <- either (const $ mzero) return e - rsa <- either (const mzero) (return . fst) (fromASN1 asn1) - let _ = rsa :: RSAPrivateKey - return $ PEMPacket $ rsaToPGP stamp rsa - dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta - mergeDate (_,obj) (Left tm) = (fromTime tm,obj) - mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key') - where key' = if tm < fromTime (timestamp key) - then key { timestamp = fromTime tm } - else key - mergeDate (tm,_) (Right mb) = (tm,mb) - return $ dta - -doImport - :: PacketTranscoder - -> Map.Map KeyKey KeyData - -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) - -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) -doImport transcode db (fname,subspec,ms,typ -> typ,_) = do - flip (maybe $ return CannotImportMasterKey) - subspec $ \tag -> do - (certs,keys) <- case typ of - PEMFile -> do - ps <- readSecretPEMFile fname - let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) - = partition (isJust . spemCert) ps - return (certs,keys) - DNSPresentation -> do - p <- readSecretDNSFile fname - return ([],[p]) - -- TODO Probably we need to move to a new design where signature - -- packets are merged into the database in one phase with null - -- signatures, and then the signatures are made in the next phase. - -- This would let us merge annotations (like certificates) from - -- seperate files. - foldM (importKey tag certs) (KikiSuccess (db,[])) keys - where - importKey tag certs prior key = do - try prior $ \(db,report) -> do - let (m0,tailms) = splitAt 1 ms - if (not (null tailms) || null m0) - then return $ AmbiguousKeySpec (resolveForReport Nothing fname) - else do - let kk = keykey key - cs = filter (\c -> kk==keykey (pcertKey c)) certs - blobs = map mkCertNotation $ nub $ map pcertBlob cs - mkCertNotation bs = NotationDataPacket - { human_readable = False - , notation_name = "x509cert@" - , notation_value = Char8.unpack bs } - datedKey = key { timestamp = fromTime $ minimum dates } - dates = fromTime (timestamp key) : map pcertTimestamp certs - r <- doImportG transcode db m0 (mkUsage tag:blobs) fname datedKey - try r $ \(db',report') -> do - return $ KikiSuccess (db',report++report') - -doImportG - :: PacketTranscoder - -> Map.Map KeyKey KeyData - -> [KeyKey] -- m0, only head is used - -> [SignatureSubpacket] -- tags - -> InputFile - -> Packet - -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) -doImportG transcode db m0 tags fname key = do - let kk = head m0 - Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db - kdr <- insertSubkey transcode kk kd tags fname key - try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) - -insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do - let topcipher = symmetric_algorithm $ packet top - tops2k = s2k $ packet top - doDecrypt = transcode (Unencrypted,S2K 100 "") - fname = resolveForReport Nothing inputfile - subkk = keykey key0 - istor = do - guard ("tor" `elem` mapMaybe usage tags) - return $ torUIDFromKey key0 - addOrigin (SubKey mp sigs) = - let mp' = mp - { locations = Map.insert fname - (origin (packet mp) (-1)) - (locations mp) } - in SubKey mp' sigs - - subkey_result <- do - case Map.lookup subkk subs of - Just sub -> return $ KikiSuccess (False,addOrigin sub,Nothing) - Nothing -> do - wkun' <- doDecrypt top - try wkun' $ \wkun -> do - key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0 - try key' $ \key -> do - return $ KikiSuccess (True, SubKey (mappedPacket fname key) [], Just (wkun,key)) - - - try subkey_result $ \(is_new,subkey,decrypted) -> do - - let subs' = Map.insert subkk subkey subs - - uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do - let has_torid = do - -- TODO: check for omitted real name field - (sigtrusts,om) <- Map.lookup idstr uids - listToMaybe $ do - s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) - signatures_over $ verify (Message [packet top]) s - flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do - - let keyflags = keyFlags (error "dummy argument (insertSubkey)") (map packet $ flattenAllUids fname True uids) - uid = UserIDPacket idstr - -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags - tor_ov = makeInducerSig (packet top) (packet top) uid keyflags - wkun' <- maybe (doDecrypt top) (return . KikiSuccess . fst) decrypted - try wkun' $ \wkun -> do - sig_ov <- pgpSign (Message [wkun]) - tor_ov - SHA1 - (fingerprint wkun) - flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) - (sig_ov >>= listToMaybe . signatures_over) - $ \sig -> do - let om = Map.singleton fname (origin sig (-1)) - trust = Map.empty - return $ KikiSuccess - ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} - , trust)],om) uids - , [] ) - - try uids' $ \(uids',report) -> do - - let SubKey subkey_p subsigs = subkey - wk = packet top - (xs',minsig,ys') = findTag tags wk key0 subsigs - doInsert mbsig = do - -- NEW SUBKEY BINDING SIGNATURE - -- XXX: Here I assume that key0 is the unencrypted version - -- of subkey_p. TODO: Check this assumption. - sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} tags mbsig - try sig' $ \(sig',report) -> do - report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] - let subs' = Map.insert subkk - (SubKey subkey_p $ xs'++[sig']++ys') - subs - return $ KikiSuccess ( KeyData top topsigs uids' subs' - , report ) - - report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) - else id - s = show (fmap fst minsig,fingerprint key0) - in return (f report) - - case minsig of - Nothing -> doInsert Nothing -- we need to create a new sig - Just (True,sig) -> -- we can deduce is_new == False - -- we may need to add a tor id - return $ KikiSuccess ( KeyData top topsigs uids' subs' - , report ) - Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag + isCryptoCoinKey :: Packet -> Bool isCryptoCoinKey p = @@ -2004,18 +1115,6 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs ++ import_rs ++ internals_rs) --- | combineTransforms --- remove rundant transforms, and compile the rest to PacketUpdate(s) --- --- eqivalent to: --- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd -combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] -combineTransforms trans rt kd = updates - where - updates = -- kManip operation rt kd ++ - concatMap (\t -> resolveTransform t rt kd) sanitized - sanitized = group (sort trans) >>= take 1 - -- | Load and update key files according to the specified 'KeyRingOperation'. @@ -2160,128 +1259,10 @@ lookupEnv var = handleIO_ (return Nothing) $ fmap Just (getEnv var) #endif -slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) -slurpWIPKeys stamp "" = ([],[]) -slurpWIPKeys stamp cs = - let (b58,xs) = Char8.span (`elem` base58chars) cs - mb = decode_btc_key stamp (Char8.unpack b58) - in if L.null b58 - then let (ys,xs') = Char8.break (`elem` base58chars) cs - (ks,js) = slurpWIPKeys stamp xs' - in (ks,ys:js) - else let (ks,js) = slurpWIPKeys stamp xs - in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb - - -decode_btc_key :: - Enum timestamp => timestamp -> String -> Maybe (Word8, Message) -decode_btc_key timestamp str = do - (network_id,us) <- base58_decode str - return . (network_id,) $ Message $ do - let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer]) - {- - xy = secp256k1_G `pmul` d - x = getx xy - y = gety xy - -- y² = x³ + 7 (mod p) - y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve) - y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve) - -} - secp256k1 = ECC.getCurveByName ECC.SEC_p256k1 - ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1 - -- pub = cannonical_eckey x y - -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub - -- address = base58_encode hash - -- pubstr = concatMap (printf "%02x") $ pub - -- _ = pubstr :: String - return $ {- trace (unlines ["pub="++show pubstr - ,"add="++show address - ,"y ="++show y - ,"y' ="++show y' - ,"y''="++show y'']) -} - SecretKeyPacket - { version = 4 - , timestamp = toEnum (fromEnum timestamp) - , key_algorithm = ECDSA - , key = [ -- public fields... - ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve) - ,('l',MPI 256) - ,('x',MPI x) - ,('y',MPI y) - -- secret fields - ,('d',MPI d) - ] - , s2k_useage = 0 - , s2k = S2K 100 "" - , symmetric_algorithm = Unencrypted - , encrypted_data = "" - , is_subkey = True - } - - -readPacketsFromWallet :: - Maybe Packet - -> InputFile - -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -readPacketsFromWallet wk fname = do - let ctx = InputFileContext "" "" - timestamp <- getInputFileTime ctx fname - input <- readInputFileL ctx fname - let (ks,_) = slurpWIPKeys timestamp input - {- - unless (null ks) $ do - -- decrypt wk - -- create sigs - -- return key/sig pairs - return () -} - return $ do - wk <- maybeToList wk - guard (not $ null ks) - let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk)) - where tag = CryptoCoins.nameFromSecretByte tagbyte - (wk,MarkerPacket,(MarkerPacket,Map.empty)) - :map prep ks - -readPacketsFromFile :: InputFileContext -> InputFile -> IO Message -readPacketsFromFile ctx fname = do - -- warn $ fname ++ ": reading..." - input <- readInputFileL ctx fname -#if MIN_VERSION_binary(0,7,0) - return $ - case decodeOrFail input of - Right (_,_,msg ) -> msg - Left (_,_,_) -> - -- FIXME - -- trace (fname++": read fail") $ - Message [] -#else - return $ decode input -#endif - -merge :: KeyDB -> InputFile -> Message -> KeyDB -merge db inputfile (Message ps) = merge_ db filename qs - where - filename = resolveForReport Nothing inputfile - qs = scanPackets filename ps - scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] - scanPackets filename [] = [] - scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps - where - ret p = (p,Map.empty) - doit (top,sub,prev) p = - case p of - _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) - _ | isKey p && is_subkey p -> (top,p,ret p) - _ | isUserID p -> (top,p,ret p) - _ | isTrust p -> (top,sub,updateTrust top sub prev p) - _ -> (top,sub,ret p) - updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public - updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public - updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret {- @@ -2292,296 +1273,11 @@ onionName kd = (addr,name) -} -merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] - -> KeyDB -merge_ db filename qs = foldl mergeit db (zip [0..] qs) - where - -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets - mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB - mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db - where - update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty - update (Just kd) = dbInsertPacket kd filename adding - mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p - - whatP (a,_) = concat . take 1 . words . show $ a - - - -mergeKeyData :: KeyData -> KeyData -> KeyData -mergeKeyData (KeyData atop asigs auids asubs) - (KeyData btop bsigs buids bsubs) - = KeyData top sigs uids subs - where - mergeMapped a b = - MappedPacket { packet = packet a - , locations = Map.union (locations a) (locations b) - } - - top = mergeMapped atop btop - - sigs = foldl' (flip mergeSig) asigs bsigs - uids = Map.unionWith mergeUIDSigs auids buids - subs = Map.unionWith mergeSub asubs bsubs - mergeSub :: SubKey -> SubKey -> SubKey - mergeSub (SubKey a as) (SubKey b bs) = - SubKey (mergeMapped a b) - (foldl' (flip mergeSig) as bs) - mergeUIDSigs :: ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) - -> ([SigAndTrust],OriginMap) - mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm) -dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData -dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) - where - asMapped n p = mappedPacketWithHint filename p n - asSigAndTrust n (p,tm) = (asMapped n p,tm) - - -- NOTE: - -- if a keyring file has both a public key packet and a secret key packet - -- for the same key, then only one of them will survive, which ever is - -- later in the file. - -- - -- This is due to the use of statements like - -- (Map.insert filename (origin p n) (locations key)) - -- - update :: Maybe KeyData -> Maybe KeyData - update v | isKey p && not (is_subkey p) - = case v of - Nothing -> Just $ KeyData (asMapped n p) [] Map.empty Map.empty - Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p - -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p) - sigs - uids - subkeys - _ -> error . concat $ ["Unexpected master key merge error: " - ,show (fingerprint top, fingerprint p)] - update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p - = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) - update (Just (KeyData key sigs uids subkeys)) | isUserID p - = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) - subkeys - update (Just (KeyData key sigs uids subkeys)) - = case sub of - MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys - UserIDPacket {} -> Just $ KeyData key - sigs - (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) - subkeys - _ | isKey sub -> Just $ KeyData key - sigs - uids - (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys) - _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1) - update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1) - - mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey - mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) [] - mergeSubkey n p (Just (SubKey key sigs)) = Just $ - SubKey (mergeKeyPacket "subs" key $ asMapped n p) - sigs - - mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap) - mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n)) - mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m) - mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p - - whatP (a,_) = concat . take 1 . words . show $ a - - - mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs, m) - mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty) - - mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs) - mergeSubSig n sig Nothing = error $ - "Unable to merge subkey signature: "++(words (show sig) >>= take 1) - -mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust] -mergeSig sig sigs = - let (xs,ys) = break (isSameSig (first packet sig)) sigs - in if null ys - then sigs++[sig] -- [first (flip (mappedPacketWithHint fname) n) sig] - else let y:ys'=ys - in xs ++ (mergeSameSig sig y : ys') - where - isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b = - a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } - isSameSig (a,_) (MappedPacket {packet=b},_) = a==b - - mergeSameSig :: (MappedPacket,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap) - mergeSameSig (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) - | isSignaturePacket (packet a) && isSignaturePacket b = - ( m { packet = b { unhashed_subpackets = - union (unhashed_subpackets b) (unhashed_subpackets $ packet a) - } - , locations = Map.union (locations a) locs } -- Map.insert fname (origin a n) locs } - -- TODO: when merging items, we should delete invalidated origins - -- from the orgin map. - , tb `Map.union` ta ) - - mergeSameSig a b = b -- trace ("discarding dup "++show a) b - - -flattenKeys :: Bool -> KeyDB -> Message -flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) - where - prefilter = if isPublic then id else filter isSecret - where - isSecret (_,(KeyData - (MappedPacket { packet=(SecretKeyPacket {})}) - _ - _ - _)) = True - isSecret _ = False - - -data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned - deriving (Eq,Ord,Enum,Show,Read) - -getSubkeys :: SubkeyStatus -> Packet -> Map.Map KeyKey SubKey -> String -> [Packet] -getSubkeys ck topk subs tag = do - SubKey k sigs <- Map.elems subs - let subk = packet k - let sigs' = do - -- require tag - torsig <- filter (has_tag tag) $ map (packet . fst) sigs - - -- require parent's signature - when (ck > Unsigned) $ do - sig <- (signatures $ Message [topk,subk,torsig]) - let v = verify (Message [topk]) sig - -- Require parent's signature - guard (not . null $ signatures_over v) - - -- require child's back signature - when (ck == CrossSigned ) $ do - let unhashed = unhashed_subpackets torsig - subsigs = mapMaybe backsig unhashed - -- This should consist only of 0x19 values - -- subtypes = map signature_type subsigs - -- subtyp <- subtypes - -- guard (subtyp == 0x19) - sig' <- signatures . Message $ [topk,subk]++subsigs - let v' = verify (Message [subk]) sig' - -- Require subkey's signature - guard . not . null $ signatures_over v' - return torsig - guard (not $ null sigs') - return subk - --- | --- Returns (ip6 fingerprint address,(onion names,other host names)) --- --- Requires a validly cross-signed tor key for each onion name returned. --- (Signature checks are performed.) -getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString])) -getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames)) - where - othernames = do - mp <- flattenAllUids "" True uids - let p = packet mp - guard $ isSignaturePacket p - uh <- unhashed_subpackets p - case uh of - NotationDataPacket True "hostname@" v - -> return $ Char8.pack v - _ -> mzero - - addr = fingerdress topk - -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key? - topk = packet topmp - torkeys = getSubkeys CrossSigned topk subs "tor" - - -- subkeyPacket (SubKey k _ ) = k - onames :: [L.ByteString] - onames = map ( (<> ".onion") - . Char8.pack - . take 16 - . torhash ) - torkeys - -hasFingerDress :: KeyDB -> SockAddr -> Bool -hasFingerDress db addr | socketFamily addr/=AF_INET6 = False -hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db) - where - (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr - g' = map toUpper g - --- We return into IO in case we want to make a signature here. -setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData -setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) = - -- TODO: we are removing the origin from the UID OriginMap, - -- when we should be removing origins from the locations - -- field of the sig's MappedPacket records. - -- Call getHostnames and compare to see if no-op. - if not (pred addr) || names0 == names \\ onions - then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) - , " file: "++show (map Char8.unpack names) - , " pred: "++show (pred addr)]) -} - (return kd) - else do - -- We should be sure to remove origins so that the data is written - -- (but only if something changed). - -- Filter all hostnames present in uids - -- Write notations into first uid - {- - trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) - , " file: "++show (map Char8.unpack names) ]) $ do - -} - return $ KeyData topmp topsigs uids1 subs - where - topk = packet topmp - addr = fingerdress topk - names :: [Char8.ByteString] - names = Hosts.namesForAddress addr hosts - (_,(onions,names0)) = getHostnames kd - notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions) - isName (NotationDataPacket True "hostname@" _) = True - isName _ = False - uids0 = fmap zapIfHasName uids - fstuid = head $ do - p <- map packet $ flattenAllUids "" True uids - guard $ isUserID p - return $ uidkey p - uids1 = Map.adjust addnames fstuid uids0 - addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin - where - (ss,ts) = splitAt 1 sigs - f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm) - else (sig, tm) - where p' = (packet sig) { unhashed_subpackets=uh } - uh = unhashed_subpackets (packet sig) ++ notations - zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin - else (sigs,om) - where - (bs, sigs') = unzip $ map unhash sigs - - unhash (sig,tm) = ( not (null ns) - , ( sig { packet = p', locations = Map.empty } - , tm ) ) - where - psig = packet sig - p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps } - else psig - uh = unhashed_subpackets psig - (ns,ps) = partition isName uh - -fingerdress :: Packet -> SockAddr -fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str - where - zero = SockAddrInet 0 0 - addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk) - colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs - colons xs = xs - -socketFamily :: SockAddr -> Family -socketFamily (SockAddrInet _ _) = AF_INET -socketFamily (SockAddrInet6 {}) = AF_INET6 -socketFamily (SockAddrUnix _) = AF_UNIX #if ! MIN_VERSION_unix(2,7,0) setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO () diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index 1c2a5aa..6de217b 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs @@ -2,13 +2,21 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module KeyRing.BuildKeyDB where -import qualified Codec.Binary.Base32 as Base32 -import qualified Codec.Binary.Base64 as Base64 + +#if defined(VERSION_memory) +import Data.ByteArray.Encoding +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString as S +#elif defined(VERSION_dataenc) +import qualified Codec.Binary.Base32 as Base32 +import qualified Codec.Binary.Base64 as Base64 +#endif import Control.Applicative (liftA2) import Control.Arrow (first, second) import Control.Exception (catch) @@ -17,7 +25,9 @@ import ControlMaybe (handleIO_) import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (decodeASN1, encodeASN1) -import Data.ASN1.Types (fromASN1, toASN1) +import Data.ASN1.Types (ASN1 (BitString, End, IntVal, Null, OID, Start), + ASN1ConstructionType (Sequence), ASN1Object, + fromASN1, toASN1) import Data.Binary import Data.Bits ((.&.), (.|.)) import Data.Bits (Bits) @@ -101,6 +111,9 @@ import ScanningParser import TimeUtil import KeyRing.Types +import Transforms +import PacketTranscoder +import GnuPGAgent -- | buildKeyDB -- @@ -116,16 +129,15 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], {- outgoing_names -}[SockAddr]) ,{- accs -} Map.Map InputFile Access - ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet) + ,{- doDecrypt -} PacketTranscoder ,{- unspilled -} Map.Map InputFile Message ) ,{- report_imports -} [(FilePath,KikiReportAction)])) buildKeyDB ctx grip0 keyring = do - let - files istyp = do + let files istyp = do (f,stream) <- Map.toList (opFiles keyring) guard (istyp $ typ stream) - resolveInputFile ctx f + return f -- resolveInputFile ctx f ringMap0 = Map.filter (isring . typ) $ opFiles keyring (genMap,ringMap) = Map.partitionWithKey isgen ringMap0 @@ -145,10 +157,10 @@ buildKeyDB ctx grip0 keyring = do _ -> AutoAccess acc -> acc - readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) + readw wk n = fmap (n,) (readPacketsFromWallet wk n) -- KeyRings (todo: KikiCondition reporting?) - (spilled,mwk,grip,accs,keys,unspilled) <- do + (spilled,mwk,grip,accs,keyqs,unspilled) <- do #if MIN_VERSION_containers(0,5,0) ringPackets <- Map.traverseWithKey readp ringMap #else @@ -164,39 +176,25 @@ buildKeyDB ctx grip0 keyring = do -- | spilled -- ring packets with info available for export - -- | unspilled + -- | unspilled -- the rest (spilled,unspilled) = Map.partition (spillable . fst) ringPackets -- | keys - -- process ringPackets, and get a map of fingerprint info to + -- process ringPackets, and get a map of fingerprint info to -- to a packet, remembering it's original file, access. - keys :: Map.Map KeyKey MappedPacket - keys = Map.foldl slurpkeys Map.empty - $ Map.mapWithKey filterSecrets ringPackets - where - filterSecrets f (_,Message ps) = - filter (isSecretKey . packet) - $ zipWith (mappedPacketWithHint fname) ps [1..] - where fname = resolveForReport (Just ctx) f - slurpkeys m ps = m `Map.union` Map.fromList ps' - where ps' = zip (map (keykey . packet) ps) ps - -- | mwk - -- first master key matching the provided grip - -- (the m is for "MappedPacket", wk for working key) + keys :: Map.Map KeyKey (OriginMapped Query) mwk :: Maybe MappedPacket - mwk = listToMaybe $ do - fp <- maybeToList grip - let matchfp mp = not (is_subkey p) && matchpr fp p == fp - where p = packet mp - Map.elems $ Map.filter matchfp keys + (mwk, keys) = keyQueries grip ringPackets + -- | accs -- file access(Sec | Pub) lookup table accs :: Map.Map InputFile Access accs = fmap (access . fst) ringPackets return (spilled,mwk,grip,accs,keys,fmap snd unspilled) - doDecrypt <- makeMemoizingDecrypter keyring ctx keys + transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs) + let doDecrypt = transcode (Unencrypted,S2K 100 "") let wk = fmap packet mwk rt0 = KeyRingRuntime { rtPubring = homepubPath ctx @@ -205,10 +203,10 @@ buildKeyDB ctx grip0 keyring = do , rtWorkingKey = wk , rtRingAccess = accs , rtKeyDB = Map.empty - , rtPassphrases = doDecrypt + , rtPassphrases = transcode } -- autosigns and deletes - transformed0 <- do + transformed0 <- let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) trans f (info,ps) = do let manip = combineTransforms (transforms info) @@ -216,87 +214,84 @@ buildKeyDB ctx grip0 keyring = do acc = Just Sec /= Map.lookup f accs r <- performManipulations doDecrypt rt1 mwk manip try r $ \(rt2,report) -> do - return $ KikiSuccess (report,rtKeyDB rt2) + return $ KikiSuccess (report,rtKeyDB rt2) + -- XXX: Unspilled keys are not obtainable from rtKeyDB. + -- If the working key is marked non spillable, then how + -- would we look up it's UID and such? #if MIN_VERSION_containers(0,5,0) - fmap sequenceA $ Map.traverseWithKey trans spilled + in fmap sequenceA $ Map.traverseWithKey trans spilled #else - fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled + in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled #endif try transformed0 $ \transformed -> do - let -- | db_rings - all keyrings combined into one - db_rings :: Map.Map KeyKey KeyData - db_rings = Map.foldlWithKey' mergeIt Map.empty transformed - where - mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans - -- | reportTrans - -- events, indexed by file - reportTrans :: [(FilePath, KikiReportAction)] - reportTrans = concat $ Map.elems $ fmap fst transformed + let -- | db_rings - all keyrings combined into one + db_rings :: Map.Map KeyKey KeyData + db_rings = Map.foldlWithKey' mergeIt Map.empty transformed + where + mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans + -- | reportTrans + -- events, indexed by file + reportTrans :: [(FilePath, KikiReportAction)] + reportTrans = concat $ Map.elems $ fmap fst transformed -- Wallets - let importWalletKey wk db' (top,fname,sub,tag) = do - try db' $ \(db',report0) -> do - r <- doImportG doDecrypt - db' - (fmap keykey $ maybeToList wk) - [mkUsage tag] - fname - sub - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) - - wms <- mapM (readw wk) (files iswallet) - let wallet_keys = do - maybeToList wk - (fname,xs) <- wms - (_,sub,(_,m)) <- xs - (tag,top) <- Map.toList m - return (top,fname,sub,tag) - db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys - try db $ \(db,reportWallets) -> do - - -- PEM files - let pems = do - (n,stream) <- Map.toList $ opFiles keyring - grip <- maybeToList grip - n <- resolveInputFile ctx n - guard $ spillable stream && isSecretKeyFile (typ stream) - let us = mapMaybe usageFromFilter [fill stream,spill stream] - usage <- take 1 us - guard $ all (==usage) $ drop 1 us - -- TODO: KikiCondition reporting for spill/fill usage mismatch? - -- TODO: parseSpec3 - let (topspec,subspec) = parseSpec grip usage - ms = map fst $ filterMatches topspec (Map.toList db) - cmd = initializer stream - return (n,subspec,ms,stream, cmd) - - imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems - db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports - try db $ \(db,reportPEMs) -> do - - -- generate keys - let gens = mapMaybe g $ Map.toList genMap - where g (Generate _ params,v) = Just (params,v) - g _ = Nothing - - db <- generateInternals doDecrypt mwk db gens - try db $ \(db,reportGens) -> do - - r <- mergeHostFiles keyring db ctx - try r $ \((db,hs),reportHosts) -> do - - return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) - , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) - - -resolveInputFile :: InputFileContext -> InputFile -> [FilePath] -resolveInputFile ctx = resolve - where - resolve HomeSec = return (homesecPath ctx) - resolve HomePub = return (homepubPath ctx) - resolve (ArgFile f) = return f - resolve _ = [] + let importWalletKey wk db' (top,fname,sub,tag) = do + try db' $ \(db',report0) -> do + r <- doImportG transcode + db' + (fmap keykey $ maybeToList wk) + [mkUsage tag] + fname + sub + try r $ \(db'',report) -> do + return $ KikiSuccess (db'', report0 ++ report) + + wms <- mapM (readw wk) (files iswallet) + let wallet_keys = do + maybeToList wk + (fname,xs) <- wms + (_,sub,(_,m)) <- xs + (tag,top) <- Map.toList m + return (top,fname,sub,tag) + + db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys + try db $ \(db,reportWallets) -> do + + -- PEM files + let pems = do + (n,stream) <- Map.toList $ opFiles keyring + grip <- maybeToList grip + guard $ spillable stream && isSecretKeyFile (typ stream) + let us = mapMaybe usageFromFilter [fill stream,spill stream] + usage <- take 1 us + guard $ all (==usage) $ drop 1 us + -- TODO: KikiCondition reporting for spill/fill usage mismatch? + -- TODO: parseSpec3 + let (topspec,subspec) = parseSpec grip usage + ms = map fst $ filterMatches topspec (Map.toList db) + cmd = initializer stream + return (n,subspec,ms,stream, cmd) + + imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n + _ -> return True) + pems + db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports + try db $ \(db,reportPEMs) -> do + + -- generate keys + let gens = mapMaybe g $ Map.toList genMap + where g (Generate _ params,v) = Just (params,v) + g _ = Nothing + + db <- generateInternals transcode mwk db gens + try db $ \(db,reportGens) -> do + + r <- mergeHostFiles keyring db ctx + try r $ \((db,hs),reportHosts) -> do + + return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled) + , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) + isring :: FileType -> Bool isring (KeyRingFile {}) = True @@ -327,11 +322,12 @@ readPacketsFromWallet wk fname = do timestamp <- getInputFileTime ctx fname input <- readInputFileL ctx fname let (ks,_) = slurpWIPKeys timestamp input + {- unless (null ks) $ do -- decrypt wk -- create sigs -- return key/sig pairs - return () + return () -} return $ do wk <- maybeToList wk guard (not $ null ks) @@ -344,120 +340,11 @@ spillable :: StreamInfo -> Bool spillable (spill -> KF_None) = False spillable _ = True -isSecretKey :: Packet -> Bool -isSecretKey (SecretKeyPacket {}) = True -isSecretKey _ = False - -mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket -mappedPacketWithHint filename p hint = MappedPacket - { packet = p - , locations = Map.singleton filename (origin p hint) - } - -resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath -resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str) - where str = case (fdr,fdw) of - (0,1) -> "-" - _ -> "&pipe" ++ show (fdr,fdw) -resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str) - where str = "&" ++ show fd -resolveForReport mctx f = concat $ resolveInputFile ctx f - where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx - -keykey :: Packet -> KeyKey -keykey key = - -- Note: The key's timestamp is normally included in it's fingerprint. - -- This is undesirable for kiki because it causes the same - -- key to be imported multiple times and show as apparently - -- distinct keys with different fingerprints. - -- Thus, we will remove the timestamp. - fingerprint_material (key {timestamp=0}) -- TODO: smaller key? - --- matchpr computes the fingerprint of the given key truncated to --- be the same lenght as the given fingerprint for comparison. --- --- matchpr fp = Data.List.Extra.takeEnd (length fp) --- -matchpr :: String -> Packet -> String -matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp - -makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext - -> Map.Map KeyKey MappedPacket - -> IO (MappedPacket -> IO (KikiCondition Packet)) -makeMemoizingDecrypter operation ctx keys = - if null chains then do - -- (*) Notice we do not pass ctx to resolveForReport. - -- This is because the merge function does not currently use a context - -- and the pws map keys must match the MappedPacket locations. - -- TODO: Perhaps these should both be of type InputFile rather than - -- FilePath? - -- pws :: Map.Map FilePath (IO S.ByteString) - {- - pws <- - Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) - (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above - $ Map.filter (isJust . pwfile . typ) $ opFiles operation) - -} - let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" - pws2 <- - Traversable.mapM (cachedContents prompt ctx) - $ Map.fromList $ mapMaybe - (\spec -> (,passSpecPassFile spec) `fmap` do - guard $ isNothing $ passSpecKeySpec spec - passSpecRingFile spec) - passspecs - defpw <- do - Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) - $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) - && isNothing (passSpecKeySpec sp)) - $ opPassphrases operation - unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) - return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw - else let PassphraseMemoizer f = head chains - in return f - where - (chains,passspecs) = partition isChain $ opPassphrases operation - where isChain (PassphraseMemoizer {}) = True - isChain _ = False - doDecrypt :: IORef (Map.Map KeyKey Packet) - -> Map.Map FilePath (IO S.ByteString) - -> Maybe (IO S.ByteString) - -> MappedPacket - -> IO (KikiCondition Packet) - doDecrypt unkeysRef pws defpw mp0 = do - unkeys <- readIORef unkeysRef - let mp = fromMaybe mp0 $ do - k <- Map.lookup kk keys - return $ mergeKeyPacket "decrypt" mp0 k - wk = packet mp0 - kk = keykey wk - fs = Map.keys $ locations mp - - decryptIt [] = return BadPassphrase - decryptIt (getpw:getpws) = do - -- TODO: This function should use mergeKeyPacket to - -- combine the packet with it's unspilled version before - -- attempting to decrypt it. - pw <- getpw - let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp) - case symmetric_algorithm wkun of - Unencrypted -> do - writeIORef unkeysRef (Map.insert kk wkun unkeys) - return $ KikiSuccess wkun - _ -> decryptIt getpws - - getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw - - case symmetric_algorithm wk of - Unencrypted -> return (KikiSuccess wk) - _ -> maybe (decryptIt getpws) - (return . KikiSuccess) - $ Map.lookup kk unkeys -- | combineTransforms --- remove rundant transforms, and compile the rest to PacketUpdate(s) +-- remove redundant transforms, and compile the rest to PacketUpdate(s) -- --- eqivalent to: +-- equivalent to: -- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] combineTransforms trans rt kd = updates @@ -490,108 +377,6 @@ merge db inputfile (Message ps) = merge_ db filename qs updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret -performManipulations :: - (MappedPacket -> IO (KikiCondition Packet)) - -> KeyRingRuntime - -> Maybe MappedPacket - -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) - -> IO (KikiCondition (KeyRingRuntime,KikiReport)) -performManipulations doDecrypt rt wk manip = do - let db = rtKeyDB rt - performAll kd = foldM perform (KikiSuccess (kd, [])) $ manip rt kd - r <- Traversable.mapM performAll db - try (sequenceA r) $ \db -> do - return $ - KikiSuccess (rt {rtKeyDB = fmap fst db}, concatMap snd $ Map.elems db) - where - perform - :: KikiCondition (KeyData, KikiReport) - -> PacketUpdate - -> IO (KikiCondition (KeyData, KikiReport)) - perform kd (InducerSignature uid subpaks) = do - try kd $ \(kd, report) -> do - flip (maybe $ return NoWorkingKey) wk $ \wk' -> do - wkun' <- doDecrypt wk' - try wkun' $ \wkun -> do - let flgs = - if keykey (keyPacket kd) == keykey wkun - then keyFlags0 - (keyPacket kd) - (map (\(x, _, _) -> x) selfsigs) - else [] - sigOver = - makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) $ - flgs ++ subpaks - om = Map.singleton "--autosign" (origin p (-1)) - where - p = UserIDPacket uid - toMappedPacket om p = (mappedPacket "" p) {locations = om} - selfsigs = - filter - (\(sig, v, whosign) -> - isJust - (v >> Just wkun >>= - guard . (== keykey whosign) . keykey)) - vs - keys = map keyPacket $ Map.elems (rtKeyDB rt) - overs sig = - signatures $ - Message (keys ++ [keyPacket kd, UserIDPacket uid, sig]) - vs - :: [(Packet -- signature - , Maybe SignatureOver -- Nothing means non-verified - , Packet -- key who signed - )] - vs = do - x <- maybeToList $ Map.lookup uid (keyUids kd) - sig <- map (packet . fst) (fst x) - o <- overs sig - k <- keys - let ov = verify (Message [k]) $ o - signatures_over ov - return (sig, Just ov, k) - additional new_sig = do - new_sig <- maybeToList new_sig - guard (null $ selfsigs) - signatures_over new_sig - sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) - let f :: ([SigAndTrust], OriginMap) -> ([SigAndTrust], OriginMap) - f x = - ( map ((, Map.empty) . toMappedPacket om) (additional sigr) ++ - fst x - , om `Map.union` snd x) - -- XXX: Shouldn't this signature generation show up in the KikiReport ? - return $ - KikiSuccess $ - (kd {keyUids = Map.adjust f uid (keyUids kd)}, report) - perform kd (SubKeyDeletion topk subk) = do - try kd $ \(kd, report) -> do - let kk = keykey $ packet $ keyMappedPacket kd - kd' - | kk /= topk = kd - | otherwise = - kd {keySubKeys = Map.filterWithKey pred $ keySubKeys kd} - pred k _ = k /= subk - ps = - concat $ - maybeToList $ do - SubKey mp sigs <- Map.lookup subk (keySubKeys kd) - return $ - packet mp : - concatMap (\(p, ts) -> packet p : Map.elems ts) sigs - ctx = InputFileContext (rtSecring rt) (rtPubring rt) - rings = [HomeSec, HomePub] >>= resolveInputFile ctx - return $ - KikiSuccess - ( kd' - , report ++ - [(f, DeletedPacket $ showPacket p) | f <- rings, p <- ps]) - -try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b) -try x body = - case functorToEither x of - Left e -> return e - Right x -> body x mergeKeyData :: KeyData -> KeyData -> KeyData mergeKeyData (KeyData atop asigs auids asubs) @@ -620,40 +405,19 @@ mergeKeyData (KeyData atop asigs auids asubs) mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm) doImportG - :: (MappedPacket -> IO (KikiCondition Packet)) + :: PacketTranscoder -> Map.Map KeyKey KeyData -> [KeyKey] -- m0, only head is used -> [SignatureSubpacket] -- tags - -> FilePath + -> InputFile -> Packet -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) -doImportG doDecrypt db m0 tags fname key = do +doImportG transcode db m0 tags fname key = do let kk = head m0 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db - kdr <- insertSubkey doDecrypt kk kd tags fname key + kdr <- insertSubkey transcode kk kd tags fname key try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) -mkUsage :: String -> SignatureSubpacket -mkUsage tag - | Just flags <- lookup tag specials = - KeyFlagsPacket - { certify_keys = fromEnum flags .&. 0x1 /= 0 - , sign_data = fromEnum flags .&. 0x2 /= 0 - , encrypt_communication = fromEnum flags .&. 0x4 /= 0 - , encrypt_storage = fromEnum flags .&. 0x8 /= 0 - , split_key = False - , authentication = False - , group_key = False - } - where - flagsets = [Special .. VouchSignEncrypt] - specials = map (\f -> (usageString f, f)) flagsets - -mkUsage tag = NotationDataPacket - { human_readable = True - , notation_name = "usage@" - , notation_value = tag - } iswallet :: FileType -> Bool iswallet (WalletFile {}) = True @@ -749,32 +513,32 @@ filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] filterMatches spec ks = filter (matchSpec spec . snd) ks importSecretKey :: - (MappedPacket -> IO (KikiCondition Packet)) + (PacketTranscoder) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) - -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) + -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -importSecretKey doDecrypt db' tup = do +importSecretKey transcode db' tup = do try db' $ \(db',report0) -> do - r <- doImport doDecrypt - db' - tup - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) + r <- doImport transcode + db' + tup + try r $ \(db'',report) -> do + return $ KikiSuccess (db'', report0 ++ report) generateInternals :: - (MappedPacket -> IO (KikiCondition Packet)) + PacketTranscoder -> Maybe MappedPacket -> Map.Map KeyKey KeyData -> [(GenerateKeyParams,StreamInfo)] -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -generateInternals doDecrypt mwk db gens = do +generateInternals transcode mwk db gens = do case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of Just kd0 -> do - kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens + kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens try kd $ \(kd,reportGens) -> do - let kk = keykey $ packet $ fromJust mwk - return $ KikiSuccess (Map.insert kk kd db,reportGens) + let kk = keykey $ packet $ fromJust mwk + return $ KikiSuccess (Map.insert kk kd db,reportGens) Nothing -> return $ KikiSuccess (db,[]) mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext @@ -875,89 +639,6 @@ slurpWIPKeys stamp cs = else let (ks,js) = slurpWIPKeys stamp xs in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb -origin :: Packet -> Int -> OriginFlags -origin p n = OriginFlags ispub n - where - ispub = case p of - SecretKeyPacket {} -> False - _ -> True - -cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString) -cachedContents maybePrompt ctx fd = do - ref <- newIORef Nothing - return $ get maybePrompt ref fd - where - trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs - - get maybePrompt ref fd = do - pw <- readIORef ref - flip (flip maybe return) pw $ do - if fd == FileDesc 0 then case maybePrompt of - Just prompt -> S.hPutStr stderr prompt - Nothing -> return () - else return () - pw <- fmap trimCR $ readInputFileS ctx fd - writeIORef ref (Just pw) - return pw - -mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket -mergeKeyPacket what key p = - key { packet = minimumBy (keyCompare what) [packet key,packet p] - , locations = Map.union (locations key) (locations p) - } - --- | resolveTransform -resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] -resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops - where - ops = map (\u -> InducerSignature u []) us - us = filter torStyle $ Map.keys umap - torStyle str = and [ uid_topdomain parsed == "onion" - , uid_realname parsed `elem` ["","Anonymous"] - , uid_user parsed == "root" - , fmap (match . fst) (lookup (packet k) torbindings) - == Just True ] - where parsed = parseUID str - match = (==subdom) . take (fromIntegral len) - subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] - subdom = Char8.unpack subdom0 - len = T.length (uid_subdomain parsed) - torbindings = getTorKeys (map packet $ flattenTop "" True kd) - getTorKeys pub = do - xs <- groupBindings pub - (_,(top,sub),us,_,_) <- xs - guard ("tor" `elem` us) - let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub - return (top,(torhash,sub)) - - groupBindings pub = gs - where (_,bindings) = getBindings pub - bindings' = accBindings bindings - code (c,(m,s),_,_,_) = (fingerprint_material m,-c) - ownerkey (_,(a,_),_,_,_) = a - sameMaster (ownerkey->a) (ownerkey->b) - = fingerprint_material a==fingerprint_material b - gs = groupBy sameMaster (sortBy (comparing code) bindings') - - --- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] -resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk - where - topk = keykey $ packet k -- key to master of key to be deleted - subk = do - (k,sub) <- Map.toList submap - guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) - return k - --- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] -resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk - where - topk = keykey $ packet k -- key to master of key to be deleted - subk = do - (k,SubKey p sigs) <- Map.toList submap - take 1 $ filter (has_tag tag) $ map (packet . fst) sigs - return k - merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -> KeyDB merge_ db filename qs = foldl mergeit db (zip [0..] qs) @@ -972,140 +653,38 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs) whatP (a,_) = concat . take 1 . words . show $ a -isKey :: Packet -> Bool -isKey (PublicKeyPacket {}) = True -isKey (SecretKeyPacket {}) = True -isKey _ = False - -isUserID :: Packet -> Bool -isUserID (UserIDPacket {}) = True -isUserID _ = False - -isTrust :: Packet -> Bool -isTrust (TrustPacket {}) = True -isTrust _ = False -keyPacket :: KeyData -> Packet -keyPacket (KeyData k _ _ _) = packet k - -keyFlags0 :: t -> [Packet] -> [SignatureSubpacket] -keyFlags0 wkun uidsigs = concat - [ keyflags - , preferredsym - , preferredhash - , preferredcomp - , features ] - - where - subs = concatMap hashed_subpackets uidsigs - keyflags = filterOr isflags subs $ - KeyFlagsPacket { certify_keys = True - , sign_data = True - , encrypt_communication = False - , encrypt_storage = False - , split_key = False - , authentication = False - , group_key = False - } - preferredsym = filterOr ispreferedsym subs $ - PreferredSymmetricAlgorithmsPacket - [ AES256 - , AES192 - , AES128 - , CAST5 - , TripleDES - ] - preferredhash = filterOr ispreferedhash subs $ - PreferredHashAlgorithmsPacket - [ SHA256 - , SHA1 - , SHA384 - , SHA512 - , SHA224 - ] - preferredcomp = filterOr ispreferedcomp subs $ - PreferredCompressionAlgorithmsPacket - [ ZLIB - , BZip2 - , ZIP - ] - features = filterOr isfeatures subs $ - FeaturesPacket { supports_mdc = True - } - - filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs - - isflags (KeyFlagsPacket {}) = True - isflags _ = False - ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True - ispreferedsym _ = False - ispreferedhash (PreferredHashAlgorithmsPacket {}) = True - ispreferedhash _ = False - ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True - ispreferedcomp _ = False - isfeatures (FeaturesPacket {}) = True - isfeatures _ = False - -makeInducerSig - :: Packet - -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver --- torsig g topk wkun uid timestamp extras = todo -makeInducerSig topk wkun uid extras - = CertificationSignature (secretToPublic topk) - uid - (sigpackets 0x13 - subpackets - subpackets_unh) - where - subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] - tsign - ++ extras - subpackets_unh = [IssuerPacket (fingerprint wkun)] - tsign = if keykey wkun == keykey topk - then [] -- tsign doesnt make sense for self-signatures - else [ TrustSignaturePacket 1 120 - , RegularExpressionPacket regex] - -- <[^>]+[@.]asdf\.nowhere>$ - regex = "<[^>]+[@.]"++hostname++">$" - -- regex = username ++ "@" ++ hostname - -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String - hostname = subdomain' pu ++ "\\." ++ topdomain' pu - pu = parseUID uidstr where UserIDPacket uidstr = uid - subdomain' = escape . T.unpack . uid_subdomain - topdomain' = escape . T.unpack . uid_topdomain - escape s = concatMap echar s - where - echar '|' = "\\|" - echar '*' = "\\*" - echar '+' = "\\+" - echar '?' = "\\?" - echar '.' = "\\." - echar '^' = "\\^" - echar '$' = "\\$" - echar '\\' = "\\\\" - echar '[' = "\\[" - echar ']' = "\\]" - echar c = [c] - -insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)])) -insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do - let subkk = keykey key - (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) - []) - ( (False,) . addOrigin ) - (Map.lookup subkk subs) - where - addOrigin (SubKey mp sigs) = +-- insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)])) +insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do + let topcipher = symmetric_algorithm $ packet top + tops2k = s2k $ packet top + doDecrypt = transcode (Unencrypted,S2K 100 "") + fname = resolveForReport Nothing inputfile + subkk = keykey key0 + istor = do + guard ("tor" `elem` mapMaybe usage tags) + return $ torUIDFromKey key0 + addOrigin (SubKey mp sigs) = let mp' = mp { locations = Map.insert fname (origin (packet mp) (-1)) (locations mp) } in SubKey mp' sigs - subs' = Map.insert subkk subkey subs - istor = do - guard ("tor" `elem` mapMaybe usage tags) - return $ "Anonymous " + subkey_result <- do + case Map.lookup subkk subs of + Just sub -> return $ KikiSuccess (False,addOrigin sub,Nothing) + Nothing -> do + wkun' <- doDecrypt top + try wkun' $ \wkun -> do + key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0 + try key' $ \key -> do + return $ KikiSuccess (True, SubKey (mappedPacket fname key) [], Just (wkun,key)) + + + try subkey_result $ \(is_new,subkey,decrypted) -> do + + let subs' = Map.insert subkk subkey subs uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do let has_torid = do @@ -1115,72 +694,58 @@ insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) signatures_over $ verify (Message [packet top]) s flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do - wkun <- doDecrypt top - - try wkun $ \wkun -> do - - let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) - uid = UserIDPacket idstr - -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags - tor_ov = makeInducerSig (packet top) wkun uid keyflags - sig_ov <- pgpSign (Message [wkun]) - tor_ov - SHA1 - (fingerprint wkun) - flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) - (sig_ov >>= listToMaybe . signatures_over) - $ \sig -> do - let om = Map.singleton fname (origin sig (-1)) - trust = Map.empty - return $ KikiSuccess - ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} - , trust)],om) uids - , [] ) + + let keyflags = keyFlags (error "dummy argument (insertSubkey)") (map packet $ flattenAllUids fname True uids) + uid = UserIDPacket idstr + -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags + tor_ov = makeInducerSig (packet top) (packet top) uid keyflags + wkun' <- maybe (doDecrypt top) (return . KikiSuccess . fst) decrypted + try wkun' $ \wkun -> do + sig_ov <- pgpSign (Message [wkun]) + tor_ov + SHA1 + (fingerprint wkun) + flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) + (sig_ov >>= listToMaybe . signatures_over) + $ \sig -> do + let om = Map.singleton fname (origin sig (-1)) + trust = Map.empty + return $ KikiSuccess + ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} + , trust)],om) uids + , [] ) try uids' $ \(uids',report) -> do - let SubKey subkey_p subsigs = subkey - wk = packet top - (xs',minsig,ys') = findTag tags wk key subsigs - doInsert mbsig = do - -- NEW SUBKEY BINDING SIGNATURE - sig' <- makeSig doDecrypt top fname subkey_p tags mbsig - try sig' $ \(sig',report) -> do - report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] - let subs' = Map.insert subkk - (SubKey subkey_p $ xs'++[sig']++ys') - subs - return $ KikiSuccess ( KeyData top topsigs uids' subs' - , report ) - - report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) - else id - s = show (fmap fst minsig,fingerprint key) - in return (f report) - - case minsig of - Nothing -> doInsert Nothing -- we need to create a new sig - Just (True,sig) -> -- we can deduce is_new == False - -- we may need to add a tor id - return $ KikiSuccess ( KeyData top topsigs uids' subs' - , report ) - Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag - -mappedPacket :: FilePath -> Packet -> MappedPacket -mappedPacket filename p = MappedPacket - { packet = p - , locations = Map.singleton filename (origin p (-1)) - } - -showPacket :: Packet -> String -showPacket p | isKey p = (if is_subkey p - then showPacket0 p - else ifSecret p "----Secret-----" "----Public-----") - ++ " "++show (key_algorithm p)++" "++fingerprint p - | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) - | otherwise = showPacket0 p -showPacket0 :: Show a => a -> [Char] -showPacket0 p = concat . take 1 $ words (show p) + let SubKey subkey_p subsigs = subkey + wk = packet top + (xs',minsig,ys') = findTag tags wk key0 subsigs + doInsert mbsig = do + -- NEW SUBKEY BINDING SIGNATURE + -- XXX: Here I assume that key0 is the unencrypted version + -- of subkey_p. TODO: Check this assumption. + sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} tags mbsig + try sig' $ \(sig',report) -> do + report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] + let subs' = Map.insert subkk + (SubKey subkey_p $ xs'++[sig']++ys') + subs + return $ KikiSuccess ( KeyData top topsigs uids' subs' + , report ) + + report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) + else id + s = show (fmap fst minsig,fingerprint key0) + in return (f report) + + case minsig of + Nothing -> doInsert Nothing -- we need to create a new sig + Just (True,sig) -> -- we can deduce is_new == False + -- we may need to add a tor id + return $ KikiSuccess ( KeyData top topsigs uids' subs' + , report ) + Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag + mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust] mergeSig sig sigs = @@ -1207,26 +772,6 @@ mergeSig sig sigs = mergeSameSig a b = b -- trace ("discarding dup "++show a) b -usageString :: PGPKeyFlags -> String -usageString flgs = - case flgs of - Special -> "special" - Vouch -> "vouch" -- signkey - Sign -> "sign" - VouchSign -> "vouch-sign" - Communication -> "communication" - VouchCommunication -> "vouch-communication" - SignCommunication -> "sign-communication" - VouchSignCommunication -> "vouch-sign-communication" - Storage -> "storage" - VouchStorage -> "vouch-storage" - SignStorage -> "sign-storage" - VouchSignStorage -> "vouch-sign-storage" - Encrypt -> "encrypt" - VouchEncrypt -> "vouch-encrypt" - SignEncrypt -> "sign-encrypt" - VouchSignEncrypt -> "vouch-sign-encrypt" - parseSingleSpec :: String -> SingleKeySpec parseSingleSpec "*" = AnyMatch parseSingleSpec "-" = WorkingKeyMatch @@ -1270,66 +815,66 @@ matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us us = filter (isInfixOf pat) $ Map.keys uids doImport - :: (MappedPacket -> IO (KikiCondition Packet)) + :: PacketTranscoder -> Map.Map KeyKey KeyData - -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) + -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) -doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do +doImport transcode db (fname,subspec,ms,typ -> typ,_) = do flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do - (certs,keys) <- case typ of - PEMFile -> do - ps <- readSecretPEMFile (ArgFile fname) - let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) - = partition (isJust . spemCert) ps - return (certs,keys) - DNSPresentation -> do - p <- readSecretDNSFile (ArgFile fname) - return ([],[p]) - -- TODO Probably we need to move to a new design where signature - -- packets are merged into the database in one phase with null - -- signatures, and then the signatures are made in the next phase. - -- This would let us merge annotations (like certificates) from - -- seperate files. - foldM (importKey tag certs) (KikiSuccess (db,[])) keys + (certs,keys) <- case typ of + PEMFile -> do + ps <- readSecretPEMFile fname + let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) + = partition (isJust . spemCert) ps + return (certs,keys) + DNSPresentation -> do + p <- readSecretDNSFile fname + return ([],[p]) + -- TODO Probably we need to move to a new design where signature + -- packets are merged into the database in one phase with null + -- signatures, and then the signatures are made in the next phase. + -- This would let us merge annotations (like certificates) from + -- seperate files. + foldM (importKey tag certs) (KikiSuccess (db,[])) keys where importKey tag certs prior key = do try prior $ \(db,report) -> do - let (m0,tailms) = splitAt 1 ms - if (not (null tailms) || null m0) - then return $ AmbiguousKeySpec fname - else do - let kk = keykey key - cs = filter (\c -> kk==keykey (pcertKey c)) certs - blobs = map mkCertNotation $ nub $ map pcertBlob cs - mkCertNotation bs = NotationDataPacket - { human_readable = False - , notation_name = "x509cert@" - , notation_value = Char8.unpack bs } - datedKey = key { timestamp = fromTime $ minimum dates } - dates = fromTime (timestamp key) : map pcertTimestamp certs - r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey - try r $ \(db',report') -> do - return $ KikiSuccess (db',report++report') + let (m0,tailms) = splitAt 1 ms + if (not (null tailms) || null m0) + then return $ AmbiguousKeySpec (resolveForReport Nothing fname) + else do + let kk = keykey key + cs = filter (\c -> kk==keykey (pcertKey c)) certs + blobs = map mkCertNotation $ nub $ map pcertBlob cs + mkCertNotation bs = NotationDataPacket + { human_readable = False + , notation_name = "x509cert@" + , notation_value = Char8.unpack bs } + datedKey = key { timestamp = fromTime $ minimum dates } + dates = fromTime (timestamp key) : map pcertTimestamp certs + r <- doImportG transcode db m0 (mkUsage tag:blobs) fname datedKey + try r $ \(db',report') -> do + return $ KikiSuccess (db',report++report') generateSubkey :: - (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[ + PacketTranscoder -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db -> (GenerateKeyParams, StreamInfo) -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) -generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do +generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do try kd' $ \(kd,report0) -> do - let subs = do - SubKey p sigs <- Map.elems $ keySubKeys kd - filter (has_tag tag) $ map (packet . fst) sigs - if null subs - then do - newkey <- generateKey genparam - kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey - try kdr $ \(newkd,report) -> do - return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) - else do - return $ KikiSuccess (kd,report0) + let subs = do + SubKey p sigs <- Map.elems $ keySubKeys kd + filter (has_tag tag) $ map (packet . fst) sigs + if null subs + then do + newkey <- generateKey genparam + kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey + try kdr $ \(newkd,report) -> do + return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) + else do + return $ KikiSuccess (kd,report0) generateSubkey _ kd _ = return kd -- | @@ -1496,12 +1041,6 @@ secp256k1_id = 0x2b8104000a "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23 -} -readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString -readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents -readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents -readInputFileS ctx inp = do - let fname = resolveInputFile ctx inp - fmap S.concat $ mapM S.readFile fname keyCompare :: String -> Packet -> Packet -> Ordering keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT @@ -1514,101 +1053,6 @@ keyCompare what a b = error $ unlines ["Unable to merge "++what++":" , PP.ppShow b ] -parseUID :: String -> UserIDRecord -parseUID str = UserIDRecord { - uid_full = str, - uid_realname = realname, - uid_user = user, - uid_subdomain = subdomain, - uid_topdomain = topdomain - } - where - text = T.pack str - (T.strip-> realname, T.dropAround isBracket-> email) - = T.break (=='<') text - (user, T.drop 1-> hostname) = T.break (=='@') email - ( T.reverse -> topdomain, - T.reverse . T.drop 1 -> subdomain) - = T.break (=='.') . T.reverse $ hostname - -flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] -flattenTop fname ispub (KeyData key sigs uids subkeys) = - unk ispub key : - ( flattenAllUids fname ispub uids - ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) - -derToBase32 :: ByteString -> String -#if !defined(VERSION_cryptonite) -derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy -#else -derToBase32 = map toLower . Base32.encode . S.unpack . sha1 - where - sha1 :: L.ByteString -> S.ByteString - sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1) -#endif - -derRSA :: Packet -> Maybe ByteString -derRSA rsa = do - k <- rsaKeyFromPacket rsa - return $ encodeASN1 DER (toASN1 k []) - -getBindings :: - [Packet] - -> - ( [([Packet],[SignatureOver])] -- other signatures with key sets - -- that were used for the verifications - , [(Word8, - (Packet, Packet), -- (topkey,subkey) - [String], -- usage flags - [SignatureSubpacket], -- hashed data - [Packet])] -- binding signatures - ) -getBindings pkts = (sigs,bindings) - where - (sigs,concat->bindings) = unzip $ do - let (keys,_) = partition isKey pkts - keys <- disjoint_fp keys - let (bs,sigs) = verifyBindings keys pkts - return . ((keys,sigs),) $ do - b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs - i <- map signature_issuer (signatures_over b) - i <- maybeToList i - who <- maybeToList $ find_key fingerprint (Message keys) i - let (code,claimants) = - case () of - _ | who == topkey b -> (1,[]) - _ | who == subkey b -> (2,[]) - _ -> (0,[who]) - let hashed = signatures_over b >>= hashed_subpackets - kind = guard (code==1) >> hashed >>= maybeToList . usage - return (code,(topkey b,subkey b), kind, hashed,claimants) - --- Returned data is simmilar to getBindings but the Word8 codes --- are ORed together. -accBindings :: - Bits t => - [(t, (Packet, Packet), [a], [a1], [a2])] - -> [(t, (Packet, Packet), [a], [a1], [a2])] -accBindings bs = as - where - gs = groupBy samePair . sortBy (comparing bindingPair) $ bs - as = map (foldl1 combine) gs - bindingPair (_,p,_,_,_) = pub2 p - where - pub2 (a,b) = (pub a, pub b) - pub a = fingerprint_material a - samePair a b = bindingPair a == bindingPair b - combine (ac,p,akind,ahashed,aclaimaints) - (bc,_,bkind,bhashed,bclaimaints) - = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) - -subkeyMappedPacket :: SubKey -> MappedPacket -subkeyMappedPacket (SubKey k _ ) = k - -has_tag :: String -> Packet -> Bool -has_tag tag p = isSignaturePacket p - && or [ tag `elem` mapMaybe usage (hashed_subpackets p) - , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) @@ -1689,200 +1133,55 @@ secretToPublic pkt@(SecretKeyPacket {}) = } secretToPublic pkt = pkt -sigpackets :: - Monad m => - Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet -sigpackets typ hashed unhashed = return $ - signaturePacket - 4 -- version - typ -- 0x18 subkey binding sig, or 0x19 back-signature - RSA - SHA1 - hashed - unhashed - 0 -- Word16 -- Left 16 bits of the signed hash value - [] -- [MPI] - -usage :: SignatureSubpacket -> Maybe String -usage (NotationDataPacket - { human_readable = True - , notation_name = "usage@" - , notation_value = u - }) = Just u -usage _ = Nothing - -torhash :: Packet -> String -torhash key = fromMaybe "" $ derToBase32 <$> derRSA key - -keyFlags :: t -> [Packet] -> [SignatureSubpacket] -keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) - -flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] -flattenAllUids fname ispub uids = - concatSort fname head (flattenUid fname ispub) (Map.assocs uids) - --- | Given list of subpackets, a master key, one of its subkeys and a --- list of signatures on that subkey, yields: --- --- * preceding list of signatures --- --- * The most recent valid signature made by the master key along with a --- flag that indicates whether or not all of the supplied subpackets occur in --- it or, if no valid signature from the working key is present, Nothing. --- --- * following list of signatures --- -findTag :: - [SignatureSubpacket] - -> Packet - -> Packet - -> [(MappedPacket, b)] - -> ([(MappedPacket, b)], - Maybe (Bool, (MappedPacket, b)), - [(MappedPacket, b)]) -findTag tag topk subkey subsigs = (xs',minsig,ys') - where - vs = map (\sig -> - (sig, do - sig <- Just (packet . fst $ sig) - guard (isSignaturePacket sig) - guard $ flip isSuffixOf - (fingerprint topk) - . fromMaybe "%bad%" - . signature_issuer - $ sig - listToMaybe $ - map (signature_time . verify (Message [topk])) - (signatures $ Message [topk,subkey,sig]))) - subsigs - (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs - xs' = map fst xs - ys' = map fst $ if isNothing minsig then ys else drop 1 ys - minsig = do - (sig,ov) <- listToMaybe ys - ov - let hshed = hashed_subpackets $ packet $ fst sig - return ( null $ tag \\ hshed, sig) - -makeSig :: - (MappedPacket -> IO (KikiCondition Packet)) - -> MappedPacket - -> [Char] - -> MappedPacket - -> [SignatureSubpacket] - -> Maybe (MappedPacket, Map.Map k a) - -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction])) -makeSig doDecrypt top fname subkey_p tags mbsig = do - let wk = packet top - wkun <- doDecrypt top - try wkun $ \wkun -> do - let grip = fingerprint wk - addOrigin new_sig = - flip - (maybe $ return FailedToMakeSignature) - (new_sig >>= listToMaybe . signatures_over) $ \new_sig -> do - let mp' = mappedPacket fname new_sig - return $ KikiSuccess (mp', Map.empty) - parsedkey = [packet subkey_p] - hashed0 - | any isFlagsPacket tags = tags - | otherwise = - KeyFlagsPacket - { certify_keys = False - , sign_data = False - , encrypt_communication = False - , encrypt_storage = False - , split_key = False - , authentication = True - , group_key = False - } : - tags - -- implicitly added: - -- , SignatureCreationTimePacket (fromIntegral timestamp) - isFlagsPacket (KeyFlagsPacket {}) = True - isFlagsPacket _ = False - subgrip = fingerprint (head parsedkey) - back_sig <- - pgpSign - (Message parsedkey) - (SubkeySignature - wk - (head parsedkey) - (sigpackets 0x19 hashed0 [IssuerPacket subgrip])) - (if key_algorithm (head parsedkey) == ECDSA - then SHA256 - else SHA1) - subgrip - let iss = IssuerPacket (fingerprint wk) - cons_iss back_sig = - iss : map EmbeddedSignaturePacket (signatures_over back_sig) - unhashed0 = maybe [iss] cons_iss back_sig - new_sig <- - pgpSign - (Message [wkun]) - (SubkeySignature wk (head parsedkey) (sigpackets 0x18 hashed0 unhashed0)) - SHA1 - grip - let newSig = do - r <- addOrigin new_sig - return $ fmap (, []) r - flip (maybe newSig) mbsig $ \(mp, trustmap) -> do - let sig = packet mp - isCreation (SignatureCreationTimePacket {}) = True - isCreation _ = False - isExpiration (SignatureExpirationTimePacket {}) = True - isExpiration _ = False - (cs, ps) = partition isCreation (hashed_subpackets sig) - (es, qs) = partition isExpiration ps - stamp = listToMaybe . sortBy (comparing Down) $ map unwrap cs - where - unwrap (SignatureCreationTimePacket x) = x - exp = listToMaybe $ sort $ map unwrap es - where - unwrap (SignatureExpirationTimePacket x) = x - expires = liftA2 (+) stamp exp - timestamp <- now - if fmap ((< timestamp) . fromIntegral) expires == Just True - then return $ - KikiSuccess ((mp, trustmap), [UnableToUpdateExpiredSignature]) - else do - let times = - (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) $ - maybeToList $ do - e <- expires - return $ - SignatureExpirationTimePacket (e - fromIntegral timestamp) - sig' = sig {hashed_subpackets = times ++ (qs `union` tags)} - new_sig <- - pgpSign - (Message [wkun]) - (SubkeySignature wk (packet subkey_p) [sig']) - SHA1 - (fingerprint wk) - newsig <- addOrigin new_sig - return $ fmap (, []) newsig ifSecret :: Packet -> t -> t -> t ifSecret (SecretKeyPacket {}) t f = t ifSecret _ t f = f -uidkey :: Packet -> String -uidkey (UserIDPacket str) = str - -keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags -keyflags flgs@(KeyFlagsPacket {}) = - Just . toEnum $ - ( bit 0x1 certify_keys - .|. bit 0x2 sign_data - .|. bit 0x4 encrypt_communication - .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags - -- other flags: - -- split_key - -- authentication (ssh-client) - -- group_key - where - bit v f = if f flgs then v else 0 -keyflags _ = Nothing +instance ASN1Object RSAPrivateKey where + toASN1 rsa@(RSAPrivateKey {}) + = \xs -> Start Sequence + : IntVal 0 + : mpiVal rsaN + : mpiVal rsaE + : mpiVal rsaD + : mpiVal rsaP + : mpiVal rsaQ + : mpiVal rsaDmodP1 + : mpiVal rsaDmodQminus1 + : mpiVal rsaCoefficient + : End Sequence + : xs + where mpiVal f = IntVal x where MPI x = f rsa + + fromASN1 ( Start Sequence + : IntVal _ -- version + : IntVal n + : IntVal e + : IntVal d + : IntVal p + : IntVal q + : IntVal dmodp1 + : IntVal dmodqminus1 + : IntVal coefficient + : ys) = + Right ( privkey, tail $ dropWhile notend ys) + where + notend (End Sequence) = False + notend _ = True + privkey = RSAPrivateKey + { rsaN = MPI n + , rsaE = MPI e + , rsaD = MPI d + , rsaP = MPI p + , rsaQ = MPI q + , rsaDmodP1 = MPI dmodp1 + , rsaDmodQminus1 = MPI dmodqminus1 + , rsaCoefficient = MPI coefficient + } + fromASN1 _ = + Left "fromASN1: RSAPrivateKey: unexpected format" + readSecretPEMFile :: InputFile -> IO [SecretPEMData] readSecretPEMFile fname = do @@ -1912,6 +1211,7 @@ readSecretPEMFile fname = do mergeDate (tm,_) (Right mb) = (tm,mb) return $ dta + readSecretDNSFile :: InputFile -> IO Packet readSecretDNSFile fname = do let ctx = InputFileContext "" "" @@ -1992,97 +1292,6 @@ socketFamily (SockAddrUnix _) = AF_UNIX selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db -isBracket :: Char -> Bool -isBracket '<' = True -isBracket '>' = True -isBracket _ = False - -unk :: Bool -> MappedPacket -> MappedPacket -unk isPublic = if isPublic then toPacket secretToPublic else id - where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} - -concatSort :: - FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a] -concatSort fname getp f = concat . sortByHint fname getp . map f - -flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] -flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs - -rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey -rsaKeyFromPacket p | isKey p = do - n <- lookup 'n' $ key p - e <- lookup 'e' $ key p - return $ RSAKey n e - -rsaKeyFromPacket _ = Nothing - -disjoint_fp :: [Packet] -> [[Packet]] -disjoint_fp ks = {- concatMap group2 $ -} transpose grouped - where - grouped = groupBy samepr . sortBy (comparing smallpr) $ ks - samepr a b = smallpr a == smallpr b - - {- - -- useful for testing - group2 :: [a] -> [[a]] - group2 (x:y:ys) = [x,y]:group2 ys - group2 [x] = [[x]] - group2 [] = [] - -} - -verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver]) -verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) - where - verified = do - sig <- signatures (Message nonkeys) - let v = verify (Message keys) sig - guard (not . null $ signatures_over v) - return v - (top,othersigs) = partition isSubkeySignature verified - embedded = do - sub <- top - let sigover = signatures_over sub - unhashed = sigover >>= unhashed_subpackets - subsigs = mapMaybe backsig unhashed - -- This should consist only of 0x19 values - -- subtypes = map signature_type subsigs - -- trace ("subtypes = "++show subtypes) (return ()) - -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ()) - sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) - let v = verify (Message [subkey sub]) sig - guard (not . null $ signatures_over v) - return v - -flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] -flattenUid fname ispub (str,(sigs,om)) = - (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs - --- | Get the time stamp of a signature. --- --- Warning: This function checks unhashed_subpackets if no timestamp occurs in --- the hashed section. TODO: change this? --- -signature_time :: SignatureOver -> Word32 -signature_time ov = case (if null cs then ds else cs) of - [] -> minBound - xs -> maximum xs - where - ps = signatures_over ov - ss = filter isSignaturePacket ps - cs = concatMap (concatMap creationTime . hashed_subpackets) ss - ds = concatMap (concatMap creationTime . unhashed_subpackets) ss - creationTime (SignatureCreationTimePacket t) = [t] - creationTime _ = [] - -splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t]) -splitAtMinBy comp xs = minimumBy comp' xxs - where - xxs = zip (inits xs) (tails xs) - comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs) - compM (Just a) (Just b) = comp a b - compM Nothing mb = GT - compM _ _ = LT - parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert parseCertBlob comp bs = do asn1 <- either (const Nothing) Just @@ -2171,15 +1380,18 @@ extractRSAKeyFields kvs = do , rsaCoefficient = u } where parseField blob = MPI <$> m +#if defined(VERSION_memory) + where m = bigendian <$> functorToMaybe (convertFromBase Base64 $ Char8.toStrict blob) + bigendian bs = snd $ S.foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs + where + nlen = S.length bs +#elif defined(VERSION_dataenc) where m = bigendian <$> Base64.decode (Char8.unpack blob) - bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs where nlen = length bs +#endif -backsig :: SignatureSubpacket -> Maybe Packet -backsig (EmbeddedSignaturePacket s) = Just s -backsig _ = Nothing selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectKey0 wantPublic (spec,mtag) db = do @@ -2190,27 +1402,7 @@ selectKey0 wantPublic (spec,mtag) db = do y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 [] -> Nothing -sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] -sortByHint fname f = sortBy (comparing gethint) - where - gethint = maybe defnum originalNum . Map.lookup fname . locations . f - defnum = -1 - -unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] -unsig fname isPublic (sig,trustmap) = - sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) - where - f n _ = n==fname -- && trace ("fname=n="++show n) True - asMapped n p = let m = mappedPacket fname p - in m { locations = fmap (\x->x {originalNum=n}) (locations m) } - -smallpr :: Packet -> [Char] -smallpr k = drop 24 $ fingerprint k - -isSubkeySignature :: SignatureOver -> Bool -isSubkeySignature (SubkeySignature {}) = True -isSubkeySignature _ = False - +-- TODO: Data.ByteString.Lazy now exports this. toStrict :: L.ByteString -> S.ByteString toStrict = foldr1 (<>) . L.toChunks diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs new file mode 100644 index 0000000..2383140 --- /dev/null +++ b/lib/KeyRing/Types.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE DeriveFunctor #-} +module KeyRing.Types where + +import Data.Char (isLower,toLower) +import Data.List (groupBy) +import Data.Map as Map (Map) +import qualified Data.Map as Map +import Data.OpenPGP +import Data.OpenPGP.Util +import Data.Time.Clock +import FunctorToMaybe +import qualified Data.ByteString.Lazy as L +import qualified System.Posix.Types as Posix + +-- | This type describes an idempotent transformation (merge or import) on a +-- set of GnuPG keyrings and other key files. +data KeyRingOperation = KeyRingOperation + { opFiles :: Map InputFile StreamInfo + -- ^ Indicates files to be read or updated. + , opPassphrases :: [PassphraseSpec] + -- ^ Indicates files or file descriptors where passphrases can be found. + , opTransforms :: [Transform] + -- ^ Transformations to be performed on the key pool after all files have + -- been read and before any have been written. + , opHome :: Maybe FilePath + -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub' + -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted + -- and if that is not set, it falls back to $HOME/.gnupg. + } + deriving (Eq,Show) + +data InputFile = HomeSec + -- ^ A file named secring.gpg located in the home directory. + -- See 'opHome'. + | HomePub + -- ^ A file named pubring.gpg located in the home directory. + -- See 'opHome'. + | ArgFile FilePath + -- ^ Contents will be read or written from the specified path. + | FileDesc Posix.Fd + -- ^ Contents will be read or written from the specified file + -- descriptor. + | Pipe Posix.Fd Posix.Fd + -- ^ Contents will be read from the first descriptor and updated + -- content will be writen to the second. Note: Don't use Pipe + -- for 'Wallet' files. (TODO: Wallet support) + | Generate Int GenerateKeyParams + -- ^ New key packets will be generated if there is no + -- matching content already in the key pool. The integer is + -- a unique id number so that multiple generations can be + -- inserted into 'opFiles' + deriving (Eq,Ord,Show) + +-- | This type describes how 'runKeyRing' will treat a file. +data StreamInfo = StreamInfo + { access :: Access + -- ^ Indicates whether the file is allowed to contain secret information. + , typ :: FileType + -- ^ Indicates the format and content type of the file. + , fill :: KeyFilter + -- ^ This filter controls what packets will be inserted into a file. + , spill :: KeyFilter + -- + -- ^ Use this to indicate whether or not a file's contents should be + -- available for updating other files. Note that although its type is + -- 'KeyFilter', it is usually interpretted as a boolean flag. Details + -- depend on 'typ' and are as follows: + -- + -- 'KeyRingFile': + -- + -- * 'KF_None' - The file's contents will not be shared. + -- + -- * otherwise - The file's contents will be shared. + -- + -- 'PEMFile': + -- + -- * 'KF_None' - The file's contents will not be shared. + -- + -- * 'KF_Match' - The file's key will be shared with the specified owner + -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be + -- equal to this value; changing the usage or owner of a key is not + -- supported via the fill/spill mechanism. + -- + -- * otherwise - Unspecified. Do not use. + -- + -- 'WalletFile': + -- + -- * The 'spill' setting is ignored and the file's contents are shared. + -- (TODO) + -- + -- 'Hosts': + -- + -- * The 'spill' setting is ignored and the file's contents are shared. + -- (TODO) + -- + , initializer :: Initializer + -- ^ If 'typ' is 'PEMFile' and an 'External' 'initializer' string is set, + -- then it is interpretted as a shell command that may be used to create + -- the key if it does not exist. + , transforms :: [Transform] + -- ^ Per-file transformations that occur before the contents of a file are + -- spilled into the common pool. + } + deriving (Eq,Show) + + +-- | This type is used to indicate where to obtain passphrases. +data PassphraseSpec = PassphraseSpec + { passSpecRingFile :: Maybe FilePath + -- ^ If not Nothing, the passphrase is to be used for packets + -- from this file. + , passSpecKeySpec :: Maybe String + -- ^ Non-Nothing value reserved for future use. + -- (TODO: Use this to implement per-key passphrase associations). + , passSpecPassFile :: InputFile + -- ^ The passphrase will be read from this file or file descriptor. + } + -- | Use this to carry pasphrases from a previous run. + | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder } + | PassphraseAgent + +instance Show PassphraseSpec where + show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) + show (PassphraseMemoizer _) = "PassphraseMemoizer" +instance Eq PassphraseSpec where + PassphraseSpec a b c == PassphraseSpec d e f + = and [a==d,b==e,c==f] + _ == _ + = False + +-- Ord instance for PassphraseSpec generally orders by generality with the most +-- general being greatest and the least general being least. The one exception +-- is the 'PassphraseMemoizer' which is considered least of all even though it +-- is very general. This is so an existing memoizer will be tried first, and +-- if there is none, one will be created that tries the others in order of +-- increasing generality. Key-specialization is considered less general than +-- file-specialization. +instance Ord PassphraseSpec where + compare (PassphraseMemoizer _) (PassphraseMemoizer _) = EQ + compare PassphraseAgent PassphraseAgent = EQ + compare (PassphraseMemoizer _) _ = LT + compare (PassphraseSpec a b c) (PassphraseSpec d e f) + | fmap (const ()) a == fmap (const ()) d + && fmap (const ()) b == fmap (const ()) e = compare (a,b,c) (d,e,f) + compare (PassphraseSpec (Just _) (Just _) _) _ = LT + compare (PassphraseSpec Nothing (Just _) _) _ = LT + compare (PassphraseSpec (Just _) _ _) _ = LT + compare PassphraseAgent _ = GT + +data Transform = + Autosign + -- ^ This operation will make signatures for any tor-style UID + -- that matches a tor subkey and thus can be authenticated without + -- requring the judgement of a human user. + -- + -- A tor-style UID is one of the following form: + -- + -- > Anonymous + | DeleteSubkeyByFingerprint String + -- ^ Delete the subkey specified by the given fingerprint and any + -- associated signatures on that key. + | DeleteSubkeyByUsage String + -- ^ Delete the subkey specified by the given usage tag and any + -- associated signatures on that key. + | RenameSubkeys String String + -- ^ Replace all subkey signatures matching the first usage tag with + -- fresh signatures that match the second usage tag. + deriving (Eq,Ord,Show) + +-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected +-- to contain secret or public PGP key packets. Note that it is not supported +-- to mix both in the same file and that the secret key packets include all of +-- the information contained in their corresponding public key packets. +data Access = AutoAccess -- ^ secret or public as appropriate based on existing content. + -- (see 'rtRingAccess') + | Sec -- ^ secret information + | Pub -- ^ public information + deriving (Eq,Ord,Show) + +data FileType = KeyRingFile + | PEMFile + | WalletFile + | DNSPresentation + | Hosts + | SshFile + deriving (Eq,Ord,Enum,Show) + +-- type UsageTag = String +data Initializer = NoCreate | Internal GenerateKeyParams | External String | WarnMissing String + deriving (Eq,Ord,Show) + + + +type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) +type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet) + +-- | Note that the documentation here is intended for when this value is +-- assigned to 'fill'. For other usage, see 'spill'. +data KeyFilter = KF_None -- ^ No keys will be imported. + | KF_Match String -- ^ Only the key that matches the spec will be imported. + | KF_Subkeys -- ^ Subkeys will be imported if their owner key is + -- already in the ring. TODO: Even if their signatures + -- are bad? + | KF_Authentic -- ^ Keys are imported if they belong to an authenticated + -- identity (signed or self-authenticating). + | KF_All -- ^ All keys will be imported. + deriving (Eq,Ord,Show) + +-- | The position and acces a packet had before the operation +data OriginFlags = OriginFlags + { originallyPublic :: Bool + -- ^ false if SecretKeyPacket + , originalNum :: Int + -- ^ packets are numbered, starting from 1.. + } deriving Show + +type OriginMap = Map FilePath OriginFlags + +type MappedPacket = OriginMapped Packet +data OriginMapped a = MappedPacket + { packet :: a + , locations :: OriginMap + } deriving Show +instance Functor OriginMapped where + fmap f (MappedPacket x ls) = MappedPacket (f x) ls + +origin :: Packet -> Int -> OriginFlags +origin p n = OriginFlags ispub n + where + ispub = case p of + SecretKeyPacket {} -> False + _ -> True + +mappedPacket :: FilePath -> Packet -> MappedPacket +mappedPacket filename p = MappedPacket + { packet = p + , locations = Map.singleton filename (origin p (-1)) + } + +mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket +mappedPacketWithHint filename p hint = MappedPacket + { packet = p + , locations = Map.singleton filename (origin p hint) + } + + +-- | This type is used to indicate success or failure +-- and in the case of success, return the computed object. +-- The 'FunctorToMaybe' class is implemented to facilitate +-- branching on failture. +data KikiCondition a = KikiSuccess a + | FailedToLock [FilePath] + | BadPassphrase + | FailedToMakeSignature + | CantFindHome + | AmbiguousKeySpec FilePath + | CannotImportMasterKey + | NoWorkingKey + | AgentConnectionFailure + | OperationCanceled + deriving ( Functor, Show ) + +instance FunctorToMaybe KikiCondition where + functorToMaybe (KikiSuccess a) = Just a + functorToMaybe _ = Nothing + +instance Applicative KikiCondition where + pure a = KikiSuccess a + f <*> a = + case functorToEither f of + Right f -> case functorToEither a of + Right a -> pure (f a) + Left err -> err + Left err -> err + +uncamel :: String -> String +uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args + where + (.:) = fmap . fmap + ( firstWord , + otherWords ) = splitAt 1 ws + ws = camel >>= groupBy (\_ c -> isLower c) + ( camel, args) = splitAt 1 $ words str + +errorString :: KikiCondition a -> String +errorString (KikiSuccess {}) = "success" +errorString e = uncamel . show $ fmap (const ()) e + + + +data InputFileContext = InputFileContext + { homesecPath :: FilePath + , homepubPath :: FilePath + } + + +-- | The 'KeyKey'-type is used to store the information of a key +-- which is used for finger-printing and as a lookup key into +-- maps. This type may be changed to an actual fingerprint in +-- in the future. +type KeyKey = [L.ByteString] + +keykey :: Packet -> KeyKey +keykey key = + -- Note: The key's timestamp is normally included in it's fingerprint. + -- This is undesirable for kiki because it causes the same + -- key to be imported multiple times and show as apparently + -- distinct keys with different fingerprints. + -- Thus, we will remove the timestamp. + fingerprint_material (key {timestamp=0}) -- TODO: smaller key? + +isKey :: Packet -> Bool +isKey (PublicKeyPacket {}) = True +isKey (SecretKeyPacket {}) = True +isKey _ = False + +isSecretKey :: Packet -> Bool +isSecretKey (SecretKeyPacket {}) = True +isSecretKey _ = False + + +isUserID :: Packet -> Bool +isUserID (UserIDPacket {}) = True +isUserID _ = False + +isTrust :: Packet -> Bool +isTrust (TrustPacket {}) = True +isTrust _ = False + +-- matchpr computes the fingerprint of the given key truncated to +-- be the same lenght as the given fingerprint for comparison. +-- +-- matchpr fp = Data.List.Extra.takeEnd (length fp) +-- +matchpr :: String -> Packet -> String +matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp + + + + +data KeySpec = + KeyGrip String -- fp: + | KeyTag Packet String -- fp:????/t: + | KeyUidMatch String -- u: + deriving Show + +{- +RSAPrivateKey ::= SEQUENCE { + version Version, + modulus INTEGER, -- n + publicExponent INTEGER, -- e + privateExponent INTEGER, -- d + prime1 INTEGER, -- p + prime2 INTEGER, -- q + exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1) + exponent2 INTEGER, -- d mod (q-1) + coefficient INTEGER, -- (inverse of q) mod p + otherPrimeInfos OtherPrimeInfos OPTIONAL + } +-} +data RSAPrivateKey = RSAPrivateKey + { rsaN :: MPI + , rsaE :: MPI + , rsaD :: MPI + , rsaP :: MPI + , rsaQ :: MPI + , rsaDmodP1 :: MPI + , rsaDmodQminus1 :: MPI + , rsaCoefficient :: MPI + } + deriving Show + +data ParsedCert = ParsedCert + { pcertKey :: Packet + , pcertTimestamp :: UTCTime + , pcertBlob :: L.ByteString + } + deriving (Show,Eq) + +data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned + deriving (Eq,Ord,Enum,Show,Read) + +data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert + deriving (Show,Eq) + +data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum) + +data SingleKeySpec = FingerprintMatch String + | SubstringMatch (Maybe MatchingField) String + | EmptyMatch + | AnyMatch + | WorkingKeyMatch + deriving (Show,Eq,Ord) + diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs index e276528..6eadfe4 100644 --- a/lib/PacketTranscoder.hs +++ b/lib/PacketTranscoder.hs @@ -20,7 +20,7 @@ import qualified Data.Traversable as Traversable import System.IO ( stderr) import System.Posix.IO ( fdToHandle ) import Text.Show.Pretty as PP ( ppShow ) -import Types +import KeyRing.Types import ControlMaybe (handleIO_) -- | Merge two representations of the same key, prefering secret version diff --git a/lib/ScanningParser.hs b/lib/ScanningParser.hs index f99e120..305402e 100644 --- a/lib/ScanningParser.hs +++ b/lib/ScanningParser.hs @@ -34,6 +34,8 @@ instance Functor (ScanningParser a) where first f (x,y) = (f x, y) +instance Semigroup (ScanningParser a b) where + (<>) = mappend instance Monoid (ScanningParser a b) where mempty = ScanningParser (const Nothing) (const $ const (Nothing,[])) mappend (ScanningParser ffstA pbdyA) diff --git a/lib/Transforms.hs b/lib/Transforms.hs index 990a5b4..c83f427 100644 --- a/lib/Transforms.hs +++ b/lib/Transforms.hs @@ -16,7 +16,7 @@ import Data.Ord import Data.OpenPGP import Data.OpenPGP.Util import Data.Word -import Types +import KeyRing.Types import FunctorToMaybe import GnuPGAgent ( key_nbits ) import PacketTranscoder @@ -257,10 +257,9 @@ mkUsage tag | Just flags <- lookup tag specials where flagsets = [Special .. VouchSignEncrypt] specials = map (\f -> (usageString f, f)) flagsets - mkUsage tag = NotationDataPacket { human_readable = True - , notation_name = "usage@" + , notation_name = "usage@" , notation_value = tag } @@ -278,6 +277,7 @@ unsig fname isPublic (sig,trustmap) = asMapped n p = let m = mappedPacket fname p in m { locations = fmap (\x->x {originalNum=n}) (locations m) } +smallpr :: Packet -> [Char] smallpr k = drop 24 $ fingerprint k backsig :: SignatureSubpacket -> Maybe Packet @@ -285,16 +285,19 @@ backsig (EmbeddedSignaturePacket s) = Just s backsig _ = Nothing +isSubkeySignature :: SignatureOver -> Bool isSubkeySignature (SubkeySignature {}) = True isSubkeySignature _ = False +has_tag :: String -> Packet -> Bool has_tag tag p = isSignaturePacket p && or [ tag `elem` mapMaybe usage (hashed_subpackets p) , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] +verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver]) verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) where verified = do @@ -317,7 +320,7 @@ verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersig guard (not . null $ signatures_over v) return v - +disjoint_fp :: [Packet] -> [[Packet]] disjoint_fp ks = {- concatMap group2 $ -} transpose grouped where grouped = groupBy samepr . sortBy (comparing smallpr) $ ks @@ -474,22 +477,22 @@ uidkey (UserIDPacket str) = str usageString :: PGPKeyFlags -> String usageString flgs = case flgs of - Special -> "special" - Vouch -> "vouch" -- signkey - Sign -> "sign" - VouchSign -> "vouch-sign" - Communication -> "communication" - VouchCommunication -> "vouch-communication" - SignCommunication -> "sign-communication" + Special -> "special" + Vouch -> "vouch" -- signkey + Sign -> "sign" + VouchSign -> "vouch-sign" + Communication -> "communication" + VouchCommunication -> "vouch-communication" + SignCommunication -> "sign-communication" VouchSignCommunication -> "vouch-sign-communication" - Storage -> "storage" - VouchStorage -> "vouch-storage" - SignStorage -> "sign-storage" - VouchSignStorage -> "vouch-sign-storage" - Encrypt -> "encrypt" - VouchEncrypt -> "vouch-encrypt" - SignEncrypt -> "sign-encrypt" - VouchSignEncrypt -> "vouch-sign-encrypt" + Storage -> "storage" + VouchStorage -> "vouch-storage" + SignStorage -> "sign-storage" + VouchSignStorage -> "vouch-sign-storage" + Encrypt -> "encrypt" + VouchEncrypt -> "vouch-encrypt" + SignEncrypt -> "sign-encrypt" + VouchSignEncrypt -> "vouch-sign-encrypt" @@ -529,7 +532,7 @@ showPacket p | isKey p = (if is_subkey p flags = mapMaybe (fmap usageString . keyflags) xs xs = hashed_subpackets p - +showPacket0 :: Show a => a -> [Char] showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p) where dropSuffix :: String -> String -> String @@ -588,7 +591,6 @@ keyFlags0 wkun uidsigs = concat , preferredhash , preferredcomp , features ] - where subs = concatMap hashed_subpackets uidsigs keyflags = filterOr isflags subs $ @@ -650,7 +652,6 @@ rsaKeyFromPacket p | isKey p = do n <- lookup 'n' $ key p e <- lookup 'e' $ key p return $ RSAKey n e - rsaKeyFromPacket _ = Nothing diff --git a/lib/Types.hs b/lib/Types.hs deleted file mode 100644 index dd519de..0000000 --- a/lib/Types.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Types where - -import Data.Char (isLower,toLower) -import Data.List (groupBy) -import Data.Map as Map (Map) -import qualified Data.Map as Map -import Data.OpenPGP -import Data.OpenPGP.Util -import FunctorToMaybe -import qualified Data.ByteString.Lazy as L -import qualified System.Posix.Types as Posix - --- | This type describes an idempotent transformation (merge or import) on a --- set of GnuPG keyrings and other key files. -data KeyRingOperation = KeyRingOperation - { opFiles :: Map InputFile StreamInfo - -- ^ Indicates files to be read or updated. - , opPassphrases :: [PassphraseSpec] - -- ^ Indicates files or file descriptors where passphrases can be found. - , opTransforms :: [Transform] - -- ^ Transformations to be performed on the key pool after all files have - -- been read and before any have been written. - , opHome :: Maybe FilePath - -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub' - -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted - -- and if that is not set, it falls back to $HOME/.gnupg. - } - deriving (Eq,Show) - -data InputFile = HomeSec - -- ^ A file named secring.gpg located in the home directory. - -- See 'opHome'. - | HomePub - -- ^ A file named pubring.gpg located in the home directory. - -- See 'opHome'. - | ArgFile FilePath - -- ^ Contents will be read or written from the specified path. - | FileDesc Posix.Fd - -- ^ Contents will be read or written from the specified file - -- descriptor. - | Pipe Posix.Fd Posix.Fd - -- ^ Contents will be read from the first descriptor and updated - -- content will be writen to the second. Note: Don't use Pipe - -- for 'Wallet' files. (TODO: Wallet support) - | Generate Int GenerateKeyParams - -- ^ New key packets will be generated if there is no - -- matching content already in the key pool. The integer is - -- a unique id number so that multiple generations can be - -- inserted into 'opFiles' - deriving (Eq,Ord,Show) - --- | This type describes how 'runKeyRing' will treat a file. -data StreamInfo = StreamInfo - { access :: Access - -- ^ Indicates whether the file is allowed to contain secret information. - , typ :: FileType - -- ^ Indicates the format and content type of the file. - , fill :: KeyFilter - -- ^ This filter controls what packets will be inserted into a file. - , spill :: KeyFilter - -- - -- ^ Use this to indicate whether or not a file's contents should be - -- available for updating other files. Note that although its type is - -- 'KeyFilter', it is usually interpretted as a boolean flag. Details - -- depend on 'typ' and are as follows: - -- - -- 'KeyRingFile': - -- - -- * 'KF_None' - The file's contents will not be shared. - -- - -- * otherwise - The file's contents will be shared. - -- - -- 'PEMFile': - -- - -- * 'KF_None' - The file's contents will not be shared. - -- - -- * 'KF_Match' - The file's key will be shared with the specified owner - -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be - -- equal to this value; changing the usage or owner of a key is not - -- supported via the fill/spill mechanism. - -- - -- * otherwise - Unspecified. Do not use. - -- - -- 'WalletFile': - -- - -- * The 'spill' setting is ignored and the file's contents are shared. - -- (TODO) - -- - -- 'Hosts': - -- - -- * The 'spill' setting is ignored and the file's contents are shared. - -- (TODO) - -- - , initializer :: Initializer - -- ^ If 'typ' is 'PEMFile' and an 'External' 'initializer' string is set, - -- then it is interpretted as a shell command that may be used to create - -- the key if it does not exist. - , transforms :: [Transform] - -- ^ Per-file transformations that occur before the contents of a file are - -- spilled into the common pool. - } - deriving (Eq,Show) - - --- | This type is used to indicate where to obtain passphrases. -data PassphraseSpec = PassphraseSpec - { passSpecRingFile :: Maybe FilePath - -- ^ If not Nothing, the passphrase is to be used for packets - -- from this file. - , passSpecKeySpec :: Maybe String - -- ^ Non-Nothing value reserved for future use. - -- (TODO: Use this to implement per-key passphrase associations). - , passSpecPassFile :: InputFile - -- ^ The passphrase will be read from this file or file descriptor. - } - -- | Use this to carry pasphrases from a previous run. - | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder } - | PassphraseAgent - -instance Show PassphraseSpec where - show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) - show (PassphraseMemoizer _) = "PassphraseMemoizer" -instance Eq PassphraseSpec where - PassphraseSpec a b c == PassphraseSpec d e f - = and [a==d,b==e,c==f] - _ == _ - = False - --- Ord instance for PassphraseSpec generally orders by generality with the most --- general being greatest and the least general being least. The one exception --- is the 'PassphraseMemoizer' which is considered least of all even though it --- is very general. This is so an existing memoizer will be tried first, and --- if there is none, one will be created that tries the others in order of --- increasing generality. Key-specialization is considered less general than --- file-specialization. -instance Ord PassphraseSpec where - compare (PassphraseMemoizer _) (PassphraseMemoizer _) = EQ - compare PassphraseAgent PassphraseAgent = EQ - compare (PassphraseMemoizer _) _ = LT - compare (PassphraseSpec a b c) (PassphraseSpec d e f) - | fmap (const ()) a == fmap (const ()) d - && fmap (const ()) b == fmap (const ()) e = compare (a,b,c) (d,e,f) - compare (PassphraseSpec (Just _) (Just _) _) _ = LT - compare (PassphraseSpec Nothing (Just _) _) _ = LT - compare (PassphraseSpec (Just _) _ _) _ = LT - compare PassphraseAgent _ = GT - -data Transform = - Autosign - -- ^ This operation will make signatures for any tor-style UID - -- that matches a tor subkey and thus can be authenticated without - -- requring the judgement of a human user. - -- - -- A tor-style UID is one of the following form: - -- - -- > Anonymous - | DeleteSubkeyByFingerprint String - -- ^ Delete the subkey specified by the given fingerprint and any - -- associated signatures on that key. - | DeleteSubkeyByUsage String - -- ^ Delete the subkey specified by the given usage tag and any - -- associated signatures on that key. - | RenameSubkeys String String - -- ^ Replace all subkey signatures matching the first usage tag with - -- fresh signatures that match the second usage tag. - deriving (Eq,Ord,Show) - --- | Use this type to indicate whether a file of type 'KeyRingFile' is expected --- to contain secret or public PGP key packets. Note that it is not supported --- to mix both in the same file and that the secret key packets include all of --- the information contained in their corresponding public key packets. -data Access = AutoAccess -- ^ secret or public as appropriate based on existing content. - -- (see 'rtRingAccess') - | Sec -- ^ secret information - | Pub -- ^ public information - deriving (Eq,Ord,Show) - -data FileType = KeyRingFile - | PEMFile - | WalletFile - | DNSPresentation - | Hosts - | SshFile - deriving (Eq,Ord,Enum,Show) - --- type UsageTag = String -data Initializer = NoCreate | Internal GenerateKeyParams | External String | WarnMissing String - deriving (Eq,Ord,Show) - - - -type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) -type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet) - --- | Note that the documentation here is intended for when this value is --- assigned to 'fill'. For other usage, see 'spill'. -data KeyFilter = KF_None -- ^ No keys will be imported. - | KF_Match String -- ^ Only the key that matches the spec will be imported. - | KF_Subkeys -- ^ Subkeys will be imported if their owner key is - -- already in the ring. TODO: Even if their signatures - -- are bad? - | KF_Authentic -- ^ Keys are imported if they belong to an authenticated - -- identity (signed or self-authenticating). - | KF_All -- ^ All keys will be imported. - deriving (Eq,Ord,Show) - --- | The position and acces a packet had before the operation -data OriginFlags = OriginFlags - { originallyPublic :: Bool - -- ^ false if SecretKeyPacket - , originalNum :: Int - -- ^ packets are numbered, starting from 1.. - } deriving Show - -type OriginMap = Map FilePath OriginFlags - -type MappedPacket = OriginMapped Packet -data OriginMapped a = MappedPacket - { packet :: a - , locations :: OriginMap - } deriving Show -instance Functor OriginMapped where - fmap f (MappedPacket x ls) = MappedPacket (f x) ls - -origin :: Packet -> Int -> OriginFlags -origin p n = OriginFlags ispub n - where - ispub = case p of - SecretKeyPacket {} -> False - _ -> True - -mappedPacket :: FilePath -> Packet -> MappedPacket -mappedPacket filename p = MappedPacket - { packet = p - , locations = Map.singleton filename (origin p (-1)) - } - -mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket -mappedPacketWithHint filename p hint = MappedPacket - { packet = p - , locations = Map.singleton filename (origin p hint) - } - - --- | This type is used to indicate success or failure --- and in the case of success, return the computed object. --- The 'FunctorToMaybe' class is implemented to facilitate --- branching on failture. -data KikiCondition a = KikiSuccess a - | FailedToLock [FilePath] - | BadPassphrase - | FailedToMakeSignature - | CantFindHome - | AmbiguousKeySpec FilePath - | CannotImportMasterKey - | NoWorkingKey - | AgentConnectionFailure - | OperationCanceled - deriving ( Functor, Show ) - -instance FunctorToMaybe KikiCondition where - functorToMaybe (KikiSuccess a) = Just a - functorToMaybe _ = Nothing - -instance Applicative KikiCondition where - pure a = KikiSuccess a - f <*> a = - case functorToEither f of - Right f -> case functorToEither a of - Right a -> pure (f a) - Left err -> err - Left err -> err - -uncamel :: String -> String -uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args - where - (.:) = fmap . fmap - ( firstWord , - otherWords ) = splitAt 1 ws - ws = camel >>= groupBy (\_ c -> isLower c) - ( camel, args) = splitAt 1 $ words str - -errorString :: KikiCondition a -> String -errorString (KikiSuccess {}) = "success" -errorString e = uncamel . show $ fmap (const ()) e - - - -data InputFileContext = InputFileContext - { homesecPath :: FilePath - , homepubPath :: FilePath - } - - --- | The 'KeyKey'-type is used to store the information of a key --- which is used for finger-printing and as a lookup key into --- maps. This type may be changed to an actual fingerprint in --- in the future. -type KeyKey = [L.ByteString] - -keykey :: Packet -> KeyKey -keykey key = - -- Note: The key's timestamp is normally included in it's fingerprint. - -- This is undesirable for kiki because it causes the same - -- key to be imported multiple times and show as apparently - -- distinct keys with different fingerprints. - -- Thus, we will remove the timestamp. - fingerprint_material (key {timestamp=0}) -- TODO: smaller key? - -isKey :: Packet -> Bool -isKey (PublicKeyPacket {}) = True -isKey (SecretKeyPacket {}) = True -isKey _ = False - -isSecretKey :: Packet -> Bool -isSecretKey (SecretKeyPacket {}) = True -isSecretKey _ = False - - -isUserID :: Packet -> Bool -isUserID (UserIDPacket {}) = True -isUserID _ = False - -isTrust :: Packet -> Bool -isTrust (TrustPacket {}) = True -isTrust _ = False - --- matchpr computes the fingerprint of the given key truncated to --- be the same lenght as the given fingerprint for comparison. --- --- matchpr fp = Data.List.Extra.takeEnd (length fp) --- -matchpr :: String -> Packet -> String -matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp - - -- cgit v1.2.3