summaryrefslogtreecommitdiff
path: root/lib/Kiki.hs
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-07-11 22:17:09 -0400
committerJoe Crayne <joe@jerkface.net>2019-07-11 22:17:09 -0400
commit365bdcd8d9f4a08aaae35fc27722d268f4af9041 (patch)
treeacc5aa18e90eb7f90174ca172136e49198495fbd /lib/Kiki.hs
parenta2cfd42e569e2f8d0a7011573f72ba0876ae16e8 (diff)
WIP: verify command to verify clear-sign PGP signatures.
Diffstat (limited to 'lib/Kiki.hs')
-rw-r--r--lib/Kiki.hs69
1 files changed, 60 insertions, 9 deletions
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index d6a8b3a..20ab1f2 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -6,6 +6,8 @@ module Kiki
6 , setVerifyFlag 6 , setVerifyFlag
7 ) where 7 ) where
8 8
9import qualified Codec.Encryption.OpenPGP.ASCIIArmor as ASCIIArmor
10import Codec.Encryption.OpenPGP.ASCIIArmor.Types
9import Control.Applicative 11import Control.Applicative
10import Control.Exception 12import Control.Exception
11import Control.Monad 13import Control.Monad
@@ -95,7 +97,7 @@ ciphers = takeWhile notFallback $ map toEnum $ [0..4]++[7..]
95refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO () 97refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO ()
96refresh root homepass = do 98refresh root homepass = do
97 let homepass' = homepass { cap_homespec = fmap root (cap_homespec homepass) } 99 let homepass' = homepass { cap_homespec = fmap root (cap_homespec homepass) }
98 KikiResult r report <- runKeyRing $ minimalOp homepass' 100 KikiResult r report <- runKeyRing $ minimalOp False homepass'
99 let mroot = case root "" of 101 let mroot = case root "" of
100 "/" -> Nothing 102 "/" -> Nothing
101 "" -> Nothing 103 "" -> Nothing
@@ -116,8 +118,8 @@ streaminfo = StreamInfo
116 , transforms = [] 118 , transforms = []
117 } 119 }
118 120
119minimalOp :: CommonArgsParsed -> KeyRingOperation 121minimalOp :: Bool -> CommonArgsParsed -> KeyRingOperation
120minimalOp cap = op 122minimalOp isHomeless cap = op
121 where 123 where
122 streaminfo = StreamInfo { fill = KF_None 124 streaminfo = StreamInfo { fill = KF_None
123 , typ = KeyRingFile 125 , typ = KeyRingFile
@@ -127,10 +129,12 @@ minimalOp cap = op
127 , transforms = [] 129 , transforms = []
128 } 130 }
129 op = KeyRingOperation 131 op = KeyRingOperation
130 { opFiles = Map.fromList $ 132 { opFiles = if isHomeless
131 [ ( HomeSec, streaminfo { access = Sec }) 133 then Map.empty
132 , ( HomePub, streaminfo { access = Pub }) 134 else Map.fromList $
133 ] 135 [ ( HomeSec, streaminfo { access = Sec })
136 , ( HomePub, streaminfo { access = Pub })
137 ]
134 , opPassphrases = withAgent $ do pfile <- maybeToList (cap_passfd cap) 138 , opPassphrases = withAgent $ do pfile <- maybeToList (cap_passfd cap)
135 return $ PassphraseSpec Nothing Nothing pfile 139 return $ PassphraseSpec Nothing Nothing pfile
136 , opTransforms = [] 140 , opTransforms = []
@@ -501,7 +505,10 @@ refreshCache rt rootdir = do
501 flip (maybe $ warn "missing working key?") (rtWorkingKey rt) $ \wk -> do 505 flip (maybe $ warn "missing working key?") (rtWorkingKey rt) $ \wk -> do
502 506
503 let grip = fingerprint wk 507 let grip = fingerprint wk
504 exportOp = passphrases <> pemSecrets <> minimalOp (CommonArgsParsed (Just $ takeDirectory $ rtPubring rt) Nothing) 508 exportOp = passphrases <> pemSecrets
509 <> minimalOp False
510 (CommonArgsParsed (Just $ takeDirectory $ rtPubring rt)
511 Nothing)
505 where 512 where
506 passphrases = mempty { opPassphrases = [PassphraseMemoizer (rtPassphrases rt)] } 513 passphrases = mempty { opPassphrases = [PassphraseMemoizer (rtPassphrases rt)] }
507 pemSecrets = mempty { opFiles = Map.fromList 514 pemSecrets = mempty { opFiles = Map.fromList
@@ -663,7 +670,7 @@ replaceSshServerKeys root cmn = do
663 strm = streaminfo { typ = PEMFile, spill = KF_Match "ssh-server", access = Sec } 670 strm = streaminfo { typ = PEMFile, spill = KF_Match "ssh-server", access = Sec }
664 delssh strm = strm { transforms = DeleteSubkeyByUsage "ssh-server" : transforms strm 671 delssh strm = strm { transforms = DeleteSubkeyByUsage "ssh-server" : transforms strm
665 , fill = KF_All } 672 , fill = KF_All }
666 KikiResult r report <- runKeyRing $ minimalOp homepass' 673 KikiResult r report <- runKeyRing $ minimalOp False homepass'
667 case r of 674 case r of
668 KikiSuccess rt -> Kiki.refreshCache rt $ case root "" of 675 KikiSuccess rt -> Kiki.refreshCache rt $ case root "" of
669 "/" -> Nothing 676 "/" -> Nothing
@@ -694,3 +701,47 @@ kikiOptions = ( ss, ps )
694 where 701 where
695 ss = [("--chroot",1),("--passphrase-fd",1),("--homedir",1),("--cipher",1)] 702 ss = [("--chroot",1),("--passphrase-fd",1),("--homedir",1),("--cipher",1)]
696 ps = [] 703 ps = []
704
705verifyFile :: Bool -> CommonArgsParsed -> [FilePath] -> FilePath -> IO ()
706verifyFile isHomeless cap keyrings filename = do
707 let mop = minimalOp isHomeless cap
708 KikiResult r report <- runKeyRing mop
709 { opFiles = opFiles mop
710 `Map.union` Map.fromList
711 [ (ArgFile f, strm { access = Pub }) | f <- keyrings ]
712 }
713 case r of
714 KikiSuccess rt -> go rt
715 err -> hPutStrLn stderr $ errorString err
716 where
717 go :: KeyRingRuntime -> IO ()
718 go rt = do
719 bs <- L.readFile filename
720 case ASCIIArmor.decodeLazy bs of
721 Right (ClearSigned hashes txt (Armor ArmorSignature _ sig):_) ->
722 case parsePackets sig of
723 Right sigs -> do
724 let over = DataSignature lit sigs
725 lit = LiteralDataPacket
726 { format = error "format" :: Char
727 , filename = filename
728 , timestamp = error "timestamp" :: Word32
729 , content = bs
730 }
731 -- TODO: Remove this take 1 after optimizing 'candidateSignerKeys'
732 tentativeTake1 xs = take 1 xs
733 keys = concatMap (candidateSignerKeys (rtKeyDB rt)) $ tentativeTake1 sigs
734 good = verify (Message keys) over
735 putStrLn $ "verifyFile: " ++ show (length $ signatures_over good)
736 rs -> do
737 hPutStrLn stderr $ show rs
738 _ -> do
739 hPutStrLn stderr "Unsupported file format."
740
741
742parsePackets :: L.ByteString -> Either String [Packet]
743parsePackets bs = case decodeOrFail bs of
744 Left (more,off,er) -> Left er
745 Right (more,off,pkt) -> do
746 if (more/=L.empty) then parsePackets more >>= \pkts -> Right (pkt : pkts)
747 else Right [pkt]