summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--cokiki.hs10
-rw-r--r--kiki.cabal3
-rw-r--r--kiki.hs2
-rw-r--r--lib/KeyRing.hs122
-rw-r--r--lib/KeyRing/BuildKeyDB.hs2275
-rw-r--r--lib/Kiki.hs186
6 files changed, 2408 insertions, 190 deletions
diff --git a/cokiki.hs b/cokiki.hs
index a685977..d145045 100644
--- a/cokiki.hs
+++ b/cokiki.hs
@@ -63,11 +63,11 @@ main = do
63 (cmd,args) <- splitAt 1 <$> getArgs 63 (cmd,args) <- splitAt 1 <$> getArgs
64 uid <- getEffectiveUserID 64 uid <- getEffectiveUserID
65 let msel = case cmd of 65 let msel = case cmd of
66 ["ssh-client"] -> Just $ sshClient uid <$> Kiki.opt_chroot <*> Kiki.opt_homedir 66 ["ssh-client"] -> Just $ sshClient uid <$> Kiki.dashdashChroot <*> Kiki.dashdashHomedir
67 ["ssh-server"] -> Just $ sshServer uid <$> Kiki.opt_chroot <*> Kiki.opt_homedir 67 ["ssh-server"] -> Just $ sshServer uid <$> Kiki.dashdashChroot <*> Kiki.dashdashHomedir
68 ["strongswan"] -> Just $ strongswan uid <$> Kiki.opt_chroot <*> Kiki.opt_homedir 68 ["strongswan"] -> Just $ strongswan uid <$> Kiki.dashdashChroot <*> Kiki.dashdashHomedir
69 ["tor"] -> Just $ configureTor uid <$> Kiki.opt_chroot <*> Kiki.opt_homedir 69 ["tor"] -> Just $ configureTor uid <$> Kiki.dashdashChroot <*> Kiki.dashdashHomedir
70 ["hosts"] -> Just $ configureHosts uid <$> Kiki.opt_chroot <*> Kiki.opt_homedir 70 ["hosts"] -> Just $ configureHosts uid <$> Kiki.dashdashChroot <*> Kiki.dashdashHomedir
71 _ -> Nothing 71 _ -> Nothing
72 spec = uncurry fancy Kiki.kikiOptions "" 72 spec = uncurry fancy Kiki.kikiOptions ""
73 errorQuit msg = do 73 errorQuit msg = do
diff --git a/kiki.cabal b/kiki.cabal
index d42166e..186e439 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -76,6 +76,8 @@ Executable cokiki
76library 76library
77 hs-source-dirs: lib 77 hs-source-dirs: lib
78 exposed-modules: KeyRing, 78 exposed-modules: KeyRing,
79 Types,
80 KeyRing.BuildKeyDB,
79 Kiki, 81 Kiki,
80 ScanningParser, 82 ScanningParser,
81 PEM, 83 PEM,
@@ -95,7 +97,6 @@ library
95 other-modules: TimeUtil, 97 other-modules: TimeUtil,
96 ControlMaybe, 98 ControlMaybe,
97 Compat, 99 Compat,
98 Types,
99 PacketTranscoder, 100 PacketTranscoder,
100 Transforms 101 Transforms
101 Build-Depends: base >=4.6.0.0, 102 Build-Depends: base >=4.6.0.0,
diff --git a/kiki.hs b/kiki.hs
index e8b6753..e5544e5 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -62,7 +62,7 @@ import Data.OpenPGP.Util (verify,fingerprint,generateKey, GenerateKeyParams(..))
62import ScanningParser 62import ScanningParser
63import PEM 63import PEM
64import DotLock 64import DotLock
65import KeyRing 65import KeyRing hiding (pemFromPacket)
66import Base58 66import Base58
67import qualified CryptoCoins 67import qualified CryptoCoins
68-- import Chroot 68-- import Chroot
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 1aed50e..244f880 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -24,98 +24,7 @@
24{-# LANGUAGE PatternGuards #-} 24{-# LANGUAGE PatternGuards #-}
25{-# LANGUAGE ForeignFunctionInterface #-} 25{-# LANGUAGE ForeignFunctionInterface #-}
26{-# LANGUAGE LambdaCase #-} 26{-# LANGUAGE LambdaCase #-}
27module KeyRing 27module KeyRing (module KeyRing.Types, module KeyRing, module KeyRing.BuildKeyDB)
28 (
29 -- * Error Handling
30 KikiResult(..)
31 , KikiCondition(..)
32 , KikiReportAction(..)
33 , errorString
34 , reportString
35 -- * Manipulating Keyrings
36 , runKeyRing
37 , KeyRingOperation(..)
38 , PassphraseSpec(..)
39 , Transform(..)
40 -- , PacketUpdate(..)
41 -- , guardAuthentic
42 -- * Describing File Operations
43 , StreamInfo(..)
44 , Access(..)
45 , FileType(..)
46 , InputFile(..)
47 , Initializer(..)
48 , KeyFilter(..)
49 -- * Results of a KeyRing Operation
50 , KeyRingRuntime(..)
51 , OriginMapped(..)
52 , MappedPacket
53 , KeyDB
54 , KeyData(..)
55 , SubKey(..)
56 , keyflags
57 -- * Miscelaneous Utilities
58 , isKey
59 , isSecretKey
60 , derRSA
61 , derToBase32
62 , backsig
63 , filterMatches
64 , flattenKeys
65 , flattenTop
66 , Hosts.Hosts
67 , isCryptoCoinKey
68 , matchpr
69 , parseSpec
70 , Spec
71 , parseUID
72 , UserIDRecord(..)
73 , pkcs8
74 , RSAPublicKey(..)
75 , PKCS8_RSAPublicKey(..)
76 , rsaKeyFromPacket
77 , secretToPublic
78 , selectPublicKey
79 , selectSecretKey
80 , usage
81 , usageString
82 , walletImportFormat
83 , writePEM
84 , getBindings
85 , accBindings
86 , isSubkeySignature
87 , torhash
88 , torUIDFromKey
89 , ParsedCert(..)
90 , parseCertBlob
91 , packetFromPublicRSAKey
92 , decodeBlob
93 , selectPublicKeyAndSigs
94 , x509cert
95 , getHomeDir
96 , unconditionally
97 , SecretPEMData(..)
98 , readSecretPEMFile
99 , writeInputFileL
100 , InputFileContext(..)
101 , onionNameForContact
102 , keykey
103 , keyPacket
104 , KeySpec(..)
105 , MatchingField(..)
106 , SpecError(..)
107 , SingleKeySpec(..)
108 , parseSpec3
109 , getHostnames
110 , secretPemFromPacket
111 , SubkeyStatus(..)
112 , getSubkeys
113 , writeKeyToFile
114 , resolveForReport
115 , KeyKey -- needed for Type sigs
116 , makeMemoizingDecrypter
117 , showPacket
118 ) where
119 28
120import System.Environment 29import System.Environment
121import Control.Monad 30import Control.Monad
@@ -214,6 +123,35 @@ import FunctorToMaybe
214import DotLock 123import DotLock
215import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) 124import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
216import GnuPGAgent as Agent 125import GnuPGAgent as Agent
126import KeyRing.BuildKeyDB (accBindings, backsig, buildKeyDB,
127 combineTransforms, concatSort,
128 derRSA, derToBase32, filterMatches,
129 findTag, fingerdress,
130 flattenAllUids, flattenKeys,
131 flattenSub, flattenTop,
132 generateInternals, getBindings,
133 getHostnames, getSubkeys,
134 importSecretKey, insertSubkey,
135 isKey, isSecretKey,
136 isSubkeySignature, isUserID,
137 keyFlags0, keyPacket, keyflags,
138 keykey, mappedPacket, matchSpec,
139 matchpr, merge, mergeKeyPacket,
140 mkUsage, origin,
141 packetFromPublicRSAKey,
142 parseCertBlob, parseSingleSpec,
143 parseSpec, parseUID,
144 performManipulations,
145 readInputFileL, readSecretPEMFile,
146 resolveForReport, resolveInputFile,
147 rsaKeyFromPacket, secp256k1_id,
148 secretToPublic, seek_key,
149 selectKey0, selectPublicKey,
150 showPacket, sortByHint,
151 subkeyMappedPacket, torhash, try,
152 usage, usageFromFilter,
153 usageString)
154
217import Types 155import Types
218import PacketTranscoder 156import PacketTranscoder
219import Transforms 157import Transforms
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
new file mode 100644
index 0000000..1c2a5aa
--- /dev/null
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -0,0 +1,2275 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DoAndIfThenElse #-}
4{-# LANGUAGE ForeignFunctionInterface #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE ViewPatterns #-}
9module KeyRing.BuildKeyDB where
10import qualified Codec.Binary.Base32 as Base32
11import qualified Codec.Binary.Base64 as Base64
12import Control.Applicative (liftA2)
13import Control.Arrow (first, second)
14import Control.Exception (catch)
15import Control.Monad
16import ControlMaybe (handleIO_)
17import Data.ASN1.BinaryEncoding (DER (..))
18import Data.ASN1.Encoding (decodeASN1, encodeASN1)
19
20import Data.ASN1.Types (fromASN1, toASN1)
21import Data.Binary
22import Data.Bits ((.&.), (.|.))
23import Data.Bits (Bits)
24import qualified Data.ByteString as S (ByteString, breakSubstring,
25 concat, drop, hGetContents,
26 hPutStr, length, null,
27 readFile, spanEnd, unpack)
28import Data.ByteString.Lazy (ByteString)
29import qualified Data.ByteString.Lazy as L (ByteString, concat, empty,
30 fromChunks, hGetContents,
31 null, readFile, toChunks)
32import Data.Char
33import Data.List
34import qualified Data.Map as Map
35import Data.Maybe
36import Data.Monoid
37import Data.OpenPGP
38import Data.OpenPGP.Util (GenerateKeyParams (..),
39 decryptSecretKey, fingerprint,
40 generateKey, pgpSign, verify)
41import Data.Ord
42import Data.Text.Encoding (encodeUtf8)
43import Data.Time.Clock (UTCTime)
44import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
45import System.Directory (doesFileExist)
46
47import System.IO.Error (isDoesNotExistError)
48import Text.Show.Pretty as PP (ppShow)
49#if !defined(VERSION_cryptonite)
50import qualified Crypto.Hash.SHA1 as SHA1
51import qualified Crypto.Types.PubKey.ECC as ECC
52#else
53import qualified Crypto.Hash as Vincent
54import qualified Crypto.PubKey.ECC.Types as ECC
55import Data.ByteArray (convert)
56#endif
57import qualified Codec.Compression.GZip as GZip
58import qualified Crypto.PubKey.RSA as RSA
59import qualified Data.Text as T (break, drop, dropAround,
60 length, pack, reverse, strip,
61 unpack)
62import qualified Data.X509 as X509
63import System.Posix.Files (getFdStatus, getFileStatus,
64 modificationTime)
65
66
67import qualified System.Posix.Types as Posix
68#if MIN_VERSION_x509(1,5,0)
69import Data.Hourglass
70#endif
71#if MIN_VERSION_unix(2,7,0)
72import Foreign.C.Types (CTime (..))
73#else
74import Foreign.C.Error (throwErrnoIfMinus1_)
75import Foreign.C.Types (CInt (..), CLong, CTime (..))
76import Foreign.Marshal.Array (withArray)
77import Foreign.Ptr
78import Foreign.Storable
79#endif
80import Data.IORef
81import Data.Traversable (sequenceA)
82import qualified Data.Traversable as Traversable
83import System.IO (stderr)
84
85import System.Posix.IO (fdToHandle)
86#if ! MIN_VERSION_base(4,6,0)
87import GHC.Exts (Down (..))
88#endif
89#if MIN_VERSION_binary(0,7,0)
90#endif
91import Compat ()
92import qualified Data.ByteString.Lazy.Char8 as Char8
93import Network.Socket
94
95import Base58
96import qualified CryptoCoins
97import FunctorToMaybe
98import qualified Hosts
99import PEM
100import ScanningParser
101import TimeUtil
102
103import KeyRing.Types
104
105-- | buildKeyDB
106--
107-- merge all keyrings, PEM files, and wallets into process memory.
108--
109buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
110 -> IO (KikiCondition (({- db -} KeyDB
111 ,{- grip -} Maybe String
112 ,{- wk -} Maybe MappedPacket
113 ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts],
114 {- hostdbs -}[Hosts.Hosts],
115 {- u1 -}Hosts.Hosts,
116 {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))],
117 {- outgoing_names -}[SockAddr])
118 ,{- accs -} Map.Map InputFile Access
119 ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet)
120 ,{- unspilled -} Map.Map InputFile Message
121 )
122 ,{- report_imports -} [(FilePath,KikiReportAction)]))
123buildKeyDB ctx grip0 keyring = do
124 let
125 files istyp = do
126 (f,stream) <- Map.toList (opFiles keyring)
127 guard (istyp $ typ stream)
128 resolveInputFile ctx f
129
130 ringMap0 = Map.filter (isring . typ) $ opFiles keyring
131 (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
132 where
133 isgen (Generate _ _) _ = True
134 isgen _ _ = False
135
136 readp :: InputFile -> StreamInfo -> IO (StreamInfo, Message)
137 readp f stream = fmap readp0 $ readPacketsFromFile ctx f
138 where
139 readp0 ps = (stream { access = acc' }, ps)
140 where acc' = case access stream of
141 AutoAccess ->
142 case ps of
143 Message ((PublicKeyPacket {}):_) -> Pub
144 Message ((SecretKeyPacket {}):_) -> Sec
145 _ -> AutoAccess
146 acc -> acc
147
148 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
149
150 -- KeyRings (todo: KikiCondition reporting?)
151 (spilled,mwk,grip,accs,keys,unspilled) <- do
152#if MIN_VERSION_containers(0,5,0)
153 ringPackets <- Map.traverseWithKey readp ringMap
154#else
155 ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap
156#endif
157 let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)
158
159 let grip = grip0 `mplus` (fingerprint <$> fstkey)
160 where
161 fstkey = do
162 (_,Message ps) <- Map.lookup HomeSec ringPackets
163 listToMaybe ps
164
165 -- | spilled
166 -- ring packets with info available for export
167 -- | unspilled
168 -- the rest
169 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
170
171 -- | keys
172 -- process ringPackets, and get a map of fingerprint info to
173 -- to a packet, remembering it's original file, access.
174 keys :: Map.Map KeyKey MappedPacket
175 keys = Map.foldl slurpkeys Map.empty
176 $ Map.mapWithKey filterSecrets ringPackets
177 where
178 filterSecrets f (_,Message ps) =
179 filter (isSecretKey . packet)
180 $ zipWith (mappedPacketWithHint fname) ps [1..]
181 where fname = resolveForReport (Just ctx) f
182 slurpkeys m ps = m `Map.union` Map.fromList ps'
183 where ps' = zip (map (keykey . packet) ps) ps
184 -- | mwk
185 -- first master key matching the provided grip
186 -- (the m is for "MappedPacket", wk for working key)
187 mwk :: Maybe MappedPacket
188 mwk = listToMaybe $ do
189 fp <- maybeToList grip
190 let matchfp mp = not (is_subkey p) && matchpr fp p == fp
191 where p = packet mp
192 Map.elems $ Map.filter matchfp keys
193 -- | accs
194 -- file access(Sec | Pub) lookup table
195 accs :: Map.Map InputFile Access
196 accs = fmap (access . fst) ringPackets
197 return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
198
199 doDecrypt <- makeMemoizingDecrypter keyring ctx keys
200
201 let wk = fmap packet mwk
202 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
203 , rtSecring = homesecPath ctx
204 , rtGrip = grip
205 , rtWorkingKey = wk
206 , rtRingAccess = accs
207 , rtKeyDB = Map.empty
208 , rtPassphrases = doDecrypt
209 }
210 -- autosigns and deletes
211 transformed0 <- do
212 let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB))
213 trans f (info,ps) = do
214 let manip = combineTransforms (transforms info)
215 rt1 = rt0 { rtKeyDB = merge Map.empty f ps }
216 acc = Just Sec /= Map.lookup f accs
217 r <- performManipulations doDecrypt rt1 mwk manip
218 try r $ \(rt2,report) -> do
219 return $ KikiSuccess (report,rtKeyDB rt2)
220#if MIN_VERSION_containers(0,5,0)
221 fmap sequenceA $ Map.traverseWithKey trans spilled
222#else
223 fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled
224#endif
225 try transformed0 $ \transformed -> do
226 let -- | db_rings - all keyrings combined into one
227 db_rings :: Map.Map KeyKey KeyData
228 db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
229 where
230 mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans
231 -- | reportTrans
232 -- events, indexed by file
233 reportTrans :: [(FilePath, KikiReportAction)]
234 reportTrans = concat $ Map.elems $ fmap fst transformed
235
236 -- Wallets
237 let importWalletKey wk db' (top,fname,sub,tag) = do
238 try db' $ \(db',report0) -> do
239 r <- doImportG doDecrypt
240 db'
241 (fmap keykey $ maybeToList wk)
242 [mkUsage tag]
243 fname
244 sub
245 try r $ \(db'',report) -> do
246 return $ KikiSuccess (db'', report0 ++ report)
247
248 wms <- mapM (readw wk) (files iswallet)
249 let wallet_keys = do
250 maybeToList wk
251 (fname,xs) <- wms
252 (_,sub,(_,m)) <- xs
253 (tag,top) <- Map.toList m
254 return (top,fname,sub,tag)
255 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
256 try db $ \(db,reportWallets) -> do
257
258 -- PEM files
259 let pems = do
260 (n,stream) <- Map.toList $ opFiles keyring
261 grip <- maybeToList grip
262 n <- resolveInputFile ctx n
263 guard $ spillable stream && isSecretKeyFile (typ stream)
264 let us = mapMaybe usageFromFilter [fill stream,spill stream]
265 usage <- take 1 us
266 guard $ all (==usage) $ drop 1 us
267 -- TODO: KikiCondition reporting for spill/fill usage mismatch?
268 -- TODO: parseSpec3
269 let (topspec,subspec) = parseSpec grip usage
270 ms = map fst $ filterMatches topspec (Map.toList db)
271 cmd = initializer stream
272 return (n,subspec,ms,stream, cmd)
273
274 imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems
275 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports
276 try db $ \(db,reportPEMs) -> do
277
278 -- generate keys
279 let gens = mapMaybe g $ Map.toList genMap
280 where g (Generate _ params,v) = Just (params,v)
281 g _ = Nothing
282
283 db <- generateInternals doDecrypt mwk db gens
284 try db $ \(db,reportGens) -> do
285
286 r <- mergeHostFiles keyring db ctx
287 try r $ \((db,hs),reportHosts) -> do
288
289 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled)
290 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
291
292
293resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
294resolveInputFile ctx = resolve
295 where
296 resolve HomeSec = return (homesecPath ctx)
297 resolve HomePub = return (homepubPath ctx)
298 resolve (ArgFile f) = return f
299 resolve _ = []
300
301isring :: FileType -> Bool
302isring (KeyRingFile {}) = True
303isring _ = False
304
305readPacketsFromFile :: InputFileContext -> InputFile -> IO Message
306readPacketsFromFile ctx fname = do
307 -- warn $ fname ++ ": reading..."
308 input <- readInputFileL ctx fname
309#if MIN_VERSION_binary(0,7,0)
310 return $
311 case decodeOrFail input of
312 Right (_,_,msg ) -> msg
313 Left (_,_,_) ->
314 -- FIXME
315 -- trace (fname++": read fail") $
316 Message []
317#else
318 return $ decode input
319#endif
320
321readPacketsFromWallet ::
322 Maybe Packet
323 -> InputFile
324 -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
325readPacketsFromWallet wk fname = do
326 let ctx = InputFileContext "" ""
327 timestamp <- getInputFileTime ctx fname
328 input <- readInputFileL ctx fname
329 let (ks,_) = slurpWIPKeys timestamp input
330 unless (null ks) $ do
331 -- decrypt wk
332 -- create sigs
333 -- return key/sig pairs
334 return ()
335 return $ do
336 wk <- maybeToList wk
337 guard (not $ null ks)
338 let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk))
339 where tag = CryptoCoins.nameFromSecretByte tagbyte
340 (wk,MarkerPacket,(MarkerPacket,Map.empty))
341 :map prep ks
342
343spillable :: StreamInfo -> Bool
344spillable (spill -> KF_None) = False
345spillable _ = True
346
347isSecretKey :: Packet -> Bool
348isSecretKey (SecretKeyPacket {}) = True
349isSecretKey _ = False
350
351mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
352mappedPacketWithHint filename p hint = MappedPacket
353 { packet = p
354 , locations = Map.singleton filename (origin p hint)
355 }
356
357resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
358resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
359 where str = case (fdr,fdw) of
360 (0,1) -> "-"
361 _ -> "&pipe" ++ show (fdr,fdw)
362resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
363 where str = "&" ++ show fd
364resolveForReport mctx f = concat $ resolveInputFile ctx f
365 where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx
366
367keykey :: Packet -> KeyKey
368keykey key =
369 -- Note: The key's timestamp is normally included in it's fingerprint.
370 -- This is undesirable for kiki because it causes the same
371 -- key to be imported multiple times and show as apparently
372 -- distinct keys with different fingerprints.
373 -- Thus, we will remove the timestamp.
374 fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
375
376-- matchpr computes the fingerprint of the given key truncated to
377-- be the same lenght as the given fingerprint for comparison.
378--
379-- matchpr fp = Data.List.Extra.takeEnd (length fp)
380--
381matchpr :: String -> Packet -> String
382matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
383
384makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
385 -> Map.Map KeyKey MappedPacket
386 -> IO (MappedPacket -> IO (KikiCondition Packet))
387makeMemoizingDecrypter operation ctx keys =
388 if null chains then do
389 -- (*) Notice we do not pass ctx to resolveForReport.
390 -- This is because the merge function does not currently use a context
391 -- and the pws map keys must match the MappedPacket locations.
392 -- TODO: Perhaps these should both be of type InputFile rather than
393 -- FilePath?
394 -- pws :: Map.Map FilePath (IO S.ByteString)
395 {-
396 pws <-
397 Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
398 (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
399 $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
400 -}
401 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
402 pws2 <-
403 Traversable.mapM (cachedContents prompt ctx)
404 $ Map.fromList $ mapMaybe
405 (\spec -> (,passSpecPassFile spec) `fmap` do
406 guard $ isNothing $ passSpecKeySpec spec
407 passSpecRingFile spec)
408 passspecs
409 defpw <- do
410 Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
411 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
412 && isNothing (passSpecKeySpec sp))
413 $ opPassphrases operation
414 unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
415 return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw
416 else let PassphraseMemoizer f = head chains
417 in return f
418 where
419 (chains,passspecs) = partition isChain $ opPassphrases operation
420 where isChain (PassphraseMemoizer {}) = True
421 isChain _ = False
422 doDecrypt :: IORef (Map.Map KeyKey Packet)
423 -> Map.Map FilePath (IO S.ByteString)
424 -> Maybe (IO S.ByteString)
425 -> MappedPacket
426 -> IO (KikiCondition Packet)
427 doDecrypt unkeysRef pws defpw mp0 = do
428 unkeys <- readIORef unkeysRef
429 let mp = fromMaybe mp0 $ do
430 k <- Map.lookup kk keys
431 return $ mergeKeyPacket "decrypt" mp0 k
432 wk = packet mp0
433 kk = keykey wk
434 fs = Map.keys $ locations mp
435
436 decryptIt [] = return BadPassphrase
437 decryptIt (getpw:getpws) = do
438 -- TODO: This function should use mergeKeyPacket to
439 -- combine the packet with it's unspilled version before
440 -- attempting to decrypt it.
441 pw <- getpw
442 let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
443 case symmetric_algorithm wkun of
444 Unencrypted -> do
445 writeIORef unkeysRef (Map.insert kk wkun unkeys)
446 return $ KikiSuccess wkun
447 _ -> decryptIt getpws
448
449 getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
450
451 case symmetric_algorithm wk of
452 Unencrypted -> return (KikiSuccess wk)
453 _ -> maybe (decryptIt getpws)
454 (return . KikiSuccess)
455 $ Map.lookup kk unkeys
456
457-- | combineTransforms
458-- remove rundant transforms, and compile the rest to PacketUpdate(s)
459--
460-- eqivalent to:
461-- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd
462combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
463combineTransforms trans rt kd = updates
464 where
465 updates = -- kManip operation rt kd ++
466 concatMap (\t -> resolveTransform t rt kd) sanitized
467 sanitized = group (sort trans) >>= take 1
468
469merge :: KeyDB -> InputFile -> Message -> KeyDB
470merge db inputfile (Message ps) = merge_ db filename qs
471 where
472 filename = resolveForReport Nothing inputfile
473
474 qs = scanPackets filename ps
475
476 scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
477 scanPackets filename [] = []
478 scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
479 where
480 ret p = (p,Map.empty)
481 doit (top,sub,prev) p =
482 case p of
483 _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
484 _ | isKey p && is_subkey p -> (top,p,ret p)
485 _ | isUserID p -> (top,p,ret p)
486 _ | isTrust p -> (top,sub,updateTrust top sub prev p)
487 _ -> (top,sub,ret p)
488
489 updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
490 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public
491 updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret
492
493performManipulations ::
494 (MappedPacket -> IO (KikiCondition Packet))
495 -> KeyRingRuntime
496 -> Maybe MappedPacket
497 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
498 -> IO (KikiCondition (KeyRingRuntime,KikiReport))
499performManipulations doDecrypt rt wk manip = do
500 let db = rtKeyDB rt
501 performAll kd = foldM perform (KikiSuccess (kd, [])) $ manip rt kd
502 r <- Traversable.mapM performAll db
503 try (sequenceA r) $ \db -> do
504 return $
505 KikiSuccess (rt {rtKeyDB = fmap fst db}, concatMap snd $ Map.elems db)
506 where
507 perform
508 :: KikiCondition (KeyData, KikiReport)
509 -> PacketUpdate
510 -> IO (KikiCondition (KeyData, KikiReport))
511 perform kd (InducerSignature uid subpaks) = do
512 try kd $ \(kd, report) -> do
513 flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
514 wkun' <- doDecrypt wk'
515 try wkun' $ \wkun -> do
516 let flgs =
517 if keykey (keyPacket kd) == keykey wkun
518 then keyFlags0
519 (keyPacket kd)
520 (map (\(x, _, _) -> x) selfsigs)
521 else []
522 sigOver =
523 makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) $
524 flgs ++ subpaks
525 om = Map.singleton "--autosign" (origin p (-1))
526 where
527 p = UserIDPacket uid
528 toMappedPacket om p = (mappedPacket "" p) {locations = om}
529 selfsigs =
530 filter
531 (\(sig, v, whosign) ->
532 isJust
533 (v >> Just wkun >>=
534 guard . (== keykey whosign) . keykey))
535 vs
536 keys = map keyPacket $ Map.elems (rtKeyDB rt)
537 overs sig =
538 signatures $
539 Message (keys ++ [keyPacket kd, UserIDPacket uid, sig])
540 vs
541 :: [(Packet -- signature
542 , Maybe SignatureOver -- Nothing means non-verified
543 , Packet -- key who signed
544 )]
545 vs = do
546 x <- maybeToList $ Map.lookup uid (keyUids kd)
547 sig <- map (packet . fst) (fst x)
548 o <- overs sig
549 k <- keys
550 let ov = verify (Message [k]) $ o
551 signatures_over ov
552 return (sig, Just ov, k)
553 additional new_sig = do
554 new_sig <- maybeToList new_sig
555 guard (null $ selfsigs)
556 signatures_over new_sig
557 sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
558 let f :: ([SigAndTrust], OriginMap) -> ([SigAndTrust], OriginMap)
559 f x =
560 ( map ((, Map.empty) . toMappedPacket om) (additional sigr) ++
561 fst x
562 , om `Map.union` snd x)
563 -- XXX: Shouldn't this signature generation show up in the KikiReport ?
564 return $
565 KikiSuccess $
566 (kd {keyUids = Map.adjust f uid (keyUids kd)}, report)
567 perform kd (SubKeyDeletion topk subk) = do
568 try kd $ \(kd, report) -> do
569 let kk = keykey $ packet $ keyMappedPacket kd
570 kd'
571 | kk /= topk = kd
572 | otherwise =
573 kd {keySubKeys = Map.filterWithKey pred $ keySubKeys kd}
574 pred k _ = k /= subk
575 ps =
576 concat $
577 maybeToList $ do
578 SubKey mp sigs <- Map.lookup subk (keySubKeys kd)
579 return $
580 packet mp :
581 concatMap (\(p, ts) -> packet p : Map.elems ts) sigs
582 ctx = InputFileContext (rtSecring rt) (rtPubring rt)
583 rings = [HomeSec, HomePub] >>= resolveInputFile ctx
584 return $
585 KikiSuccess
586 ( kd'
587 , report ++
588 [(f, DeletedPacket $ showPacket p) | f <- rings, p <- ps])
589
590try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
591try x body =
592 case functorToEither x of
593 Left e -> return e
594 Right x -> body x
595
596mergeKeyData :: KeyData -> KeyData -> KeyData
597mergeKeyData (KeyData atop asigs auids asubs)
598 (KeyData btop bsigs buids bsubs)
599 = KeyData top sigs uids subs
600 where
601 mergeMapped a b =
602 MappedPacket { packet = packet a
603 , locations = Map.union (locations a) (locations b)
604 }
605
606 top = mergeMapped atop btop
607
608 sigs = foldl' (flip mergeSig) asigs bsigs
609
610 uids = Map.unionWith mergeUIDSigs auids buids
611 subs = Map.unionWith mergeSub asubs bsubs
612
613 mergeSub :: SubKey -> SubKey -> SubKey
614 mergeSub (SubKey a as) (SubKey b bs) =
615 SubKey (mergeMapped a b)
616 (foldl' (flip mergeSig) as bs)
617
618 mergeUIDSigs :: ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
619 -> ([SigAndTrust],OriginMap)
620 mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm)
621
622doImportG
623 :: (MappedPacket -> IO (KikiCondition Packet))
624 -> Map.Map KeyKey KeyData
625 -> [KeyKey] -- m0, only head is used
626 -> [SignatureSubpacket] -- tags
627 -> FilePath
628 -> Packet
629 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
630doImportG doDecrypt db m0 tags fname key = do
631 let kk = head m0
632 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
633 kdr <- insertSubkey doDecrypt kk kd tags fname key
634 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
635
636mkUsage :: String -> SignatureSubpacket
637mkUsage tag
638 | Just flags <- lookup tag specials =
639 KeyFlagsPacket
640 { certify_keys = fromEnum flags .&. 0x1 /= 0
641 , sign_data = fromEnum flags .&. 0x2 /= 0
642 , encrypt_communication = fromEnum flags .&. 0x4 /= 0
643 , encrypt_storage = fromEnum flags .&. 0x8 /= 0
644 , split_key = False
645 , authentication = False
646 , group_key = False
647 }
648 where
649 flagsets = [Special .. VouchSignEncrypt]
650 specials = map (\f -> (usageString f, f)) flagsets
651
652mkUsage tag = NotationDataPacket
653 { human_readable = True
654 , notation_name = "usage@"
655 , notation_value = tag
656 }
657
658iswallet :: FileType -> Bool
659iswallet (WalletFile {}) = True
660iswallet _ = False
661
662isSecretKeyFile :: FileType -> Bool
663isSecretKeyFile PEMFile = True
664isSecretKeyFile DNSPresentation = True
665isSecretKeyFile _ = False
666
667usageFromFilter :: MonadPlus m => KeyFilter -> m String
668usageFromFilter (KF_Match usage) = return usage
669usageFromFilter _ = mzero
670
671-- | Parse a key specification.
672-- The first argument is a grip for the default working key.
673parseSpec :: String -> String -> (KeySpec,Maybe String)
674parseSpec wkgrip spec =
675 if not slashed
676 then
677 case prespec of
678 AnyMatch -> (KeyGrip "", Nothing)
679 EmptyMatch -> error "Bad key spec."
680 WorkingKeyMatch -> (KeyGrip wkgrip, Nothing)
681 SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag)
682 SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str)
683 SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing)
684 FingerprintMatch fp -> (KeyGrip fp, Nothing)
685 else
686 case (prespec,postspec) of
687 (FingerprintMatch fp, SubstringMatch st t)
688 | st /= Just UserIDField -> (KeyGrip fp, Just t)
689 (SubstringMatch mt u, _)
690 | postspec `elem` [AnyMatch,EmptyMatch]
691 && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing)
692 (SubstringMatch mt u, SubstringMatch st t)
693 | mt /= Just KeyTypeField
694 && st /= Just UserIDField -> (KeyUidMatch u, Just t)
695 (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec"
696 (_,FingerprintMatch fp) -> error "todo: support /fp: spec"
697 (FingerprintMatch fp,_) -> error "todo: support fp:/ spec"
698 _ -> error "Bad key spec."
699 where
700 (preslash,slashon) = break (=='/') spec
701 slashed = not $ null $ take 1 slashon
702 postslash = drop 1 slashon
703
704 prespec = parseSingleSpec preslash
705 postspec = parseSingleSpec postslash
706
707{-
708 - BUGGY
709parseSpec grip spec = (topspec,subspec)
710 where
711 (topspec0,subspec0) = unprefix '/' spec
712 (toptyp,top) = unprefix ':' topspec0
713 (subtyp,sub) = unprefix ':' subspec0
714 topspec = case () of
715 _ | null top && or [ subtyp=="fp"
716 , null subtyp && is40digitHex sub
717 ]
718 -> KeyGrip sub
719 _ | null top && null grip -> KeyUidMatch sub
720 _ | null top -> KeyGrip grip
721 _ | toptyp=="fp" || (null toptyp && is40digitHex top)
722 -> KeyGrip top
723 _ | toptyp=="u" -> KeyUidMatch top
724 _ -> KeyUidMatch top
725 subspec = case subtyp of
726 "t" -> Just sub
727 "fp" | top=="" -> Nothing
728 "" | top=="" && is40digitHex sub -> Nothing
729 "" -> listToMaybe sub >> Just sub
730 _ -> Nothing
731
732 is40digitHex xs = ys == xs && length ys==40
733 where
734 ys = filter ishex xs
735 ishex c | '0' <= c && c <= '9' = True
736 | 'A' <= c && c <= 'F' = True
737 | 'a' <= c && c <= 'f' = True
738 ishex c = False
739
740 -- | Split a string into two at the first occurance of the given
741 -- delimiter. If the delimeter does not occur, then the first
742 -- item of the returned pair is empty and the second item is the
743 -- input string.
744 unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
745 where p = break (==c) spec
746-}
747
748filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
749filterMatches spec ks = filter (matchSpec spec . snd) ks
750
751importSecretKey ::
752 (MappedPacket -> IO (KikiCondition Packet))
753 -> KikiCondition
754 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
755 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
756 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
757importSecretKey doDecrypt db' tup = do
758 try db' $ \(db',report0) -> do
759 r <- doImport doDecrypt
760 db'
761 tup
762 try r $ \(db'',report) -> do
763 return $ KikiSuccess (db'', report0 ++ report)
764
765generateInternals ::
766 (MappedPacket -> IO (KikiCondition Packet))
767 -> Maybe MappedPacket
768 -> Map.Map KeyKey KeyData
769 -> [(GenerateKeyParams,StreamInfo)]
770 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
771generateInternals doDecrypt mwk db gens = do
772 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
773 Just kd0 -> do
774 kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens
775 try kd $ \(kd,reportGens) -> do
776 let kk = keykey $ packet $ fromJust mwk
777 return $ KikiSuccess (Map.insert kk kd db,reportGens)
778 Nothing -> return $ KikiSuccess (db,[])
779
780mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
781 -> IO
782 (KikiCondition
783 ( ( Map.Map [Char8.ByteString] KeyData
784 , ( [Hosts.Hosts]
785 , [Hosts.Hosts]
786 , Hosts.Hosts
787 , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))]
788 , [SockAddr]))
789 , [(FilePath,KikiReportAction)]))
790mergeHostFiles krd db ctx = do
791 let hns = files ishosts
792 ishosts Hosts = True
793 ishosts _ = False
794 files istyp = do
795 (f,stream) <- Map.toList (opFiles krd)
796 guard (istyp $ typ stream)
797 return f
798
799 readInputFileL' ctx f =
800 readInputFileL ctx f
801 `catch` \e -> do when (not $ isDoesNotExistError e) $ do
802 return () -- todo report problem
803 return L.empty
804
805 hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns
806
807 let gpgnames = map getHostnames $ Map.elems db
808 os = do
809 (addr,(ns,_)) <- gpgnames
810 n <- ns
811 return (addr,n)
812 setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
813 -- we ensure .onion names are set properly
814 hostdbs = map setOnions hostdbs0
815 outgoing_names = do
816 (addr,(_,gns)) <- gpgnames
817 guard . not $ null gns
818 guard $ all (null . Hosts.namesForAddress addr) hostdbs0
819 return addr
820 -- putStrLn $ "hostdbs = " ++ show hostdbs
821
822 -- 1. let U = union all the host dbs
823 -- preserving whitespace and comments of the first
824 let u0 = foldl' Hosts.plus Hosts.empty hostdbs
825 -- we filter U to be only finger-dresses
826 u1 = Hosts.filterAddrs (hasFingerDress db) u0
827
828 -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
829 {-
830 putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}"
831 putStrLn $ "--> " ++ show (nf (head hostdbs))
832 putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
833 putStrLn $ "--> " ++ show (nf u0)
834 putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
835 putStrLn $ "--> " ++ show (nf u1)
836 -}
837
838 -- 2. replace gpg annotations with those in U
839 -- forM use_db
840 db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db
841
842 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[])
843
844readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString
845readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents
846readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents
847readInputFileL ctx inp = do
848 let fname = resolveInputFile ctx inp
849 fmap L.concat $ mapM L.readFile fname
850
851getInputFileTime :: InputFileContext -> InputFile -> IO CTime
852getInputFileTime ctx (Pipe fdr fdw) = do
853 mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr
854 maybe tryw return mt
855 where
856 tryw = do
857 handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?")
858 $ modificationTime <$> getFdStatus fdw
859getInputFileTime ctx (FileDesc fd) = do
860 handleIO_ (error $ "&"++show fd++": modificaiton time?") $
861 modificationTime <$> getFdStatus fd
862getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do
863 handleIO_ (error $ fname++": modificaiton time?") $
864 modificationTime <$> getFileStatus fname
865
866slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
867slurpWIPKeys stamp "" = ([],[])
868slurpWIPKeys stamp cs =
869 let (b58,xs) = Char8.span (`elem` base58chars) cs
870 mb = decode_btc_key stamp (Char8.unpack b58)
871 in if L.null b58
872 then let (ys,xs') = Char8.break (`elem` base58chars) cs
873 (ks,js) = slurpWIPKeys stamp xs'
874 in (ks,ys:js)
875 else let (ks,js) = slurpWIPKeys stamp xs
876 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
877
878origin :: Packet -> Int -> OriginFlags
879origin p n = OriginFlags ispub n
880 where
881 ispub = case p of
882 SecretKeyPacket {} -> False
883 _ -> True
884
885cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
886cachedContents maybePrompt ctx fd = do
887 ref <- newIORef Nothing
888 return $ get maybePrompt ref fd
889 where
890 trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
891
892 get maybePrompt ref fd = do
893 pw <- readIORef ref
894 flip (flip maybe return) pw $ do
895 if fd == FileDesc 0 then case maybePrompt of
896 Just prompt -> S.hPutStr stderr prompt
897 Nothing -> return ()
898 else return ()
899 pw <- fmap trimCR $ readInputFileS ctx fd
900 writeIORef ref (Just pw)
901 return pw
902
903mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
904mergeKeyPacket what key p =
905 key { packet = minimumBy (keyCompare what) [packet key,packet p]
906 , locations = Map.union (locations key) (locations p)
907 }
908
909-- | resolveTransform
910resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
911resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
912 where
913 ops = map (\u -> InducerSignature u []) us
914 us = filter torStyle $ Map.keys umap
915 torStyle str = and [ uid_topdomain parsed == "onion"
916 , uid_realname parsed `elem` ["","Anonymous"]
917 , uid_user parsed == "root"
918 , fmap (match . fst) (lookup (packet k) torbindings)
919 == Just True ]
920 where parsed = parseUID str
921 match = (==subdom) . take (fromIntegral len)
922 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
923 subdom = Char8.unpack subdom0
924 len = T.length (uid_subdomain parsed)
925 torbindings = getTorKeys (map packet $ flattenTop "" True kd)
926 getTorKeys pub = do
927 xs <- groupBindings pub
928 (_,(top,sub),us,_,_) <- xs
929 guard ("tor" `elem` us)
930 let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
931 return (top,(torhash,sub))
932
933 groupBindings pub = gs
934 where (_,bindings) = getBindings pub
935 bindings' = accBindings bindings
936 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
937 ownerkey (_,(a,_),_,_,_) = a
938 sameMaster (ownerkey->a) (ownerkey->b)
939 = fingerprint_material a==fingerprint_material b
940 gs = groupBy sameMaster (sortBy (comparing code) bindings')
941
942
943-- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
944resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
945 where
946 topk = keykey $ packet k -- key to master of key to be deleted
947 subk = do
948 (k,sub) <- Map.toList submap
949 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
950 return k
951
952-- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
953resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
954 where
955 topk = keykey $ packet k -- key to master of key to be deleted
956 subk = do
957 (k,SubKey p sigs) <- Map.toList submap
958 take 1 $ filter (has_tag tag) $ map (packet . fst) sigs
959 return k
960
961merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
962 -> KeyDB
963merge_ db filename qs = foldl mergeit db (zip [0..] qs)
964 where
965 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
966 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
967 mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
968 where
969 update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
970 update (Just kd) = dbInsertPacket kd filename adding
971 mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
972
973 whatP (a,_) = concat . take 1 . words . show $ a
974
975isKey :: Packet -> Bool
976isKey (PublicKeyPacket {}) = True
977isKey (SecretKeyPacket {}) = True
978isKey _ = False
979
980isUserID :: Packet -> Bool
981isUserID (UserIDPacket {}) = True
982isUserID _ = False
983
984isTrust :: Packet -> Bool
985isTrust (TrustPacket {}) = True
986isTrust _ = False
987
988keyPacket :: KeyData -> Packet
989keyPacket (KeyData k _ _ _) = packet k
990
991keyFlags0 :: t -> [Packet] -> [SignatureSubpacket]
992keyFlags0 wkun uidsigs = concat
993 [ keyflags
994 , preferredsym
995 , preferredhash
996 , preferredcomp
997 , features ]
998
999 where
1000 subs = concatMap hashed_subpackets uidsigs
1001 keyflags = filterOr isflags subs $
1002 KeyFlagsPacket { certify_keys = True
1003 , sign_data = True
1004 , encrypt_communication = False
1005 , encrypt_storage = False
1006 , split_key = False
1007 , authentication = False
1008 , group_key = False
1009 }
1010 preferredsym = filterOr ispreferedsym subs $
1011 PreferredSymmetricAlgorithmsPacket
1012 [ AES256
1013 , AES192
1014 , AES128
1015 , CAST5
1016 , TripleDES
1017 ]
1018 preferredhash = filterOr ispreferedhash subs $
1019 PreferredHashAlgorithmsPacket
1020 [ SHA256
1021 , SHA1
1022 , SHA384
1023 , SHA512
1024 , SHA224
1025 ]
1026 preferredcomp = filterOr ispreferedcomp subs $
1027 PreferredCompressionAlgorithmsPacket
1028 [ ZLIB
1029 , BZip2
1030 , ZIP
1031 ]
1032 features = filterOr isfeatures subs $
1033 FeaturesPacket { supports_mdc = True
1034 }
1035
1036 filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
1037
1038 isflags (KeyFlagsPacket {}) = True
1039 isflags _ = False
1040 ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
1041 ispreferedsym _ = False
1042 ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
1043 ispreferedhash _ = False
1044 ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
1045 ispreferedcomp _ = False
1046 isfeatures (FeaturesPacket {}) = True
1047 isfeatures _ = False
1048
1049makeInducerSig
1050 :: Packet
1051 -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
1052-- torsig g topk wkun uid timestamp extras = todo
1053makeInducerSig topk wkun uid extras
1054 = CertificationSignature (secretToPublic topk)
1055 uid
1056 (sigpackets 0x13
1057 subpackets
1058 subpackets_unh)
1059 where
1060 subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
1061 tsign
1062 ++ extras
1063 subpackets_unh = [IssuerPacket (fingerprint wkun)]
1064 tsign = if keykey wkun == keykey topk
1065 then [] -- tsign doesnt make sense for self-signatures
1066 else [ TrustSignaturePacket 1 120
1067 , RegularExpressionPacket regex]
1068 -- <[^>]+[@.]asdf\.nowhere>$
1069 regex = "<[^>]+[@.]"++hostname++">$"
1070 -- regex = username ++ "@" ++ hostname
1071 -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
1072 hostname = subdomain' pu ++ "\\." ++ topdomain' pu
1073 pu = parseUID uidstr where UserIDPacket uidstr = uid
1074 subdomain' = escape . T.unpack . uid_subdomain
1075 topdomain' = escape . T.unpack . uid_topdomain
1076 escape s = concatMap echar s
1077 where
1078 echar '|' = "\\|"
1079 echar '*' = "\\*"
1080 echar '+' = "\\+"
1081 echar '?' = "\\?"
1082 echar '.' = "\\."
1083 echar '^' = "\\^"
1084 echar '$' = "\\$"
1085 echar '\\' = "\\\\"
1086 echar '[' = "\\["
1087 echar ']' = "\\]"
1088 echar c = [c]
1089
1090insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)]))
1091insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
1092 let subkk = keykey key
1093 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
1094 [])
1095 ( (False,) . addOrigin )
1096 (Map.lookup subkk subs)
1097 where
1098 addOrigin (SubKey mp sigs) =
1099 let mp' = mp
1100 { locations = Map.insert fname
1101 (origin (packet mp) (-1))
1102 (locations mp) }
1103 in SubKey mp' sigs
1104 subs' = Map.insert subkk subkey subs
1105
1106 istor = do
1107 guard ("tor" `elem` mapMaybe usage tags)
1108 return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
1109
1110 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
1111 let has_torid = do
1112 -- TODO: check for omitted real name field
1113 (sigtrusts,om) <- Map.lookup idstr uids
1114 listToMaybe $ do
1115 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
1116 signatures_over $ verify (Message [packet top]) s
1117 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
1118 wkun <- doDecrypt top
1119
1120 try wkun $ \wkun -> do
1121
1122 let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
1123 uid = UserIDPacket idstr
1124 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
1125 tor_ov = makeInducerSig (packet top) wkun uid keyflags
1126 sig_ov <- pgpSign (Message [wkun])
1127 tor_ov
1128 SHA1
1129 (fingerprint wkun)
1130 flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)]))
1131 (sig_ov >>= listToMaybe . signatures_over)
1132 $ \sig -> do
1133 let om = Map.singleton fname (origin sig (-1))
1134 trust = Map.empty
1135 return $ KikiSuccess
1136 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
1137 , trust)],om) uids
1138 , [] )
1139
1140 try uids' $ \(uids',report) -> do
1141
1142 let SubKey subkey_p subsigs = subkey
1143 wk = packet top
1144 (xs',minsig,ys') = findTag tags wk key subsigs
1145 doInsert mbsig = do
1146 -- NEW SUBKEY BINDING SIGNATURE
1147 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig
1148 try sig' $ \(sig',report) -> do
1149 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
1150 let subs' = Map.insert subkk
1151 (SubKey subkey_p $ xs'++[sig']++ys')
1152 subs
1153 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1154 , report )
1155
1156 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
1157 else id
1158 s = show (fmap fst minsig,fingerprint key)
1159 in return (f report)
1160
1161 case minsig of
1162 Nothing -> doInsert Nothing -- we need to create a new sig
1163 Just (True,sig) -> -- we can deduce is_new == False
1164 -- we may need to add a tor id
1165 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1166 , report )
1167 Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag
1168
1169mappedPacket :: FilePath -> Packet -> MappedPacket
1170mappedPacket filename p = MappedPacket
1171 { packet = p
1172 , locations = Map.singleton filename (origin p (-1))
1173 }
1174
1175showPacket :: Packet -> String
1176showPacket p | isKey p = (if is_subkey p
1177 then showPacket0 p
1178 else ifSecret p "----Secret-----" "----Public-----")
1179 ++ " "++show (key_algorithm p)++" "++fingerprint p
1180 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
1181 | otherwise = showPacket0 p
1182showPacket0 :: Show a => a -> [Char]
1183showPacket0 p = concat . take 1 $ words (show p)
1184
1185mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust]
1186mergeSig sig sigs =
1187 let (xs,ys) = break (isSameSig (first packet sig)) sigs
1188 in if null ys
1189 then sigs++[sig] -- [first (flip (mappedPacketWithHint fname) n) sig]
1190 else let y:ys'=ys
1191 in xs ++ (mergeSameSig sig y : ys')
1192 where
1193 isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
1194 a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
1195 isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
1196
1197 mergeSameSig :: (MappedPacket,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
1198 mergeSameSig (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb)
1199 | isSignaturePacket (packet a) && isSignaturePacket b =
1200 ( m { packet = b { unhashed_subpackets =
1201 union (unhashed_subpackets b) (unhashed_subpackets $ packet a)
1202 }
1203 , locations = Map.union (locations a) locs } -- Map.insert fname (origin a n) locs }
1204 -- TODO: when merging items, we should delete invalidated origins
1205 -- from the orgin map.
1206 , tb `Map.union` ta )
1207
1208 mergeSameSig a b = b -- trace ("discarding dup "++show a) b
1209
1210usageString :: PGPKeyFlags -> String
1211usageString flgs =
1212 case flgs of
1213 Special -> "special"
1214 Vouch -> "vouch" -- signkey
1215 Sign -> "sign"
1216 VouchSign -> "vouch-sign"
1217 Communication -> "communication"
1218 VouchCommunication -> "vouch-communication"
1219 SignCommunication -> "sign-communication"
1220 VouchSignCommunication -> "vouch-sign-communication"
1221 Storage -> "storage"
1222 VouchStorage -> "vouch-storage"
1223 SignStorage -> "sign-storage"
1224 VouchSignStorage -> "vouch-sign-storage"
1225 Encrypt -> "encrypt"
1226 VouchEncrypt -> "vouch-encrypt"
1227 SignEncrypt -> "sign-encrypt"
1228 VouchSignEncrypt -> "vouch-sign-encrypt"
1229
1230parseSingleSpec :: String -> SingleKeySpec
1231parseSingleSpec "*" = AnyMatch
1232parseSingleSpec "-" = WorkingKeyMatch
1233parseSingleSpec "" = EmptyMatch
1234parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag
1235parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag
1236parseSingleSpec ('c':':':tag) = SubstringMatch (Just GroupIDField) tag
1237parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
1238parseSingleSpec str
1239 | is40digitHex str = FingerprintMatch str
1240 | otherwise = SubstringMatch Nothing str
1241
1242is40digitHex :: [Char] -> Bool
1243is40digitHex xs = ys == xs && length ys==40
1244 where
1245 ys = filter ishex xs
1246 ishex c | '0' <= c && c <= '9' = True
1247 | 'A' <= c && c <= 'F' = True
1248 | 'a' <= c && c <= 'f' = True
1249 ishex c = False
1250
1251matchSpec :: KeySpec -> KeyData -> Bool
1252matchSpec (KeyGrip grip) (KeyData p _ _ _)
1253 | matchpr grip (packet p)==grip = True
1254 | otherwise = False
1255
1256matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
1257 where
1258 ps = map (packet .fst) sigs
1259 match p = isSignaturePacket p
1260 && has_tag tag p
1261 && has_issuer key p
1262 has_issuer key p = isJust $ do
1263 issuer <- signature_issuer p
1264 guard $ matchpr issuer key == issuer
1265 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
1266 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
1267
1268matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
1269 where
1270 us = filter (isInfixOf pat) $ Map.keys uids
1271
1272doImport
1273 :: (MappedPacket -> IO (KikiCondition Packet))
1274 -> Map.Map KeyKey KeyData
1275 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
1276 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
1277doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
1278 flip (maybe $ return CannotImportMasterKey)
1279 subspec $ \tag -> do
1280 (certs,keys) <- case typ of
1281 PEMFile -> do
1282 ps <- readSecretPEMFile (ArgFile fname)
1283 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
1284 = partition (isJust . spemCert) ps
1285 return (certs,keys)
1286 DNSPresentation -> do
1287 p <- readSecretDNSFile (ArgFile fname)
1288 return ([],[p])
1289 -- TODO Probably we need to move to a new design where signature
1290 -- packets are merged into the database in one phase with null
1291 -- signatures, and then the signatures are made in the next phase.
1292 -- This would let us merge annotations (like certificates) from
1293 -- seperate files.
1294 foldM (importKey tag certs) (KikiSuccess (db,[])) keys
1295 where
1296 importKey tag certs prior key = do
1297 try prior $ \(db,report) -> do
1298 let (m0,tailms) = splitAt 1 ms
1299 if (not (null tailms) || null m0)
1300 then return $ AmbiguousKeySpec fname
1301 else do
1302 let kk = keykey key
1303 cs = filter (\c -> kk==keykey (pcertKey c)) certs
1304 blobs = map mkCertNotation $ nub $ map pcertBlob cs
1305 mkCertNotation bs = NotationDataPacket
1306 { human_readable = False
1307 , notation_name = "x509cert@"
1308 , notation_value = Char8.unpack bs }
1309 datedKey = key { timestamp = fromTime $ minimum dates }
1310 dates = fromTime (timestamp key) : map pcertTimestamp certs
1311 r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey
1312 try r $ \(db',report') -> do
1313 return $ KikiSuccess (db',report++report')
1314
1315generateSubkey ::
1316 (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[
1317 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
1318 -> (GenerateKeyParams, StreamInfo)
1319 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
1320generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1321 try kd' $ \(kd,report0) -> do
1322 let subs = do
1323 SubKey p sigs <- Map.elems $ keySubKeys kd
1324 filter (has_tag tag) $ map (packet . fst) sigs
1325 if null subs
1326 then do
1327 newkey <- generateKey genparam
1328 kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey
1329 try kdr $ \(newkd,report) -> do
1330 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
1331 else do
1332 return $ KikiSuccess (kd,report0)
1333generateSubkey _ kd _ = return kd
1334
1335-- |
1336-- Returns (ip6 fingerprint address,(onion names,other host names))
1337--
1338-- Requires a validly cross-signed tor key for each onion name returned.
1339-- (Signature checks are performed.)
1340getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
1341getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
1342 where
1343 othernames = do
1344 mp <- flattenAllUids "" True uids
1345 let p = packet mp
1346 guard $ isSignaturePacket p
1347 uh <- unhashed_subpackets p
1348 case uh of
1349 NotationDataPacket True "hostname@" v
1350 -> return $ Char8.pack v
1351 _ -> mzero
1352
1353 addr = fingerdress topk
1354 topk = packet topmp
1355 torkeys = getSubkeys CrossSigned topk subs "tor"
1356
1357 -- subkeyPacket (SubKey k _ ) = k
1358 onames :: [L.ByteString]
1359 onames = map ( (<> ".onion")
1360 . Char8.pack
1361 . take 16
1362 . torhash )
1363 torkeys
1364
1365hasFingerDress :: KeyDB -> SockAddr -> Bool
1366hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
1367hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
1368 where
1369 (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
1370 g' = map toUpper g
1371
1372-- We return into IO in case we want to make a signature here.
1373setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
1374setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
1375 -- TODO: we are removing the origin from the UID OriginMap,
1376 -- when we should be removing origins from the locations
1377 -- field of the sig's MappedPacket records.
1378 -- Call getHostnames and compare to see if no-op.
1379 if not (pred addr) || gotNonOnions == namesWithoutGotOnions
1380 then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
1381 , " file: "++show (map Char8.unpack names)
1382 , " pred: "++show (pred addr)]) -}
1383 (return kd)
1384 else do
1385 -- We should be sure to remove origins so that the data is written
1386 -- (but only if something changed).
1387 -- Filter all hostnames present in uids
1388 -- Write notations into first uid
1389 {-
1390 trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
1391 , " file: "++show (map Char8.unpack names) ]) $ do
1392 -}
1393 return $ KeyData topmp topsigs uids1 subs
1394 where
1395 topk = packet topmp
1396 addr = fingerdress topk
1397 names :: [Char8.ByteString]
1398 names = Hosts.namesForAddress addr hosts
1399 (_, (gotOnions, gotNonOnions)) = getHostnames kd
1400 namesWithoutGotOnions = names \\ gotOnions
1401 notations = map (NotationDataPacket True "hostname@" . Char8.unpack) namesWithoutGotOnions
1402 isName (NotationDataPacket True "hostname@" _) = True
1403 isName _ = False
1404 uids0 = fmap zapIfHasName uids
1405 fstuid = head $ do
1406 p <- map packet $ flattenAllUids "" True uids
1407 guard $ isUserID p
1408 return $ uidkey p
1409 uids1 = Map.adjust addnames fstuid uids0
1410 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
1411 where
1412 (ss,ts) = splitAt 1 sigs
1413 f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm)
1414 else (sig, tm)
1415 where p' = (packet sig) { unhashed_subpackets=uh }
1416 uh = unhashed_subpackets (packet sig) ++ notations
1417 zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin
1418 else (sigs,om)
1419 where
1420 (bs, sigs') = unzip $ map unhash sigs
1421
1422 unhash (sig,tm) = ( not (null ns)
1423 , ( sig { packet = p', locations = Map.empty }
1424 , tm ) )
1425 where
1426 psig = packet sig
1427 p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
1428 else psig
1429 uh = unhashed_subpackets psig
1430 (ns,ps) = partition isName uh
1431
1432decode_btc_key ::
1433 Enum timestamp => timestamp -> String -> Maybe (Word8, Message)
1434decode_btc_key timestamp str = do
1435 (network_id,us) <- base58_decode str
1436 return . (network_id,) $ Message $ do
1437 let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
1438 {-
1439 xy = secp256k1_G `pmul` d
1440 x = getx xy
1441 y = gety xy
1442 -- y² = x³ + 7 (mod p)
1443 y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve)
1444 y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve)
1445 -}
1446 secp256k1 = ECC.getCurveByName ECC.SEC_p256k1
1447 ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1
1448 -- pub = cannonical_eckey x y
1449 -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub
1450 -- address = base58_encode hash
1451 -- pubstr = concatMap (printf "%02x") $ pub
1452 -- _ = pubstr :: String
1453 return $ {- trace (unlines ["pub="++show pubstr
1454 ,"add="++show address
1455 ,"y ="++show y
1456 ,"y' ="++show y'
1457 ,"y''="++show y'']) -}
1458 SecretKeyPacket
1459 { version = 4
1460 , timestamp = toEnum (fromEnum timestamp)
1461 , key_algorithm = ECDSA
1462 , key = [ -- public fields...
1463 ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve)
1464 ,('l',MPI 256)
1465 ,('x',MPI x)
1466 ,('y',MPI y)
1467 -- secret fields
1468 ,('d',MPI d)
1469 ]
1470 , s2k_useage = 0
1471 , s2k = S2K 100 ""
1472 , symmetric_algorithm = Unencrypted
1473 , encrypted_data = ""
1474 , is_subkey = True
1475 }
1476
1477-- DER-encoded elliptic curve ids
1478-- nistp256_id = 0x2a8648ce3d030107
1479secp256k1_id :: Integer
1480secp256k1_id = 0x2b8104000a
1481-- "\x2a\x86\x48\xce\x3d\x03\x01\x07"
1482{- OID Curve description Curve name
1483 ----------------------------------------------------------------
1484 1.2.840.10045.3.1.7 NIST Curve P-256 [FIPS 186-2] "NIST P-256"
1485 1.3.132.0.34 NIST Curve P-384 [FIPS 186-2] "NIST P-384"
1486 1.3.132.0.35 NIST Curve P-521 [FIPS 186-2] "NIST P-521"
1487
1488 Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST
1489 P-521". The hexadecimal representation used in the public and
1490 private key encodings are:
1491
1492 Curve Name Len Hexadecimal representation of the OID
1493 ----------------------------------------------------------------
1494 "NIST P-256" 8 0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07
1495 "NIST P-384" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x22
1496 "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23
1497-}
1498
1499readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
1500readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents
1501readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
1502readInputFileS ctx inp = do
1503 let fname = resolveInputFile ctx inp
1504 fmap S.concat $ mapM S.readFile fname
1505
1506keyCompare :: String -> Packet -> Packet -> Ordering
1507keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
1508keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
1509keyCompare what a b | keykey a==keykey b = EQ
1510keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
1511 , fingerprint a
1512 , PP.ppShow a
1513 , fingerprint b
1514 , PP.ppShow b
1515 ]
1516
1517parseUID :: String -> UserIDRecord
1518parseUID str = UserIDRecord {
1519 uid_full = str,
1520 uid_realname = realname,
1521 uid_user = user,
1522 uid_subdomain = subdomain,
1523 uid_topdomain = topdomain
1524 }
1525 where
1526 text = T.pack str
1527 (T.strip-> realname, T.dropAround isBracket-> email)
1528 = T.break (=='<') text
1529 (user, T.drop 1-> hostname) = T.break (=='@') email
1530 ( T.reverse -> topdomain,
1531 T.reverse . T.drop 1 -> subdomain)
1532 = T.break (=='.') . T.reverse $ hostname
1533
1534flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
1535flattenTop fname ispub (KeyData key sigs uids subkeys) =
1536 unk ispub key :
1537 ( flattenAllUids fname ispub uids
1538 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
1539
1540derToBase32 :: ByteString -> String
1541#if !defined(VERSION_cryptonite)
1542derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
1543#else
1544derToBase32 = map toLower . Base32.encode . S.unpack . sha1
1545 where
1546 sha1 :: L.ByteString -> S.ByteString
1547 sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
1548#endif
1549
1550derRSA :: Packet -> Maybe ByteString
1551derRSA rsa = do
1552 k <- rsaKeyFromPacket rsa
1553 return $ encodeASN1 DER (toASN1 k [])
1554
1555getBindings ::
1556 [Packet]
1557 ->
1558 ( [([Packet],[SignatureOver])] -- other signatures with key sets
1559 -- that were used for the verifications
1560 , [(Word8,
1561 (Packet, Packet), -- (topkey,subkey)
1562 [String], -- usage flags
1563 [SignatureSubpacket], -- hashed data
1564 [Packet])] -- binding signatures
1565 )
1566getBindings pkts = (sigs,bindings)
1567 where
1568 (sigs,concat->bindings) = unzip $ do
1569 let (keys,_) = partition isKey pkts
1570 keys <- disjoint_fp keys
1571 let (bs,sigs) = verifyBindings keys pkts
1572 return . ((keys,sigs),) $ do
1573 b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
1574 i <- map signature_issuer (signatures_over b)
1575 i <- maybeToList i
1576 who <- maybeToList $ find_key fingerprint (Message keys) i
1577 let (code,claimants) =
1578 case () of
1579 _ | who == topkey b -> (1,[])
1580 _ | who == subkey b -> (2,[])
1581 _ -> (0,[who])
1582 let hashed = signatures_over b >>= hashed_subpackets
1583 kind = guard (code==1) >> hashed >>= maybeToList . usage
1584 return (code,(topkey b,subkey b), kind, hashed,claimants)
1585
1586-- Returned data is simmilar to getBindings but the Word8 codes
1587-- are ORed together.
1588accBindings ::
1589 Bits t =>
1590 [(t, (Packet, Packet), [a], [a1], [a2])]
1591 -> [(t, (Packet, Packet), [a], [a1], [a2])]
1592accBindings bs = as
1593 where
1594 gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
1595 as = map (foldl1 combine) gs
1596 bindingPair (_,p,_,_,_) = pub2 p
1597 where
1598 pub2 (a,b) = (pub a, pub b)
1599 pub a = fingerprint_material a
1600 samePair a b = bindingPair a == bindingPair b
1601 combine (ac,p,akind,ahashed,aclaimaints)
1602 (bc,_,bkind,bhashed,bclaimaints)
1603 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
1604
1605subkeyMappedPacket :: SubKey -> MappedPacket
1606subkeyMappedPacket (SubKey k _ ) = k
1607
1608has_tag :: String -> Packet -> Bool
1609has_tag tag p = isSignaturePacket p
1610 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
1611 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
1612
1613dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData
1614dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
1615 where
1616 asMapped n p = mappedPacketWithHint filename p n
1617 asSigAndTrust n (p,tm) = (asMapped n p,tm)
1618
1619 -- NOTE:
1620 -- if a keyring file has both a public key packet and a secret key packet
1621 -- for the same key, then only one of them will survive, which ever is
1622 -- later in the file.
1623 --
1624 -- This is due to the use of statements like
1625 -- (Map.insert filename (origin p n) (locations key))
1626 --
1627 update :: Maybe KeyData -> Maybe KeyData
1628 update v | isKey p && not (is_subkey p)
1629 = case v of
1630 Nothing -> Just $ KeyData (asMapped n p) [] Map.empty Map.empty
1631 Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
1632 -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p)
1633 sigs
1634 uids
1635 subkeys
1636 _ -> error . concat $ ["Unexpected master key merge error: "
1637 ,show (fingerprint top, fingerprint p)]
1638 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
1639 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
1640 update (Just (KeyData key sigs uids subkeys)) | isUserID p
1641 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
1642 subkeys
1643 update (Just (KeyData key sigs uids subkeys))
1644 = case sub of
1645 MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys
1646 UserIDPacket {} -> Just $ KeyData key
1647 sigs
1648 (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
1649 subkeys
1650 _ | isKey sub -> Just $ KeyData key
1651 sigs
1652 uids
1653 (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
1654 _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
1655 update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
1656
1657 mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
1658 mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) []
1659 mergeSubkey n p (Just (SubKey key sigs)) = Just $
1660 SubKey (mergeKeyPacket "subs" key $ asMapped n p)
1661 sigs
1662
1663 mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
1664 mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n))
1665 mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
1666 mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
1667
1668 whatP (a,_) = concat . take 1 . words . show $ a
1669
1670
1671 mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs, m)
1672 mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty)
1673
1674 mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs)
1675 mergeSubSig n sig Nothing = error $
1676 "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
1677
1678secretToPublic :: Packet -> Packet
1679secretToPublic pkt@(SecretKeyPacket {}) =
1680 PublicKeyPacket { version = version pkt
1681 , timestamp = timestamp pkt
1682 , key_algorithm = key_algorithm pkt
1683 -- , ecc_curve = ecc_curve pkt
1684 , key = let seckey = key pkt
1685 pubs = public_key_fields (key_algorithm pkt)
1686 in filter (\(k,v) -> k `elem` pubs) seckey
1687 , is_subkey = is_subkey pkt
1688 , v3_days_of_validity = Nothing
1689 }
1690secretToPublic pkt = pkt
1691
1692sigpackets ::
1693 Monad m =>
1694 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
1695sigpackets typ hashed unhashed = return $
1696 signaturePacket
1697 4 -- version
1698 typ -- 0x18 subkey binding sig, or 0x19 back-signature
1699 RSA
1700 SHA1
1701 hashed
1702 unhashed
1703 0 -- Word16 -- Left 16 bits of the signed hash value
1704 [] -- [MPI]
1705
1706usage :: SignatureSubpacket -> Maybe String
1707usage (NotationDataPacket
1708 { human_readable = True
1709 , notation_name = "usage@"
1710 , notation_value = u
1711 }) = Just u
1712usage _ = Nothing
1713
1714torhash :: Packet -> String
1715torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
1716
1717keyFlags :: t -> [Packet] -> [SignatureSubpacket]
1718keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
1719
1720flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
1721flattenAllUids fname ispub uids =
1722 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
1723
1724-- | Given list of subpackets, a master key, one of its subkeys and a
1725-- list of signatures on that subkey, yields:
1726--
1727-- * preceding list of signatures
1728--
1729-- * The most recent valid signature made by the master key along with a
1730-- flag that indicates whether or not all of the supplied subpackets occur in
1731-- it or, if no valid signature from the working key is present, Nothing.
1732--
1733-- * following list of signatures
1734--
1735findTag ::
1736 [SignatureSubpacket]
1737 -> Packet
1738 -> Packet
1739 -> [(MappedPacket, b)]
1740 -> ([(MappedPacket, b)],
1741 Maybe (Bool, (MappedPacket, b)),
1742 [(MappedPacket, b)])
1743findTag tag topk subkey subsigs = (xs',minsig,ys')
1744 where
1745 vs = map (\sig ->
1746 (sig, do
1747 sig <- Just (packet . fst $ sig)
1748 guard (isSignaturePacket sig)
1749 guard $ flip isSuffixOf
1750 (fingerprint topk)
1751 . fromMaybe "%bad%"
1752 . signature_issuer
1753 $ sig
1754 listToMaybe $
1755 map (signature_time . verify (Message [topk]))
1756 (signatures $ Message [topk,subkey,sig])))
1757 subsigs
1758 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
1759 xs' = map fst xs
1760 ys' = map fst $ if isNothing minsig then ys else drop 1 ys
1761 minsig = do
1762 (sig,ov) <- listToMaybe ys
1763 ov
1764 let hshed = hashed_subpackets $ packet $ fst sig
1765 return ( null $ tag \\ hshed, sig)
1766
1767makeSig ::
1768 (MappedPacket -> IO (KikiCondition Packet))
1769 -> MappedPacket
1770 -> [Char]
1771 -> MappedPacket
1772 -> [SignatureSubpacket]
1773 -> Maybe (MappedPacket, Map.Map k a)
1774 -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
1775makeSig doDecrypt top fname subkey_p tags mbsig = do
1776 let wk = packet top
1777 wkun <- doDecrypt top
1778 try wkun $ \wkun -> do
1779 let grip = fingerprint wk
1780 addOrigin new_sig =
1781 flip
1782 (maybe $ return FailedToMakeSignature)
1783 (new_sig >>= listToMaybe . signatures_over) $ \new_sig -> do
1784 let mp' = mappedPacket fname new_sig
1785 return $ KikiSuccess (mp', Map.empty)
1786 parsedkey = [packet subkey_p]
1787 hashed0
1788 | any isFlagsPacket tags = tags
1789 | otherwise =
1790 KeyFlagsPacket
1791 { certify_keys = False
1792 , sign_data = False
1793 , encrypt_communication = False
1794 , encrypt_storage = False
1795 , split_key = False
1796 , authentication = True
1797 , group_key = False
1798 } :
1799 tags
1800 -- implicitly added:
1801 -- , SignatureCreationTimePacket (fromIntegral timestamp)
1802 isFlagsPacket (KeyFlagsPacket {}) = True
1803 isFlagsPacket _ = False
1804 subgrip = fingerprint (head parsedkey)
1805 back_sig <-
1806 pgpSign
1807 (Message parsedkey)
1808 (SubkeySignature
1809 wk
1810 (head parsedkey)
1811 (sigpackets 0x19 hashed0 [IssuerPacket subgrip]))
1812 (if key_algorithm (head parsedkey) == ECDSA
1813 then SHA256
1814 else SHA1)
1815 subgrip
1816 let iss = IssuerPacket (fingerprint wk)
1817 cons_iss back_sig =
1818 iss : map EmbeddedSignaturePacket (signatures_over back_sig)
1819 unhashed0 = maybe [iss] cons_iss back_sig
1820 new_sig <-
1821 pgpSign
1822 (Message [wkun])
1823 (SubkeySignature wk (head parsedkey) (sigpackets 0x18 hashed0 unhashed0))
1824 SHA1
1825 grip
1826 let newSig = do
1827 r <- addOrigin new_sig
1828 return $ fmap (, []) r
1829 flip (maybe newSig) mbsig $ \(mp, trustmap) -> do
1830 let sig = packet mp
1831 isCreation (SignatureCreationTimePacket {}) = True
1832 isCreation _ = False
1833 isExpiration (SignatureExpirationTimePacket {}) = True
1834 isExpiration _ = False
1835 (cs, ps) = partition isCreation (hashed_subpackets sig)
1836 (es, qs) = partition isExpiration ps
1837 stamp = listToMaybe . sortBy (comparing Down) $ map unwrap cs
1838 where
1839 unwrap (SignatureCreationTimePacket x) = x
1840 exp = listToMaybe $ sort $ map unwrap es
1841 where
1842 unwrap (SignatureExpirationTimePacket x) = x
1843 expires = liftA2 (+) stamp exp
1844 timestamp <- now
1845 if fmap ((< timestamp) . fromIntegral) expires == Just True
1846 then return $
1847 KikiSuccess ((mp, trustmap), [UnableToUpdateExpiredSignature])
1848 else do
1849 let times =
1850 (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) $
1851 maybeToList $ do
1852 e <- expires
1853 return $
1854 SignatureExpirationTimePacket (e - fromIntegral timestamp)
1855 sig' = sig {hashed_subpackets = times ++ (qs `union` tags)}
1856 new_sig <-
1857 pgpSign
1858 (Message [wkun])
1859 (SubkeySignature wk (packet subkey_p) [sig'])
1860 SHA1
1861 (fingerprint wk)
1862 newsig <- addOrigin new_sig
1863 return $ fmap (, []) newsig
1864
1865ifSecret :: Packet -> t -> t -> t
1866ifSecret (SecretKeyPacket {}) t f = t
1867ifSecret _ t f = f
1868
1869uidkey :: Packet -> String
1870uidkey (UserIDPacket str) = str
1871
1872keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
1873keyflags flgs@(KeyFlagsPacket {}) =
1874 Just . toEnum $
1875 ( bit 0x1 certify_keys
1876 .|. bit 0x2 sign_data
1877 .|. bit 0x4 encrypt_communication
1878 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
1879 -- other flags:
1880 -- split_key
1881 -- authentication (ssh-client)
1882 -- group_key
1883 where
1884 bit v f = if f flgs then v else 0
1885keyflags _ = Nothing
1886
1887readSecretPEMFile :: InputFile -> IO [SecretPEMData]
1888readSecretPEMFile fname = do
1889 -- warn $ fname ++ ": reading ..."
1890 let ctx = InputFileContext "" ""
1891 -- Note: The key's timestamp is included in it's fingerprint.
1892 -- Therefore, we should attempt to preserve it.
1893 stamp <- getInputFileTime ctx fname
1894 input <- readInputFileL ctx fname
1895 let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
1896 pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
1897 $ pemParser $ Just "RSA PRIVATE KEY"
1898 cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
1899 $ pemParser $ Just "CERTIFICATE"
1900 parseRSAPrivateKey dta = do
1901 let e = decodeASN1 DER dta
1902 asn1 <- either (const $ mzero) return e
1903 rsa <- either (const mzero) (return . fst) (fromASN1 asn1)
1904 let _ = rsa :: RSAPrivateKey
1905 return $ PEMPacket $ rsaToPGP stamp rsa
1906 dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
1907 mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
1908 mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
1909 where key' = if tm < fromTime (timestamp key)
1910 then key { timestamp = fromTime tm }
1911 else key
1912 mergeDate (tm,_) (Right mb) = (tm,mb)
1913 return $ dta
1914
1915readSecretDNSFile :: InputFile -> IO Packet
1916readSecretDNSFile fname = do
1917 let ctx = InputFileContext "" ""
1918 stamp <- getInputFileTime ctx fname
1919 input <- readInputFileL ctx fname
1920 let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1)
1921 . Char8.break (==':'))
1922 $ Char8.lines input
1923 alg = maybe RSA parseAlg $ lookup "Algorithm" kvs
1924 parseAlg spec = case Char8.words spec of
1925 nstr:_ -> case read (Char8.unpack nstr) :: Int of
1926 2 -> DH
1927 3 -> DSA -- SHA1
1928 5 -> RSA -- SHA1
1929 6 -> DSA -- NSEC3-SHA1 (RFC5155)
1930 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155)
1931 8 -> RSA -- SHA256
1932 10 -> RSA -- SHA512 (RFC5702)
1933 -- 12 -> GOST
1934 13 -> ECDSA -- P-256 SHA256 (RFC6605)
1935 14 -> ECDSA -- P-384 SHA384 (RFC6605)
1936 _ -> RSA
1937 case alg of
1938 RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs
1939
1940spemPacket :: SecretPEMData -> Maybe Packet
1941spemPacket (PEMPacket p) = Just p
1942spemPacket _ = Nothing
1943
1944spemCert :: SecretPEMData -> Maybe ParsedCert
1945spemCert (PEMCertificate p) = Just p
1946spemCert _ = Nothing
1947
1948fingerdress :: Packet -> SockAddr
1949fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str
1950 where
1951 zero = SockAddrInet 0 0
1952 addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk)
1953 colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
1954 colons xs = xs
1955
1956getSubkeys :: SubkeyStatus -> Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
1957getSubkeys ck topk subs tag = do
1958 SubKey k sigs <- Map.elems subs
1959 let subk = packet k
1960 let sigs' = do
1961 -- require tag
1962 torsig <- filter (has_tag tag) $ map (packet . fst) sigs
1963
1964 -- require parent's signature
1965 when (ck > Unsigned) $ do
1966 sig <- (signatures $ Message [topk,subk,torsig])
1967 let v = verify (Message [topk]) sig
1968 -- Require parent's signature
1969 guard (not . null $ signatures_over v)
1970
1971 -- require child's back signature
1972 when (ck == CrossSigned ) $ do
1973 let unhashed = unhashed_subpackets torsig
1974 subsigs = mapMaybe backsig unhashed
1975 -- This should consist only of 0x19 values
1976 -- subtypes = map signature_type subsigs
1977 -- subtyp <- subtypes
1978 -- guard (subtyp == 0x19)
1979 sig' <- signatures . Message $ [topk,subk]++subsigs
1980 let v' = verify (Message [subk]) sig'
1981 -- Require subkey's signature
1982 guard . not . null $ signatures_over v'
1983 return torsig
1984 guard (not $ null sigs')
1985 return subk
1986
1987socketFamily :: SockAddr -> Family
1988socketFamily (SockAddrInet _ _) = AF_INET
1989socketFamily (SockAddrInet6 {}) = AF_INET6
1990socketFamily (SockAddrUnix _) = AF_UNIX
1991
1992selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1993selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
1994
1995isBracket :: Char -> Bool
1996isBracket '<' = True
1997isBracket '>' = True
1998isBracket _ = False
1999
2000unk :: Bool -> MappedPacket -> MappedPacket
2001unk isPublic = if isPublic then toPacket secretToPublic else id
2002 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
2003
2004concatSort ::
2005 FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
2006concatSort fname getp f = concat . sortByHint fname getp . map f
2007
2008flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
2009flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
2010
2011rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
2012rsaKeyFromPacket p | isKey p = do
2013 n <- lookup 'n' $ key p
2014 e <- lookup 'e' $ key p
2015 return $ RSAKey n e
2016
2017rsaKeyFromPacket _ = Nothing
2018
2019disjoint_fp :: [Packet] -> [[Packet]]
2020disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
2021 where
2022 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
2023 samepr a b = smallpr a == smallpr b
2024
2025 {-
2026 -- useful for testing
2027 group2 :: [a] -> [[a]]
2028 group2 (x:y:ys) = [x,y]:group2 ys
2029 group2 [x] = [[x]]
2030 group2 [] = []
2031 -}
2032
2033verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver])
2034verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
2035 where
2036 verified = do
2037 sig <- signatures (Message nonkeys)
2038 let v = verify (Message keys) sig
2039 guard (not . null $ signatures_over v)
2040 return v
2041 (top,othersigs) = partition isSubkeySignature verified
2042 embedded = do
2043 sub <- top
2044 let sigover = signatures_over sub
2045 unhashed = sigover >>= unhashed_subpackets
2046 subsigs = mapMaybe backsig unhashed
2047 -- This should consist only of 0x19 values
2048 -- subtypes = map signature_type subsigs
2049 -- trace ("subtypes = "++show subtypes) (return ())
2050 -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
2051 sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
2052 let v = verify (Message [subkey sub]) sig
2053 guard (not . null $ signatures_over v)
2054 return v
2055
2056flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
2057flattenUid fname ispub (str,(sigs,om)) =
2058 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
2059
2060-- | Get the time stamp of a signature.
2061--
2062-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
2063-- the hashed section. TODO: change this?
2064--
2065signature_time :: SignatureOver -> Word32
2066signature_time ov = case (if null cs then ds else cs) of
2067 [] -> minBound
2068 xs -> maximum xs
2069 where
2070 ps = signatures_over ov
2071 ss = filter isSignaturePacket ps
2072 cs = concatMap (concatMap creationTime . hashed_subpackets) ss
2073 ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
2074 creationTime (SignatureCreationTimePacket t) = [t]
2075 creationTime _ = []
2076
2077splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
2078splitAtMinBy comp xs = minimumBy comp' xxs
2079 where
2080 xxs = zip (inits xs) (tails xs)
2081 comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
2082 compM (Just a) (Just b) = comp a b
2083 compM Nothing mb = GT
2084 compM _ _ = LT
2085
2086parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert
2087parseCertBlob comp bs = do
2088 asn1 <- either (const Nothing) Just
2089 $ decodeASN1 DER bs
2090 let asn1' = drop 2 asn1
2091 cert <- either (const Nothing) (Just . fst) (fromASN1 asn1')
2092 let _ = cert :: X509.Certificate
2093 notBefore :: UTCTime
2094#if MIN_VERSION_x509(1,5,0)
2095 notBefore = toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano
2096 where (vincentTime,_) = X509.certValidity cert
2097#else
2098 (notBefore,_) = X509.certValidity cert
2099#endif
2100 case X509.certPubKey cert of
2101 X509.PubKeyRSA key -> do
2102 let withoutkey =
2103 let ekey = toStrict $ encodeASN1 DER (toASN1 key [])
2104 (pre,post) = S.breakSubstring ekey $ toStrict bs
2105 post' = S.drop (S.length ekey) post
2106 len :: Word16
2107 len = if S.null post then maxBound
2108 else fromIntegral $ S.length pre
2109 in if len < 4096
2110 then encode len <> GZip.compress (Char8.fromChunks [pre,post'])
2111 else bs
2112 return
2113 ParsedCert { pcertKey = packetFromPublicRSAKey notBefore
2114 (MPI $ RSA.public_n key)
2115 (MPI $ RSA.public_e key)
2116 , pcertTimestamp = notBefore
2117 , pcertBlob = if comp then withoutkey
2118 else bs
2119 }
2120 _ -> Nothing
2121
2122rsaToPGP :: TimeUtil.IsUTC a => a -> RSAPrivateKey -> Packet
2123rsaToPGP stamp rsa = SecretKeyPacket
2124 { version = 4
2125 , timestamp = fromTime stamp -- toEnum (fromEnum stamp)
2126 , key_algorithm = RSA
2127 , key = [ -- public fields...
2128 ('n',rsaN rsa)
2129 ,('e',rsaE rsa)
2130 -- secret fields
2131 ,('d',rsaD rsa)
2132 ,('p',rsaQ rsa) -- Note: p & q swapped
2133 ,('q',rsaP rsa) -- Note: p & q swapped
2134 ,('u',rsaCoefficient rsa)
2135 ]
2136 -- , ecc_curve = def
2137 , s2k_useage = 0
2138 , s2k = S2K 100 ""
2139 , symmetric_algorithm = Unencrypted
2140 , encrypted_data = ""
2141 , is_subkey = True
2142 }
2143
2144extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey
2145extractRSAKeyFields kvs = do
2146 let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs
2147 n <- lookup "Modulus" kvs'
2148 e <- lookup "PublicExponent" kvs'
2149 d <- lookup "PrivateExponent" kvs'
2150 p <- lookup "Prime1" kvs' -- p
2151 q <- lookup "Prime2" kvs' -- q
2152 dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1)
2153 dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1)
2154 u <- lookup "Coefficient" kvs'
2155 {-
2156 case (d,p,dmodp1) of
2157 (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return ()
2158 _ -> error "dmodp fail!"
2159 case (d,q,dmodqminus1) of
2160 (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return ()
2161 _ -> error "dmodq fail!"
2162 -}
2163 return $ RSAPrivateKey
2164 { rsaN = n
2165 , rsaE = e
2166 , rsaD = d
2167 , rsaP = p
2168 , rsaQ = q
2169 , rsaDmodP1 = dmodp1
2170 , rsaDmodQminus1 = dmodqminus1
2171 , rsaCoefficient = u }
2172 where
2173 parseField blob = MPI <$> m
2174 where m = bigendian <$> Base64.decode (Char8.unpack blob)
2175
2176 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
2177 where
2178 nlen = length bs
2179
2180backsig :: SignatureSubpacket -> Maybe Packet
2181backsig (EmbeddedSignaturePacket s) = Just s
2182backsig _ = Nothing
2183
2184selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
2185selectKey0 wantPublic (spec,mtag) db = do
2186 let Message ps = flattenKeys wantPublic db
2187 ys = snd $ seek_key spec ps
2188 flip (maybe (listToMaybe ys)) mtag $ \tag -> do
2189 case ys of
2190 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
2191 [] -> Nothing
2192
2193sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
2194sortByHint fname f = sortBy (comparing gethint)
2195 where
2196 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
2197 defnum = -1
2198
2199unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
2200unsig fname isPublic (sig,trustmap) =
2201 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
2202 where
2203 f n _ = n==fname -- && trace ("fname=n="++show n) True
2204 asMapped n p = let m = mappedPacket fname p
2205 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
2206
2207smallpr :: Packet -> [Char]
2208smallpr k = drop 24 $ fingerprint k
2209
2210isSubkeySignature :: SignatureOver -> Bool
2211isSubkeySignature (SubkeySignature {}) = True
2212isSubkeySignature _ = False
2213
2214toStrict :: L.ByteString -> S.ByteString
2215toStrict = foldr1 (<>) . L.toChunks
2216
2217packetFromPublicRSAKey :: UTCTime -> MPI -> MPI -> Packet
2218packetFromPublicRSAKey notBefore n e =
2219 PublicKeyPacket { version = 4
2220 , timestamp = round $ utcTimeToPOSIXSeconds notBefore
2221 , key_algorithm = RSA
2222 , key = [('n',n),('e',e)]
2223 , is_subkey = True
2224 , v3_days_of_validity = Nothing
2225 }
2226
2227flattenKeys :: Bool -> KeyDB -> Message
2228flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
2229 where
2230 prefilter = if isPublic then id else filter isSecret
2231 where
2232 isSecret (_,(KeyData
2233 (MappedPacket { packet=(SecretKeyPacket {})})
2234 _
2235 _
2236 _)) = True
2237 isSecret _ = False
2238
2239seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
2240seek_key (KeyGrip grip) sec = (pre, subs)
2241 where
2242 (pre,subs) = break pred sec
2243 pred p@(SecretKeyPacket {}) = matchpr grip p == grip
2244 pred p@(PublicKeyPacket {}) = matchpr grip p == grip
2245 pred _ = False
2246
2247seek_key (KeyTag key tag) ps
2248 | null bs = (ps, [])
2249 | null qs =
2250 let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
2251 (as ++ (head bs : as'), bs')
2252 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
2253 where
2254 (as,bs) = break (\p -> isSignaturePacket p
2255 && has_tag tag p
2256 && isJust (signature_issuer p)
2257 && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
2258 ps
2259 (rs,qs) = break isKey (reverse as)
2260
2261 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
2262 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
2263
2264seek_key (KeyUidMatch pat) ps
2265 | null bs = (ps, [])
2266 | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
2267 (as ++ (head bs : as'), bs')
2268 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
2269 where
2270 (as,bs) = break (isInfixOf pat . uidStr) ps
2271 (rs,qs) = break isKey (reverse as)
2272
2273 uidStr (UserIDPacket s) = s
2274 uidStr _ = ""
2275
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index a683a91..27ebbcd 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -1,50 +1,51 @@
1{-# LANGUAGE CPP #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-} 2{-# LANGUAGE OverloadedStrings #-}
3module Kiki where 3module Kiki where
4 4
5import Control.Applicative 5import Control.Applicative
6import Control.Arrow 6import Control.Arrow
7import Control.Concurrent 7import Control.Concurrent
8import Control.Exception 8import Control.Exception
9import Control.Monad 9import Control.Monad
10import Data.ASN1.BinaryEncoding 10import Data.ASN1.BinaryEncoding
11import Data.ASN1.Encoding 11import Data.ASN1.Encoding
12import Data.ASN1.Types 12import Data.ASN1.Types
13import Data.Binary 13import Data.Binary
14import Data.Char 14import Data.Bool
15import Data.List 15import Data.Char
16import Data.Maybe 16import Data.List
17import Data.Monoid 17import Data.Maybe
18import Data.OpenPGP 18import Data.Monoid
19import Data.OpenPGP.Util 19import Data.OpenPGP
20import Data.Ord 20import Data.OpenPGP.Util
21import System.Directory 21import Data.Ord
22import System.FilePath.Posix as FilePath 22import qualified Data.Traversable as T (mapM)
23import System.IO 23import System.Directory
24import System.IO.Temp 24import System.FilePath.Posix as FilePath
25import System.IO.Error 25import System.IO
26import System.Posix.IO as Posix (createPipe) 26import System.IO.Error
27import System.Posix.User 27import System.IO.Temp
28import System.Process 28import System.Posix.Files
29import System.Posix.Files 29import System.Posix.IO as Posix (createPipe)
30import qualified Data.Traversable as T (mapM) 30import System.Posix.User
31import System.Process
31#if defined(VERSION_memory) 32#if defined(VERSION_memory)
32import qualified Data.ByteString.Char8 as S8 33import Data.ByteArray.Encoding
33import Data.ByteArray.Encoding 34import qualified Data.ByteString.Char8 as S8
34#elif defined(VERSION_dataenc) 35#elif defined(VERSION_dataenc)
35import qualified Codec.Binary.Base64 as Base64 36import qualified Codec.Binary.Base64 as Base64
36#endif 37#endif
37import qualified Data.ByteString.Lazy as L 38import qualified Data.ByteString.Lazy as L
38import qualified Data.ByteString.Lazy.Char8 as Char8 39import qualified Data.ByteString.Lazy.Char8 as Char8
39import qualified Data.Map.Strict as Map 40import qualified Data.Map.Strict as Map
40import qualified SSHKey as SSH 41import Network.Socket
41import Network.Socket -- (SockAddr) 42import ProcessUtils
42import ProcessUtils 43import qualified SSHKey as SSH
43 44
44import GnuPGAgent (Query(..)) 45import CommandLine
45import CommandLine 46import DotLock
46import KeyRing 47import GnuPGAgent (Query (..))
47import DotLock 48import KeyRing
48 49
49withAgent :: [PassphraseSpec] -> [PassphraseSpec] 50withAgent :: [PassphraseSpec] -> [PassphraseSpec]
50withAgent [] = [PassphraseAgent] 51withAgent [] = [PassphraseAgent]
@@ -97,7 +98,7 @@ refresh root homepass = do
97 pth -> Just pth 98 pth -> Just pth
98 case r of 99 case r of
99 KikiSuccess rt -> refreshCache rt mroot 100 KikiSuccess rt -> refreshCache rt mroot
100 _ -> return () -- XXX: silent fail? 101 _ -> return () -- XXX: silent fail?
101 102
102data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile } 103data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile }
103 104
@@ -145,15 +146,12 @@ outputReport report = do
145 146
146importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> SymmetricAlgorithm -> IO () 147importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> SymmetricAlgorithm -> IO ()
147importAndRefresh root cmn cipher = do 148importAndRefresh root cmn cipher = do
148 let rootdir = do guard (root "x" /= "x") 149 let rootdir = do guard (root "x" /= "x")
149 Just $ root "" 150 Just $ root ""
150 151 me <- getEffectiveUserID
151 me <- getEffectiveUserID 152 let noChrootArg = rootdir == Nothing
152 153 bUnprivileged = (me/=0) && noChrootArg
153 let noChrootArg = rootdir == Nothing 154 bool id (error "--chroot requires an argument") (rootdir==Just "") $ do
154 bUnprivileged = (me/=0) && noChrootArg
155 if rootdir==Just "" then error "--chroot requires an argument" else do
156
157 let homespec = mplus (slash <$> rootdir <*> cap_homespec cmn) 155 let homespec = mplus (slash <$> rootdir <*> cap_homespec cmn)
158 (fmap (++"/root/.gnupg") rootdir) 156 (fmap (++"/root/.gnupg") rootdir)
159 sshkeygen size = Just $ concat [ "mkdir -p \"$(dirname $file)\" && " 157 sshkeygen size = Just $ concat [ "mkdir -p \"$(dirname $file)\" && "
@@ -173,10 +171,7 @@ importAndRefresh root cmn cipher = do
173 171
174 let passfd = cap_passfd cmn 172 let passfd = cap_passfd cmn
175 173
176 (torgen,pwds) <- 174 (torgen,pwds) <- bool id (const $ return (Generate 0 $ GenRSA $ 1024 `div` 8, [])) $ do
177 if gotsec
178 then return (Generate 0 $ GenRSA $ 1024 `div` 8, [])
179 else do
180 {- ssh-keygen to create master key... 175 {- ssh-keygen to create master key...
181 let mkpath = home ++ "/master-key" 176 let mkpath = home ++ "/master-key"
182 mkdirFor mkpath 177 mkdirFor mkpath
@@ -255,30 +250,38 @@ importAndRefresh root cmn cipher = do
255 250
256 -- First, we ensure that the tor key exists and is imported 251 -- First, we ensure that the tor key exists and is imported
257 -- so that we know where to put the strongswan key. 252 -- so that we know where to put the strongswan key.
258 let strm = StreamInfo { typ = KeyRingFile 253 let strm =
259 , fill = KF_None 254 StreamInfo
260 , spill = KF_All 255 { typ = KeyRingFile
261 , access = AutoAccess 256 , fill = KF_None
262 , initializer = NoCreate 257 , spill = KF_All
263 , transforms = [] } 258 , access = AutoAccess
264 buildStreamInfo rtyp ftyp = StreamInfo { typ = ftyp 259 , initializer = NoCreate
265 , fill = rtyp 260 , transforms = []
266 , spill = KF_All 261 }
267 , access = AutoAccess 262 buildStreamInfo rtyp ftyp =
268 , initializer = NoCreate 263 StreamInfo
269 , transforms = [] } 264 { typ = ftyp
265 , fill = rtyp
266 , spill = KF_All
267 , access = AutoAccess
268 , initializer = NoCreate
269 , transforms = [] }
270 peminfo bits usage = 270 peminfo bits usage =
271 StreamInfo { typ = PEMFile 271 StreamInfo
272 , fill = KF_None -- KF_Match usage 272 { typ = PEMFile
273 , spill = KF_Match usage 273 , fill = KF_None -- KF_Match usage
274 , access = Sec 274 , spill = KF_Match usage
275 , initializer = Internal (GenRSA $ bits `div` 8) 275 , access = Sec
276 , transforms = [] 276 , initializer = Internal (GenRSA $ bits `div` 8)
277 } 277 , transforms = []
278 }
278 sshcpath = fromMaybe "" rootdir ++ osHomeDir ++ ".ssh/id_rsa" 279 sshcpath = fromMaybe "" rootdir ++ osHomeDir ++ ".ssh/id_rsa"
279 sshspath = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key" 280 sshspath = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key"
280 op = KeyRingOperation 281 op =
281 { opFiles = Map.fromList $ 282 KeyRingOperation
283 { opFiles =
284 Map.fromList $
282 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile ) 285 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
283 , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } ) 286 , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } )
284 , ( torgen , case torgen of 287 , ( torgen , case torgen of
@@ -295,18 +298,19 @@ importAndRefresh root cmn cipher = do
295 , ( Generate 2 (GenRSA (4096 `div` 8)), strm { spill = KF_Match "encrypt" }) 298 , ( Generate 2 (GenRSA (4096 `div` 8)), strm { spill = KF_Match "encrypt" })
296 , ( Generate 3 (GenRSA (4096 `div` 8)), strm { spill = KF_Match "sign" }) 299 , ( Generate 3 (GenRSA (4096 `div` 8)), strm { spill = KF_Match "sign" })
297 ] 300 ]
298 , opPassphrases = withAgent $ pwds ++ do pfd <- maybeToList passfd 301 , opPassphrases = withAgent $ pwds ++ do pfd <- maybeToList passfd
299 return $ PassphraseSpec Nothing Nothing pfd 302 return $ PassphraseSpec Nothing Nothing pfd
300 , opHome = homespec 303 , opHome = homespec
301 , opTransforms = [] 304 , opTransforms = []
302 } 305 }
303 -- doNothing = return () 306 -- doNothing = return ()
304 nop = KeyRingOperation 307 nop =
305 { opFiles = Map.empty 308 KeyRingOperation
306 , opPassphrases = withAgent $ do pfd <- maybeToList passfd 309 { opFiles = Map.empty
307 return $ PassphraseSpec Nothing Nothing pfd 310 , opPassphrases = withAgent $ do pfd <- maybeToList passfd
308 , opHome=homespec, opTransforms = [] 311 return $ PassphraseSpec Nothing Nothing pfd
309 } 312 , opHome=homespec, opTransforms = []
313 }
310 -- if bUnprivileged then doNothing else mkdirFor torpath 314 -- if bUnprivileged then doNothing else mkdirFor torpath
311 KikiResult rt report <- runKeyRing (if bUnprivileged then nop else op) 315 KikiResult rt report <- runKeyRing (if bUnprivileged then nop else op)
312 outputReport report 316 outputReport report
@@ -656,16 +660,16 @@ slash "" ('/':xs) = '/':xs
656slash "" xs = '/':xs 660slash "" xs = '/':xs
657slash (y:ys) xs = y:slash ys xs 661slash (y:ys) xs = y:slash ys xs
658 662
659opt_chroot :: Args (FilePath -> FilePath) 663dashdashChroot :: Args (FilePath -> FilePath)
660opt_chroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id 664dashdashChroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id
661 665
662opt_homedir :: Args CommonArgsParsed 666dashdashHomedir :: Args CommonArgsParsed
663opt_homedir = CommonArgsParsed 667dashdashHomedir = CommonArgsParsed
664 <$> optional (arg "--homedir") 668 <$> optional (arg "--homedir")
665 <*> optional (FileDesc <$> read <$> arg "--passphrase-fd") 669 <*> optional (FileDesc <$> read <$> arg "--passphrase-fd")
666 670
667opt_cipher :: Args SymmetricAlgorithm 671dashdashCipher :: Args SymmetricAlgorithm
668opt_cipher = fromMaybe CAST5 <$> optional (cipherFromString <$> arg "--cipher") 672dashdashCipher = fromMaybe CAST5 <$> optional (cipherFromString <$> arg "--cipher")
669 673
670kikiOptions :: ( [(String,Int)], [String] ) 674kikiOptions :: ( [(String,Int)], [String] )
671kikiOptions = ( ss, ps ) 675kikiOptions = ( ss, ps )
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-26 02:33:34 +0000