summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Base58.hs70
-rw-r--r--lib/Compat.hs58
-rw-r--r--lib/ControlMaybe.hs29
-rw-r--r--lib/CryptoCoins.hs70
-rw-r--r--lib/DotLock.hs45
-rw-r--r--lib/FunctorToMaybe.hs69
-rw-r--r--lib/Hosts.hs314
-rw-r--r--lib/KeyRing.hs3505
-rw-r--r--lib/PEM.hs34
-rw-r--r--lib/ProcessUtils.hs45
-rw-r--r--lib/ScanningParser.hs74
-rw-r--r--lib/TimeUtil.hs128
-rw-r--r--lib/dotlock.c1303
-rw-r--r--lib/dotlock.h112
14 files changed, 5856 insertions, 0 deletions
diff --git a/lib/Base58.hs b/lib/Base58.hs
new file mode 100644
index 0000000..3c1a113
--- /dev/null
+++ b/lib/Base58.hs
@@ -0,0 +1,70 @@
1{-# LANGUAGE CPP #-}
2module Base58 where
3
4#if !defined(VERSION_cryptonite)
5import qualified Crypto.Hash.SHA256 as SHA256
6#else
7import Crypto.Hash
8import Data.ByteArray (convert)
9#endif
10import qualified Data.ByteString as S
11import Data.Maybe
12import Data.List
13import Data.Word ( Word8 )
14import Control.Monad
15
16base58chars :: [Char]
17base58chars = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
18
19base58digits :: [Char] -> Maybe [Int]
20base58digits str = sequence mbs
21 where
22 mbs = map (flip elemIndex base58chars) str
23
24-- 5HueCGU8rMjxEXxiPuD5BDku4MkFqeZyd4dZ1jvhTVqvbTLvyTJ
25base58_decode :: [Char] -> Maybe (Word8,[Word8])
26base58_decode str = do
27 ds <- base58digits str
28 let n = foldl' (\a b-> a*58 + b) 0 $ ( map fromIntegral ds :: [Integer] )
29 rbytes = unfoldr getbyte n
30 getbyte d = do
31 guard (d/=0)
32 let (q,b) = d `divMod` 256
33 return (fromIntegral b,q)
34
35 let (rcksum,rpayload) = splitAt 4 $ rbytes
36 a_payload = reverse rpayload
37#if !defined(VERSION_cryptonite)
38 hash_result = S.take 4 . SHA256.hash . SHA256.hash . S.pack $ a_payload
39#else
40 hash_result = S.take 4 . convert $ digest
41 where digest = hash (S.pack a_payload) :: Digest SHA256
42#endif
43 expected_hash = S.pack $ reverse rcksum
44 (network_id,payload) = splitAt 1 a_payload
45
46 network_id <- listToMaybe network_id
47 guard (hash_result==expected_hash)
48 return (network_id,payload)
49
50base58_encode :: S.ByteString -> String
51base58_encode hsh = replicate zcount '1' ++ map (base58chars !!) (reverse rdigits)
52 where
53 zcount = S.length . S.takeWhile (==0) $ hsh
54#if !defined(VERSION_cryptonite)
55 cksum = S.take 4 . SHA256.hash . SHA256.hash $ hsh
56#else
57 cksum = S.take 4 (convert digest2 :: S.ByteString)
58 where digest2 = hash ( convert digest1 :: S.ByteString) :: Digest SHA256
59 digest1 = hash hsh :: Digest SHA256
60#endif
61 n = foldl' (\a b->a*256+b) 0 . map asInteger $ concatMap S.unpack [hsh, cksum]
62 asInteger x = fromIntegral x :: Integer
63 rdigits = unfoldr getdigit n
64 where
65 getdigit d = do
66 guard (d/=0)
67 let (q,b) = d `divMod` 58
68 return (fromIntegral b,q)
69
70
diff --git a/lib/Compat.hs b/lib/Compat.hs
new file mode 100644
index 0000000..3b77851
--- /dev/null
+++ b/lib/Compat.hs
@@ -0,0 +1,58 @@
1{-# LANGUAGE CPP #-}
2module Compat where
3
4import Data.Bits
5import Data.Word
6import Data.ASN1.Types
7import Data.ASN1.Encoding
8import Data.ASN1.BinaryEncoding
9import Crypto.PubKey.RSA as RSA
10
11#if defined(VERSION_cryptonite)
12
13instance ASN1Object PublicKey where
14 toASN1 pubKey = \xs -> Start Sequence
15 : IntVal (public_n pubKey)
16 : IntVal (public_e pubKey)
17 : End Sequence
18 : xs
19 fromASN1 (Start Sequence:IntVal smodulus:IntVal pubexp:End Sequence:xs) =
20 Right (PublicKey { public_size = calculate_modulus modulus 1
21 , public_n = modulus
22 , public_e = pubexp
23 }
24 , xs)
25 where calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1)
26 -- some bad implementation will not serialize ASN.1 integer properly, leading
27 -- to negative modulus. if that's the case, we correct it.
28 modulus = toPositive smodulus
29 fromASN1 ( Start Sequence
30 : IntVal 0
31 : Start Sequence
32 : OID [1, 2, 840, 113549, 1, 1, 1]
33 : Null
34 : End Sequence
35 : OctetString bs
36 : xs
37 ) = let inner = either strError fromASN1 $ decodeASN1' BER bs
38 strError = Left .
39 ("fromASN1: RSA.PublicKey: " ++) . show
40 in either Left (\(k, _) -> Right (k, xs)) inner
41 fromASN1 _ =
42 Left "fromASN1: RSA.PublicKey: unexpected format"
43
44#endif
45
46toPositive :: Integer -> Integer
47toPositive int
48 | int < 0 = uintOfBytes $ bytesOfInt int
49 | otherwise = int
50 where uintOfBytes = foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0
51 bytesOfInt :: Integer -> [Word8]
52 bytesOfInt n = if testBit (head nints) 7 then nints else 0xff : nints
53 where nints = reverse $ plusOne $ reverse $ map complement $ bytesOfUInt (abs n)
54 plusOne [] = [1]
55 plusOne (x:xs) = if x == 0xff then 0 : plusOne xs else (x+1) : xs
56 bytesOfUInt x = reverse (list x)
57 where list i = if i <= 0xff then [fromIntegral i] else (fromIntegral i .&. 0xff) : list (i `shiftR` 8)
58
diff --git a/lib/ControlMaybe.hs b/lib/ControlMaybe.hs
new file mode 100644
index 0000000..659dab7
--- /dev/null
+++ b/lib/ControlMaybe.hs
@@ -0,0 +1,29 @@
1{-# LANGUAGE ScopedTypeVariables #-}
2module ControlMaybe where
3
4-- import GHC.IO.Exception (IOException(..))
5import Control.Exception as Exception (IOException(..),catch)
6
7
8withJust :: Monad m => Maybe x -> (x -> m ()) -> m ()
9withJust (Just x) f = f x
10withJust Nothing f = return ()
11
12whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m ()
13whenJust acn f = do
14 x <- acn
15 withJust x f
16
17
18catchIO_ :: IO a -> IO a -> IO a
19catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h)
20
21catchIO :: IO a -> (IOException -> IO a) -> IO a
22catchIO body handler = Exception.catch body handler
23
24handleIO_ :: IO a -> IO a -> IO a
25handleIO_ = flip catchIO_
26
27
28handleIO :: (IOException -> IO a) -> IO a -> IO a
29handleIO = flip catchIO
diff --git a/lib/CryptoCoins.hs b/lib/CryptoCoins.hs
new file mode 100644
index 0000000..f417036
--- /dev/null
+++ b/lib/CryptoCoins.hs
@@ -0,0 +1,70 @@
1{-# LANGUAGE ViewPatterns #-}
2module CryptoCoins where
3
4import Numeric
5import Data.Word
6import Data.Maybe
7
8data CoinNetwork = CoinNetwork
9 { network_name :: String
10 , public_byte_id :: Word8
11 , private_byte_id :: Word8
12 , source_code_uri :: String
13 }
14 deriving (Show,Read)
15
16-- For forks of bitcoin, grep sources for PUBKEY_ADDRESS
17-- That value + 0x80 will be the private_byte_id.
18-- information source: https://raw.github.com/zamgo/PHPCoinAddress/master/README.md
19coin_networks :: [CoinNetwork]
20coin_networks =
21 [ CoinNetwork "bitcoin" 0x00 0x80 "https://github.com/bitcoin/bitcoin"
22 , CoinNetwork "litecoin" 0x30 0xB0 "https://github.com/litecoin-project/litecoin"
23 , CoinNetwork "peercoin" 0x37 0xB7 "https://github.com/ppcoin/ppcoin" -- AKA: ppcoin
24 , CoinNetwork "namecoin" 0x34 0xB4 "https://github.com/namecoin/namecoin"
25 , CoinNetwork "bbqcoin" 0x05 0xD5 "https://github.com/overware/BBQCoin"
26 , CoinNetwork "bitbar" 0x19 0x99 "https://github.com/aLQ/bitbar"
27 , CoinNetwork "bytecoin" 0x12 0x80 "https://github.com/bryan-mills/bytecoin"
28 , CoinNetwork "chncoin" 0x1C 0x9C "https://github.com/CHNCoin/CHNCoin"
29 , CoinNetwork "devcoin" 0x00 0x80 "http://sourceforge.net/projects/galacticmilieu/files/DeVCoin"
30 , CoinNetwork "feathercoin" 0x0E 0x8E "https://github.com/FeatherCoin/FeatherCoin"
31 , CoinNetwork "freicoin" 0x00 0x80 "https://github.com/freicoin/freicoin"
32 , CoinNetwork "junkcoin" 0x10 0x90 "https://github.com/js2082/JKC"
33 , CoinNetwork "mincoin" 0x32 0xB2 "https://github.com/SandyCohen/mincoin"
34 , CoinNetwork "novacoin" 0x08 0x88 "https://github.com/CryptoManiac/novacoin"
35 , CoinNetwork "onecoin" 0x73 0xF3 "https://github.com/cre8r/onecoin"
36 , CoinNetwork "smallchange" 0x3E 0xBE "https://github.com/bfroemel/smallchange"
37 , CoinNetwork "terracoin" 0x00 0x80 "https://github.com/terracoin/terracoin"
38 , CoinNetwork "yacoin" 0x4D 0xCD "https://github.com/pocopoco/yacoin"
39 , CoinNetwork "bitcoin-t" 0x6F 0xEF ""
40 , CoinNetwork "bbqcoin-t" 0x19 0x99 ""
41 , CoinNetwork "bitbar-t" 0x73 0xF3 ""
42 ]
43 -- fairbrix - - https://github.com/coblee/Fairbrix
44 -- ixcoin - - https://github.com/ixcoin/ixcoin
45 -- royalcoin - - http://sourceforge.net/projects/royalcoin/
46
47lookupNetwork :: Eq a => (CoinNetwork -> a) -> a -> Maybe CoinNetwork
48lookupNetwork f b = listToMaybe $ filter (\n->f n==b) coin_networks
49
50nameFromSecretByte :: Word8 -> String
51nameFromSecretByte b = maybe (defaultName b) network_name (lookupNetwork private_byte_id b)
52 where
53 defaultName b = "?coin?"++hexit b
54 where
55 hexit b = pad0 $ showHex b ""
56 where pad0 [c] = '0':c:[]
57 pad0 cs = take 2 cs
58
59publicByteFromName :: String -> Word8
60publicByteFromName n = maybe (secretByteFromName n - 0x80)
61 -- exceptions to the above: bbqcoin, bytecoin
62 public_byte_id
63 (lookupNetwork network_name n)
64
65secretByteFromName :: String -> Word8
66secretByteFromName n = maybe (defaultID n) private_byte_id (lookupNetwork network_name n)
67 where
68 defaultID ('?':'c':'o':'i':'n':'?':(readHex->((x,_):_)))
69 = x
70 defaultID _ = 0x00
diff --git a/lib/DotLock.hs b/lib/DotLock.hs
new file mode 100644
index 0000000..af05f5d
--- /dev/null
+++ b/lib/DotLock.hs
@@ -0,0 +1,45 @@
1{-# LANGUAGE ForeignFunctionInterface #-}
2module DotLock
3 ( DotLock
4 , Flags
5 , dotlock_init
6 , dotlock_create
7 , dotlock_take
8 , dotlock_release
9 , dotlock_destroy
10 , dotlock_remove_lockfiles
11 , dotlock_set_fd
12 , dotlock_get_fd
13 , dotlock_disable
14 ) where
15
16import System.Posix.Types (Fd(..))
17import Foreign.C.String
18import Foreign.C.Types
19import Foreign.Ptr
20
21newtype DotLock = DotLockPtr (Ptr ())
22type Flags = Int
23
24foreign import ccall "dotlock_create" _dotlock_create_ptr :: Ptr Char -> Flags -> IO (Ptr ())
25
26foreign import ccall "dotlock_create" _dotlock_create :: CString -> Flags -> IO (Ptr ())
27
28dotlock_init :: IO ()
29dotlock_init = do
30 null_ptr <- _dotlock_create_ptr nullPtr 0
31 return ()
32
33dotlock_create :: FilePath -> Flags -> IO (Maybe DotLock)
34dotlock_create file flags = do
35 ptr <- withCString file (flip _dotlock_create flags)
36 if ptr == nullPtr then return Nothing else return (Just $ DotLockPtr ptr)
37
38
39foreign import ccall "dotlock_take" dotlock_take :: DotLock -> CLong -> IO CInt
40foreign import ccall "dotlock_release" dotlock_release :: DotLock -> IO CInt
41foreign import ccall "dotlock_destroy" dotlock_destroy :: DotLock -> IO ()
42foreign import ccall "dotlock_remove_lockfiles" dotlock_remove_lockfiles ::DotLock -> IO ()
43foreign import ccall "dotlock_set_fd" dotlock_set_fd :: DotLock -> Fd -> IO ()
44foreign import ccall "dotlock_get_fd" dotlock_get_fd :: DotLock -> IO Fd
45foreign import ccall "dotlock_disable" dotlock_disable :: IO ()
diff --git a/lib/FunctorToMaybe.hs b/lib/FunctorToMaybe.hs
new file mode 100644
index 0000000..658b024
--- /dev/null
+++ b/lib/FunctorToMaybe.hs
@@ -0,0 +1,69 @@
1---------------------------------------------------------------------------
2-- |
3-- Module : FunctorToMaybe
4--
5-- Maintainer : joe@jerkface.net
6-- Stability : experimental
7--
8-- Motivation: When parsing a stream of events, it is often desirable to
9-- let certain control events pass-through to the output stream without
10-- interrupting the parse. For example, the conduit package uses
11-- <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
12-- which adds a special command to a stream and the blaze-builder-conduit
13-- package has <http://hackage.haskell.org/package/blaze-builder-conduit-1.0.0/docs/Data-Conduit-Blaze.html#g:2 conduits> that treat the nullary constructor with special significance.
14--
15-- But for other intermediary conduits, the nullary @Flush@ constructor may
16-- be noise that they should politely preserve in case it is meaningul downstream.
17-- If <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
18-- implemented the 'FunctorToMaybe' type class, then 'functorToEither' could be used to
19-- seperate the noise from the work-product.
20--
21{-# LANGUAGE CPP #-}
22module FunctorToMaybe where
23
24#if MIN_VERSION_base(4,6,0)
25#else
26import Control.Monad.Instances()
27#endif
28
29-- | The 'FunctorToMaybe' class genaralizes 'Maybe' in that the
30-- there may be multiple null elements.
31--
32-- Instances of 'FunctorToMaybe' should satisfy the following laws:
33--
34-- > functorToMaybe (fmap f g) == fmap f (functorToMaybe g)
35--
36class Functor g => FunctorToMaybe g where
37 functorToMaybe :: g a -> Maybe a
38
39
40instance FunctorToMaybe Maybe where
41 functorToMaybe = id
42instance FunctorToMaybe (Either a) where
43 functorToMaybe (Right x) = Just x
44 functorToMaybe _ = Nothing
45
46
47-- | 'functorToEither' is a null-preserving cast.
48--
49-- If @functorToMaybe g == Nothing@, then a casted value is returned with Left.
50-- If @functorToMaybe g == Just a@, then @Right a@ is returned.
51--
52-- Returning to our <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
53-- example, if we define
54--
55-- > instance Flush where
56-- > functorToMaybe Flush = Nothing
57-- > functorToMaybe (Chunk a) = Just a
58--
59-- Now stream processors can use 'functorToEither' to transform any nullary constructors while
60-- while doing its work to transform the data before forwarding it into
61-- <http://hackage.haskell.org/package/blaze-builder-conduit-1.0.0/docs/Data-Conduit-Blaze.html#v:builderToByteStringFlush builderToByteStringFlush>.
62--
63functorToEither :: FunctorToMaybe f => f a -> Either (f b) a
64functorToEither ga =
65 maybe (Left $ uncast ga)
66 Right
67 (functorToMaybe ga)
68 where
69 uncast = fmap (error "bad FunctorToMaybe instance")
diff --git a/lib/Hosts.hs b/lib/Hosts.hs
new file mode 100644
index 0000000..5f09de1
--- /dev/null
+++ b/lib/Hosts.hs
@@ -0,0 +1,314 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE OverloadedStrings #-}
4#if ! MIN_VERSION_network(2,4,0)
5{-# LANGUAGE StandaloneDeriving #-}
6#endif
7module Hosts
8 ( Hosts
9 , assignName
10 , assignName'
11 , assignNewName
12 , removeName
13 , inet_pton
14 , inet_ntop
15 , empty
16 , hasName
17 , hasAddr
18 , encode
19 , decode
20 , diff
21 , plus
22 , filterAddrs
23 , namesForAddress
24 ) where
25
26import Data.Maybe
27import Data.Monoid ( (<>) )
28import Data.List as List (foldl', (\\) )
29import Data.Ord
30import Data.Char (isSpace)
31import qualified Data.Map as Map
32import Data.Map (Map)
33import qualified Data.ByteString.Lazy.Char8 as L
34import System.IO.Unsafe (unsafePerformIO)
35import Control.Applicative ( (<$>), (<*>) )
36import Control.Monad (mplus)
37import Network.Socket
38import ControlMaybe ( handleIO_ )
39
40#if ! MIN_VERSION_network(2,4,0)
41deriving instance Ord SockAddr
42#endif
43
44inet_pton :: String -> Maybe SockAddr
45inet_pton p = n
46 where
47 n = unsafePerformIO $ do
48 handleIO_ (return Nothing) $ do
49 info <- getAddrInfo safe_hints (Just p) Nothing
50 return $ fmap addrAddress $ listToMaybe info
51 safe_hints = Just $ defaultHints { addrFlags=[AI_NUMERICHOST] }
52
53inet_ntop :: SockAddr -> String
54inet_ntop n = p
55 where
56 p = case show n of
57 '[':xs -> fst $ break (==']') xs
58 xs -> fst $ break (==':') xs
59
60
61data Hosts = Hosts
62 { lineCount :: Int
63 , numline :: Map Int L.ByteString
64 , namenum :: Map L.ByteString [Int]
65 , addrnum :: Map SockAddr Int
66 }
67
68instance Show Hosts where
69 show = L.unpack . encode
70
71encode :: Hosts -> L.ByteString
72encode = L.unlines . map snd . Map.assocs . numline
73
74parseLine :: L.ByteString -> (Maybe SockAddr, [L.ByteString])
75parseLine s = (addr,names)
76 where
77 (addr0,names) = splitAt 1 $ L.words (uncom s)
78 addr = do
79 a <- fmap L.unpack $ listToMaybe addr0
80 n <- inet_pton a
81 return $ n -- inet_ntop n
82
83 uncom s = fst $ L.break (=='#') s
84
85empty :: Hosts
86empty = Hosts { lineCount = 0
87 , numline = Map.empty
88 , addrnum = Map.empty
89 , namenum = Map.empty
90 }
91
92{-
93parseHosts fname = do
94 input <- L.readFile fname
95 return $ decode input
96-}
97
98decode :: L.ByteString -> Hosts
99decode input =
100 let ls = L.lines input
101 ans = map (\l->(parseLine l,l)) ls
102 hosts = foldl' upd empty ans
103 upd hosts ((addr,names),line) = hosts
104 { lineCount = count
105 , numline = Map.insert count line (numline hosts)
106 , addrnum = maybeInsert (addrnum hosts) addr
107 , namenum = foldl' (\m x->Map.alter (cons count) x m)
108 (namenum hosts)
109 names
110 }
111 where count = lineCount hosts + 1
112 cons v xs = Just $ maybe [v] (v:) xs
113 maybeInsert m x = maybe m
114 (\x->Map.insert x count m)
115 x
116 in hosts
117
118
119hasName :: L.ByteString -> Hosts -> Bool
120hasName name hosts = Map.member name $ namenum hosts
121
122hasAddr :: SockAddr -> Hosts -> Bool
123hasAddr addr hosts = Map.member addr $ addrnum hosts
124
125scrubName ::
126 ([L.ByteString] -> [L.ByteString]) -> L.ByteString -> L.ByteString
127scrubName f line = line'
128 where
129 (x,ign) = L.break (=='#') line
130 ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x
131 where oo = (.) . (.)
132 (a,ws') = splitAt 2 ws
133 ws'' = f ws'
134 line' = if null ws''
135 then if length a==2 then "" -- "# " <> L.concat a <> ign
136 else line
137 else if length a==2
138 then L.concat (a ++ ws'') <> ign
139 else let vs = L.groupBy ( (==EQ) `oo` comparing isSpace) $ L.dropWhile isSpace
140 $ L.tail ign
141 where oo = (.) . (.)
142 (a',vs') = splitAt 2 vs
143 vs'' = L.concat vs'
144 vs''' = if L.take 1 vs'' `elem` ["#",""]
145 then vs''
146 else "# " <> vs''
147 in L.concat (a'++ws'') <> vs'''
148
149assignName :: SockAddr -> L.ByteString -> Hosts -> Hosts
150assignName addr name hosts = assignName' False addr name hosts
151
152chaddr :: Int -> SockAddr -> Hosts -> Hosts
153chaddr n addr hosts =
154 hosts { addrnum = Map.insert addr n (addrnum hosts)
155 , numline = Map.adjust re n (numline hosts) }
156 where
157 re line = if length a==2
158 then L.pack (inet_ntop addr) <> " " <> L.concat ws' <> ign
159 else line
160 where (x,ign) = L.break (=='#') line
161 ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x
162 where oo = (.) . (.)
163 (a,ws') = splitAt 2 ws
164
165isLonerName line = length ws' <= 2
166 where (x,_) = L.break (=='#') line
167 ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x
168 where oo = (.) . (.)
169 (_,ws') = splitAt 2 ws
170
171scrubTrailingEmpties :: Hosts -> Hosts
172scrubTrailingEmpties hosts =
173 hosts { lineCount = cnt'
174 , numline = foldl' (flip Map.delete) (numline hosts) es
175 }
176 where
177 cnt = lineCount hosts
178 es = takeWhile (\n -> Map.lookup n (numline hosts) == Just "")
179 $ [cnt,cnt-1..]
180 cnt' = cnt - length es
181
182cannonizeName :: L.ByteString -> L.ByteString -> L.ByteString
183cannonizeName name line = scrubName f line
184 where
185 f ws = [name," "] ++ pre ++ drop 2 rst
186 where
187 (pre,rst) = break (==name) ws
188
189removeName name hosts = hosts'
190 where
191 hosts' = scrubTrailingEmpties (maybe hosts (removeName0 name hosts) ns)
192 ns = Map.lookup name (namenum hosts)
193
194
195removeName0 name hosts nums = hosts
196 { namenum = Map.delete name (namenum hosts)
197 , numline = foldl' scrub (numline hosts) nums
198 }
199 where scrub m num = Map.adjust (scrubName $ filter (/=name)) num m
200
201assignName' :: Bool -> SockAddr -> L.ByteString -> Hosts -> Hosts
202assignName' iscannon addr name hosts = hosts'
203 where
204 ns = Map.lookup name (namenum hosts)
205 a = Map.lookup addr (addrnum hosts)
206 canonize numline n = Map.adjust (cannonizeName name) n numline
207 hosts' = do
208 if (== Just True) $ elem <$> a <*> ns
209 then if not iscannon then hosts -- address already has name, nothing to do
210 else hosts { numline = foldl' canonize (numline hosts) $ fromJust ns}
211 else
212 let hosts0 = -- remove name if it's present
213 scrubTrailingEmpties $ maybe hosts (removeName0 name hosts) ns
214 ns' = fmap (filter $
215 isLonerName
216 . fromJust
217 . (\n -> Map.lookup n (numline hosts)))
218 ns
219 >>= listToMaybe
220 hosts1 = -- insert name, or add new line
221 maybe (maybe (newLine hosts0)
222 (\n -> chaddr n addr $ appendName iscannon name hosts0 n)
223 ns')
224 (appendName iscannon name hosts0)
225 a
226 in hosts1
227 newLine hosts = hosts
228 { lineCount = cnt
229 , numline = Map.insert cnt line $ numline hosts
230 , addrnum = Map.insert addr cnt $ addrnum hosts
231 , namenum = Map.alter (cons cnt) name $ namenum hosts
232 }
233 where cnt = lineCount hosts + 1
234 line = L.pack (inet_ntop addr) <> " " <> name
235 cons v xs = Just $ maybe [v] (v:) xs
236
237assignNewName :: SockAddr -> L.ByteString -> Hosts -> Hosts
238assignNewName addr name hosts =
239 if hasName name hosts then hosts
240 else assignName' True addr name hosts
241
242appendName :: Bool -> L.ByteString -> Hosts -> Int -> Hosts
243appendName iscannon name hosts num = hosts
244 { numline = Map.adjust (scrubName f) num (numline hosts)
245 , namenum = Map.alter (cons num) name (namenum hosts)
246 }
247 where f ws = if iscannon
248 then [name, " "] ++ ws
249 else let rs = reverse ws
250 (sp,rs') = span (L.any isSpace) rs
251 in reverse $ sp ++ [name," "] ++ rs'
252 cons v xs = Just $ maybe [v] (v:) xs
253
254-- Returns a list of bytestrings intended to show the
255-- differences between the two host databases. It is
256-- assumed that no lines are deleted, only altered or
257-- appended.
258diff :: Hosts -> Hosts -> [L.ByteString]
259diff as bs = cs
260 where
261 [as',bs'] = map (L.lines . Hosts.encode) [as,bs]
262 ext xs = map Just xs ++ repeat Nothing
263 ds = takeWhile (isJust . uncurry mplus) $ zip (ext as') (ext bs')
264 es = filter (uncurry (/=)) ds
265 cs = do
266 (a,b) <- es
267 [a,b] <- return $ map maybeToList [a,b]
268 fmap ("- " <>) a ++ fmap ("+ " <>) b
269
270namesForAddress :: SockAddr -> Hosts -> [L.ByteString]
271namesForAddress addr hosts = snd $ _namesForAddress addr hosts
272
273_namesForAddress :: SockAddr -> Hosts -> (Int, [L.ByteString])
274_namesForAddress addr (Hosts {numline=numline, addrnum=addrnum}) = ns
275 where
276 ns = maybe (-1,[]) id $ do
277 n <- Map.lookup addr addrnum
278 line <- Map.lookup n numline
279 return (n, snd $ parseLine line)
280
281
282plus :: Hosts -> Hosts -> Hosts
283plus a b = Map.foldlWithKey' mergeAddr a (addrnum b)
284 where
285 mergeAddr a addr bnum = a'
286 where
287 (anum,ns) = _namesForAddress addr a
288 bs = maybe [] (List.\\ ns) $ do
289 line <- Map.lookup bnum (numline b)
290 return . snd $ parseLine line
291 a' = if anum/=(-1) then foldl' app a $ reverse bs
292 else newLine a
293 app a b = appendName True b a anum -- True to allow b to reassign cannonical name
294 newLine hosts = hosts
295 { lineCount = cnt
296 , numline = Map.insert cnt line $ numline hosts
297 , addrnum = Map.insert addr cnt $ addrnum hosts
298 , namenum = foldl' updnamenum (namenum hosts) bs
299 }
300 where cnt = lineCount hosts + 1
301 line = L.pack (inet_ntop addr) <> " " <> L.intercalate " " bs
302 cons v xs = Just $ maybe [v] (v:) xs
303 updnamenum m name = Map.alter (cons cnt) name m
304
305filterAddrs :: (SockAddr -> Bool) -> Hosts -> Hosts
306filterAddrs pred hosts = hosts'
307 where
308 als = Map.toList (addrnum hosts)
309 nl = foldl' f (numline hosts) als
310 f m (addr,num) = if pred addr
311 then m
312 else Map.adjust (scrubName $ const []) num m
313 lines = L.unlines . Map.elems $ nl
314 hosts' = decode lines
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
new file mode 100644
index 0000000..0fbf2c2
--- /dev/null
+++ b/lib/KeyRing.hs
@@ -0,0 +1,3505 @@
1---------------------------------------------------------------------------
2-- |
3-- Module : KeyRing
4--
5-- Maintainer : joe@jerkface.net
6-- Stability : experimental
7--
8-- kiki is a command-line utility for manipulating GnuPG's keyring files. This
9-- module is the programmer-facing API it uses to do that.
10--
11-- Note: This is *not* a public facing API. I (the author) consider this
12-- library to be internal to kiki and subject to change at my whim.
13--
14-- Typically, a client to this module would prepare a 'KeyRingOperation'
15-- describing what he wants done, and then invoke 'runKeyRing' to make it
16-- happen.
17{-# LANGUAGE CPP #-}
18{-# LANGUAGE TupleSections #-}
19{-# LANGUAGE ViewPatterns #-}
20{-# LANGUAGE OverloadedStrings #-}
21{-# LANGUAGE DeriveFunctor #-}
22{-# LANGUAGE DoAndIfThenElse #-}
23{-# LANGUAGE NoPatternGuards #-}
24{-# LANGUAGE ForeignFunctionInterface #-}
25module KeyRing
26 (
27 -- * Error Handling
28 KikiResult(..)
29 , KikiCondition(..)
30 , KikiReportAction(..)
31 , errorString
32 , reportString
33 -- * Manipulating Keyrings
34 , runKeyRing
35 , KeyRingOperation(..)
36 , PassphraseSpec(..)
37 , Transform(..)
38 -- , PacketUpdate(..)
39 -- , guardAuthentic
40 -- * Describing File Operations
41 , StreamInfo(..)
42 , Access(..)
43 , FileType(..)
44 , InputFile(..)
45 , KeyFilter(..)
46 -- * Results of a KeyRing Operation
47 , KeyRingRuntime(..)
48 , MappedPacket(..)
49 , KeyDB
50 , KeyData(..)
51 , SubKey(..)
52 , packet
53 , locations
54 , keyflags
55 -- * Miscelaneous Utilities
56 , isKey
57 , derRSA
58 , derToBase32
59 , backsig
60 , filterMatches
61 , flattenKeys
62 , flattenTop
63 , Hosts.Hosts
64 , isCryptoCoinKey
65 , matchpr
66 , parseSpec
67 , parseUID
68 , UserIDRecord(..)
69 , pkcs8
70 , RSAPublicKey(..)
71 , PKCS8_RSAPublicKey(..)
72 , rsaKeyFromPacket
73 , secretToPublic
74 , selectPublicKey
75 , selectSecretKey
76 , usage
77 , usageString
78 , walletImportFormat
79 , writePEM
80 , getBindings
81 , accBindings
82 , isSubkeySignature
83 , torhash
84 , ParsedCert(..)
85 , parseCertBlob
86 , packetFromPublicRSAKey
87 , decodeBlob
88 , selectPublicKeyAndSigs
89 , x509cert
90 , getHomeDir
91 , unconditionally
92 , SecretPEMData(..)
93 , readSecretPEMFile
94 , writeInputFileL
95 , InputFileContext(..)
96 , onionNameForContact
97 , keykey
98 , keyPacket
99 , KeySpec(..)
100 , getHostnames
101 , secretPemFromPacket
102 , getCrossSignedSubkeys
103 ) where
104
105import System.Environment
106import Control.Monad
107import Data.Maybe
108import Data.Either
109import Data.Char
110import Data.Ord
111import Data.List
112import Data.OpenPGP
113import Data.Functor
114import Data.Monoid
115import Data.Tuple ( swap )
116import Data.Bits ( (.|.), (.&.) )
117import Control.Applicative ( Applicative, pure, liftA2, (<*>) )
118import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
119import Control.Arrow ( first, second )
120import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign)
121import Data.ByteString.Lazy ( ByteString )
122import Text.Show.Pretty as PP ( ppShow )
123import Data.Binary {- decode, decodeOrFail -}
124import ControlMaybe ( handleIO_ )
125import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
126 , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) )
127import Data.ASN1.BitArray ( BitArray(..), toBitArray )
128import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
129import Data.ASN1.BinaryEncoding ( DER(..) )
130import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds )
131import Data.Time.Clock ( UTCTime )
132import Data.Bits ( Bits, shiftR )
133import Data.Text.Encoding ( encodeUtf8 )
134import qualified Data.Map as Map
135import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile
136 , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt
137 , index, break, pack )
138import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, hPutStr, singleton, unfoldr, reverse )
139import qualified Codec.Binary.Base32 as Base32
140import qualified Codec.Binary.Base64 as Base64
141#if !defined(VERSION_cryptonite)
142import qualified Crypto.Hash.SHA1 as SHA1
143import qualified Crypto.Types.PubKey.ECC as ECC
144#else
145import qualified Crypto.Hash as Vincent
146import Data.ByteArray (convert)
147import qualified Crypto.PubKey.ECC.Types as ECC
148#endif
149import qualified Data.X509 as X509
150import qualified Crypto.PubKey.RSA as RSA
151import qualified Codec.Compression.GZip as GZip
152import qualified Data.Text as T ( Text, unpack, pack,
153 strip, reverse, drop, break, dropAround, length )
154import qualified System.Posix.Types as Posix
155import System.Posix.Files ( modificationTime, getFileStatus, getFdStatus
156 , setFileCreationMask, setFileTimes )
157#if MIN_VERSION_x509(1,5,0)
158import Data.Hourglass.Types
159import Data.Hourglass
160#endif
161#if MIN_VERSION_unix(2,7,0)
162import System.Posix.Files ( setFdTimesHiRes )
163import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
164#else
165import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
166import Foreign.Marshal.Array ( withArray )
167import Foreign.Ptr
168import Foreign.C.Error ( throwErrnoIfMinus1_ )
169import Foreign.Storable
170#endif
171import System.FilePath ( takeDirectory )
172import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr)
173import Data.IORef
174import System.Posix.IO ( fdToHandle )
175import qualified Data.Traversable as Traversable
176import Data.Traversable ( sequenceA )
177#if ! MIN_VERSION_base(4,6,0)
178import GHC.Exts ( Down(..) )
179#endif
180#if MIN_VERSION_binary(0,7,0)
181import Debug.Trace
182#endif
183import Network.Socket -- (SockAddr)
184import qualified Data.ByteString.Lazy.Char8 as Char8
185import Compat
186
187import TimeUtil
188import PEM
189import ScanningParser
190import qualified Hosts
191import qualified CryptoCoins
192import Base58
193import FunctorToMaybe
194import DotLock
195import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
196
197-- DER-encoded elliptic curve ids
198-- nistp256_id = 0x2a8648ce3d030107
199secp256k1_id :: Integer
200secp256k1_id = 0x2b8104000a
201-- "\x2a\x86\x48\xce\x3d\x03\x01\x07"
202{- OID Curve description Curve name
203 ----------------------------------------------------------------
204 1.2.840.10045.3.1.7 NIST Curve P-256 [FIPS 186-2] "NIST P-256"
205 1.3.132.0.34 NIST Curve P-384 [FIPS 186-2] "NIST P-384"
206 1.3.132.0.35 NIST Curve P-521 [FIPS 186-2] "NIST P-521"
207
208 Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST
209 P-521". The hexadecimal representation used in the public and
210 private key encodings are:
211
212 Curve Name Len Hexadecimal representation of the OID
213 ----------------------------------------------------------------
214 "NIST P-256" 8 0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07
215 "NIST P-384" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x22
216 "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23
217-}
218
219data HomeDir =
220 HomeDir { homevar :: String
221 , appdir :: String
222 , optfile_alts :: [String]
223 }
224
225home :: HomeDir
226home = HomeDir
227 { homevar = "GNUPGHOME"
228 , appdir = ".gnupg"
229 , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
230 }
231
232data InputFile = HomeSec
233 -- ^ A file named secring.gpg located in the home directory.
234 -- See 'opHome'.
235 | HomePub
236 -- ^ A file named pubring.gpg located in the home directory.
237 -- See 'opHome'.
238 | ArgFile FilePath
239 -- ^ Contents will be read or written from the specified path.
240 | FileDesc Posix.Fd
241 -- ^ Contents will be read or written from the specified file
242 -- descriptor.
243 | Pipe Posix.Fd Posix.Fd
244 -- ^ Contents will be read from the first descriptor and updated
245 -- content will be writen to the second. Note: Don't use Pipe
246 -- for 'Wallet' files. (TODO: Wallet support)
247 deriving (Eq,Ord,Show)
248
249-- type UsageTag = String
250type Initializer = String
251
252data FileType = KeyRingFile
253 | PEMFile
254 | WalletFile
255 | DNSPresentation
256 | Hosts
257 deriving (Eq,Ord,Enum,Show)
258
259-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected
260-- to contain secret or public PGP key packets. Note that it is not supported
261-- to mix both in the same file and that the secret key packets include all of
262-- the information contained in their corresponding public key packets.
263data Access = AutoAccess -- ^ secret or public as appropriate based on existing content.
264 -- (see 'rtRingAccess')
265 | Sec -- ^ secret information
266 | Pub -- ^ public information
267 deriving (Eq,Ord,Show)
268
269-- | Note that the documentation here is intended for when this value is
270-- assigned to 'fill'. For other usage, see 'spill'.
271data KeyFilter = KF_None -- ^ No keys will be imported.
272 | KF_Match String -- ^ Only the key that matches the spec will be imported.
273 | KF_Subkeys -- ^ Subkeys will be imported if their owner key is
274 -- already in the ring. TODO: Even if their signatures
275 -- are bad?
276 | KF_Authentic -- ^ Keys are imported if they belong to an authenticated
277 -- identity (signed or self-authenticating).
278 | KF_All -- ^ All keys will be imported.
279 deriving (Eq,Ord,Show)
280
281-- | This type describes how 'runKeyRing' will treat a file.
282data StreamInfo = StreamInfo
283 { access :: Access
284 -- ^ Indicates whether the file is allowed to contain secret information.
285 , typ :: FileType
286 -- ^ Indicates the format and content type of the file.
287 , fill :: KeyFilter
288 -- ^ This filter controls what packets will be inserted into a file.
289 , spill :: KeyFilter
290 --
291 -- ^ Use this to indicate whether or not a file's contents should be
292 -- available for updating other files. Note that although its type is
293 -- 'KeyFilter', it is usually interpretted as a boolean flag. Details
294 -- depend on 'typ' and are as follows:
295 --
296 -- 'KeyRingFile':
297 --
298 -- * 'KF_None' - The file's contents will not be shared.
299 --
300 -- * otherwise - The file's contents will be shared.
301 --
302 -- 'PEMFile':
303 --
304 -- * 'KF_None' - The file's contents will not be shared.
305 --
306 -- * 'KF_Match' - The file's key will be shared with the specified owner
307 -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be
308 -- equal to this value; changing the usage or owner of a key is not
309 -- supported via the fill/spill mechanism.
310 --
311 -- * otherwise - Unspecified. Do not use.
312 --
313 -- 'WalletFile':
314 --
315 -- * The 'spill' setting is ignored and the file's contents are shared.
316 -- (TODO)
317 --
318 -- 'Hosts':
319 --
320 -- * The 'spill' setting is ignored and the file's contents are shared.
321 -- (TODO)
322 --
323 , initializer :: Maybe String
324 -- ^ If 'typ' is 'PEMFile' and an 'initializer' string is set, then it is
325 -- interpretted as a shell command that may be used to create the key if it
326 -- does not exist.
327 , transforms :: [Transform]
328 -- ^ Per-file transformations that occur before the contents of a file are
329 -- spilled into the common pool.
330 }
331 deriving (Eq,Show)
332
333
334spillable :: StreamInfo -> Bool
335spillable (spill -> KF_None) = False
336spillable _ = True
337
338isMutable :: StreamInfo -> Bool
339isMutable (fill -> KF_None) = False
340isMutable _ = True
341
342isring :: FileType -> Bool
343isring (KeyRingFile {}) = True
344isring _ = False
345
346isSecretKeyFile :: FileType -> Bool
347isSecretKeyFile PEMFile = True
348isSecretKeyFile DNSPresentation = True
349isSecretKeyFile _ = False
350
351{-
352pwfile :: FileType -> Maybe InputFile
353pwfile (KeyRingFile f) = f
354pwfile _ = Nothing
355-}
356
357iswallet :: FileType -> Bool
358iswallet (WalletFile {}) = True
359iswallet _ = False
360
361usageFromFilter :: MonadPlus m => KeyFilter -> m String
362usageFromFilter (KF_Match usage) = return usage
363usageFromFilter _ = mzero
364
365data KeyRingRuntime = KeyRingRuntime
366 { rtPubring :: FilePath
367 -- ^ Path to the file represented by 'HomePub'
368 , rtSecring :: FilePath
369 -- ^ Path to the file represented by 'HomeSec'
370 , rtGrip :: Maybe String
371 -- ^ Fingerprint or portion of a fingerprint used
372 -- to identify the working GnuPG identity used to
373 -- make signatures.
374 , rtWorkingKey :: Maybe Packet
375 -- ^ The master key of the working GnuPG identity.
376 , rtKeyDB :: KeyDB
377 -- ^ The common information pool where files spilled
378 -- their content and from which they received new
379 -- content.
380 , rtRingAccess :: Map.Map InputFile Access
381 -- ^ The 'Access' values used for files of type
382 -- 'KeyRingFile'. If 'AutoAccess' was specified
383 -- for a file, this 'Map.Map' will indicate the
384 -- detected value that was used by the algorithm.
385 , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet)
386 }
387
388-- | Roster-entry level actions
389data PacketUpdate = InducerSignature String [SignatureSubpacket]
390 | SubKeyDeletion KeyKey KeyKey
391
392-- | This type is used to indicate where to obtain passphrases.
393data PassphraseSpec = PassphraseSpec
394 { passSpecRingFile :: Maybe FilePath
395 -- ^ If not Nothing, the passphrase is to be used for packets
396 -- from this file.
397 , passSpecKeySpec :: Maybe String
398 -- ^ Non-Nothing value reserved for future use.
399 -- (TODO: Use this to implement per-key passphrase associations).
400 , passSpecPassFile :: InputFile
401 -- ^ The passphrase will be read from this file or file descriptor.
402 }
403 -- | Use this to carry pasphrases from a previous run.
404 | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet))
405
406instance Show PassphraseSpec where
407 show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
408 show (PassphraseMemoizer _) = "PassphraseMemoizer"
409instance Eq PassphraseSpec where
410 PassphraseSpec a b c == PassphraseSpec d e f
411 = and [a==d,b==e,c==f]
412 _ == _
413 = False
414
415
416
417data Transform =
418 Autosign
419 -- ^ This operation will make signatures for any tor-style UID
420 -- that matches a tor subkey and thus can be authenticated without
421 -- requring the judgement of a human user.
422 --
423 -- A tor-style UID is one of the following form:
424 --
425 -- > Anonymous <root@HOSTNAME.onion>
426 | DeleteSubKey String
427 -- ^ Delete the subkey specified by the given fingerprint and any
428 -- associated signatures on that key.
429 deriving (Eq,Ord,Show)
430
431-- | This type describes an idempotent transformation (merge or import) on a
432-- set of GnuPG keyrings and other key files.
433data KeyRingOperation = KeyRingOperation
434 { opFiles :: Map.Map InputFile StreamInfo
435 -- ^ Indicates files to be read or updated.
436 , opPassphrases :: [PassphraseSpec]
437 -- ^ Indicates files or file descriptors where passphrases can be found.
438 , opTransforms :: [Transform]
439 -- ^ Transformations to be performed on the key pool after all files have
440 -- been read and before any have been written.
441 , opHome :: Maybe FilePath
442 -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub'
443 -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted
444 -- and if that is not set, it falls back to $HOME/.gnupg.
445 }
446 deriving (Eq,Show)
447
448resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
449resolveInputFile ctx = resolve
450 where
451 resolve HomeSec = return (homesecPath ctx)
452 resolve HomePub = return (homepubPath ctx)
453 resolve (ArgFile f) = return f
454 resolve _ = []
455
456resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
457resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
458 where str = case (fdr,fdw) of
459 (0,1) -> "-"
460 _ -> "&pipe" ++ show (fdr,fdw)
461resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
462 where str = "&" ++ show fd
463resolveForReport mctx f = concat $ resolveInputFile ctx f
464 where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx
465
466filesToLock ::
467 KeyRingOperation -> InputFileContext -> [FilePath]
468filesToLock k ctx = do
469 (f,stream) <- Map.toList (opFiles k)
470 case fill stream of
471 KF_None -> []
472 _ -> resolveInputFile ctx f
473
474
475-- kret :: a -> KeyRingOperation a
476-- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x)
477
478data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
479data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show
480
481pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey
482pkcs8 (RSAKey n e) = RSAKey8 n e
483
484instance ASN1Object RSAPublicKey where
485 -- PKCS #1 RSA Public Key
486 toASN1 (RSAKey (MPI n) (MPI e))
487 = \xs -> Start Sequence
488 : IntVal n
489 : IntVal e
490 : End Sequence
491 : xs
492 fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) =
493 Right (RSAKey (MPI n) (MPI e), xs)
494
495 fromASN1 _ =
496 Left "fromASN1: RSAPublicKey: unexpected format"
497
498instance ASN1Object PKCS8_RSAPublicKey where
499
500 -- PKCS #8 Public key data
501 toASN1 (RSAKey8 (MPI n) (MPI e))
502 = \xs -> Start Sequence
503 : Start Sequence
504 : OID [1,2,840,113549,1,1,1]
505 : Null -- Doesn't seem to be neccessary, but i'm adding it
506 -- to match PEM files I see in the wild.
507 : End Sequence
508 : BitString (toBitArray bs 0)
509 : End Sequence
510 : xs
511 where
512 pubkey = [ Start Sequence, IntVal n, IntVal e, End Sequence ]
513 bs = encodeASN1' DER pubkey
514
515 fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
516 Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs)
517 fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:Null:End Sequence:BitString b:End Sequence:xs) =
518 case decodeASN1' DER bs of
519 Right as -> fromASN1 as
520 Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
521 where
522 BitArray _ bs = b
523 fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) =
524 case decodeASN1' DER bs of
525 Right as -> fromASN1 as
526 Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
527 where
528 BitArray _ bs = b
529
530 fromASN1 _ =
531 Left "fromASN1: RSAPublicKey: unexpected format"
532
533{-
534RSAPrivateKey ::= SEQUENCE {
535 version Version,
536 modulus INTEGER, -- n
537 publicExponent INTEGER, -- e
538 privateExponent INTEGER, -- d
539 prime1 INTEGER, -- p
540 prime2 INTEGER, -- q
541 exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1)
542 exponent2 INTEGER, -- d mod (q-1)
543 coefficient INTEGER, -- (inverse of q) mod p
544 otherPrimeInfos OtherPrimeInfos OPTIONAL
545 }
546-}
547data RSAPrivateKey = RSAPrivateKey
548 { rsaN :: MPI
549 , rsaE :: MPI
550 , rsaD :: MPI
551 , rsaP :: MPI
552 , rsaQ :: MPI
553 , rsaDmodP1 :: MPI
554 , rsaDmodQminus1 :: MPI
555 , rsaCoefficient :: MPI
556 }
557 deriving Show
558
559instance ASN1Object RSAPrivateKey where
560 toASN1 rsa@(RSAPrivateKey {})
561 = \xs -> Start Sequence
562 : IntVal 0
563 : mpiVal rsaN
564 : mpiVal rsaE
565 : mpiVal rsaD
566 : mpiVal rsaP
567 : mpiVal rsaQ
568 : mpiVal rsaDmodP1
569 : mpiVal rsaDmodQminus1
570 : mpiVal rsaCoefficient
571 : End Sequence
572 : xs
573 where mpiVal f = IntVal x where MPI x = f rsa
574
575 fromASN1 ( Start Sequence
576 : IntVal _ -- version
577 : IntVal n
578 : IntVal e
579 : IntVal d
580 : IntVal p
581 : IntVal q
582 : IntVal dmodp1
583 : IntVal dmodqminus1
584 : IntVal coefficient
585 : ys) =
586 Right ( privkey, tail $ dropWhile notend ys)
587 where
588 notend (End Sequence) = False
589 notend _ = True
590 privkey = RSAPrivateKey
591 { rsaN = MPI n
592 , rsaE = MPI e
593 , rsaD = MPI d
594 , rsaP = MPI p
595 , rsaQ = MPI q
596 , rsaDmodP1 = MPI dmodp1
597 , rsaDmodQminus1 = MPI dmodqminus1
598 , rsaCoefficient = MPI coefficient
599 }
600 fromASN1 _ =
601 Left "fromASN1: RSAPrivateKey: unexpected format"
602
603
604
605-- | This type is used to indicate success or failure
606-- and in the case of success, return the computed object.
607-- The 'FunctorToMaybe' class is implemented to facilitate
608-- branching on failture.
609data KikiCondition a = KikiSuccess a
610 | FailedToLock [FilePath]
611 | BadPassphrase
612 | FailedToMakeSignature
613 | CantFindHome
614 | AmbiguousKeySpec FilePath
615 | CannotImportMasterKey
616 | NoWorkingKey
617 deriving ( Functor, Show )
618
619instance FunctorToMaybe KikiCondition where
620 functorToMaybe (KikiSuccess a) = Just a
621 functorToMaybe _ = Nothing
622
623instance Applicative KikiCondition where
624 pure a = KikiSuccess a
625 f <*> a =
626 case functorToEither f of
627 Right f -> case functorToEither a of
628 Right a -> pure (f a)
629 Left err -> err
630 Left err -> err
631
632-- | This type is used to describe events triggered by 'runKeyRing'. In
633-- addition to normal feedback (e.g. 'NewPacket'), it also may indicate
634-- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a
635-- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with
636-- many inputs and outputs, an operation may be partially (or even mostly)
637-- successful even when I/O failures occured. In this situation, the files may
638-- not have all the information they were intended to store, but they will be
639-- in a valid format for GnuPG or kiki to operate on in the future.
640data KikiReportAction =
641 NewPacket String
642 | MissingPacket String
643 | ExportedSubkey
644 | GeneratedSubkeyFile
645 | NewWalletKey String
646 | YieldSignature
647 | YieldSecretKeyPacket String
648 | UnableToUpdateExpiredSignature
649 | WarnFailedToMakeSignature
650 | FailedExternal Int
651 | ExternallyGeneratedFile
652 | UnableToExport KeyAlgorithm String
653 | FailedFileWrite
654 | HostsDiff ByteString
655 | DeletedPacket String
656 deriving Show
657
658uncamel :: String -> String
659uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
660 where
661 (.:) = fmap . fmap
662 ( firstWord ,
663 otherWords ) = splitAt 1 ws
664 ws = camel >>= groupBy (\_ c -> isLower c)
665 ( camel, args) = splitAt 1 $ words str
666
667reportString :: KikiReportAction -> String
668reportString x = uncamel $ show x
669
670errorString :: KikiCondition a -> String
671errorString (KikiSuccess {}) = "success"
672errorString e = uncamel . show $ fmap (const ()) e
673
674-- | Errors in kiki are indicated by the returning of this record.
675data KikiResult a = KikiResult
676 { kikiCondition :: KikiCondition a
677 -- ^ The result or a fatal error condition.
678 , kikiReport :: KikiReport
679 -- ^ A list of non-fatal warnings and informational messages
680 -- along with the files that triggered them.
681 }
682
683type KikiReport = [ (FilePath, KikiReportAction) ]
684
685keyPacket :: KeyData -> Packet
686keyPacket (KeyData k _ _ _) = packet k
687
688subkeyMappedPacket :: SubKey -> MappedPacket
689subkeyMappedPacket (SubKey k _ ) = k
690
691
692usage :: SignatureSubpacket -> Maybe String
693usage (NotationDataPacket
694 { human_readable = True
695 , notation_name = "usage@"
696 , notation_value = u
697 }) = Just u
698usage _ = Nothing
699
700x509cert :: SignatureSubpacket -> Maybe Char8.ByteString
701x509cert (NotationDataPacket
702 { human_readable = False
703 , notation_name = "x509cert@"
704 , notation_value = u
705 }) = Just (Char8.pack u)
706x509cert _ = Nothing
707
708makeInducerSig
709 :: Packet
710 -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
711-- torsig g topk wkun uid timestamp extras = todo
712makeInducerSig topk wkun uid extras
713 = CertificationSignature (secretToPublic topk)
714 uid
715 (sigpackets 0x13
716 subpackets
717 subpackets_unh)
718 where
719 subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
720 tsign
721 ++ extras
722 subpackets_unh = [IssuerPacket (fingerprint wkun)]
723 tsign = if keykey wkun == keykey topk
724 then [] -- tsign doesnt make sense for self-signatures
725 else [ TrustSignaturePacket 1 120
726 , RegularExpressionPacket regex]
727 -- <[^>]+[@.]asdf\.nowhere>$
728 regex = "<[^>]+[@.]"++hostname++">$"
729 -- regex = username ++ "@" ++ hostname
730 -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
731 hostname = subdomain' pu ++ "\\." ++ topdomain' pu
732 pu = parseUID uidstr where UserIDPacket uidstr = uid
733 subdomain' = escape . T.unpack . uid_subdomain
734 topdomain' = escape . T.unpack . uid_topdomain
735 escape s = concatMap echar s
736 where
737 echar '|' = "\\|"
738 echar '*' = "\\*"
739 echar '+' = "\\+"
740 echar '?' = "\\?"
741 echar '.' = "\\."
742 echar '^' = "\\^"
743 echar '$' = "\\$"
744 echar '\\' = "\\\\"
745 echar '[' = "\\["
746 echar ']' = "\\]"
747 echar c = [c]
748
749
750keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
751keyflags flgs@(KeyFlagsPacket {}) =
752 Just . toEnum $
753 ( bit 0x1 certify_keys
754 .|. bit 0x2 sign_data
755 .|. bit 0x4 encrypt_communication
756 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
757 -- other flags:
758 -- split_key
759 -- authentication (ssh-client)
760 -- group_key
761 where
762 bit v f = if f flgs then v else 0
763keyflags _ = Nothing
764
765
766data PGPKeyFlags =
767 Special
768 | Vouch -- Signkey
769 | Sign
770 | VouchSign
771 | Communication
772 | VouchCommunication
773 | SignCommunication
774 | VouchSignCommunication
775 | Storage
776 | VouchStorage
777 | SignStorage
778 | VouchSignStorage
779 | Encrypt
780 | VouchEncrypt
781 | SignEncrypt
782 | VouchSignEncrypt
783 deriving (Eq,Show,Read,Enum)
784
785
786usageString :: PGPKeyFlags -> String
787usageString flgs =
788 case flgs of
789 Special -> "special"
790 Vouch -> "vouch" -- signkey
791 Sign -> "sign"
792 VouchSign -> "vouch-sign"
793 Communication -> "communication"
794 VouchCommunication -> "vouch-communication"
795 SignCommunication -> "sign-communication"
796 VouchSignCommunication -> "vouch-sign-communication"
797 Storage -> "storage"
798 VouchStorage -> "vouch-storage"
799 SignStorage -> "sign-storage"
800 VouchSignStorage -> "vouch-sign-storage"
801 Encrypt -> "encrypt"
802 VouchEncrypt -> "vouch-encrypt"
803 SignEncrypt -> "sign-encrypt"
804 VouchSignEncrypt -> "vouch-sign-encrypt"
805
806
807
808
809-- matchpr computes the fingerprint of the given key truncated to
810-- be the same lenght as the given fingerprint for comparison.
811matchpr :: String -> Packet -> String
812matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
813
814keyFlags :: t -> [Packet] -> [SignatureSubpacket]
815keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
816
817keyFlags0 :: t -> [Packet] -> [SignatureSubpacket]
818keyFlags0 wkun uidsigs = concat
819 [ keyflags
820 , preferredsym
821 , preferredhash
822 , preferredcomp
823 , features ]
824
825 where
826 subs = concatMap hashed_subpackets uidsigs
827 keyflags = filterOr isflags subs $
828 KeyFlagsPacket { certify_keys = True
829 , sign_data = True
830 , encrypt_communication = False
831 , encrypt_storage = False
832 , split_key = False
833 , authentication = False
834 , group_key = False
835 }
836 preferredsym = filterOr ispreferedsym subs $
837 PreferredSymmetricAlgorithmsPacket
838 [ AES256
839 , AES192
840 , AES128
841 , CAST5
842 , TripleDES
843 ]
844 preferredhash = filterOr ispreferedhash subs $
845 PreferredHashAlgorithmsPacket
846 [ SHA256
847 , SHA1
848 , SHA384
849 , SHA512
850 , SHA224
851 ]
852 preferredcomp = filterOr ispreferedcomp subs $
853 PreferredCompressionAlgorithmsPacket
854 [ ZLIB
855 , BZip2
856 , ZIP
857 ]
858 features = filterOr isfeatures subs $
859 FeaturesPacket { supports_mdc = True
860 }
861
862 filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
863
864 isflags (KeyFlagsPacket {}) = True
865 isflags _ = False
866 ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
867 ispreferedsym _ = False
868 ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
869 ispreferedhash _ = False
870 ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
871 ispreferedcomp _ = False
872 isfeatures (FeaturesPacket {}) = True
873 isfeatures _ = False
874
875
876matchSpec :: KeySpec -> KeyData -> Bool
877matchSpec (KeyGrip grip) (KeyData p _ _ _)
878 | matchpr grip (packet p)==grip = True
879 | otherwise = False
880
881matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
882 where
883 ps = map (packet .fst) sigs
884 match p = isSignaturePacket p
885 && has_tag tag p
886 && has_issuer key p
887 has_issuer key p = isJust $ do
888 issuer <- signature_issuer p
889 guard $ matchpr issuer key == issuer
890 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
891 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
892
893matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
894 where
895 us = filter (isInfixOf pat) $ Map.keys uids
896
897data UserIDRecord = UserIDRecord {
898 uid_full :: String,
899 uid_realname :: T.Text,
900 uid_user :: T.Text,
901 uid_subdomain :: T.Text,
902 uid_topdomain :: T.Text
903}
904 deriving Show
905
906parseUID :: String -> UserIDRecord
907parseUID str = UserIDRecord {
908 uid_full = str,
909 uid_realname = realname,
910 uid_user = user,
911 uid_subdomain = subdomain,
912 uid_topdomain = topdomain
913 }
914 where
915 text = T.pack str
916 (T.strip-> realname, T.dropAround isBracket-> email)
917 = T.break (=='<') text
918 (user, T.drop 1-> hostname) = T.break (=='@') email
919 ( T.reverse -> topdomain,
920 T.reverse . T.drop 1 -> subdomain)
921 = T.break (=='.') . T.reverse $ hostname
922isBracket :: Char -> Bool
923isBracket '<' = True
924isBracket '>' = True
925isBracket _ = False
926
927
928
929
930data KeySpec =
931 KeyGrip String -- fp:
932 | KeyTag Packet String -- fp:????/t:
933 | KeyUidMatch String -- u:
934 deriving Show
935
936data MatchingField = UserIDField | KeyTypeField deriving (Show,Eq,Ord,Enum)
937data SingleKeySpec = FingerprintMatch String
938 | SubstringMatch (Maybe MatchingField) String
939 | EmptyMatch
940 | AnyMatch
941 | WorkingKeyMatch
942 deriving (Show,Eq,Ord)
943
944-- A pair of specs. The first specifies an identity and the second
945-- specifies a specific key (possibly master) associated with that
946-- identity.
947--
948-- When no slash is specified, context will decide whether the SingleKeySpec
949-- is specifying an identity or a key belonging to the working identity.
950type Spec = (SingleKeySpec,SingleKeySpec)
951
952parseSingleSpec :: String -> SingleKeySpec
953parseSingleSpec "*" = AnyMatch
954parseSingleSpec "-" = WorkingKeyMatch
955parseSingleSpec "" = EmptyMatch
956parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag
957parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag
958parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
959parseSingleSpec str
960 | is40digitHex str = FingerprintMatch str
961 | otherwise = SubstringMatch Nothing str
962
963is40digitHex xs = ys == xs && length ys==40
964 where
965 ys = filter ishex xs
966 ishex c | '0' <= c && c <= '9' = True
967 | 'A' <= c && c <= 'F' = True
968 | 'a' <= c && c <= 'f' = True
969 ishex c = False
970
971
972 -- t:tor -- (FingerprintMatch "", SubstringMatch "tor")
973 -- u:joe -- (SubstringMatch "joe", FingerprintMatch "")
974 -- u:joe/ -- (SubstringMatch "joe", FingerprintMatch "!")
975 -- fp:4A39F/tor -- (FingerprintMatch "4A39F", SubstringMatch "tor")
976 -- u:joe/tor -- (SubstringMatch "joe", SubstringMatch "tor")
977 -- u:joe/t:tor -- (SubstringMatch "joe", SubstringMatch "tor")
978 -- u:joe/fp:4abf30 -- (SubstringMatch "joe", FingerprintMatch "4abf30")
979 -- joe/tor -- (SubstringMatch "joe", SubstringMatch "tor")
980
981-- | Parse a key specification.
982-- The first argument is a grip for the default working key.
983parseSpec :: String -> String -> (KeySpec,Maybe String)
984parseSpec wkgrip spec =
985 if not slashed
986 then
987 case prespec of
988 AnyMatch -> (KeyGrip "", Nothing)
989 EmptyMatch -> error "Bad key spec."
990 WorkingKeyMatch -> (KeyGrip wkgrip, Nothing)
991 SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag)
992 SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str)
993 SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing)
994 FingerprintMatch fp -> (KeyGrip fp, Nothing)
995 else
996 case (prespec,postspec) of
997 (FingerprintMatch fp, SubstringMatch st t)
998 | st /= Just UserIDField -> (KeyGrip fp, Just t)
999 (SubstringMatch mt u, _)
1000 | postspec `elem` [AnyMatch,EmptyMatch]
1001 && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing)
1002 (SubstringMatch mt u, SubstringMatch st t)
1003 | mt /= Just KeyTypeField
1004 && st /= Just UserIDField -> (KeyUidMatch u, Just t)
1005 (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec"
1006 (_,FingerprintMatch fp) -> error "todo: support /fp: spec"
1007 (FingerprintMatch fp,_) -> error "todo: support fp:/ spec"
1008 _ -> error "Bad key spec."
1009 where
1010 (preslash,slashon) = break (=='/') spec
1011 slashed = not $ null $ take 1 slashon
1012 postslash = drop 1 slashon
1013
1014 prespec = parseSingleSpec preslash
1015 postspec = parseSingleSpec postslash
1016
1017{-
1018 - BUGGY
1019parseSpec grip spec = (topspec,subspec)
1020 where
1021 (topspec0,subspec0) = unprefix '/' spec
1022 (toptyp,top) = unprefix ':' topspec0
1023 (subtyp,sub) = unprefix ':' subspec0
1024 topspec = case () of
1025 _ | null top && or [ subtyp=="fp"
1026 , null subtyp && is40digitHex sub
1027 ]
1028 -> KeyGrip sub
1029 _ | null top && null grip -> KeyUidMatch sub
1030 _ | null top -> KeyGrip grip
1031 _ | toptyp=="fp" || (null toptyp && is40digitHex top)
1032 -> KeyGrip top
1033 _ | toptyp=="u" -> KeyUidMatch top
1034 _ -> KeyUidMatch top
1035 subspec = case subtyp of
1036 "t" -> Just sub
1037 "fp" | top=="" -> Nothing
1038 "" | top=="" && is40digitHex sub -> Nothing
1039 "" -> listToMaybe sub >> Just sub
1040 _ -> Nothing
1041
1042 is40digitHex xs = ys == xs && length ys==40
1043 where
1044 ys = filter ishex xs
1045 ishex c | '0' <= c && c <= '9' = True
1046 | 'A' <= c && c <= 'F' = True
1047 | 'a' <= c && c <= 'f' = True
1048 ishex c = False
1049
1050 -- | Split a string into two at the first occurance of the given
1051 -- delimiter. If the delimeter does not occur, then the first
1052 -- item of the returned pair is empty and the second item is the
1053 -- input string.
1054 unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
1055 where p = break (==c) spec
1056-}
1057
1058
1059filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
1060filterMatches spec ks = filter (matchSpec spec . snd) ks
1061
1062filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData
1063filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs'
1064 where
1065 matchAll = KeyGrip ""
1066
1067 subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip)
1068 subkeySpec (topspec,Just mtag) = (topspec , KeyTag (packet p) mtag)
1069
1070 match spec mps
1071 = not . null
1072 . snd
1073 . seek_key spec
1074 . map packet
1075 $ mps
1076
1077 old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub)
1078
1079 oldOrMatch spec sub = old sub
1080 || match spec (flattenSub "" True sub)
1081
1082 subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty)
1083 then oldOrMatch subspec
1084 else old)
1085 subs
1086 where
1087 (topspec,subspec) = subkeySpec spec
1088
1089selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1090selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
1091
1092selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1093selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
1094
1095selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])]
1096selectPublicKeyAndSigs (spec,mtag) db =
1097 case mtag of
1098 Nothing -> do
1099 (kk,r) <- Map.toList $ fmap (findbyspec spec) db
1100 (sub,sigs) <- r
1101 return (kk,sub,sigs)
1102 Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag
1103 where
1104 topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)
1105
1106 findbyspec (KeyGrip g) kd = do
1107 filter ismatch $
1108 topresult kd
1109 : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs))
1110 (Map.elems $ keySubKeys kd)
1111 where
1112 ismatch (p,sigs) = matchpr g p ==g
1113 findbyspec spec kd = if matchSpec spec kd then [topresult kd] else []
1114
1115 findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag
1116 where
1117 gettag (SubKey sub sigs) = do
1118 let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs
1119 (hastag,_) <- maybeToList mb
1120 guard hastag
1121 return $ (kk, packet sub, map (packet . fst) sigs)
1122
1123selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1124selectKey0 wantPublic (spec,mtag) db = do
1125 let Message ps = flattenKeys wantPublic db
1126 ys = snd $ seek_key spec ps
1127 flip (maybe (listToMaybe ys)) mtag $ \tag -> do
1128 case ys of
1129 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
1130 [] -> Nothing
1131
1132{-
1133selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)]
1134selectAll wantPublic (spec,mtag) db = do
1135 let Message ps = flattenKeys wantPublic db
1136 ys = snd $ seek_key spec ps
1137 y <- take 1 ys
1138 case mtag of
1139 Nothing -> return (y,Nothing)
1140 Just tag ->
1141 let search ys1 = do
1142 let zs = snd $ seek_key (KeyTag y tag) ys1
1143 z <- take 1 zs
1144 (y,Just z):search (drop 1 zs)
1145 in search (drop 1 ys)
1146-}
1147
1148seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
1149seek_key (KeyGrip grip) sec = (pre, subs)
1150 where
1151 (pre,subs) = break pred sec
1152 pred p@(SecretKeyPacket {}) = matchpr grip p == grip
1153 pred p@(PublicKeyPacket {}) = matchpr grip p == grip
1154 pred _ = False
1155
1156seek_key (KeyTag key tag) ps
1157 | null bs = (ps, [])
1158 | null qs =
1159 let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
1160 (as ++ (head bs : as'), bs')
1161 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
1162 where
1163 (as,bs) = break (\p -> isSignaturePacket p
1164 && has_tag tag p
1165 && isJust (signature_issuer p)
1166 && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
1167 ps
1168 (rs,qs) = break isKey (reverse as)
1169
1170 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
1171 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
1172
1173seek_key (KeyUidMatch pat) ps
1174 | null bs = (ps, [])
1175 | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
1176 (as ++ (head bs : as'), bs')
1177 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
1178 where
1179 (as,bs) = break (isInfixOf pat . uidStr) ps
1180 (rs,qs) = break isKey (reverse as)
1181
1182 uidStr (UserIDPacket s) = s
1183 uidStr _ = ""
1184
1185
1186data InputFileContext = InputFileContext
1187 { homesecPath :: FilePath
1188 , homepubPath :: FilePath
1189 }
1190
1191readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
1192readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents
1193readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
1194readInputFileS ctx inp = do
1195 let fname = resolveInputFile ctx inp
1196 fmap S.concat $ mapM S.readFile fname
1197
1198readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString
1199readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents
1200readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents
1201readInputFileL ctx inp = do
1202 let fname = resolveInputFile ctx inp
1203 fmap L.concat $ mapM L.readFile fname
1204
1205
1206writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs)
1207writeInputFileL ctx (FileDesc fd) bs = fdToHandle fd >>= (`L.hPut` bs)
1208writeInputFileL ctx inp bs = do
1209 let fname = resolveInputFile ctx inp
1210 mapM_ (`L.writeFile` bs) fname
1211
1212-- writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO ()
1213-- writeStamped0 :: InputFileContext -> InputFile
1214
1215getWriteFD :: InputFile -> Maybe Posix.Fd
1216getWriteFD (Pipe _ fd) = Just fd
1217getWriteFD (FileDesc fd) = Just fd
1218getWriteFD _ = Nothing
1219
1220writeStamped0 :: InputFileContext
1221 -> InputFile
1222 -> Posix.EpochTime
1223 -> (Either Handle FilePath -> t -> IO ())
1224 -> t
1225 -> IO ()
1226writeStamped0 ctx (getWriteFD -> Just fd) stamp dowrite bs = do
1227 h <- fdToHandle fd
1228 dowrite (Left h) bs
1229 handleIO_ (return ())
1230 $ setFdTimesHiRes fd (realToFrac stamp) (realToFrac stamp)
1231writeStamped0 ctx inp stamp dowrite bs = do
1232 let fname = resolveInputFile ctx inp
1233 forM_ fname $ \fname -> do
1234 createDirectoryIfMissing True $ takeDirectory fname
1235 dowrite (Right fname) bs
1236 setFileTimes fname stamp stamp
1237
1238{- This may be useful later. Commented for now, as it is not used.
1239 -
1240writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO ()
1241writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs
1242-}
1243
1244writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO ()
1245writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str
1246
1247getInputFileTime :: InputFileContext -> InputFile -> IO CTime
1248getInputFileTime ctx (Pipe fdr fdw) = do
1249 mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr
1250 maybe tryw return mt
1251 where
1252 tryw = do
1253 handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?")
1254 $ modificationTime <$> getFdStatus fdw
1255getInputFileTime ctx (FileDesc fd) = do
1256 handleIO_ (error $ "&"++show fd++": modificaiton time?") $
1257 modificationTime <$> getFdStatus fd
1258getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do
1259 handleIO_ (error $ fname++": modificaiton time?") $
1260 modificationTime <$> getFileStatus fname
1261
1262{-
1263 - This may be useful later. Commented for now as it is not used.
1264 -
1265doesInputFileExist :: InputFileContext -> InputFile -> IO Bool
1266doesInputFileExist ctx f = do
1267 case resolveInputFile ctx f of
1268 [n] -> doesFileExist n
1269 _ -> return True
1270-}
1271
1272
1273cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
1274cachedContents maybePrompt ctx fd = do
1275 ref <- newIORef Nothing
1276 return $ get maybePrompt ref fd
1277 where
1278 trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
1279
1280 get maybePrompt ref fd = do
1281 pw <- readIORef ref
1282 flip (flip maybe return) pw $ do
1283 if fd == FileDesc 0 then case maybePrompt of
1284 Just prompt -> S.hPutStr stderr prompt
1285 Nothing -> return ()
1286 else return ()
1287 pw <- fmap trimCR $ readInputFileS ctx fd
1288 writeIORef ref (Just pw)
1289 return pw
1290
1291importSecretKey ::
1292 (MappedPacket -> IO (KikiCondition Packet))
1293 -> KikiCondition
1294 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
1295 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
1296 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
1297importSecretKey doDecrypt db' tup = do
1298 try db' $ \(db',report0) -> do
1299 r <- doImport doDecrypt
1300 db'
1301 tup
1302 try r $ \(db'',report) -> do
1303 return $ KikiSuccess (db'', report0 ++ report)
1304
1305
1306mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
1307 -> IO
1308 (KikiCondition
1309 ( ( Map.Map [Char8.ByteString] KeyData
1310 , ( [Hosts.Hosts]
1311 , [Hosts.Hosts]
1312 , Hosts.Hosts
1313 , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))]
1314 , [SockAddr]))
1315 , [(FilePath,KikiReportAction)]))
1316mergeHostFiles krd db ctx = do
1317 let hns = files ishosts
1318 ishosts Hosts = True
1319 ishosts _ = False
1320 files istyp = do
1321 (f,stream) <- Map.toList (opFiles krd)
1322 guard (istyp $ typ stream)
1323 return f
1324
1325 hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL ctx) hns
1326
1327 let gpgnames = map getHostnames $ Map.elems db
1328 os = do
1329 (addr,(ns,_)) <- gpgnames
1330 n <- ns
1331 return (addr,n)
1332 setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
1333 -- we ensure .onion names are set properly
1334 hostdbs = map setOnions hostdbs0
1335 outgoing_names = do
1336 (addr,(_,gns)) <- gpgnames
1337 guard . not $ null gns
1338 guard $ all (null . Hosts.namesForAddress addr) hostdbs0
1339 return addr
1340 -- putStrLn $ "hostdbs = " ++ show hostdbs
1341
1342 -- 1. let U = union all the host dbs
1343 -- preserving whitespace and comments of the first
1344 let u0 = foldl' Hosts.plus Hosts.empty hostdbs
1345 -- we filter U to be only finger-dresses
1346 u1 = Hosts.filterAddrs (hasFingerDress db) u0
1347
1348 -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
1349 {-
1350 putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}"
1351 putStrLn $ "--> " ++ show (nf (head hostdbs))
1352 putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
1353 putStrLn $ "--> " ++ show (nf u0)
1354 putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
1355 putStrLn $ "--> " ++ show (nf u1)
1356 -}
1357
1358 -- 2. replace gpg annotations with those in U
1359 -- forM use_db
1360 db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db
1361
1362 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[])
1363
1364writeHostsFiles
1365 :: KeyRingOperation -> InputFileContext
1366 -> ([Hosts.Hosts],
1367 [Hosts.Hosts],
1368 Hosts.Hosts,
1369 [(SockAddr, (t1, [Char8.ByteString]))],
1370 [SockAddr])
1371 -> IO [(FilePath, KikiReportAction)]
1372writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
1373 let hns = files isMutableHosts
1374 isMutableHosts (fill -> KF_None) = False
1375 isMutableHosts (typ -> Hosts) = True
1376 isMutableHosts _ = False
1377 files istyp = do
1378 (f,stream) <- Map.toList (opFiles krd)
1379 guard (istyp stream)
1380 return f -- resolveInputFile ctx f
1381
1382 -- 3. add hostnames from gpg for addresses not in U
1383 let u = foldl' f u1 ans
1384 ans = reverse $ do
1385 (addr,(_,ns)) <- gpgnames
1386 guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0
1387 n <- ns
1388 return (addr,n)
1389 f h (addr,n) = Hosts.assignNewName addr n h
1390
1391 -- 4. for each host db H, union H with U and write it out as H'
1392 -- only if there is a non-empty diff
1393 rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do
1394 let h = h1 `Hosts.plus` u
1395 d = Hosts.diff h0 h
1396 rs = map ((fname,) . HostsDiff) d
1397 unless (null d) $ writeInputFileL ctx fname $ Hosts.encode h
1398 return $ map (first $ resolveForReport $ Just ctx) rs
1399 return $ concat rss
1400
1401isSecretKey :: Packet -> Bool
1402isSecretKey (SecretKeyPacket {}) = True
1403isSecretKey _ = False
1404
1405buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
1406 -> IO (KikiCondition ((KeyDB
1407 ,Maybe String
1408 ,Maybe MappedPacket
1409 ,([Hosts.Hosts],
1410 [Hosts.Hosts],
1411 Hosts.Hosts,
1412 [(SockAddr, (KeyKey, KeyKey))],
1413 [SockAddr])
1414 ,Map.Map InputFile Access
1415 ,MappedPacket -> IO (KikiCondition Packet)
1416 ,Map.Map InputFile Message
1417 )
1418 ,[(FilePath,KikiReportAction)]))
1419buildKeyDB ctx grip0 keyring = do
1420 let
1421 files isring = do
1422 (f,stream) <- Map.toList (opFiles keyring)
1423 guard (isring $ typ stream)
1424 resolveInputFile ctx f
1425
1426 ringMap = Map.filter (isring . typ) $ opFiles keyring
1427
1428 readp f stream = fmap readp0 $ readPacketsFromFile ctx f
1429 where
1430 readp0 ps = (stream { access = acc' }, ps)
1431 where acc' = case access stream of
1432 AutoAccess ->
1433 case ps of
1434 Message ((PublicKeyPacket {}):_) -> Pub
1435 Message ((SecretKeyPacket {}):_) -> Sec
1436 _ -> AutoAccess
1437 acc -> acc
1438
1439 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
1440
1441 -- KeyRings (todo: KikiCondition reporting?)
1442 (spilled,mwk,grip,accs,keys,unspilled) <- do
1443#if MIN_VERSION_containers(0,5,0)
1444 ringPackets <- Map.traverseWithKey readp ringMap
1445#else
1446 ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap
1447#endif
1448 let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)
1449
1450 let grip = grip0 `mplus` (fingerprint <$> fstkey)
1451 where
1452 fstkey = do
1453 (_,Message ps) <- Map.lookup HomeSec ringPackets
1454 listToMaybe ps
1455 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
1456 keys :: Map.Map KeyKey MappedPacket
1457 keys = Map.foldl slurpkeys Map.empty
1458 $ Map.mapWithKey filterSecrets ringPackets
1459 where
1460 filterSecrets f (_,Message ps) =
1461 filter (isSecretKey . packet)
1462 $ zipWith (mappedPacketWithHint fname) ps [1..]
1463 where fname = resolveForReport (Just ctx) f
1464 slurpkeys m ps = m `Map.union` Map.fromList ps'
1465 where ps' = zip (map (keykey . packet) ps) ps
1466 wk = listToMaybe $ do
1467 fp <- maybeToList grip
1468 let matchfp mp = not (is_subkey p) && matchpr fp p == fp
1469 where p = packet mp
1470 Map.elems $ Map.filter matchfp keys
1471 accs = fmap (access . fst) ringPackets
1472 return (spilled,wk,grip,accs,keys,fmap snd unspilled)
1473
1474 doDecrypt <- makeMemoizingDecrypter keyring ctx keys
1475
1476 let wk = fmap packet mwk
1477 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
1478 , rtSecring = homesecPath ctx
1479 , rtGrip = grip
1480 , rtWorkingKey = wk
1481 , rtRingAccess = accs
1482 , rtKeyDB = Map.empty
1483 , rtPassphrases = doDecrypt
1484 }
1485 transformed0 <-
1486 let trans f (info,ps) = do
1487 let manip = combineTransforms (transforms info)
1488 rt1 = rt0 { rtKeyDB = merge Map.empty f ps }
1489 acc = Just Sec /= Map.lookup f accs
1490 r <- performManipulations doDecrypt rt1 mwk manip
1491 try r $ \(rt2,report) -> do
1492 return $ KikiSuccess (report,(info,flattenKeys acc $ rtKeyDB rt2))
1493#if MIN_VERSION_containers(0,5,0)
1494 in fmap sequenceA $ Map.traverseWithKey trans spilled
1495#else
1496 in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled
1497#endif
1498 try transformed0 $ \transformed -> do
1499 let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
1500 where
1501 mergeIt db f (_,(info,ps)) = merge db f ps
1502 reportTrans = concat $ Map.elems $ fmap fst transformed
1503
1504 -- Wallets
1505 let importWalletKey wk db' (top,fname,sub,tag) = do
1506 try db' $ \(db',report0) -> do
1507 r <- doImportG doDecrypt
1508 db'
1509 (fmap keykey $ maybeToList wk)
1510 [mkUsage tag]
1511 fname
1512 sub
1513 try r $ \(db'',report) -> do
1514 return $ KikiSuccess (db'', report0 ++ report)
1515
1516 wms <- mapM (readw wk) (files iswallet)
1517 let wallet_keys = do
1518 maybeToList wk
1519 (fname,xs) <- wms
1520 (_,sub,(_,m)) <- xs
1521 (tag,top) <- Map.toList m
1522 return (top,fname,sub,tag)
1523 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
1524 try db $ \(db,reportWallets) -> do
1525
1526 -- PEM files
1527 let pems = do
1528 (n,stream) <- Map.toList $ opFiles keyring
1529 grip <- maybeToList grip
1530 n <- resolveInputFile ctx n
1531 guard $ spillable stream && isSecretKeyFile (typ stream)
1532 let us = mapMaybe usageFromFilter [fill stream,spill stream]
1533 usage <- take 1 us
1534 guard $ all (==usage) $ drop 1 us
1535 -- TODO: KikiCondition reporting for spill/fill usage mismatch?
1536 let (topspec,subspec) = parseSpec grip usage
1537 ms = map fst $ filterMatches topspec (Map.toList db)
1538 cmd = initializer stream
1539 return (n,subspec,ms,stream, cmd)
1540 imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems
1541 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports
1542 try db $ \(db,reportPEMs) -> do
1543
1544 r <- mergeHostFiles keyring db ctx
1545 try r $ \((db,hs),reportHosts) -> do
1546
1547 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled)
1548 , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts )
1549
1550torhash :: Packet -> String
1551torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
1552
1553derToBase32 :: ByteString -> String
1554#if !defined(VERSION_cryptonite)
1555derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
1556#else
1557derToBase32 = map toLower . Base32.encode . S.unpack . sha1
1558 where
1559 sha1 :: L.ByteString -> S.ByteString
1560 sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
1561#endif
1562
1563derRSA :: Packet -> Maybe ByteString
1564derRSA rsa = do
1565 k <- rsaKeyFromPacket rsa
1566 return $ encodeASN1 DER (toASN1 k [])
1567
1568unconditionally :: IO (KikiCondition a) -> IO a
1569unconditionally action = do
1570 r <- action
1571 case r of
1572 KikiSuccess x -> return x
1573 e -> error $ errorString e
1574
1575try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
1576try x body =
1577 case functorToEither x of
1578 Left e -> return e
1579 Right x -> body x
1580
1581
1582data ParsedCert = ParsedCert
1583 { pcertKey :: Packet
1584 , pcertTimestamp :: UTCTime
1585 , pcertBlob :: L.ByteString
1586 }
1587 deriving (Show,Eq)
1588data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
1589 deriving (Show,Eq)
1590
1591spemPacket (PEMPacket p) = Just p
1592spemPacket _ = Nothing
1593
1594spemCert (PEMCertificate p) = Just p
1595spemCert _ = Nothing
1596
1597toStrict :: L.ByteString -> S.ByteString
1598toStrict = foldr1 (<>) . L.toChunks
1599
1600-- No instance for (ASN1Object RSA.PublicKey)
1601
1602parseCertBlob comp bs = do
1603 asn1 <- either (const Nothing) Just
1604 $ decodeASN1 DER bs
1605 let asn1' = drop 2 asn1
1606 cert <- either (const Nothing) (Just . fst) (fromASN1 asn1')
1607 let _ = cert :: X509.Certificate
1608 notBefore :: UTCTime
1609#if MIN_VERSION_x509(1,5,0)
1610 notBefore = toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano
1611 where (vincentTime,_) = X509.certValidity cert
1612#else
1613 (notBefore,_) = X509.certValidity cert
1614#endif
1615 case X509.certPubKey cert of
1616 X509.PubKeyRSA key -> do
1617 let withoutkey =
1618 let ekey = toStrict $ encodeASN1 DER (toASN1 key [])
1619 (pre,post) = S.breakSubstring ekey $ toStrict bs
1620 post' = S.drop (S.length ekey) post
1621 len :: Word16
1622 len = if S.null post then maxBound
1623 else fromIntegral $ S.length pre
1624 in if len < 4096
1625 then encode len <> GZip.compress (Char8.fromChunks [pre,post'])
1626 else bs
1627 return
1628 ParsedCert { pcertKey = packetFromPublicRSAKey notBefore
1629 (MPI $ RSA.public_n key)
1630 (MPI $ RSA.public_e key)
1631 , pcertTimestamp = notBefore
1632 , pcertBlob = if comp then withoutkey
1633 else bs
1634 }
1635 _ -> Nothing
1636
1637packetFromPublicRSAKey notBefore n e =
1638 PublicKeyPacket { version = 4
1639 , timestamp = round $ utcTimeToPOSIXSeconds notBefore
1640 , key_algorithm = RSA
1641 , key = [('n',n),('e',e)]
1642 , is_subkey = True
1643 , v3_days_of_validity = Nothing
1644 }
1645
1646decodeBlob cert =
1647 if 0 /= (bs `L.index` 0) .&. 0x10
1648 then bs
1649 else let (keypos0,bs') = L.splitAt 2 bs
1650 keypos :: Word16
1651 keypos = decode keypos0
1652 ds = GZip.decompress bs'
1653 (prekey,postkey) = L.splitAt (fromIntegral keypos) ds
1654 in prekey <> key <> postkey
1655 where
1656 bs = pcertBlob cert
1657 key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert
1658
1659extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey
1660extractRSAKeyFields kvs = do
1661 let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs
1662 n <- lookup "Modulus" kvs'
1663 e <- lookup "PublicExponent" kvs'
1664 d <- lookup "PrivateExponent" kvs'
1665 p <- lookup "Prime1" kvs' -- p
1666 q <- lookup "Prime2" kvs' -- q
1667 dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1)
1668 dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1)
1669 u <- lookup "Coefficient" kvs'
1670 {-
1671 case (d,p,dmodp1) of
1672 (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return ()
1673 _ -> error "dmodp fail!"
1674 case (d,q,dmodqminus1) of
1675 (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return ()
1676 _ -> error "dmodq fail!"
1677 -}
1678 return $ RSAPrivateKey
1679 { rsaN = n
1680 , rsaE = e
1681 , rsaD = d
1682 , rsaP = p
1683 , rsaQ = q
1684 , rsaDmodP1 = dmodp1
1685 , rsaDmodQminus1 = dmodqminus1
1686 , rsaCoefficient = u }
1687 where
1688 parseField blob = MPI <$> m
1689 where m = bigendian <$> Base64.decode (Char8.unpack blob)
1690
1691 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
1692 where
1693 nlen = length bs
1694
1695rsaToPGP stamp rsa = SecretKeyPacket
1696 { version = 4
1697 , timestamp = fromTime stamp -- toEnum (fromEnum stamp)
1698 , key_algorithm = RSA
1699 , key = [ -- public fields...
1700 ('n',rsaN rsa)
1701 ,('e',rsaE rsa)
1702 -- secret fields
1703 ,('d',rsaD rsa)
1704 ,('p',rsaQ rsa) -- Note: p & q swapped
1705 ,('q',rsaP rsa) -- Note: p & q swapped
1706 ,('u',rsaCoefficient rsa)
1707 ]
1708 -- , ecc_curve = def
1709 , s2k_useage = 0
1710 , s2k = S2K 100 ""
1711 , symmetric_algorithm = Unencrypted
1712 , encrypted_data = ""
1713 , is_subkey = True
1714 }
1715
1716readSecretDNSFile :: InputFile -> IO Packet
1717readSecretDNSFile fname = do
1718 let ctx = InputFileContext "" ""
1719 stamp <- getInputFileTime ctx fname
1720 input <- readInputFileL ctx fname
1721 let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1)
1722 . Char8.break (==':'))
1723 $ Char8.lines input
1724 alg = maybe RSA parseAlg $ lookup "Algorithm" kvs
1725 parseAlg spec = case Char8.words spec of
1726 nstr:_ -> case read (Char8.unpack nstr) :: Int of
1727 2 -> DH
1728 3 -> DSA -- SHA1
1729 5 -> RSA -- SHA1
1730 6 -> DSA -- NSEC3-SHA1 (RFC5155)
1731 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155)
1732 8 -> RSA -- SHA256
1733 10 -> RSA -- SHA512 (RFC5702)
1734 -- 12 -> GOST
1735 13 -> ECDSA -- P-256 SHA256 (RFC6605)
1736 14 -> ECDSA -- P-384 SHA384 (RFC6605)
1737 _ -> RSA
1738 case alg of
1739 RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs
1740
1741
1742readSecretPEMFile :: InputFile -> IO [SecretPEMData]
1743readSecretPEMFile fname = do
1744 -- warn $ fname ++ ": reading ..."
1745 let ctx = InputFileContext "" ""
1746 -- Note: The key's timestamp is included in it's fingerprint.
1747 -- Therefore, we should attempt to preserve it.
1748 stamp <- getInputFileTime ctx fname
1749 input <- readInputFileL ctx fname
1750 let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
1751 pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
1752 $ pemParser $ Just "RSA PRIVATE KEY"
1753 cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
1754 $ pemParser $ Just "CERTIFICATE"
1755 parseRSAPrivateKey dta = do
1756 let e = decodeASN1 DER dta
1757 asn1 <- either (const $ mzero) return e
1758 rsa <- either (const mzero) (return . fst) (fromASN1 asn1)
1759 let _ = rsa :: RSAPrivateKey
1760 return $ PEMPacket $ rsaToPGP stamp rsa
1761 dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
1762 mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
1763 mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
1764 where key' = if tm < fromTime (timestamp key)
1765 then key { timestamp = fromTime tm }
1766 else key
1767 mergeDate (tm,_) (Right mb) = (tm,mb)
1768 return $ dta
1769
1770doImport
1771 :: Ord k =>
1772 (MappedPacket -> IO (KikiCondition Packet))
1773 -> Map.Map k KeyData
1774 -> (FilePath, Maybe [Char], [k], StreamInfo, t)
1775 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
1776doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
1777 flip (maybe $ return CannotImportMasterKey)
1778 subspec $ \tag -> do
1779 (certs,keys) <- case typ of
1780 PEMFile -> do
1781 ps <- readSecretPEMFile (ArgFile fname)
1782 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
1783 = partition (isJust . spemCert) ps
1784 return (certs,keys)
1785 DNSPresentation -> do
1786 p <- readSecretDNSFile (ArgFile fname)
1787 return ([],[p])
1788 -- TODO Probably we need to move to a new design where signature
1789 -- packets are merged into the database in one phase with null
1790 -- signatures, and then the signatures are made in the next phase.
1791 -- This would let us merge annotations (like certificates) from
1792 -- seperate files.
1793 foldM (importKey tag certs) (KikiSuccess (db,[])) keys
1794 where
1795 importKey tag certs prior key = do
1796 try prior $ \(db,report) -> do
1797 let (m0,tailms) = splitAt 1 ms
1798 if (not (null tailms) || null m0)
1799 then return $ AmbiguousKeySpec fname
1800 else do
1801 let kk = keykey key
1802 cs = filter (\c -> kk==keykey (pcertKey c)) certs
1803 blobs = map mkCertNotation $ nub $ map pcertBlob cs
1804 mkCertNotation bs = NotationDataPacket
1805 { human_readable = False
1806 , notation_name = "x509cert@"
1807 , notation_value = Char8.unpack bs }
1808 datedKey = key { timestamp = fromTime $ minimum dates }
1809 dates = fromTime (timestamp key) : map pcertTimestamp certs
1810 r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey
1811 try r $ \(db',report') -> do
1812 return $ KikiSuccess (db',report++report')
1813
1814doImportG
1815 :: Ord k =>
1816 (MappedPacket -> IO (KikiCondition Packet))
1817 -> Map.Map k KeyData
1818 -> [k]
1819 -> [SignatureSubpacket]
1820 -> [Char]
1821 -> Packet
1822 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
1823doImportG doDecrypt db m0 tags fname key = do
1824 let kk = head m0
1825 Just (KeyData top topsigs uids subs) = Map.lookup kk db
1826 subkk = keykey key
1827 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
1828 [])
1829 ( (False,) . addOrigin )
1830 (Map.lookup subkk subs)
1831 where
1832 addOrigin (SubKey mp sigs) =
1833 let mp' = mp
1834 { locations = Map.insert fname
1835 (origin (packet mp) (-1))
1836 (locations mp) }
1837 in SubKey mp' sigs
1838 subs' = Map.insert subkk subkey subs
1839
1840 istor = do
1841 guard ("tor" `elem` mapMaybe usage tags)
1842 return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
1843
1844 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
1845 let has_torid = do
1846 -- TODO: check for omitted real name field
1847 (sigtrusts,om) <- Map.lookup idstr uids
1848 listToMaybe $ do
1849 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
1850 signatures_over $ verify (Message [packet top]) s
1851 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
1852 wkun <- doDecrypt top
1853
1854 try wkun $ \wkun -> do
1855
1856 let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
1857 uid = UserIDPacket idstr
1858 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
1859 tor_ov = makeInducerSig (packet top) wkun uid keyflags
1860 sig_ov <- pgpSign (Message [wkun])
1861 tor_ov
1862 SHA1
1863 (fingerprint wkun)
1864 flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)]))
1865 (sig_ov >>= listToMaybe . signatures_over)
1866 $ \sig -> do
1867 let om = Map.singleton fname (origin sig (-1))
1868 trust = Map.empty
1869 return $ KikiSuccess
1870 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
1871 , trust)],om) uids
1872 , [] )
1873
1874 try uids' $ \(uids',report) -> do
1875
1876 let SubKey subkey_p subsigs = subkey
1877 wk = packet top
1878 (xs',minsig,ys') = findTag tags wk key subsigs
1879 doInsert mbsig db = do
1880 -- NEW SUBKEY BINDING SIGNATURE
1881 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig
1882 try sig' $ \(sig',report) -> do
1883 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
1884 let subs' = Map.insert subkk
1885 (SubKey subkey_p $ xs'++[sig']++ys')
1886 subs
1887 return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
1888 , report )
1889
1890 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
1891 else id
1892 s = show (fmap fst minsig,fingerprint key)
1893 in return (f report)
1894
1895 case minsig of
1896 Nothing -> doInsert Nothing db -- we need to create a new sig
1897 Just (True,sig) -> -- we can deduce is_new == False
1898 -- we may need to add a tor id
1899 return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
1900 , report )
1901 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
1902
1903isCryptoCoinKey :: Packet -> Bool
1904isCryptoCoinKey p =
1905 and [ isKey p
1906 , key_algorithm p == ECDSA
1907 , lookup 'c' (key p) == Just (MPI secp256k1_id)
1908 ]
1909
1910getCryptoCoinTag :: Packet -> Maybe CryptoCoins.CoinNetwork
1911getCryptoCoinTag p | isSignaturePacket p = do
1912 -- CryptoCoins.secret
1913 let sps = hashed_subpackets p ++ unhashed_subpackets p
1914 u <- listToMaybe $ mapMaybe usage sps
1915 CryptoCoins.lookupNetwork CryptoCoins.network_name u
1916getCryptoCoinTag _ = Nothing
1917
1918
1919coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPacket)]
1920coinKeysOwnedBy db wk = do
1921 wk <- maybeToList wk
1922 let kk = keykey wk
1923 KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db
1924 (subkk,SubKey mp sigs) <- Map.toList subs
1925 let sub = packet mp
1926 guard $ isCryptoCoinKey sub
1927 tag <- take 1 $ mapMaybe (getCryptoCoinTag . packet . fst) sigs
1928 return (tag,mp)
1929
1930walletImportFormat :: Word8 -> Packet -> String
1931walletImportFormat idbyte k = secret_base58_foo
1932 where
1933 -- isSecret (SecretKeyPacket {}) = True
1934 -- isSecret _ = False
1935 secret_base58_foo = base58_encode seckey
1936 Just d = lookup 'd' (key k)
1937 (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d)
1938 seckey = S.cons idbyte bigendian
1939
1940writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)])
1941writeWalletKeys krd db wk = do
1942 let cs = db `coinKeysOwnedBy` wk
1943 -- export wallet keys
1944 isMutableWallet (fill -> KF_None) = False
1945 isMutableWallet (typ -> WalletFile {}) = True
1946 isMutableWallet _ = False
1947 files pred = do
1948 (f,stream) <- Map.toList (opFiles krd)
1949 guard (pred stream)
1950 resolveInputFile (InputFileContext "" "") f
1951 let writeWallet report n = do
1952 let cs' = do
1953 (nw,mp) <- cs
1954 -- let fns = Map.keys (locations mp)
1955 -- trace ("COIN KEY: "++show fns) $ return ()
1956 guard . not $ Map.member n (locations mp)
1957 let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp)
1958 return (CryptoCoins.network_name nw,wip)
1959 handleIO_ (return report) $ do
1960 -- TODO: This AppendMode stratagy is not easy to adapt from FilePath-based
1961 -- to InputFile-based.
1962 withFile n AppendMode $ \fh -> do
1963 rs <- forM cs' $ \(net,wip) -> do
1964 hPutStrLn fh wip
1965 return (n, NewWalletKey net)
1966 return (report ++ rs)
1967 report <- foldM writeWallet [] (files isMutableWallet)
1968 return $ KikiSuccess report
1969
1970ifSecret :: Packet -> t -> t -> t
1971ifSecret (SecretKeyPacket {}) t f = t
1972ifSecret _ t f = f
1973
1974showPacket :: Packet -> String
1975showPacket p | isKey p = (if is_subkey p
1976 then showPacket0 p
1977 else ifSecret p "----Secret-----" "----Public-----")
1978 ++ " "++show (key_algorithm p)++" "++fingerprint p
1979 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
1980 | otherwise = showPacket0 p
1981showPacket0 p = concat . take 1 $ words (show p)
1982
1983
1984-- | returns Just True so as to indicate that
1985-- the public portions of keys will be imported
1986importPublic :: Maybe Bool
1987importPublic = Just True
1988
1989-- | returns False True so as to indicate that
1990-- the public portions of keys will be imported
1991importSecret :: Maybe Bool
1992importSecret = Just False
1993
1994
1995-- TODO: Do we need to memoize this?
1996guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe ()
1997guardAuthentic rt keydata = guard (isauth rt keydata)
1998
1999isauth :: KeyRingRuntime -> KeyData -> Bool
2000isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
2001 where wk = workingKey (rtGrip rt) (rtKeyDB rt)
2002 dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt)
2003 $ locations p
2004 has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids
2005 where
2006 goodsig (uidstr,(sigs,_)) = not . null $ do
2007 sig0 <- fmap (packet . fst) sigs
2008 pre_ov <- signatures (Message [packet k, UserIDPacket uidstr, sig0])
2009 signatures_over $ verify (Message [wk]) pre_ov
2010
2011 workingKey grip use_db = listToMaybe $ do
2012 fp <- maybeToList grip
2013 elm <- Map.elems use_db
2014 guard $ matchSpec (KeyGrip fp) elm
2015 return $ keyPacket elm
2016
2017writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
2018 -> [(FilePath,KikiReportAction)]
2019 {-
2020 -> KeyDB -> Maybe Packet
2021 -> FilePath -> FilePath
2022 -}
2023 -> IO (KikiCondition [(FilePath,KikiReportAction)])
2024writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do
2025 let isring (KeyRingFile {}) = True
2026 isring _ = False
2027 db = rtKeyDB rt
2028 secring = rtSecring rt
2029 pubring = rtPubring rt
2030 ctx = InputFileContext secring pubring
2031 let s = do
2032 (f,f0,stream) <- do
2033 (f0,stream) <- Map.toList (opFiles krd)
2034 guard (isring $ typ stream)
2035 f <- resolveInputFile ctx f0
2036 return (f,f0,stream)
2037 let db' = fromMaybe db $ do
2038 msg <- Map.lookup f0 unspilled
2039 return $ merge db f0 msg
2040 x = do
2041 let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool
2042 wantedForFill acc KF_None = importByExistingMaster
2043 -- Note the KF_None case is almost irrelevent as it will be
2044 -- filtered later when isMutable returns False.
2045 -- We use importByExistingMaster in order to generate
2046 -- MissingPacket warnings. To disable those warnings, use
2047 -- const Nothing instead.
2048 wantedForFill acc (KF_Match {}) = importByExistingMaster
2049 wantedForFill acc KF_Subkeys = importByExistingMaster
2050 wantedForFill acc KF_Authentic = \kd -> do guardAuthentic rt kd
2051 importByAccess acc kd
2052 wantedForFill acc KF_All = importByAccess acc
2053 importByAccess Pub kd = importPublic
2054 importByAccess Sec kd = importSecret
2055 importByAccess AutoAccess kd =
2056 mplus (importByExistingMaster kd)
2057 (error $ f ++ ": write public or secret key to file?")
2058 importByExistingMaster kd@(KeyData p _ _ _) =
2059 fmap originallyPublic $ Map.lookup f $ locations p
2060 d <- sortByHint f keyMappedPacket (Map.elems db')
2061 acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
2062 only_public <- maybeToList $ wantedForFill acc (fill stream) d
2063 guard $ only_public || isSecretKey (keyPacket d)
2064 case fill stream of
2065 KF_Match usage -> do grip <- maybeToList $ rtGrip rt
2066 flattenTop f only_public
2067 $ filterNewSubs f (parseSpec grip usage) d
2068 _ -> flattenTop f only_public d
2069 new_packets = filter isnew x
2070 where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p)
2071 -- TODO: We depend on an exact string match between the reported
2072 -- file origin of the deleted packet and the path of the file we are
2073 -- writing. Verify that this is a safe assumption.
2074 isdeleted (f',DeletedPacket _) = f'==f
2075 isdeleted _ = False
2076 guard (not (null new_packets) || any isdeleted report_manips)
2077 return ((f0,isMutable stream),(new_packets,x))
2078 let (towrites,report) = (\f -> foldl f ([],[]) s) $
2079 \(ws,report) ((f,mutable),(new_packets,x)) ->
2080 if mutable
2081 then
2082 let rs = flip map new_packets
2083 $ \c -> (concat $ resolveInputFile ctx f, NewPacket $ showPacket (packet c))
2084 in (ws++[(f,x)],report++rs)
2085 else
2086 let rs = flip map new_packets
2087 $ \c -> (concat $ resolveInputFile ctx f,MissingPacket (showPacket (packet c)))
2088 in (ws,report++rs)
2089 forM_ towrites $ \(f,x) -> do
2090 let m = Message $ map packet x
2091 -- warn $ "writing "++f
2092 writeInputFileL ctx f (encode m)
2093 return $ KikiSuccess report
2094
2095
2096{-
2097getSubkeysForExport kk subspec db = do
2098 kd <- maybeToList $ Map.lookup kk db
2099 subkeysForExport subspec kd
2100-}
2101
2102-- | If provided Nothing for the first argument, this function returns the
2103-- master key of the given identity. Otherwise, it returns all the subkeys of
2104-- the given identity which have a usage tag that matches the first argument.
2105subkeysForExport :: Maybe String -> KeyData -> [MappedPacket]
2106subkeysForExport subspec (KeyData key _ _ subkeys) = do
2107 let subs tag = do
2108 e <- Map.elems subkeys
2109 guard $ doSearch key tag e
2110 return $ subkeyMappedPacket e
2111 maybe [key] subs subspec
2112 where
2113 doSearch key tag (SubKey sub_mp sigtrusts) =
2114 let (_,v,_) = findTag [mkUsage tag]
2115 (packet key)
2116 (packet sub_mp)
2117 sigtrusts
2118 in fmap fst v==Just True
2119
2120writePEM :: String -> String -> String
2121writePEM typ dta = pem
2122 where
2123 pem = unlines . concat $
2124 [ ["-----BEGIN " <> typ <> "-----"]
2125 , split64s dta
2126 , ["-----END " <> typ <> "-----"] ]
2127 split64s :: String -> [String]
2128 split64s "" = []
2129 split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
2130
2131 -- 64 byte lines
2132
2133rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey
2134rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
2135 -- public fields...
2136 n <- lookup 'n' $ key pkt
2137 e <- lookup 'e' $ key pkt
2138 -- secret fields
2139 MPI d <- lookup 'd' $ key pkt
2140 MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped
2141 MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped
2142
2143 -- Note: Here we fail if 'u' key is missing.
2144 -- Ideally, it would be better to compute (inverse q) mod p
2145 -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg
2146 -- (package constructive-algebra)
2147 coefficient <- lookup 'u' $ key pkt
2148
2149 let dmodp1 = MPI $ d `mod` (p - 1)
2150 dmodqminus1 = MPI $ d `mod` (q - 1)
2151 return $ RSAPrivateKey
2152 { rsaN = n
2153 , rsaE = e
2154 , rsaD = MPI d
2155 , rsaP = MPI p
2156 , rsaQ = MPI q
2157 , rsaDmodP1 = dmodp1
2158 , rsaDmodQminus1 = dmodqminus1
2159 , rsaCoefficient = coefficient }
2160rsaPrivateKeyFromPacket _ = Nothing
2161
2162secretPemFromPacket packet = pemFromPacket Sec packet
2163
2164pemFromPacket Sec packet =
2165 case key_algorithm packet of
2166 RSA -> do
2167 rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey
2168 let asn1 = toASN1 rsa []
2169 bs = encodeASN1 DER asn1
2170 dta = Base64.encode (L.unpack bs)
2171 output = writePEM "RSA PRIVATE KEY" dta
2172 Just output
2173 algo -> Nothing
2174pemFromPacket Pub packet =
2175 case key_algorithm packet of
2176 RSA -> do
2177 rsa <- rsaKeyFromPacket packet
2178 let asn1 = toASN1 (pkcs8 rsa) []
2179 bs = encodeASN1 DER asn1
2180 dta = Base64.encode (L.unpack bs)
2181 output = writePEM "PUBLIC KEY" dta
2182 Just output
2183 algo -> Nothing
2184pemFromPacket AutoAccess p@(PublicKeyPacket {}) = pemFromPacket Pub p
2185pemFromPacket AutoAccess p@(SecretKeyPacket {}) = pemFromPacket Sec p
2186pemFromPacket AutoAccess _ = Nothing
2187
2188writeKeyToFile ::
2189 Bool -> StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)]
2190writeKeyToFile False stream@(StreamInfo { typ = PEMFile }) fname packet = do
2191 case pemFromPacket (access stream) packet of
2192 Just output -> do
2193 let stamp = toEnum . fromEnum $ timestamp packet
2194 handleIO_ (return [(fname, FailedFileWrite)]) $ do
2195 saved_mask <- setFileCreationMask 0o077
2196 -- Note: The key's timestamp is included in it's fingerprint.
2197 -- Therefore, we should attempt to preserve it.
2198 writeStamped (InputFileContext "" "") fname stamp output
2199 setFileCreationMask saved_mask
2200 return [(fname, ExportedSubkey)]
2201 Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)]
2202
2203writeKeyToFile False StreamInfo { typ = DNSPresentation } fname packet = do
2204 case key_algorithm packet of
2205 RSA -> do
2206 flip (maybe (return []))
2207 (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey
2208 $ \rsa -> do
2209 let -- asn1 = toASN1 rsa []
2210 -- bs = encodeASN1 DER asn1
2211 -- dta = Base64.encode (L.unpack bs)
2212 b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i)
2213 where
2214 MPI i = ac rsa
2215 i2bs_unsized :: Integer -> S.ByteString
2216 i2bs_unsized 0 = S.singleton 0
2217 i2bs_unsized i = S.reverse $ S.unfoldr go i
2218 where go i' = if i' <= 0 then Nothing
2219 else Just (fromIntegral i', (i' `shiftR` 8))
2220 output = unlines
2221 [ "Private-key-format: v1.2"
2222 , "Algorithm: 8 (RSASHA256)"
2223 , "Modulus: " ++ b64 rsaN rsa
2224 , "PublicExponent: " ++ b64 rsaE rsa
2225 , "PrivateExponent: " ++ b64 rsaD rsa
2226 , "Prime1: " ++ b64 rsaP rsa
2227 , "Prime2: " ++ b64 rsaQ rsa
2228 , "Exponent1: " ++ b64 rsaDmodP1 rsa
2229 , "Exponent2: " ++ b64 rsaDmodQminus1 rsa
2230 , "Coefficient: " ++ b64 rsaCoefficient rsa
2231 ]
2232 stamp = toEnum . fromEnum $ timestamp packet
2233 handleIO_ (return [(fname, FailedFileWrite)]) $ do
2234 saved_mask <- setFileCreationMask 0o077
2235 -- Note: The key's timestamp is included in it's fingerprint.
2236 -- Therefore, we should attempt to preserve it.
2237 writeStamped (InputFileContext "" "") fname stamp output
2238 setFileCreationMask saved_mask
2239 return [(fname, ExportedSubkey)]
2240 algo -> return [(fname, UnableToExport algo $ fingerprint packet)]
2241
2242writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet))
2243 -> KeyDB
2244 -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)]
2245 -> IO (KikiCondition [(FilePath,KikiReportAction)])
2246writePEMKeys doDecrypt db exports = do
2247 ds <- mapM decryptKeys exports
2248 let ds' = map functorToEither ds
2249 if null (lefts ds')
2250 then do
2251 rs <- mapM (\(f,stream,p) -> writeKeyToFile False stream (ArgFile f) p)
2252 (rights ds')
2253 return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs)
2254 else do
2255 return (head $ lefts ds')
2256 where
2257 decryptKeys (fname,subspec,[p],stream@(StreamInfo { access=Pub }))
2258 = return $ KikiSuccess (fname,stream,packet p) -- public keys are never encrypted.
2259 decryptKeys (fname,subspec,[p],stream) = do
2260 pun <- doDecrypt p
2261 try pun $ \pun -> do
2262 return $ KikiSuccess (fname,stream,pun)
2263
2264makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
2265 -> Map.Map KeyKey MappedPacket
2266 -> IO (MappedPacket -> IO (KikiCondition Packet))
2267makeMemoizingDecrypter operation ctx keys =
2268 if null chains then do
2269 -- (*) Notice we do not pass ctx to resolveForReport.
2270 -- This is because the merge function does not currently use a context
2271 -- and the pws map keys must match the MappedPacket locations.
2272 -- TODO: Perhaps these should both be of type InputFile rather than
2273 -- FilePath?
2274 -- pws :: Map.Map FilePath (IO S.ByteString)
2275 {-
2276 pws <-
2277 Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
2278 (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
2279 $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
2280 -}
2281 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
2282 pws2 <-
2283 Traversable.mapM (cachedContents prompt ctx)
2284 $ Map.fromList $ mapMaybe
2285 (\spec -> (,passSpecPassFile spec) `fmap` do
2286 guard $ isNothing $ passSpecKeySpec spec
2287 passSpecRingFile spec)
2288 passspecs
2289 defpw <- do
2290 Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
2291 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
2292 && isNothing (passSpecKeySpec sp))
2293 $ opPassphrases operation
2294 unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
2295 return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw
2296 else let PassphraseMemoizer f = head chains
2297 in return f
2298 where
2299 (chains,passspecs) = partition isChain $ opPassphrases operation
2300 where isChain (PassphraseMemoizer {}) = True
2301 isChain _ = False
2302 doDecrypt :: IORef (Map.Map KeyKey Packet)
2303 -> Map.Map FilePath (IO S.ByteString)
2304 -> Maybe (IO S.ByteString)
2305 -> MappedPacket
2306 -> IO (KikiCondition Packet)
2307 doDecrypt unkeysRef pws defpw mp0 = do
2308 unkeys <- readIORef unkeysRef
2309 let mp = fromMaybe mp0 $ do
2310 k <- Map.lookup kk keys
2311 return $ mergeKeyPacket "decrypt" mp0 k
2312 wk = packet mp0
2313 kk = keykey wk
2314 fs = Map.keys $ locations mp
2315
2316 decryptIt [] = return BadPassphrase
2317 decryptIt (getpw:getpws) = do
2318 -- TODO: This function should use mergeKeyPacket to
2319 -- combine the packet with it's unspilled version before
2320 -- attempting to decrypt it.
2321 pw <- getpw
2322 let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
2323 case symmetric_algorithm wkun of
2324 Unencrypted -> do
2325 writeIORef unkeysRef (Map.insert kk wkun unkeys)
2326 return $ KikiSuccess wkun
2327 _ -> decryptIt getpws
2328
2329 getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
2330
2331 case symmetric_algorithm wk of
2332 Unencrypted -> return (KikiSuccess wk)
2333 _ -> maybe (decryptIt getpws)
2334 (return . KikiSuccess)
2335 $ Map.lookup kk unkeys
2336
2337performManipulations ::
2338 (MappedPacket -> IO (KikiCondition Packet))
2339 -> KeyRingRuntime
2340 -> Maybe MappedPacket
2341 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
2342 -> IO (KikiCondition (KeyRingRuntime,KikiReport))
2343performManipulations doDecrypt rt wk manip = do
2344 let db = rtKeyDB rt
2345 performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd
2346 r <- Traversable.mapM performAll db
2347 try (sequenceA r) $ \db -> do
2348 return $ KikiSuccess (rt { rtKeyDB = fmap fst db }, concatMap snd $ Map.elems db)
2349 where
2350 perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
2351 perform kd (InducerSignature uid subpaks) = do
2352 try kd $ \(kd,report) -> do
2353 flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
2354 wkun' <- doDecrypt wk'
2355 try wkun' $ \wkun -> do
2356 let flgs = if keykey (keyPacket kd) == keykey wkun
2357 then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs)
2358 else []
2359 sigOver = makeInducerSig (keyPacket kd)
2360 wkun
2361 (UserIDPacket uid)
2362 $ flgs ++ subpaks
2363 om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid
2364 toMappedPacket om p = (mappedPacket "" p) {locations=om}
2365 selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
2366 . (== keykey whosign)
2367 . keykey)) vs
2368 keys = map keyPacket $ Map.elems (rtKeyDB rt)
2369 overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig])
2370 vs :: [ ( Packet -- signature
2371 , Maybe SignatureOver -- Nothing means non-verified
2372 , Packet ) -- key who signed
2373 ]
2374 vs = do
2375 x <- maybeToList $ Map.lookup uid (keyUids kd)
2376 sig <- map (packet . fst) (fst x)
2377 o <- overs sig
2378 k <- keys
2379 let ov = verify (Message [k]) $ o
2380 signatures_over ov
2381 return (sig,Just ov,k)
2382 additional new_sig = do
2383 new_sig <- maybeToList new_sig
2384 guard (null $ selfsigs)
2385 signatures_over new_sig
2386 sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
2387 let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
2388 f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x
2389 , om `Map.union` snd x )
2390 -- XXX: Shouldn't this signature generation show up in the KikiReport ?
2391 return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report )
2392
2393 perform kd (SubKeyDeletion topk subk) = do
2394 try kd $ \(kd,report) -> do
2395 let kk = keykey $ packet $ keyMappedPacket kd
2396 kd' | kk /= topk = kd
2397 | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd }
2398 pred k _ = k /= subk
2399 ps = concat $ maybeToList $ do
2400 SubKey mp sigs <- Map.lookup subk (keySubKeys kd)
2401 return $ packet mp : concatMap (\(p,ts) -> packet p : Map.elems ts) sigs
2402 ctx = InputFileContext (rtSecring rt) (rtPubring rt)
2403 rings = [HomeSec, HomePub] >>= resolveInputFile ctx
2404 return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ])
2405
2406initializeMissingPEMFiles ::
2407 KeyRingOperation
2408 -> InputFileContext -> Maybe String
2409 -> (MappedPacket -> IO (KikiCondition Packet))
2410 -> KeyDB
2411 -> IO (KikiCondition ( (KeyDB,[( FilePath
2412 , Maybe String
2413 , [MappedPacket]
2414 , StreamInfo )])
2415 , [(FilePath,KikiReportAction)]))
2416initializeMissingPEMFiles operation ctx grip decrypt db = do
2417 nonexistents <-
2418 filterM (fmap not . doesFileExist . fst)
2419 $ do (f,t) <- Map.toList (opFiles operation)
2420 f <- resolveInputFile ctx f
2421 return (f,t)
2422
2423 let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do
2424 (fname,stream) <- nonexistents
2425 guard $ isMutable stream
2426 guard $ isSecretKeyFile (typ stream)
2427 usage <- usageFromFilter (fill stream) -- TODO: Error if no result?
2428 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
2429 -- ms will contain duplicates if a top key has multiple matching
2430 -- subkeys. This is intentional.
2431 -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db
2432 -- ms = filterMatches topspec $ Map.toList db
2433 ns = do
2434 (kk,kd) <- filterMatches topspec $ Map.toList db
2435 return (kk , subkeysForExport subspec kd)
2436 return (fname,subspec,ns,stream)
2437 (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
2438 notmissing
2439 exports = map (\(f,subspec,ns,stream) -> (f,subspec,ns >>= snd,stream)) exports0
2440
2441 ambiguity (f,topspec,subspec,_) = do
2442 return $ AmbiguousKeySpec f
2443
2444 ifnotnull (x:xs) f g = f x
2445 ifnotnull _ f g = g
2446
2447 ifnotnull ambiguous ambiguity $ do
2448
2449 -- create nonexistent files via external commands
2450 do
2451 let cmds = mapMaybe getcmd missing
2452 where
2453 getcmd (fname,subspec,ms,stream) = do
2454 cmd <- initializer stream
2455 return (fname,subspec,ms,stream,cmd)
2456 rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do
2457 e <- systemEnv [ ("file",fname)
2458 , ("usage",fromMaybe "" subspec) ]
2459 cmd
2460 case e of
2461 ExitFailure num -> return (tup,FailedExternal num)
2462 ExitSuccess -> return (tup,ExternallyGeneratedFile)
2463
2464 v <- foldM (importSecretKey decrypt)
2465 (KikiSuccess (db,[])) $ do
2466 ((f,subspec,ms,stream,cmd),r) <- rs
2467 guard $ case r of
2468 ExternallyGeneratedFile -> True
2469 _ -> False
2470 return (f,subspec,map fst ms,stream,cmd)
2471
2472 try v $ \(db,import_rs) -> do
2473 return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs
2474 ++ import_rs)
2475{-
2476interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData
2477interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
2478interpretManip kd manip = return kd
2479-}
2480
2481combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
2482combineTransforms trans rt kd = updates
2483 where
2484 updates = -- kManip operation rt kd ++
2485 concatMap (\t -> resolveTransform t rt kd) sanitized
2486 sanitized = group (sort trans) >>= take 1
2487
2488isSubkeySignature (SubkeySignature {}) = True
2489isSubkeySignature _ = False
2490
2491-- Returned data is simmilar to getBindings but the Word8 codes
2492-- are ORed together.
2493accBindings ::
2494 Bits t =>
2495 [(t, (Packet, Packet), [a], [a1], [a2])]
2496 -> [(t, (Packet, Packet), [a], [a1], [a2])]
2497accBindings bs = as
2498 where
2499 gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
2500 as = map (foldl1 combine) gs
2501 bindingPair (_,p,_,_,_) = pub2 p
2502 where
2503 pub2 (a,b) = (pub a, pub b)
2504 pub a = fingerprint_material a
2505 samePair a b = bindingPair a == bindingPair b
2506 combine (ac,p,akind,ahashed,aclaimaints)
2507 (bc,_,bkind,bhashed,bclaimaints)
2508 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
2509
2510
2511
2512verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
2513 where
2514 verified = do
2515 sig <- signatures (Message nonkeys)
2516 let v = verify (Message keys) sig
2517 guard (not . null $ signatures_over v)
2518 return v
2519 (top,othersigs) = partition isSubkeySignature verified
2520 embedded = do
2521 sub <- top
2522 let sigover = signatures_over sub
2523 unhashed = sigover >>= unhashed_subpackets
2524 subsigs = mapMaybe backsig unhashed
2525 -- This should consist only of 0x19 values
2526 -- subtypes = map signature_type subsigs
2527 -- trace ("subtypes = "++show subtypes) (return ())
2528 -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
2529 sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
2530 let v = verify (Message [subkey sub]) sig
2531 guard (not . null $ signatures_over v)
2532 return v
2533
2534smallpr k = drop 24 $ fingerprint k
2535
2536disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
2537 where
2538 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
2539 samepr a b = smallpr a == smallpr b
2540
2541 {-
2542 -- useful for testing
2543 group2 :: [a] -> [[a]]
2544 group2 (x:y:ys) = [x,y]:group2 ys
2545 group2 [x] = [[x]]
2546 group2 [] = []
2547 -}
2548
2549
2550getBindings ::
2551 [Packet]
2552 ->
2553 ( [([Packet],[SignatureOver])] -- other signatures with key sets
2554 -- that were used for the verifications
2555 , [(Word8,
2556 (Packet, Packet), -- (topkey,subkey)
2557 [String], -- usage flags
2558 [SignatureSubpacket], -- hashed data
2559 [Packet])] -- binding signatures
2560 )
2561getBindings pkts = (sigs,bindings)
2562 where
2563 (sigs,concat->bindings) = unzip $ do
2564 let (keys,_) = partition isKey pkts
2565 keys <- disjoint_fp keys
2566 let (bs,sigs) = verifyBindings keys pkts
2567 return . ((keys,sigs),) $ do
2568 b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
2569 i <- map signature_issuer (signatures_over b)
2570 i <- maybeToList i
2571 who <- maybeToList $ find_key fingerprint (Message keys) i
2572 let (code,claimants) =
2573 case () of
2574 _ | who == topkey b -> (1,[])
2575 _ | who == subkey b -> (2,[])
2576 _ -> (0,[who])
2577 let hashed = signatures_over b >>= hashed_subpackets
2578 kind = guard (code==1) >> hashed >>= maybeToList . usage
2579 return (code,(topkey b,subkey b), kind, hashed,claimants)
2580
2581resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
2582resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
2583 where
2584 ops = map (\u -> InducerSignature u []) us
2585 us = filter torStyle $ Map.keys umap
2586 torStyle str = and [ uid_topdomain parsed == "onion"
2587 , uid_realname parsed `elem` ["","Anonymous"]
2588 , uid_user parsed == "root"
2589 , fmap (match . fst) (lookup (packet k) torbindings)
2590 == Just True ]
2591 where parsed = parseUID str
2592 match = (==subdom) . take (fromIntegral len)
2593 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
2594 subdom = Char8.unpack subdom0
2595 len = T.length (uid_subdomain parsed)
2596 torbindings = getTorKeys (map packet $ flattenTop "" True kd)
2597 getTorKeys pub = do
2598 xs <- groupBindings pub
2599 (_,(top,sub),us,_,_) <- xs
2600 guard ("tor" `elem` us)
2601 let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
2602 return (top,(torhash,sub))
2603
2604 groupBindings pub = gs
2605 where (_,bindings) = getBindings pub
2606 bindings' = accBindings bindings
2607 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
2608 ownerkey (_,(a,_),_,_,_) = a
2609 sameMaster (ownerkey->a) (ownerkey->b)
2610 = fingerprint_material a==fingerprint_material b
2611 gs = groupBy sameMaster (sortBy (comparing code) bindings')
2612
2613
2614resolveTransform (DeleteSubKey fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
2615 where
2616 topk = keykey $ packet k -- key to master of key to be deleted
2617 subk = do
2618 (k,sub) <- Map.toList submap
2619 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
2620 return k
2621
2622
2623-- | Load and update key files according to the specified 'KeyRingOperation'.
2624runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
2625runKeyRing operation = do
2626 homedir <- getHomeDir (opHome operation)
2627 let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b)
2628 -- FIXME: try' should probably accept a list of KikiReportActions.
2629 -- This would be useful for reporting on disk writes that have already
2630 -- succeded prior to this termination.
2631 try' v body =
2632 case functorToEither v of
2633 Left e -> return $ KikiResult e []
2634 Right wkun -> body wkun
2635 try' homedir $ \(homedir,secring,pubring,grip0) -> do
2636 let ctx = InputFileContext secring pubring
2637 tolocks = filesToLock operation ctx
2638 secring <- return Nothing
2639 pubring <- return Nothing
2640 lks <- forM tolocks $ \f -> do
2641 lk <- dotlock_create f 0
2642 v <- flip (maybe $ return Nothing) lk $ \lk -> do
2643 e <- dotlock_take lk (-1)
2644 if e==0 then return $ Just lk
2645 else dotlock_destroy lk >> return Nothing
2646 return (v,f)
2647 let (lked, map snd -> failed_locks) = partition (isJust . fst) lks
2648 ret <-
2649 if not $ null failed_locks
2650 then return $ KikiResult (FailedToLock failed_locks) []
2651 else do
2652
2653 -- merge all keyrings, PEM files, and wallets
2654 bresult <- buildKeyDB ctx grip0 operation
2655 try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do
2656
2657 externals_ret <- initializeMissingPEMFiles operation
2658 ctx
2659 grip
2660 decrypt
2661 db
2662 try' externals_ret $ \((db,exports),report_externals) -> do
2663
2664 let rt = KeyRingRuntime
2665 { rtPubring = homepubPath ctx
2666 , rtSecring = homesecPath ctx
2667 , rtGrip = grip
2668 , rtWorkingKey = fmap packet wk
2669 , rtKeyDB = db
2670 , rtRingAccess = accs
2671 , rtPassphrases = decrypt
2672 }
2673
2674 r <- performManipulations decrypt
2675 rt
2676 wk
2677 (combineTransforms $ opTransforms operation)
2678 try' r $ \(rt,report_manips) -> do
2679
2680 r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)
2681 try' r $ \report_wallets -> do
2682
2683 r <- writeRingKeys operation rt unspilled report_manips
2684 try' r $ \report_rings -> do
2685
2686 r <- writePEMKeys decrypt (rtKeyDB rt) exports
2687 try' r $ \report_pems -> do
2688
2689 import_hosts <- writeHostsFiles operation ctx hs
2690
2691 return $ KikiResult (KikiSuccess rt)
2692 $ concat [ report_imports
2693 , report_externals
2694 , report_manips
2695 , report_wallets
2696 , report_rings
2697 , report_pems ]
2698
2699 forM_ lked $ \(Just lk, fname) -> dotlock_release lk
2700
2701 return ret
2702
2703parseOptionFile :: FilePath -> IO [String]
2704parseOptionFile fname = do
2705 xs <- fmap lines (readFile fname)
2706 let ys = filter notComment xs
2707 notComment ('#':_) = False
2708 notComment cs = not (all isSpace cs)
2709 return ys
2710
2711-- | returns ( home directory
2712-- , path to secret ring
2713-- , path to public ring
2714-- , fingerprint of working key
2715-- )
2716getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String))
2717getHomeDir protohome = do
2718 homedir <- envhomedir protohome
2719 flip (maybe (return CantFindHome))
2720 homedir $ \homedir -> do
2721 -- putStrLn $ "homedir = " ++show homedir
2722 let secring = homedir ++ "/" ++ "secring.gpg"
2723 pubring = homedir ++ "/" ++ "pubring.gpg"
2724 -- putStrLn $ "secring = " ++ show secring
2725 workingkey <- getWorkingKey homedir
2726 return $ KikiSuccess (homedir,secring,pubring,workingkey)
2727 where
2728 envhomedir opt = do
2729 gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home)
2730 homed <- fmap (mfilter (/="") . Just) getHomeDirectory
2731 let homegnupg = (++('/':(appdir home))) <$> homed
2732 let val = (opt `mplus` gnupghome `mplus` homegnupg)
2733 return $ val
2734
2735 -- TODO: rename this to getGrip
2736 getWorkingKey homedir = do
2737 let o = Nothing
2738 h = Just homedir
2739 ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
2740 let optfiles = map (second ((h++"/")++))
2741 (maybe optfile_alts' (:[]) o')
2742 optfile_alts' = zip (False:repeat True) (optfile_alts home)
2743 o' = fmap (False,) o
2744 in filterM (doesFileExist . snd) optfiles
2745 args <- flip (maybe $ return []) ofile $
2746 \(forgive,fname) -> parseOptionFile fname
2747 let config = map (topair . words) args
2748 where topair (x:xs) = (x,xs)
2749 return $ lookup "default-key" config >>= listToMaybe
2750
2751#if MIN_VERSION_base(4,6,0)
2752#else
2753lookupEnv :: String -> IO (Maybe String)
2754lookupEnv var =
2755 handleIO_ (return Nothing) $ fmap Just (getEnv var)
2756#endif
2757
2758isKey :: Packet -> Bool
2759isKey (PublicKeyPacket {}) = True
2760isKey (SecretKeyPacket {}) = True
2761isKey _ = False
2762
2763isUserID :: Packet -> Bool
2764isUserID (UserIDPacket {}) = True
2765isUserID _ = False
2766
2767isTrust :: Packet -> Bool
2768isTrust (TrustPacket {}) = True
2769isTrust _ = False
2770
2771sigpackets ::
2772 Monad m =>
2773 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
2774sigpackets typ hashed unhashed = return $
2775 signaturePacket
2776 4 -- version
2777 typ -- 0x18 subkey binding sig, or 0x19 back-signature
2778 RSA
2779 SHA1
2780 hashed
2781 unhashed
2782 0 -- Word16 -- Left 16 bits of the signed hash value
2783 [] -- [MPI]
2784
2785secretToPublic :: Packet -> Packet
2786secretToPublic pkt@(SecretKeyPacket {}) =
2787 PublicKeyPacket { version = version pkt
2788 , timestamp = timestamp pkt
2789 , key_algorithm = key_algorithm pkt
2790 -- , ecc_curve = ecc_curve pkt
2791 , key = let seckey = key pkt
2792 pubs = public_key_fields (key_algorithm pkt)
2793 in filter (\(k,v) -> k `elem` pubs) seckey
2794 , is_subkey = is_subkey pkt
2795 , v3_days_of_validity = Nothing
2796 }
2797secretToPublic pkt = pkt
2798
2799
2800
2801slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
2802slurpWIPKeys stamp "" = ([],[])
2803slurpWIPKeys stamp cs =
2804 let (b58,xs) = Char8.span (`elem` base58chars) cs
2805 mb = decode_btc_key stamp (Char8.unpack b58)
2806 in if L.null b58
2807 then let (ys,xs') = Char8.break (`elem` base58chars) cs
2808 (ks,js) = slurpWIPKeys stamp xs'
2809 in (ks,ys:js)
2810 else let (ks,js) = slurpWIPKeys stamp xs
2811 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
2812
2813
2814decode_btc_key ::
2815 Enum timestamp => timestamp -> String -> Maybe (Word8, Message)
2816decode_btc_key timestamp str = do
2817 (network_id,us) <- base58_decode str
2818 return . (network_id,) $ Message $ do
2819 let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
2820 {-
2821 xy = secp256k1_G `pmul` d
2822 x = getx xy
2823 y = gety xy
2824 -- y² = x³ + 7 (mod p)
2825 y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve)
2826 y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve)
2827 -}
2828 secp256k1 = ECC.getCurveByName ECC.SEC_p256k1
2829 ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1
2830 -- pub = cannonical_eckey x y
2831 -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub
2832 -- address = base58_encode hash
2833 -- pubstr = concatMap (printf "%02x") $ pub
2834 -- _ = pubstr :: String
2835 return $ {- trace (unlines ["pub="++show pubstr
2836 ,"add="++show address
2837 ,"y ="++show y
2838 ,"y' ="++show y'
2839 ,"y''="++show y'']) -}
2840 SecretKeyPacket
2841 { version = 4
2842 , timestamp = toEnum (fromEnum timestamp)
2843 , key_algorithm = ECDSA
2844 , key = [ -- public fields...
2845 ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve)
2846 ,('l',MPI 256)
2847 ,('x',MPI x)
2848 ,('y',MPI y)
2849 -- secret fields
2850 ,('d',MPI d)
2851 ]
2852 , s2k_useage = 0
2853 , s2k = S2K 100 ""
2854 , symmetric_algorithm = Unencrypted
2855 , encrypted_data = ""
2856 , is_subkey = True
2857 }
2858
2859rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
2860rsaKeyFromPacket p | isKey p = do
2861 n <- lookup 'n' $ key p
2862 e <- lookup 'e' $ key p
2863 return $ RSAKey n e
2864
2865rsaKeyFromPacket _ = Nothing
2866
2867
2868readPacketsFromWallet ::
2869 Maybe Packet
2870 -> InputFile
2871 -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
2872readPacketsFromWallet wk fname = do
2873 let ctx = InputFileContext "" ""
2874 timestamp <- getInputFileTime ctx fname
2875 input <- readInputFileL ctx fname
2876 let (ks,_) = slurpWIPKeys timestamp input
2877 unless (null ks) $ do
2878 -- decrypt wk
2879 -- create sigs
2880 -- return key/sig pairs
2881 return ()
2882 return $ do
2883 wk <- maybeToList wk
2884 guard (not $ null ks)
2885 let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk))
2886 where tag = CryptoCoins.nameFromSecretByte tagbyte
2887 (wk,MarkerPacket,(MarkerPacket,Map.empty))
2888 :map prep ks
2889
2890readPacketsFromFile :: InputFileContext -> InputFile -> IO Message
2891readPacketsFromFile ctx fname = do
2892 -- warn $ fname ++ ": reading..."
2893 input <- readInputFileL ctx fname
2894#if MIN_VERSION_binary(0,7,0)
2895 return $
2896 case decodeOrFail input of
2897 Right (_,_,msg ) -> msg
2898 Left (_,_,_) ->
2899 -- FIXME
2900 -- trace (fname++": read fail") $
2901 Message []
2902#else
2903 return $ decode input
2904#endif
2905
2906-- | Get the time stamp of a signature.
2907--
2908-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
2909-- the hashed section. TODO: change this?
2910--
2911signature_time :: SignatureOver -> Word32
2912signature_time ov = case (if null cs then ds else cs) of
2913 [] -> minBound
2914 xs -> maximum xs
2915 where
2916 ps = signatures_over ov
2917 ss = filter isSignaturePacket ps
2918 cs = concatMap (concatMap creationTime . hashed_subpackets) ss
2919 ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
2920 creationTime (SignatureCreationTimePacket t) = [t]
2921 creationTime _ = []
2922
2923splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
2924splitAtMinBy comp xs = minimumBy comp' xxs
2925 where
2926 xxs = zip (inits xs) (tails xs)
2927 comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
2928 compM (Just a) (Just b) = comp a b
2929 compM Nothing mb = GT
2930 compM _ _ = LT
2931
2932
2933
2934-- | Given list of subpackets, a master key, one of its subkeys and a
2935-- list of signatures on that subkey, yields:
2936--
2937-- * preceding list of signatures
2938--
2939-- * The most recent valid signature made by the master key along with a
2940-- flag that indicates whether or not all of the supplied subpackets occur in
2941-- it or, if no valid signature from the working key is present, Nothing.
2942--
2943-- * following list of signatures
2944--
2945findTag ::
2946 [SignatureSubpacket]
2947 -> Packet
2948 -> Packet
2949 -> [(MappedPacket, b)]
2950 -> ([(MappedPacket, b)],
2951 Maybe (Bool, (MappedPacket, b)),
2952 [(MappedPacket, b)])
2953findTag tag topk subkey subsigs = (xs',minsig,ys')
2954 where
2955 vs = map (\sig ->
2956 (sig, do
2957 sig <- Just (packet . fst $ sig)
2958 guard (isSignaturePacket sig)
2959 guard $ flip isSuffixOf
2960 (fingerprint topk)
2961 . fromMaybe "%bad%"
2962 . signature_issuer
2963 $ sig
2964 listToMaybe $
2965 map (signature_time . verify (Message [topk]))
2966 (signatures $ Message [topk,subkey,sig])))
2967 subsigs
2968 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
2969 xs' = map fst xs
2970 ys' = map fst $ if isNothing minsig then ys else drop 1 ys
2971 minsig = do
2972 (sig,ov) <- listToMaybe ys
2973 ov
2974 let hshed = hashed_subpackets $ packet $ fst sig
2975 return ( null $ tag \\ hshed, sig)
2976
2977mkUsage :: String -> SignatureSubpacket
2978mkUsage tag = NotationDataPacket
2979 { human_readable = True
2980 , notation_name = "usage@"
2981 , notation_value = tag
2982 }
2983
2984makeSig ::
2985 (MappedPacket -> IO (KikiCondition Packet))
2986 -> MappedPacket
2987 -> [Char]
2988 -> MappedPacket
2989 -> [SignatureSubpacket]
2990 -> Maybe (MappedPacket, Map.Map k a)
2991 -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
2992makeSig doDecrypt top fname subkey_p tags mbsig = do
2993 let wk = packet top
2994 wkun <- doDecrypt top
2995 try wkun $ \wkun -> do
2996 let grip = fingerprint wk
2997 addOrigin new_sig =
2998 flip (maybe $ return FailedToMakeSignature)
2999 (new_sig >>= listToMaybe . signatures_over)
3000 $ \new_sig -> do
3001 let mp' = mappedPacket fname new_sig
3002 return $ KikiSuccess (mp', Map.empty)
3003 parsedkey = [packet subkey_p]
3004 hashed0 = KeyFlagsPacket
3005 { certify_keys = False
3006 , sign_data = False
3007 , encrypt_communication = False
3008 , encrypt_storage = False
3009 , split_key = False
3010 , authentication = True
3011 , group_key = False }
3012 : tags
3013 -- implicitly added:
3014 -- , SignatureCreationTimePacket (fromIntegral timestamp)
3015 subgrip = fingerprint (head parsedkey)
3016
3017 back_sig <- pgpSign (Message parsedkey)
3018 (SubkeySignature wk
3019 (head parsedkey)
3020 (sigpackets 0x19
3021 hashed0
3022 [IssuerPacket subgrip]))
3023 (if key_algorithm (head parsedkey)==ECDSA
3024 then SHA256
3025 else SHA1)
3026 subgrip
3027 let iss = IssuerPacket (fingerprint wk)
3028 cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
3029 unhashed0 = maybe [iss] cons_iss back_sig
3030
3031 new_sig <- pgpSign (Message [wkun])
3032 (SubkeySignature wk
3033 (head parsedkey)
3034 (sigpackets 0x18
3035 hashed0
3036 unhashed0))
3037 SHA1
3038 grip
3039 let newSig = do
3040 r <- addOrigin new_sig
3041 return $ fmap (,[]) r
3042 flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
3043 let sig = packet mp
3044 isCreation (SignatureCreationTimePacket {}) = True
3045 isCreation _ = False
3046 isExpiration (SignatureExpirationTimePacket {}) = True
3047 isExpiration _ = False
3048 (cs,ps) = partition isCreation (hashed_subpackets sig)
3049 (es,qs) = partition isExpiration ps
3050 stamp = listToMaybe . sortBy (comparing Down) $
3051 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
3052 exp = listToMaybe $ sort $
3053 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
3054 expires = liftA2 (+) stamp exp
3055 timestamp <- now
3056 if fmap ( (< timestamp) . fromIntegral) expires == Just True then
3057 return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
3058 else do
3059 let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
3060 $ maybeToList $ do
3061 e <- expires
3062 return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
3063 sig' = sig { hashed_subpackets = times ++ (qs `union` tags) }
3064 new_sig <- pgpSign (Message [wkun])
3065 (SubkeySignature wk
3066 (packet subkey_p)
3067 [sig'] )
3068 SHA1
3069 (fingerprint wk)
3070 newsig <- addOrigin new_sig
3071 return $ fmap (,[]) newsig
3072
3073
3074
3075data OriginFlags = OriginFlags {
3076 originallyPublic :: Bool,
3077 originalNum :: Int
3078 }
3079 deriving Show
3080type OriginMap = Map.Map FilePath OriginFlags
3081data MappedPacket = MappedPacket
3082 { packet :: Packet
3083 , locations :: OriginMap
3084 } deriving Show
3085
3086type TrustMap = Map.Map FilePath Packet
3087type SigAndTrust = ( MappedPacket
3088 , TrustMap ) -- trust packets
3089
3090type KeyKey = [ByteString]
3091data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
3092
3093-- | This is a GPG Identity which includes a master key and all its UIDs and
3094-- subkeys and associated signatures.
3095data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key
3096 , keySigAndTrusts :: [SigAndTrust] -- sigs on main key
3097 , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids
3098 , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys
3099 } deriving Show
3100
3101type KeyDB = Map.Map KeyKey KeyData
3102
3103origin :: Packet -> Int -> OriginFlags
3104origin p n = OriginFlags ispub n
3105 where
3106 ispub = case p of
3107 SecretKeyPacket {} -> False
3108 _ -> True
3109
3110mappedPacket :: FilePath -> Packet -> MappedPacket
3111mappedPacket filename p = MappedPacket
3112 { packet = p
3113 , locations = Map.singleton filename (origin p (-1))
3114 }
3115
3116mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
3117mappedPacketWithHint filename p hint = MappedPacket
3118 { packet = p
3119 , locations = Map.singleton filename (origin p hint)
3120 }
3121
3122keykey :: Packet -> KeyKey
3123keykey key =
3124 -- Note: The key's timestamp is normally included in it's fingerprint.
3125 -- This is undesirable for kiki because it causes the same
3126 -- key to be imported multiple times and show as apparently
3127 -- distinct keys with different fingerprints.
3128 -- Thus, we will remove the timestamp.
3129 fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
3130
3131uidkey :: Packet -> String
3132uidkey (UserIDPacket str) = str
3133
3134merge :: KeyDB -> InputFile -> Message -> KeyDB
3135merge db inputfile (Message ps) = merge_ db filename qs
3136 where
3137 filename = resolveForReport Nothing inputfile
3138
3139 qs = scanPackets filename ps
3140
3141 scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
3142 scanPackets filename [] = []
3143 scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
3144 where
3145 ret p = (p,Map.empty)
3146 doit (top,sub,prev) p =
3147 case p of
3148 _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
3149 _ | isKey p && is_subkey p -> (top,p,ret p)
3150 _ | isUserID p -> (top,p,ret p)
3151 _ | isTrust p -> (top,sub,updateTrust top sub prev p)
3152 _ -> (top,sub,ret p)
3153
3154 updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
3155 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public
3156 updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret
3157
3158
3159{-
3160onionName :: KeyData -> (SockAddr,L.ByteString)
3161onionName kd = (addr,name)
3162 where
3163 (addr,(name:_,_)) = getHostnames kd
3164-}
3165keyCompare :: String -> Packet -> Packet -> Ordering
3166keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
3167keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
3168keyCompare what a b | keykey a==keykey b = EQ
3169keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
3170 , fingerprint a
3171 , PP.ppShow a
3172 , fingerprint b
3173 , PP.ppShow b
3174 ]
3175
3176mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
3177mergeKeyPacket what key p =
3178 key { packet = minimumBy (keyCompare what) [packet key,packet p]
3179 , locations = Map.union (locations key) (locations p)
3180 }
3181
3182
3183merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
3184 -> KeyDB
3185merge_ db filename qs = foldl mergeit db (zip [0..] qs)
3186 where
3187 asMapped n p = mappedPacketWithHint filename p n
3188 asSigAndTrust n (p,tm) = (asMapped n p,tm)
3189 emptyUids = Map.empty
3190 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
3191 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
3192 mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
3193 where
3194 -- NOTE:
3195 -- if a keyring file has both a public key packet and a secret key packet
3196 -- for the same key, then only one of them will survive, which ever is
3197 -- later in the file.
3198 --
3199 -- This is due to the use of statements like
3200 -- (Map.insert filename (origin p n) (locations key))
3201 --
3202 update :: Maybe KeyData -> Maybe KeyData
3203 update v | isKey p && not (is_subkey p)
3204 = case v of
3205 Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
3206 Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
3207 -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p)
3208 sigs
3209 uids
3210 subkeys
3211 _ -> error . concat $ ["Unexpected master key merge error: "
3212 ,show (fingerprint top, fingerprint p)]
3213 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
3214 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
3215 update (Just (KeyData key sigs uids subkeys)) | isUserID p
3216 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
3217 subkeys
3218 update (Just (KeyData key sigs uids subkeys))
3219 = case sub of
3220 MarkerPacket -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys
3221 UserIDPacket {} -> Just $ KeyData key
3222 sigs
3223 (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
3224 subkeys
3225 _ | isKey sub -> Just $ KeyData key
3226 sigs
3227 uids
3228 (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
3229 _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
3230 update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
3231
3232 mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
3233
3234 mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
3235 mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) []
3236 mergeSubkey n p (Just (SubKey key sigs)) = Just $
3237 SubKey (mergeKeyPacket "subs" key $ asMapped n p)
3238 sigs
3239
3240 mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
3241 mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n))
3242 mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
3243 mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
3244
3245 whatP (a,_) = concat . take 1 . words . show $ a
3246
3247
3248 mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
3249 mergeSig n sig sigs =
3250 let (xs,ys) = break (isSameSig sig) sigs
3251 in if null ys
3252 then sigs++[first (asMapped n) sig]
3253 else let y:ys'=ys
3254 in xs ++ (mergeSameSig n sig y : ys')
3255 where
3256 isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
3257 a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
3258 isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
3259
3260 mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
3261 mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb)
3262 | isSignaturePacket a && isSignaturePacket b =
3263 ( m { packet = b { unhashed_subpackets =
3264 union (unhashed_subpackets b) (unhashed_subpackets a)
3265 }
3266 , locations = Map.insert filename (origin a n) locs }
3267 -- TODO: when merging items, we should delete invalidated origins
3268 -- from the orgin map.
3269 , tb `Map.union` ta )
3270
3271 mergeSameSig n a b = b -- trace ("discarding dup "++show a) b
3272
3273 mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
3274 mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty)
3275
3276 mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
3277 mergeSubSig n sig Nothing = error $
3278 "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
3279
3280unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
3281unsig fname isPublic (sig,trustmap) =
3282 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
3283 where
3284 f n _ = n==fname -- && trace ("fname=n="++show n) True
3285 asMapped n p = let m = mappedPacket fname p
3286 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
3287
3288concatSort ::
3289 FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
3290concatSort fname getp f = concat . sortByHint fname getp . map f
3291
3292sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
3293sortByHint fname f = sortBy (comparing gethint)
3294 where
3295 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
3296 defnum = -1
3297
3298flattenKeys :: Bool -> KeyDB -> Message
3299flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
3300 where
3301 prefilter = if isPublic then id else filter isSecret
3302 where
3303 isSecret (_,(KeyData
3304 (MappedPacket { packet=(SecretKeyPacket {})})
3305 _
3306 _
3307 _)) = True
3308 isSecret _ = False
3309
3310
3311flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
3312flattenTop fname ispub (KeyData key sigs uids subkeys) =
3313 unk ispub key :
3314 ( flattenAllUids fname ispub uids
3315 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
3316
3317flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
3318flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
3319
3320unk :: Bool -> MappedPacket -> MappedPacket
3321unk isPublic = if isPublic then toPacket secretToPublic else id
3322 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
3323
3324flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
3325flattenAllUids fname ispub uids =
3326 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
3327
3328flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
3329flattenUid fname ispub (str,(sigs,om)) =
3330 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
3331
3332getCrossSignedSubkeys :: Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
3333getCrossSignedSubkeys topk subs tag = do
3334 SubKey k sigs <- Map.elems subs
3335 let subk = packet k
3336 let sigs' = do
3337 torsig <- filter (has_tag tag) $ map (packet . fst) sigs
3338 sig <- (signatures $ Message [topk,subk,torsig])
3339 let v = verify (Message [topk]) sig
3340 -- Require parent's signature
3341 guard (not . null $ signatures_over v)
3342 let unhashed = unhashed_subpackets torsig
3343 subsigs = mapMaybe backsig unhashed
3344 -- This should consist only of 0x19 values
3345 -- subtypes = map signature_type subsigs
3346 sig' <- signatures . Message $ [topk,subk]++subsigs
3347 let v' = verify (Message [subk]) sig'
3348 -- Require subkey's signature
3349 guard . not . null $ signatures_over v'
3350 return torsig
3351 guard (not $ null sigs')
3352 return subk
3353 where
3354 has_tag tag p = isSignaturePacket p
3355 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
3356 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
3357
3358
3359-- |
3360-- Returns (ip6 fingerprint address,(onion names,other host names))
3361--
3362-- Requires a validly cross-signed tor key for each onion name returned.
3363-- (Signature checks are performed.)
3364getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
3365getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
3366 where
3367 othernames = do
3368 mp <- flattenAllUids "" True uids
3369 let p = packet mp
3370 guard $ isSignaturePacket p
3371 uh <- unhashed_subpackets p
3372 case uh of
3373 NotationDataPacket True "hostname@" v
3374 -> return $ Char8.pack v
3375 _ -> mzero
3376
3377 addr = fingerdress topk
3378 -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
3379 topk = packet topmp
3380 torkeys = getCrossSignedSubkeys topk subs "tor"
3381
3382 -- subkeyPacket (SubKey k _ ) = k
3383 onames :: [L.ByteString]
3384 onames = map ( (<> ".onion")
3385 . Char8.pack
3386 . take 16
3387 . torhash )
3388 torkeys
3389
3390hasFingerDress :: KeyDB -> SockAddr -> Bool
3391hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
3392hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
3393 where
3394 (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
3395 g' = map toUpper g
3396
3397-- We return into IO in case we want to make a signature here.
3398setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
3399setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
3400 -- TODO: we are removing the origin from the UID OriginMap,
3401 -- when we should be removing origins from the locations
3402 -- field of the sig's MappedPacket records.
3403 -- Call getHostnames and compare to see if no-op.
3404 if not (pred addr) || names0 == names \\ onions
3405 then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
3406 , " file: "++show (map Char8.unpack names)
3407 , " pred: "++show (pred addr)]) -}
3408 (return kd)
3409 else do
3410 -- We should be sure to remove origins so that the data is written
3411 -- (but only if something changed).
3412 -- Filter all hostnames present in uids
3413 -- Write notations into first uid
3414 {-
3415 trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
3416 , " file: "++show (map Char8.unpack names) ]) $ do
3417 -}
3418 return $ KeyData topmp topsigs uids1 subs
3419 where
3420 topk = packet topmp
3421 addr = fingerdress topk
3422 names :: [Char8.ByteString]
3423 names = Hosts.namesForAddress addr hosts
3424 (_,(onions,names0)) = getHostnames kd
3425 notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions)
3426 isName (NotationDataPacket True "hostname@" _) = True
3427 isName _ = False
3428 uids0 = fmap zapIfHasName uids
3429 fstuid = head $ do
3430 p <- map packet $ flattenAllUids "" True uids
3431 guard $ isUserID p
3432 return $ uidkey p
3433 uids1 = Map.adjust addnames fstuid uids0
3434 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
3435 where
3436 (ss,ts) = splitAt 1 sigs
3437 f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm)
3438 else (sig, tm)
3439 where p' = (packet sig) { unhashed_subpackets=uh }
3440 uh = unhashed_subpackets (packet sig) ++ notations
3441 zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin
3442 else (sigs,om)
3443 where
3444 (bs, sigs') = unzip $ map unhash sigs
3445
3446 unhash (sig,tm) = ( not (null ns)
3447 , ( sig { packet = p', locations = Map.empty }
3448 , tm ) )
3449 where
3450 psig = packet sig
3451 p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
3452 else psig
3453 uh = unhashed_subpackets psig
3454 (ns,ps) = partition isName uh
3455
3456fingerdress :: Packet -> SockAddr
3457fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str
3458 where
3459 zero = SockAddrInet 0 0
3460 addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk)
3461 colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
3462 colons xs = xs
3463
3464backsig :: SignatureSubpacket -> Maybe Packet
3465backsig (EmbeddedSignaturePacket s) = Just s
3466backsig _ = Nothing
3467
3468socketFamily :: SockAddr -> Family
3469socketFamily (SockAddrInet _ _) = AF_INET
3470socketFamily (SockAddrInet6 {}) = AF_INET6
3471socketFamily (SockAddrUnix _) = AF_UNIX
3472
3473#if ! MIN_VERSION_unix(2,7,0)
3474setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO ()
3475setFdTimesHiRes (Posix.Fd fd) atime mtime =
3476 withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times ->
3477 throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times)
3478
3479data CTimeSpec = CTimeSpec Posix.EpochTime CLong
3480instance Storable CTimeSpec where
3481 sizeOf _ = (16)
3482 alignment _ = alignment (undefined :: CInt)
3483 poke p (CTimeSpec sec nsec) = do
3484 ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p sec
3485 ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p nsec
3486 peek p = do
3487 sec <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
3488 nsec <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
3489 return $ CTimeSpec sec nsec
3490
3491toCTimeSpec :: POSIXTime -> CTimeSpec
3492toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^(9::Int) * frac)
3493 where
3494 (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac')
3495 (sec', frac') = properFraction $ toRational t
3496
3497foreign import ccall unsafe "futimens"
3498 c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt
3499#endif
3500
3501onionNameForContact :: KeyKey -> KeyDB -> Maybe String
3502onionNameForContact kk db = do
3503 contact <- Map.lookup kk db
3504 let (_,(name:_,_)) = getHostnames contact
3505 return $ Char8.unpack name
diff --git a/lib/PEM.hs b/lib/PEM.hs
new file mode 100644
index 0000000..e07b3d4
--- /dev/null
+++ b/lib/PEM.hs
@@ -0,0 +1,34 @@
1{-# LANGUAGE OverloadedStrings #-}
2module PEM where
3
4import Data.Monoid
5import qualified Data.ByteString.Lazy as LW
6import qualified Data.ByteString.Lazy.Char8 as L
7import Control.Monad
8import Control.Applicative
9import qualified Codec.Binary.Base64 as Base64
10import ScanningParser
11
12data PEMBlob = PEMBlob { pemType :: L.ByteString
13 , pemBlob :: L.ByteString
14 }
15 deriving (Eq,Show)
16
17pemParser mtyp = ScanningParser (maybe fndany fndtyp mtyp) pbdy
18 where
19 hdr typ = "-----BEGIN " <> typ <> "-----"
20 fndtyp typ bs = if bs==hdr typ then Just typ else Nothing
21 fndany bs = do
22 guard $ "-----BEGIN " `L.isPrefixOf` bs
23 let x0 = L.drop 11 bs
24 guard $ "-----" `LW.isSuffixOf` x0
25 let typ = L.take (L.length x0 - 5) x0
26 return typ
27
28 pbdy typ xs = (mblob, drop 1 rs)
29 where
30 (ys,rs) = span (/="-----END " <> typ <> "-----") xs
31 mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta)
32 dta = case ys of
33 [] -> ""
34 dta_lines -> L.concat dta_lines
diff --git a/lib/ProcessUtils.hs b/lib/ProcessUtils.hs
new file mode 100644
index 0000000..4e3ac38
--- /dev/null
+++ b/lib/ProcessUtils.hs
@@ -0,0 +1,45 @@
1module ProcessUtils
2 ( ExitCode(ExitFailure,ExitSuccess)
3 , systemEnv
4 ) where
5
6import GHC.IO.Exception ( ioException, IOErrorType(..) )
7import System.Process
8import System.Posix.Signals
9import System.Process.Internals (runGenProcess_,defaultSignal)
10import System.Environment
11import Data.Maybe ( isNothing )
12import System.IO.Error ( mkIOError, ioeSetErrorString )
13import System.Exit ( ExitCode(..) )
14
15
16-- | systemEnv
17-- This is like System.Process.system except that it lets you set
18-- some environment variables.
19systemEnv :: [(String, String)] -> String -> IO ExitCode
20systemEnv _ "" =
21 ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")
22systemEnv vars cmd = do
23 env0 <- getEnvironment
24 let env1 = filter (isNothing . flip lookup vars . fst) env0
25 env = vars ++ env1
26 syncProcess "system" $ (shell cmd) {env=Just env}
27 where
28 -- This is a non-exported function from System.Process
29 syncProcess fun c = do
30 -- The POSIX version of system needs to do some manipulation of signal
31 -- handlers. Since we're going to be synchronously waiting for the child,
32 -- we want to ignore ^C in the parent, but handle it the default way
33 -- in the child (using SIG_DFL isn't really correct, it should be the
34 -- original signal handler, but the GHC RTS will have already set up
35 -- its own handler and we don't want to use that).
36 old_int <- installHandler sigINT Ignore Nothing
37 old_quit <- installHandler sigQUIT Ignore Nothing
38 (_,_,_,p) <- runGenProcess_ fun c
39 (Just defaultSignal) (Just defaultSignal)
40 r <- waitForProcess p
41 _ <- installHandler sigINT old_int Nothing
42 _ <- installHandler sigQUIT old_quit Nothing
43 return r
44
45
diff --git a/lib/ScanningParser.hs b/lib/ScanningParser.hs
new file mode 100644
index 0000000..f99e120
--- /dev/null
+++ b/lib/ScanningParser.hs
@@ -0,0 +1,74 @@
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE ExistentialQuantification #-}
3module ScanningParser
4 ( ScanningParser(..)
5 , scanAndParse
6 , scanAndParse1
7 ) where
8
9import Data.Maybe
10import Data.List
11import Control.Applicative
12import Control.Monad
13import Data.Monoid
14
15-- | This type provides the means to parse a stream of 'tok' and extract all
16-- the 'obj' parses that occur.
17--
18-- Use Functor and Monoid interfaces to combine parsers. For example,
19--
20-- > parserAorB = fmap Left parserA <> fmap Right parserB
21--
22data ScanningParser tok obj = forall partial. ScanningParser
23 { findFirst :: tok -> Maybe partial
24 -- ^ If the token starts an object, returns a partial parse.
25 , parseBody :: partial -> [tok] -> (Maybe obj,[tok])
26 -- ^ Given a partial parse and the stream of tokens that follow, attempt to
27 -- parse an object and return the unconsumed tokens.
28 }
29
30instance Functor (ScanningParser a) where
31 fmap f (ScanningParser ffst pbody)
32 = ScanningParser ffst (\b -> first (fmap f) . pbody b)
33 where
34 first f (x,y) = (f x, y)
35
36
37instance Monoid (ScanningParser a b) where
38 mempty = ScanningParser (const Nothing) (const $ const (Nothing,[]))
39 mappend (ScanningParser ffstA pbdyA)
40 (ScanningParser ffstB pbdyB)
41 = ScanningParser ffst pbody
42 where
43 ffst x = mplus (Left <$> ffstA x)
44 (Right <$> ffstB x)
45 pbody (Left apart) = pbdyA apart
46 pbody (Right bpart) = pbdyB bpart
47
48
49-- | Apply a 'ScanningParser' to a list of tokens, yielding a list of parsed
50-- objects.
51scanAndParse :: ScanningParser a c -> [a] -> [c]
52scanAndParse psr [] = []
53scanAndParse psr@(ScanningParser ffst pbdy) ts = do
54 (b,xs) <- take 1 $ mapMaybe findfst' tss
55 let (mc,ts') = pbdy b xs
56 rec = scanAndParse psr ts'
57 maybe rec (:rec) mc
58 where
59 tss = tails ts
60 findfst' ts = do
61 x <- listToMaybe ts
62 b <- ffst x
63 return (b,drop 1 ts)
64
65scanAndParse1 :: ScanningParser a c -> [a] -> (Maybe c, [a])
66scanAndParse1 psr@(ScanningParser ffst pbdy) ts =
67 maybe (Nothing,[]) (uncurry pbdy) mb
68 where
69 mb = listToMaybe $ mapMaybe findfst' tss
70 tss = tails ts
71 findfst' ts = do
72 x <- listToMaybe ts
73 b <- ffst x
74 return (b,drop 1 ts)
diff --git a/lib/TimeUtil.hs b/lib/TimeUtil.hs
new file mode 100644
index 0000000..879bc32
--- /dev/null
+++ b/lib/TimeUtil.hs
@@ -0,0 +1,128 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE CPP #-}
4module TimeUtil
5 ( now
6 , IsTime(..)
7 , fromTime
8 , toUTC
9 , parseRFC2822
10 , printRFC2822
11 , dateParser
12 ) where
13
14import Data.Time.LocalTime
15import Data.Time.Format
16import Data.Time.Clock
17import Data.Time.Clock.POSIX
18#if !MIN_VERSION_time(1,5,0)
19import System.Locale (defaultTimeLocale)
20#endif
21import Data.String
22import Control.Applicative
23import Data.Maybe
24import Data.Char
25import qualified Data.ByteString.Char8 as S
26import qualified Data.ByteString.Lazy.Char8 as L
27import Foreign.C.Types ( CTime(..) )
28import Data.Word ( Word32 )
29
30import ScanningParser
31
32class IsTime a where
33 fromZonedTime :: ZonedTime -> a
34 toZonedTime :: a -> IO ZonedTime
35
36instance IsTime ZonedTime where
37 fromZonedTime x = x
38 toZonedTime x = return x
39
40instance IsTime UTCTime where
41 toZonedTime t = utcToLocalZonedTime t
42 fromZonedTime zt = zonedTimeToUTC zt
43
44instance IsTime Integer where
45 toZonedTime t = utcToLocalZonedTime utime
46 where
47 utime = posixSecondsToUTCTime (fromIntegral t)
48 fromZonedTime zt = round $ utcTimeToPOSIXSeconds utime
49 where
50 utime = zonedTimeToUTC zt
51
52printRFC2822 :: (IsString b, IsTime a) => a -> IO b
53printRFC2822 tm = do
54 zt@(ZonedTime lt z) <- toZonedTime tm
55 let rfc2822 = formatTime defaultTimeLocale "%a, %0e %b %Y %T" zt ++ printZone
56 timeZoneStr = timeZoneOffsetString z
57 printZone = " " ++ timeZoneStr ++ " (" ++ fromString (show z) ++ ")"
58 return $ fromString $ rfc2822
59
60parseRFC2822 :: IsTime b => S.ByteString -> Maybe b
61parseRFC2822 str =
62 case mapMaybe (\f->parseTime defaultTimeLocale f str') formatRFC2822 of
63 [] -> Nothing
64 (zt:_) -> Just $ fromZonedTime zt
65 where
66 str' = S.unpack stripped
67 stripped = strip $ str
68 strip bs = bs3
69 where
70 (_,bs0) = S.span isSpace bs
71 (bs1,_) = S.spanEnd isSpace bs0
72 (bs2,cp) = S.spanEnd (==')') bs1
73 bs3 = if S.null cp
74 then bs2
75 else let (op,_) = S.spanEnd (/='(') bs2
76 in fst $ S.spanEnd isSpace $ S.init op
77 formatRFC2822 = [ "%a, %e %b %Y %T GMT"
78 , "%a, %e %b %Y %T %z"
79 , "%e %b %Y %T GMT"
80 , "%e %b %Y %T %z"
81 , "%a, %e %b %Y %R GMT"
82 , "%a, %e %b %Y %R %z"
83 , "%e %b %Y %R GMT"
84 , "%e %b %Y %R %z"
85 ]
86
87now :: IO Integer
88now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime
89
90dateParser :: ScanningParser L.ByteString UTCTime
91dateParser = ScanningParser ffst pbdy
92 where
93 ffst bs = do
94 let (h,bs') = L.splitAt 6 bs
95 if h=="Date: "
96 then return $ parseRFC2822 $ foldr1 S.append $ L.toChunks bs'
97 else Nothing
98 pbdy date xs = (date,xs)
99
100class IsUTC a where
101 fromUTC :: UTCTime -> a
102 toUTC :: a -> UTCTime
103
104fromTime :: ( IsUTC a, IsUTC b ) => a -> b
105fromTime = fromUTC . toUTC
106
107instance IsUTC UTCTime where
108 fromUTC = id
109 toUTC = id
110
111instance IsUTC CTime where
112 fromUTC utc = CTime (round $ utcTimeToPOSIXSeconds utc)
113 toUTC (CTime t) = posixSecondsToUTCTime (realToFrac t)
114
115instance IsUTC Word32 where
116 fromUTC utc = round $ utcTimeToPOSIXSeconds utc
117 toUTC t = posixSecondsToUTCTime (realToFrac t)
118
119{-
120main = do
121 nowtime <- now
122 printRFC2822 nowtime >>= putStrLn
123 let test1 = "Thu, 08 May 2014 23:24:47 -0400"
124 test2 = " Thu, 08 May 2014 23:24:47 -0400 (EDT) "
125 putStrLn $ show (parseRFC2822 test1 :: Maybe Integer)
126 putStrLn $ show (parseRFC2822 test2 :: Maybe Integer)
127 return ()
128-}
diff --git a/lib/dotlock.c b/lib/dotlock.c
new file mode 100644
index 0000000..c111159
--- /dev/null
+++ b/lib/dotlock.c
@@ -0,0 +1,1303 @@
1/* dotlock.c - dotfile locking
2 * Copyright (C) 1998, 2000, 2001, 2003, 2004,
3 * 2005, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
4 *
5 * This file is part of JNLIB, which is a subsystem of GnuPG.
6 *
7 * JNLIB is free software; you can redistribute it and/or modify it
8 * under the terms of either
9 *
10 * - the GNU Lesser General Public License as published by the Free
11 * Software Foundation; either version 3 of the License, or (at
12 * your option) any later version.
13 *
14 * or
15 *
16 * - the GNU General Public License as published by the Free
17 * Software Foundation; either version 2 of the License, or (at
18 * your option) any later version.
19 *
20 * or both in parallel, as here.
21 *
22 * JNLIB is distributed in the hope that it will be useful, but
23 * WITHOUT ANY WARRANTY; without even the implied warranty of
24 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
25 * General Public License for more details.
26 *
27 * You should have received a copies of the GNU General Public License
28 * and the GNU Lesser General Public License along with this program;
29 * if not, see <http://www.gnu.org/licenses/>.
30 *
31 * ALTERNATIVELY, this file may be distributed under the terms of the
32 * following license, in which case the provisions of this license are
33 * required INSTEAD OF the GNU Lesser General License or the GNU
34 * General Public License. If you wish to allow use of your version of
35 * this file only under the terms of the GNU Lesser General License or
36 * the GNU General Public License, and not to allow others to use your
37 * version of this file under the terms of the following license,
38 * indicate your decision by deleting this paragraph and the license
39 * below.
40 *
41 * Redistribution and use in source and binary forms, with or without
42 * modification, are permitted provided that the following conditions
43 * are met:
44 *
45 * 1. Redistributions of source code must retain the above copyright
46 * notice, and the entire permission notice in its entirety,
47 * including the disclaimer of warranties.
48 * 2. Redistributions in binary form must reproduce the above copyright
49 * notice, this list of conditions and the following disclaimer in the
50 * documentation and/or other materials provided with the distribution.
51 * 3. The name of the author may not be used to endorse or promote
52 * products derived from this software without specific prior
53 * written permission.
54 *
55 * THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED
56 * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
57 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
58 * DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
59 * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
60 * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
61 * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
62 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
63 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
64 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
65 * OF THE POSSIBILITY OF SUCH DAMAGE.
66 */
67
68/*
69 Overview:
70 =========
71
72 This module implements advisory file locking in a portable way.
73 Due to the problems with POSIX fcntl locking a separate lock file
74 is used. It would be possible to use fcntl locking on this lock
75 file and thus avoid the weird auto unlock bug of POSIX while still
76 having an unproved better performance of fcntl locking. However
77 there are still problems left, thus we resort to use a hardlink
78 which has the well defined property that a link call will fail if
79 the target file already exists.
80
81 Given that hardlinks are also available on NTFS file systems since
82 Windows XP; it will be possible to enhance this module to use
83 hardlinks even on Windows and thus allow Windows and Posix clients
84 to use locking on the same directory. This is not yet implemented;
85 instead we use a lockfile on Windows along with W32 style file
86 locking.
87
88 On FAT file systems hardlinks are not supported. Thus this method
89 does not work. Our solution is to use a O_EXCL locking instead.
90 Querying the type of the file system is not easy to do in a
91 portable way (e.g. Linux has a statfs, BSDs have a the same call
92 but using different structures and constants). What we do instead
93 is to check at runtime whether link(2) works for a specific lock
94 file.
95
96
97 How to use:
98 ===========
99
100 At program initialization time, the module should be explicitly
101 initialized:
102
103 dotlock_create (NULL, 0);
104
105 This installs an atexit handler and may also initialize mutex etc.
106 It is optional for non-threaded applications. Only the first call
107 has an effect. This needs to be done before any extra threads are
108 started.
109
110 To create a lock file (which prepares it but does not take the
111 lock) you do:
112
113 dotlock_t h
114
115 h = dotlock_create (fname, 0);
116 if (!h)
117 error ("error creating lock file: %s\n", strerror (errno));
118
119 It is important to handle the error. For example on a read-only
120 file system a lock can't be created (but is usually not needed).
121 FNAME is the file you want to lock; the actual lockfile is that
122 name with the suffix ".lock" appended. On success a handle to be
123 used with the other functions is returned or NULL on error. Note
124 that the handle shall only be used by one thread at a time. This
125 function creates a unique file temporary file (".#lk*") in the same
126 directory as FNAME and returns a handle for further operations.
127 The module keeps track of theses unique files so that they will be
128 unlinked using the atexit handler. If you don't need the lock file
129 anymore, you may also explicitly remove it with a call to:
130
131 dotlock_destroy (h);
132
133 To actually lock the file, you use:
134
135 if (dotlock_take (h, -1))
136 error ("error taking lock: %s\n", strerror (errno));
137
138 This function will wait until the lock is acquired. If an
139 unexpected error occurs if will return non-zero and set ERRNO. If
140 you pass (0) instead of (-1) the function does not wait in case the
141 file is already locked but returns -1 and sets ERRNO to EACCES.
142 Any other positive value for the second parameter is considered a
143 timeout valuie in milliseconds.
144
145 To release the lock you call:
146
147 if (dotlock_release (h))
148 error ("error releasing lock: %s\n", strerror (errno));
149
150 or, if the lock file is not anymore needed, you may just call
151 dotlock_destroy. However dotlock_release does some extra checks
152 before releasing the lock and prints diagnostics to help detecting
153 bugs.
154
155 If you want to explicitly destroy all lock files you may call
156
157 dotlock_remove_lockfiles ();
158
159 which is the core of the installed atexit handler. In case your
160 application wants to disable locking completely it may call
161
162 disable_locking ()
163
164 before any locks are created.
165
166 There are two convenience functions to store an integer (e.g. a
167 file descriptor) value with the handle:
168
169 void dotlock_set_fd (dotlock_t h, int fd);
170 int dotlock_get_fd (dotlock_t h);
171
172 If nothing has been stored dotlock_get_fd returns -1.
173
174
175
176 How to build:
177 =============
178
179 This module was originally developed for GnuPG but later changed to
180 allow its use without any GnuPG dependency. If you want to use it
181 with you application you may simply use it and it should figure out
182 most things automagically.
183
184 You may use the common config.h file to pass macros, but take care
185 to pass -DHAVE_CONFIG_H to the compiler. Macros used by this
186 module are:
187
188 DOTLOCK_USE_PTHREAD - Define if POSIX threads are in use.
189
190 DOTLOCK_GLIB_LOGGING - Define this to use Glib logging functions.
191
192 DOTLOCK_EXT_SYM_PREFIX - Prefix all external symbols with the
193 string to which this macro evaluates.
194
195 GNUPG_MAJOR_VERSION - Defined when used by GnuPG.
196
197 HAVE_DOSISH_SYSTEM - Defined for Windows etc. Will be
198 automatically defined if a the target is
199 Windows.
200
201 HAVE_POSIX_SYSTEM - Internally defined to !HAVE_DOSISH_SYSTEM.
202
203 HAVE_SIGNAL_H - Should be defined on Posix systems. If config.h
204 is not used defaults to defined.
205
206 DIRSEP_C - Separation character for file name parts.
207 Usually not redefined.
208
209 EXTSEP_S - Separation string for file name suffixes.
210 Usually not redefined.
211
212 HAVE_W32CE_SYSTEM - Currently only used by GnuPG.
213
214 Note that there is a test program t-dotlock which has compile
215 instructions at its end. At least for SMBFS and CIFS it is
216 important that 64 bit versions of stat are used; most programming
217 environments do this these days, just in case you want to compile
218 it on the command line, remember to pass -D_FILE_OFFSET_BITS=64
219
220
221 Bugs:
222 =====
223
224 On Windows this module is not yet thread-safe.
225
226
227 Miscellaneous notes:
228 ====================
229
230 On hardlinks:
231 - Hardlinks are supported under Windows with NTFS since XP/Server2003.
232 - In Linux 2.6.33 both SMBFS and CIFS seem to support hardlinks.
233 - NFS supports hard links. But there are solvable problems.
234 - FAT does not support links
235
236 On the file locking API:
237 - CIFS on Linux 2.6.33 supports several locking methods.
238 SMBFS seems not to support locking. No closer checks done.
239 - NFS supports Posix locks. flock is emulated in the server.
240 However there are a couple of problems; see below.
241 - FAT does not support locks.
242 - An advantage of fcntl locking is that R/W locks can be
243 implemented which is not easy with a straight lock file.
244
245 On O_EXCL:
246 - Does not work reliable on NFS
247 - Should work on CIFS and SMBFS but how can we delete lockfiles?
248
249 On NFS problems:
250 - Locks vanish if the server crashes and reboots.
251 - Client crashes keep the lock in the server until the client
252 re-connects.
253 - Communication problems may return unreliable error codes. The
254 MUA Postfix's workaround is to compare the link count after
255 seeing an error for link. However that gives a race. If using a
256 unique file to link to a lockfile and using stat to check the
257 link count instead of looking at the error return of link(2) is
258 the best solution.
259 - O_EXCL seems to have a race and may re-create a file anyway.
260
261*/
262
263#ifdef HAVE_CONFIG_H
264# include <config.h>
265#endif
266
267/* Some quick replacements for stuff we usually expect to be defined
268 in config.h. Define HAVE_POSIX_SYSTEM for better readability. */
269#if !defined (HAVE_DOSISH_SYSTEM) && defined(_WIN32)
270# define HAVE_DOSISH_SYSTEM 1
271#endif
272#if !defined (HAVE_DOSISH_SYSTEM) && !defined (HAVE_POSIX_SYSTEM)
273# define HAVE_POSIX_SYSTEM 1
274#endif
275
276/* With no config.h assume that we have sitgnal.h. */
277#if !defined (HAVE_CONFIG_H) && defined (HAVE_POSIX_SYSTEM)
278# define HAVE_SIGNAL_H 1
279#endif
280
281/* Standard headers. */
282#include <stdlib.h>
283#include <stdio.h>
284#include <string.h>
285#include <errno.h>
286#include <ctype.h>
287#include <errno.h>
288#include <unistd.h>
289#ifdef HAVE_DOSISH_SYSTEM
290# define WIN32_LEAN_AND_MEAN /* We only need the OS core stuff. */
291# include <windows.h>
292#else
293# include <sys/types.h>
294# include <sys/stat.h>
295# include <sys/utsname.h>
296#endif
297#include <sys/types.h>
298#include <sys/time.h>
299#include <sys/stat.h>
300#include <fcntl.h>
301#ifdef HAVE_SIGNAL_H
302# include <signal.h>
303#endif
304#ifdef DOTLOCK_USE_PTHREAD
305# include <pthread.h>
306#endif
307
308#ifdef DOTLOCK_GLIB_LOGGING
309# include <glib.h>
310#endif
311
312#ifdef GNUPG_MAJOR_VERSION
313# include "libjnlib-config.h"
314#endif
315#ifdef HAVE_W32CE_SYSTEM
316# include "utf8conv.h" /* WindowsCE requires filename conversion. */
317#endif
318
319#include "dotlock.h"
320
321
322/* Define constants for file name construction. */
323#if !defined(DIRSEP_C) && !defined(EXTSEP_S)
324# ifdef HAVE_DOSISH_SYSTEM
325# define DIRSEP_C '\\'
326# define EXTSEP_S "."
327#else
328# define DIRSEP_C '/'
329# define EXTSEP_S "."
330# endif
331#endif
332
333/* In GnuPG we use wrappers around the malloc fucntions. If they are
334 not defined we assume that this code is used outside of GnuPG and
335 fall back to the regular malloc functions. */
336#ifndef jnlib_malloc
337# define jnlib_malloc(a) malloc ((a))
338# define jnlib_calloc(a,b) calloc ((a), (b))
339# define jnlib_free(a) free ((a))
340#endif
341
342/* Wrapper to set ERRNO. */
343#ifndef jnlib_set_errno
344# ifdef HAVE_W32CE_SYSTEM
345# define jnlib_set_errno(e) gpg_err_set_errno ((e))
346# else
347# define jnlib_set_errno(e) do { errno = (e); } while (0)
348# endif
349#endif
350
351/* Gettext macro replacement. */
352#ifndef _
353# define _(a) (a)
354#endif
355
356#ifdef GNUPG_MAJOR_VERSION
357# define my_info_0(a) log_info ((a))
358# define my_info_1(a,b) log_info ((a), (b))
359# define my_info_2(a,b,c) log_info ((a), (b), (c))
360# define my_info_3(a,b,c,d) log_info ((a), (b), (c), (d))
361# define my_error_0(a) log_error ((a))
362# define my_error_1(a,b) log_error ((a), (b))
363# define my_error_2(a,b,c) log_error ((a), (b), (c))
364# define my_debug_1(a,b) log_debug ((a), (b))
365# define my_fatal_0(a) log_fatal ((a))
366#elif defined (DOTLOCK_GLIB_LOGGING)
367# define my_info_0(a) g_message ((a))
368# define my_info_1(a,b) g_message ((a), (b))
369# define my_info_2(a,b,c) g_message ((a), (b), (c))
370# define my_info_3(a,b,c,d) g_message ((a), (b), (c), (d))
371# define my_error_0(a) g_warning ((a))
372# define my_error_1(a,b) g_warning ((a), (b))
373# define my_error_2(a,b,c) g_warning ((a), (b), (c))
374# define my_debug_1(a,b) g_debug ((a), (b))
375# define my_fatal_0(a) g_error ((a))
376#else
377# define my_info_0(a) fprintf (stderr, (a))
378# define my_info_1(a,b) fprintf (stderr, (a), (b))
379# define my_info_2(a,b,c) fprintf (stderr, (a), (b), (c))
380# define my_info_3(a,b,c,d) fprintf (stderr, (a), (b), (c), (d))
381# define my_error_0(a) fprintf (stderr, (a))
382# define my_error_1(a,b) fprintf (stderr, (a), (b))
383# define my_error_2(a,b,c) fprintf (stderr, (a), (b), (c))
384# define my_debug_1(a,b) fprintf (stderr, (a), (b))
385# define my_fatal_0(a) do { fprintf (stderr,(a)); fflush (stderr); \
386 abort (); } while (0)
387#endif
388
389
390
391
392
393/* The object describing a lock. */
394struct dotlock_handle
395{
396 struct dotlock_handle *next;
397 char *lockname; /* Name of the actual lockfile. */
398 unsigned int locked:1; /* Lock status. */
399 unsigned int disable:1; /* If true, locking is disabled. */
400 unsigned int use_o_excl:1; /* Use open (O_EXCL) for locking. */
401
402 int extra_fd; /* A place for the caller to store an FD. */
403
404#ifdef HAVE_DOSISH_SYSTEM
405 HANDLE lockhd; /* The W32 handle of the lock file. */
406#else /*!HAVE_DOSISH_SYSTEM */
407 char *tname; /* Name of the lockfile template. */
408 size_t nodename_off; /* Offset in TNAME of the nodename part. */
409 size_t nodename_len; /* Length of the nodename part. */
410#endif /*!HAVE_DOSISH_SYSTEM */
411};
412
413
414/* A list of of all lock handles. The volatile attribute might help
415 if used in an atexit handler. */
416static volatile dotlock_t all_lockfiles;
417#ifdef DOTLOCK_USE_PTHREAD
418static pthread_mutex_t all_lockfiles_mutex = PTHREAD_MUTEX_INITIALIZER;
419# define LOCK_all_lockfiles() do { \
420 if (pthread_mutex_lock (&all_lockfiles_mutex)) \
421 my_fatal_0 ("locking all_lockfiles_mutex failed\n"); \
422 } while (0)
423# define UNLOCK_all_lockfiles() do { \
424 if (pthread_mutex_unlock (&all_lockfiles_mutex)) \
425 my_fatal_0 ("unlocking all_lockfiles_mutex failed\n"); \
426 } while (0)
427#else /*!DOTLOCK_USE_PTHREAD*/
428# define LOCK_all_lockfiles() do { } while (0)
429# define UNLOCK_all_lockfiles() do { } while (0)
430#endif /*!DOTLOCK_USE_PTHREAD*/
431
432/* If this has the value true all locking is disabled. */
433static int never_lock;
434
435
436
437
438
439/* Entirely disable all locking. This function should be called
440 before any locking is done. It may be called right at startup of
441 the process as it only sets a global value. */
442void
443dotlock_disable (void)
444{
445 never_lock = 1;
446}
447
448
449#ifdef HAVE_POSIX_SYSTEM
450static int
451maybe_deadlock (dotlock_t h)
452{
453 dotlock_t r;
454 int res = 0;
455
456 LOCK_all_lockfiles ();
457 for (r=all_lockfiles; r; r = r->next)
458 {
459 if ( r != h && r->locked )
460 {
461 res = 1;
462 break;
463 }
464 }
465 UNLOCK_all_lockfiles ();
466 return res;
467}
468#endif /*HAVE_POSIX_SYSTEM*/
469
470
471/* Read the lock file and return the pid, returns -1 on error. True
472 will be stored in the integer at address SAME_NODE if the lock file
473 has been created on the same node. */
474#ifdef HAVE_POSIX_SYSTEM
475static int
476read_lockfile (dotlock_t h, int *same_node )
477{
478 char buffer_space[10+1+70+1]; /* 70 is just an estimated value; node
479 names are usually shorter. */
480 int fd;
481 int pid = -1;
482 char *buffer, *p;
483 size_t expected_len;
484 int res, nread;
485
486 *same_node = 0;
487 expected_len = 10 + 1 + h->nodename_len + 1;
488 if ( expected_len >= sizeof buffer_space)
489 {
490 buffer = jnlib_malloc (expected_len);
491 if (!buffer)
492 return -1;
493 }
494 else
495 buffer = buffer_space;
496
497 if ( (fd = open (h->lockname, O_RDONLY)) == -1 )
498 {
499 int e = errno;
500 my_info_2 ("error opening lockfile '%s': %s\n",
501 h->lockname, strerror(errno) );
502 if (buffer != buffer_space)
503 jnlib_free (buffer);
504 jnlib_set_errno (e); /* Need to return ERRNO here. */
505 return -1;
506 }
507
508 p = buffer;
509 nread = 0;
510 do
511 {
512 res = read (fd, p, expected_len - nread);
513 if (res == -1 && errno == EINTR)
514 continue;
515 if (res < 0)
516 {
517 my_info_1 ("error reading lockfile '%s'\n", h->lockname );
518 close (fd);
519 if (buffer != buffer_space)
520 jnlib_free (buffer);
521 jnlib_set_errno (0); /* Do not return an inappropriate ERRNO. */
522 return -1;
523 }
524 p += res;
525 nread += res;
526 }
527 while (res && nread != expected_len);
528 close(fd);
529
530 if (nread < 11)
531 {
532 my_info_1 ("invalid size of lockfile '%s'\n", h->lockname);
533 if (buffer != buffer_space)
534 jnlib_free (buffer);
535 jnlib_set_errno (0); /* Better don't return an inappropriate ERRNO. */
536 return -1;
537 }
538
539 if (buffer[10] != '\n'
540 || (buffer[10] = 0, pid = atoi (buffer)) == -1
541 || !pid )
542 {
543 my_error_2 ("invalid pid %d in lockfile '%s'\n", pid, h->lockname);
544 if (buffer != buffer_space)
545 jnlib_free (buffer);
546 jnlib_set_errno (0);
547 return -1;
548 }
549
550 if (nread == expected_len
551 && !memcmp (h->tname+h->nodename_off, buffer+11, h->nodename_len)
552 && buffer[11+h->nodename_len] == '\n')
553 *same_node = 1;
554
555 if (buffer != buffer_space)
556 jnlib_free (buffer);
557 return pid;
558}
559#endif /*HAVE_POSIX_SYSTEM */
560
561
562/* Check whether the file system which stores TNAME supports
563 hardlinks. Instead of using the non-portable statsfs call which
564 differs between various Unix versions, we do a runtime test.
565 Returns: 0 supports hardlinks; 1 no hardlink support, -1 unknown
566 (test error). */
567#ifdef HAVE_POSIX_SYSTEM
568static int
569use_hardlinks_p (const char *tname)
570{
571 char *lname;
572 struct stat sb;
573 unsigned int nlink;
574 int res;
575
576 if (stat (tname, &sb))
577 return -1;
578 nlink = (unsigned int)sb.st_nlink;
579
580 lname = jnlib_malloc (strlen (tname) + 1 + 1);
581 if (!lname)
582 return -1;
583 strcpy (lname, tname);
584 strcat (lname, "x");
585
586 /* We ignore the return value of link() because it is unreliable. */
587 (void) link (tname, lname);
588
589 if (stat (tname, &sb))
590 res = -1; /* Ooops. */
591 else if (sb.st_nlink == nlink + 1)
592 res = 0; /* Yeah, hardlinks are supported. */
593 else
594 res = 1; /* No hardlink support. */
595
596 unlink (lname);
597 jnlib_free (lname);
598 return res;
599}
600#endif /*HAVE_POSIX_SYSTEM */
601
602
603
604#ifdef HAVE_POSIX_SYSTEM
605/* Locking core for Unix. It used a temporary file and the link
606 system call to make locking an atomic operation. */
607static dotlock_t
608dotlock_create_unix (dotlock_t h, const char *file_to_lock)
609{
610 int fd = -1;
611 char pidstr[16];
612 const char *nodename;
613 const char *dirpart;
614 int dirpartlen;
615 struct utsname utsbuf;
616 size_t tnamelen;
617
618 snprintf (pidstr, sizeof pidstr, "%10d\n", (int)getpid() );
619
620 /* Create a temporary file. */
621 if ( uname ( &utsbuf ) )
622 nodename = "unknown";
623 else
624 nodename = utsbuf.nodename;
625
626 if ( !(dirpart = strrchr (file_to_lock, DIRSEP_C)) )
627 {
628 dirpart = EXTSEP_S;
629 dirpartlen = 1;
630 }
631 else
632 {
633 dirpartlen = dirpart - file_to_lock;
634 dirpart = file_to_lock;
635 }
636
637 LOCK_all_lockfiles ();
638 h->next = all_lockfiles;
639 all_lockfiles = h;
640
641 tnamelen = dirpartlen + 6 + 30 + strlen(nodename) + 10 + 1;
642 h->tname = jnlib_malloc (tnamelen + 1);
643 if (!h->tname)
644 {
645 all_lockfiles = h->next;
646 UNLOCK_all_lockfiles ();
647 jnlib_free (h);
648 return NULL;
649 }
650 h->nodename_len = strlen (nodename);
651
652 snprintf (h->tname, tnamelen, "%.*s/.#lk%p.", dirpartlen, dirpart, h );
653 h->nodename_off = strlen (h->tname);
654 snprintf (h->tname+h->nodename_off, tnamelen - h->nodename_off,
655 "%s.%d", nodename, (int)getpid ());
656
657 do
658 {
659 jnlib_set_errno (0);
660 fd = open (h->tname, O_WRONLY|O_CREAT|O_EXCL,
661 S_IRUSR|S_IRGRP|S_IROTH|S_IWUSR );
662 }
663 while (fd == -1 && errno == EINTR);
664
665 if ( fd == -1 )
666 {
667 all_lockfiles = h->next;
668 UNLOCK_all_lockfiles ();
669 my_error_2 (_("failed to create temporary file '%s': %s\n"),
670 h->tname, strerror(errno));
671 jnlib_free (h->tname);
672 jnlib_free (h);
673 return NULL;
674 }
675 if ( write (fd, pidstr, 11 ) != 11 )
676 goto write_failed;
677 if ( write (fd, nodename, strlen (nodename) ) != strlen (nodename) )
678 goto write_failed;
679 if ( write (fd, "\n", 1 ) != 1 )
680 goto write_failed;
681 if ( close (fd) )
682 goto write_failed;
683
684 /* Check whether we support hard links. */
685 switch (use_hardlinks_p (h->tname))
686 {
687 case 0: /* Yes. */
688 break;
689 case 1: /* No. */
690 unlink (h->tname);
691 h->use_o_excl = 1;
692 break;
693 default:
694 my_error_2 ("can't check whether hardlinks are supported for '%s': %s\n",
695 h->tname, strerror(errno));
696 goto write_failed;
697 }
698
699 h->lockname = jnlib_malloc (strlen (file_to_lock) + 6 );
700 if (!h->lockname)
701 {
702 all_lockfiles = h->next;
703 UNLOCK_all_lockfiles ();
704 unlink (h->tname);
705 jnlib_free (h->tname);
706 jnlib_free (h);
707 return NULL;
708 }
709 strcpy (stpcpy (h->lockname, file_to_lock), EXTSEP_S "lock");
710 UNLOCK_all_lockfiles ();
711 if (h->use_o_excl)
712 my_debug_1 ("locking for '%s' done via O_EXCL\n", h->lockname);
713
714 return h;
715
716 write_failed:
717 all_lockfiles = h->next;
718 UNLOCK_all_lockfiles ();
719 my_error_2 (_("error writing to '%s': %s\n"), h->tname, strerror (errno));
720 close (fd);
721 unlink (h->tname);
722 jnlib_free (h->tname);
723 jnlib_free (h);
724 return NULL;
725}
726#endif /*HAVE_POSIX_SYSTEM*/
727
728
729#ifdef HAVE_DOSISH_SYSTEM
730/* Locking core for Windows. This version does not need a temporary
731 file but uses the plain lock file along with record locking. We
732 create this file here so that we later only need to do the file
733 locking. For error reporting it is useful to keep the name of the
734 file in the handle. */
735static dotlock_t
736dotlock_create_w32 (dotlock_t h, const char *file_to_lock)
737{
738 LOCK_all_lockfiles ();
739 h->next = all_lockfiles;
740 all_lockfiles = h;
741
742 h->lockname = jnlib_malloc ( strlen (file_to_lock) + 6 );
743 if (!h->lockname)
744 {
745 all_lockfiles = h->next;
746 UNLOCK_all_lockfiles ();
747 jnlib_free (h);
748 return NULL;
749 }
750 strcpy (stpcpy(h->lockname, file_to_lock), EXTSEP_S "lock");
751
752 /* If would be nice if we would use the FILE_FLAG_DELETE_ON_CLOSE
753 along with FILE_SHARE_DELETE but that does not work due to a race
754 condition: Despite the OPEN_ALWAYS flag CreateFile may return an
755 error and we can't reliable create/open the lock file unless we
756 would wait here until it works - however there are other valid
757 reasons why a lock file can't be created and thus the process
758 would not stop as expected but spin until Windows crashes. Our
759 solution is to keep the lock file open; that does not harm. */
760 {
761#ifdef HAVE_W32CE_SYSTEM
762 wchar_t *wname = utf8_to_wchar (h->lockname);
763
764 if (wname)
765 h->lockhd = CreateFile (wname,
766 GENERIC_READ|GENERIC_WRITE,
767 FILE_SHARE_READ|FILE_SHARE_WRITE,
768 NULL, OPEN_ALWAYS, 0, NULL);
769 else
770 h->lockhd = INVALID_HANDLE_VALUE;
771 jnlib_free (wname);
772#else
773 h->lockhd = CreateFile (h->lockname,
774 GENERIC_READ|GENERIC_WRITE,
775 FILE_SHARE_READ|FILE_SHARE_WRITE,
776 NULL, OPEN_ALWAYS, 0, NULL);
777#endif
778 }
779 if (h->lockhd == INVALID_HANDLE_VALUE)
780 {
781 all_lockfiles = h->next;
782 UNLOCK_all_lockfiles ();
783 my_error_2 (_("can't create '%s': %s\n"), h->lockname, w32_strerror (-1));
784 jnlib_free (h->lockname);
785 jnlib_free (h);
786 return NULL;
787 }
788 return h;
789}
790#endif /*HAVE_DOSISH_SYSTEM*/
791
792
793/* Create a lockfile for a file name FILE_TO_LOCK and returns an
794 object of type dotlock_t which may be used later to actually acquire
795 the lock. A cleanup routine gets installed to cleanup left over
796 locks or other files used internally by the lock mechanism.
797
798 Calling this function with NULL does only install the atexit
799 handler and may thus be used to assure that the cleanup is called
800 after all other atexit handlers.
801
802 This function creates a lock file in the same directory as
803 FILE_TO_LOCK using that name and a suffix of ".lock". Note that on
804 POSIX systems a temporary file ".#lk.<hostname>.pid[.threadid] is
805 used.
806
807 FLAGS must be 0.
808
809 The function returns an new handle which needs to be released using
810 destroy_dotlock but gets also released at the termination of the
811 process. On error NULL is returned.
812 */
813
814dotlock_t
815dotlock_create (const char *file_to_lock, unsigned int flags)
816{
817 static int initialized;
818 dotlock_t h;
819
820 if ( !initialized )
821 {
822 atexit (dotlock_remove_lockfiles);
823 initialized = 1;
824 }
825
826 if ( !file_to_lock )
827 return NULL; /* Only initialization was requested. */
828
829 if (flags)
830 {
831 jnlib_set_errno (EINVAL);
832 return NULL;
833 }
834
835 h = jnlib_calloc (1, sizeof *h);
836 if (!h)
837 return NULL;
838 h->extra_fd = -1;
839
840 if (never_lock)
841 {
842 h->disable = 1;
843 LOCK_all_lockfiles ();
844 h->next = all_lockfiles;
845 all_lockfiles = h;
846 UNLOCK_all_lockfiles ();
847 return h;
848 }
849
850#ifdef HAVE_DOSISH_SYSTEM
851 return dotlock_create_w32 (h, file_to_lock);
852#else /*!HAVE_DOSISH_SYSTEM */
853 return dotlock_create_unix (h, file_to_lock);
854#endif /*!HAVE_DOSISH_SYSTEM*/
855}
856
857
858
859/* Convenience function to store a file descriptor (or any any other
860 integer value) in the context of handle H. */
861void
862dotlock_set_fd (dotlock_t h, int fd)
863{
864 h->extra_fd = fd;
865}
866
867/* Convenience function to retrieve a file descriptor (or any any other
868 integer value) stored in the context of handle H. */
869int
870dotlock_get_fd (dotlock_t h)
871{
872 return h->extra_fd;
873}
874
875
876
877#ifdef HAVE_POSIX_SYSTEM
878/* Unix specific code of destroy_dotlock. */
879static void
880dotlock_destroy_unix (dotlock_t h)
881{
882 if (h->locked && h->lockname)
883 unlink (h->lockname);
884 if (h->tname && !h->use_o_excl)
885 unlink (h->tname);
886 jnlib_free (h->tname);
887}
888#endif /*HAVE_POSIX_SYSTEM*/
889
890
891#ifdef HAVE_DOSISH_SYSTEM
892/* Windows specific code of destroy_dotlock. */
893static void
894dotlock_destroy_w32 (dotlock_t h)
895{
896 if (h->locked)
897 {
898 OVERLAPPED ovl;
899
900 memset (&ovl, 0, sizeof ovl);
901 UnlockFileEx (h->lockhd, 0, 1, 0, &ovl);
902 }
903 CloseHandle (h->lockhd);
904}
905#endif /*HAVE_DOSISH_SYSTEM*/
906
907
908/* Destroy the locck handle H and release the lock. */
909void
910dotlock_destroy (dotlock_t h)
911{
912 dotlock_t hprev, htmp;
913
914 if ( !h )
915 return;
916
917 /* First remove the handle from our global list of all locks. */
918 LOCK_all_lockfiles ();
919 for (hprev=NULL, htmp=all_lockfiles; htmp; hprev=htmp, htmp=htmp->next)
920 if (htmp == h)
921 {
922 if (hprev)
923 hprev->next = htmp->next;
924 else
925 all_lockfiles = htmp->next;
926 h->next = NULL;
927 break;
928 }
929 UNLOCK_all_lockfiles ();
930
931 /* Then destroy the lock. */
932 if (!h->disable)
933 {
934#ifdef HAVE_DOSISH_SYSTEM
935 dotlock_destroy_w32 (h);
936#else /* !HAVE_DOSISH_SYSTEM */
937 dotlock_destroy_unix (h);
938#endif /* HAVE_DOSISH_SYSTEM */
939 jnlib_free (h->lockname);
940 }
941 jnlib_free(h);
942}
943
944
945
946#ifdef HAVE_POSIX_SYSTEM
947/* Unix specific code of make_dotlock. Returns 0 on success and -1 on
948 error. */
949static int
950dotlock_take_unix (dotlock_t h, long timeout)
951{
952 int wtime = 0;
953 int sumtime = 0;
954 int pid;
955 int lastpid = -1;
956 int ownerchanged;
957 const char *maybe_dead="";
958 int same_node;
959
960 again:
961 if (h->use_o_excl)
962 {
963 /* No hardlink support - use open(O_EXCL). */
964 int fd;
965
966 do
967 {
968 jnlib_set_errno (0);
969 fd = open (h->lockname, O_WRONLY|O_CREAT|O_EXCL,
970 S_IRUSR|S_IRGRP|S_IROTH|S_IWUSR );
971 }
972 while (fd == -1 && errno == EINTR);
973
974 if (fd == -1 && errno == EEXIST)
975 ; /* Lock held by another process. */
976 else if (fd == -1)
977 {
978 my_error_2 ("lock not made: open(O_EXCL) of '%s' failed: %s\n",
979 h->lockname, strerror (errno));
980 return -1;
981 }
982 else
983 {
984 char pidstr[16];
985
986 snprintf (pidstr, sizeof pidstr, "%10d\n", (int)getpid());
987 if (write (fd, pidstr, 11 ) == 11
988 && write (fd, h->tname + h->nodename_off,h->nodename_len)
989 == h->nodename_len
990 && write (fd, "\n", 1) == 1
991 && !close (fd))
992 {
993 h->locked = 1;
994 return 0;
995 }
996 /* Write error. */
997 my_error_2 ("lock not made: writing to '%s' failed: %s\n",
998 h->lockname, strerror (errno));
999 close (fd);
1000 unlink (h->lockname);
1001 return -1;
1002 }
1003 }
1004 else /* Standard method: Use hardlinks. */
1005 {
1006 struct stat sb;
1007
1008 /* We ignore the return value of link() because it is unreliable. */
1009 (void) link (h->tname, h->lockname);
1010
1011 if (stat (h->tname, &sb))
1012 {
1013 my_error_1 ("lock not made: Oops: stat of tmp file failed: %s\n",
1014 strerror (errno));
1015 /* In theory this might be a severe error: It is possible
1016 that link succeeded but stat failed due to changed
1017 permissions. We can't do anything about it, though. */
1018 return -1;
1019 }
1020
1021 if (sb.st_nlink == 2)
1022 {
1023 h->locked = 1;
1024 return 0; /* Okay. */
1025 }
1026 }
1027
1028 /* Check for stale lock files. */
1029 if ( (pid = read_lockfile (h, &same_node)) == -1 )
1030 {
1031 if ( errno != ENOENT )
1032 {
1033 my_info_0 ("cannot read lockfile\n");
1034 return -1;
1035 }
1036 my_info_0 ("lockfile disappeared\n");
1037 goto again;
1038 }
1039 else if ( pid == getpid() && same_node )
1040 {
1041 my_info_0 ("Oops: lock already held by us\n");
1042 h->locked = 1;
1043 return 0; /* okay */
1044 }
1045 else if ( same_node && kill (pid, 0) && errno == ESRCH )
1046 {
1047 /* Note: It is unlikley that we get a race here unless a pid is
1048 reused too fast or a new process with the same pid as the one
1049 of the stale file tries to lock right at the same time as we. */
1050 my_info_1 (_("removing stale lockfile (created by %d)\n"), pid);
1051 unlink (h->lockname);
1052 goto again;
1053 }
1054
1055 if (lastpid == -1)
1056 lastpid = pid;
1057 ownerchanged = (pid != lastpid);
1058
1059 if (timeout)
1060 {
1061 struct timeval tv;
1062
1063 /* Wait until lock has been released. We use increasing retry
1064 intervals of 50ms, 100ms, 200ms, 400ms, 800ms, 2s, 4s and 8s
1065 but reset it if the lock owner meanwhile changed. */
1066 if (!wtime || ownerchanged)
1067 wtime = 50;
1068 else if (wtime < 800)
1069 wtime *= 2;
1070 else if (wtime == 800)
1071 wtime = 2000;
1072 else if (wtime < 8000)
1073 wtime *= 2;
1074
1075 if (timeout > 0)
1076 {
1077 if (wtime > timeout)
1078 wtime = timeout;
1079 timeout -= wtime;
1080 }
1081
1082 sumtime += wtime;
1083 if (sumtime >= 1500)
1084 {
1085 sumtime = 0;
1086 my_info_3 (_("waiting for lock (held by %d%s) %s...\n"),
1087 pid, maybe_dead, maybe_deadlock(h)? _("(deadlock?) "):"");
1088 }
1089
1090
1091 tv.tv_sec = wtime / 1000;
1092 tv.tv_usec = (wtime % 1000) * 1000;
1093 select (0, NULL, NULL, NULL, &tv);
1094 goto again;
1095 }
1096
1097 jnlib_set_errno (EACCES);
1098 return -1;
1099}
1100#endif /*HAVE_POSIX_SYSTEM*/
1101
1102
1103#ifdef HAVE_DOSISH_SYSTEM
1104/* Windows specific code of make_dotlock. Returns 0 on success and -1 on
1105 error. */
1106static int
1107dotlock_take_w32 (dotlock_t h, long timeout)
1108{
1109 int wtime = 0;
1110 int w32err;
1111 OVERLAPPED ovl;
1112
1113 again:
1114 /* Lock one byte at offset 0. The offset is given by OVL. */
1115 memset (&ovl, 0, sizeof ovl);
1116 if (LockFileEx (h->lockhd, (LOCKFILE_EXCLUSIVE_LOCK
1117 | LOCKFILE_FAIL_IMMEDIATELY), 0, 1, 0, &ovl))
1118 {
1119 h->locked = 1;
1120 return 0; /* okay */
1121 }
1122
1123 w32err = GetLastError ();
1124 if (w32err != ERROR_LOCK_VIOLATION)
1125 {
1126 my_error_2 (_("lock '%s' not made: %s\n"),
1127 h->lockname, w32_strerror (w32err));
1128 return -1;
1129 }
1130
1131 if (timeout)
1132 {
1133 /* Wait until lock has been released. We use retry intervals of
1134 50ms, 100ms, 200ms, 400ms, 800ms, 2s, 4s and 8s. */
1135 if (!wtime)
1136 wtime = 50;
1137 else if (wtime < 800)
1138 wtime *= 2;
1139 else if (wtime == 800)
1140 wtime = 2000;
1141 else if (wtime < 8000)
1142 wtime *= 2;
1143
1144 if (timeout > 0)
1145 {
1146 if (wtime > timeout)
1147 wtime = timeout;
1148 timeout -= wtime;
1149 }
1150
1151 if (wtime >= 800)
1152 my_info_1 (_("waiting for lock %s...\n"), h->lockname);
1153
1154 Sleep (wtime);
1155 goto again;
1156 }
1157
1158 return -1;
1159}
1160#endif /*HAVE_DOSISH_SYSTEM*/
1161
1162
1163/* Take a lock on H. A value of 0 for TIMEOUT returns immediately if
1164 the lock can't be taked, -1 waits forever (hopefully not), other
1165 values wait for TIMEOUT milliseconds. Returns: 0 on success */
1166int
1167dotlock_take (dotlock_t h, long timeout)
1168{
1169 int ret;
1170
1171 if ( h->disable )
1172 return 0; /* Locks are completely disabled. Return success. */
1173
1174 if ( h->locked )
1175 {
1176 my_debug_1 ("Oops, '%s' is already locked\n", h->lockname);
1177 return 0;
1178 }
1179
1180#ifdef HAVE_DOSISH_SYSTEM
1181 ret = dotlock_take_w32 (h, timeout);
1182#else /*!HAVE_DOSISH_SYSTEM*/
1183 ret = dotlock_take_unix (h, timeout);
1184#endif /*!HAVE_DOSISH_SYSTEM*/
1185
1186 return ret;
1187}
1188
1189
1190
1191#ifdef HAVE_POSIX_SYSTEM
1192/* Unix specific code of release_dotlock. */
1193static int
1194dotlock_release_unix (dotlock_t h)
1195{
1196 int pid, same_node;
1197
1198 pid = read_lockfile (h, &same_node);
1199 if ( pid == -1 )
1200 {
1201 my_error_0 ("release_dotlock: lockfile error\n");
1202 return -1;
1203 }
1204 if ( pid != getpid() || !same_node )
1205 {
1206 my_error_1 ("release_dotlock: not our lock (pid=%d)\n", pid);
1207 return -1;
1208 }
1209
1210 if ( unlink( h->lockname ) )
1211 {
1212 my_error_1 ("release_dotlock: error removing lockfile '%s'\n",
1213 h->lockname);
1214 return -1;
1215 }
1216 /* Fixme: As an extra check we could check whether the link count is
1217 now really at 1. */
1218 return 0;
1219}
1220#endif /*HAVE_POSIX_SYSTEM */
1221
1222
1223#ifdef HAVE_DOSISH_SYSTEM
1224/* Windows specific code of release_dotlock. */
1225static int
1226dotlock_release_w32 (dotlock_t h)
1227{
1228 OVERLAPPED ovl;
1229
1230 memset (&ovl, 0, sizeof ovl);
1231 if (!UnlockFileEx (h->lockhd, 0, 1, 0, &ovl))
1232 {
1233 my_error_2 ("release_dotlock: error removing lockfile '%s': %s\n",
1234 h->lockname, w32_strerror (-1));
1235 return -1;
1236 }
1237
1238 return 0;
1239}
1240#endif /*HAVE_DOSISH_SYSTEM */
1241
1242
1243/* Release a lock. Returns 0 on success. */
1244int
1245dotlock_release (dotlock_t h)
1246{
1247 int ret;
1248
1249 /* To avoid atexit race conditions we first check whether there are
1250 any locks left. It might happen that another atexit handler
1251 tries to release the lock while the atexit handler of this module
1252 already ran and thus H is undefined. */
1253 LOCK_all_lockfiles ();
1254 ret = !all_lockfiles;
1255 UNLOCK_all_lockfiles ();
1256 if (ret)
1257 return 0;
1258
1259 if ( h->disable )
1260 return 0;
1261
1262 if ( !h->locked )
1263 {
1264 my_debug_1 ("Oops, '%s' is not locked\n", h->lockname);
1265 return 0;
1266 }
1267
1268#ifdef HAVE_DOSISH_SYSTEM
1269 ret = dotlock_release_w32 (h);
1270#else
1271 ret = dotlock_release_unix (h);
1272#endif
1273
1274 if (!ret)
1275 h->locked = 0;
1276 return ret;
1277}
1278
1279
1280
1281/* Remove all lockfiles. This is called by the atexit handler
1282 installed by this module but may also be called by other
1283 termination handlers. */
1284void
1285dotlock_remove_lockfiles (void)
1286{
1287 dotlock_t h, h2;
1288
1289 /* First set the lockfiles list to NULL so that for example
1290 dotlock_release is ware that this fucntion is currently
1291 running. */
1292 LOCK_all_lockfiles ();
1293 h = all_lockfiles;
1294 all_lockfiles = NULL;
1295 UNLOCK_all_lockfiles ();
1296
1297 while ( h )
1298 {
1299 h2 = h->next;
1300 dotlock_destroy (h);
1301 h = h2;
1302 }
1303}
diff --git a/lib/dotlock.h b/lib/dotlock.h
new file mode 100644
index 0000000..3fb9bcb
--- /dev/null
+++ b/lib/dotlock.h
@@ -0,0 +1,112 @@
1/* dotlock.h - dotfile locking declarations
2 * Copyright (C) 2000, 2001, 2006, 2011 Free Software Foundation, Inc.
3 *
4 * This file is part of JNLIB, which is a subsystem of GnuPG.
5 *
6 * JNLIB is free software; you can redistribute it and/or modify it
7 * under the terms of either
8 *
9 * - the GNU Lesser General Public License as published by the Free
10 * Software Foundation; either version 3 of the License, or (at
11 * your option) any later version.
12 *
13 * or
14 *
15 * - the GNU General Public License as published by the Free
16 * Software Foundation; either version 2 of the License, or (at
17 * your option) any later version.
18 *
19 * or both in parallel, as here.
20 *
21 * JNLIB is distributed in the hope that it will be useful, but
22 * WITHOUT ANY WARRANTY; without even the implied warranty of
23 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
24 * General Public License for more details.
25 *
26 * You should have received a copies of the GNU General Public License
27 * and the GNU Lesser General Public License along with this program;
28 * if not, see <http://www.gnu.org/licenses/>.
29 *
30 * ALTERNATIVELY, this file may be distributed under the terms of the
31 * following license, in which case the provisions of this license are
32 * required INSTEAD OF the GNU Lesser General License or the GNU
33 * General Public License. If you wish to allow use of your version of
34 * this file only under the terms of the GNU Lesser General License or
35 * the GNU General Public License, and not to allow others to use your
36 * version of this file under the terms of the following license,
37 * indicate your decision by deleting this paragraph and the license
38 * below.
39 *
40 * Redistribution and use in source and binary forms, with or without
41 * modification, are permitted provided that the following conditions
42 * are met:
43 *
44 * 1. Redistributions of source code must retain the above copyright
45 * notice, and the entire permission notice in its entirety,
46 * including the disclaimer of warranties.
47 * 2. Redistributions in binary form must reproduce the above copyright
48 * notice, this list of conditions and the following disclaimer in the
49 * documentation and/or other materials provided with the distribution.
50 * 3. The name of the author may not be used to endorse or promote
51 * products derived from this software without specific prior
52 * written permission.
53 *
54 * THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED
55 * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
56 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
57 * DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
58 * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
59 * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
60 * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
61 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
62 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
63 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
64 * OF THE POSSIBILITY OF SUCH DAMAGE.
65 */
66
67#ifndef LIBJNLIB_DOTLOCK_H
68#define LIBJNLIB_DOTLOCK_H
69
70/* See dotlock.c for a description. */
71
72#ifdef DOTLOCK_EXT_SYM_PREFIX
73# ifndef _DOTLOCK_PREFIX
74# define _DOTLOCK_PREFIX1(x,y) x ## y
75# define _DOTLOCK_PREFIX2(x,y) _DOTLOCK_PREFIX1(x,y)
76# define _DOTLOCK_PREFIX(x) _DOTLOCK_PREFIX2(DOTLOCK_EXT_SYM_PREFIX,x)
77# endif /*_DOTLOCK_PREFIX*/
78# define dotlock_disable _DOTLOCK_PREFIX(dotlock_disable)
79# define dotlock_create _DOTLOCK_PREFIX(dotlock_create)
80# define dotlock_set_fd _DOTLOCK_PREFIX(dotlock_set_fd)
81# define dotlock_get_fd _DOTLOCK_PREFIX(dotlock_get_fd)
82# define dotlock_destroy _DOTLOCK_PREFIX(dotlock_destroy)
83# define dotlock_take _DOTLOCK_PREFIX(dotlock_take)
84# define dotlock_release _DOTLOCK_PREFIX(dotlock_release)
85# define dotlock_remove_lockfiles _DOTLOCK_PREFIX(dotlock_remove_lockfiles)
86#endif /*DOTLOCK_EXT_SYM_PREFIX*/
87
88#ifdef __cplusplus
89extern "C"
90{
91#if 0
92}
93#endif
94#endif
95
96
97struct dotlock_handle;
98typedef struct dotlock_handle *dotlock_t;
99
100void dotlock_disable (void);
101dotlock_t dotlock_create (const char *file_to_lock, unsigned int flags);
102void dotlock_set_fd (dotlock_t h, int fd);
103int dotlock_get_fd (dotlock_t h);
104void dotlock_destroy (dotlock_t h);
105int dotlock_take (dotlock_t h, long timeout);
106int dotlock_release (dotlock_t h);
107void dotlock_remove_lockfiles (void);
108
109#ifdef __cplusplus
110}
111#endif
112#endif /*LIBJNLIB_DOTLOCK_H*/
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 01:43:36 +0000