From fbf425fbef1c1e60fcdddfbd9b25976162725f97 Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 24 Apr 2016 18:43:00 -0400 Subject: Refactored build of executable and library. --- Base58.hs | 70 - Compat.hs | 58 - ControlMaybe.hs | 29 - CryptoCoins.hs | 70 - DotLock.hs | 45 - FunctorToMaybe.hs | 69 - Hosts.hs | 314 ----- KeyRing.hs | 3505 ------------------------------------------------- PEM.hs | 34 - ProcessUtils.hs | 45 - ScanningParser.hs | 74 -- TimeUtil.hs | 128 -- dotlock.c | 1303 ------------------ dotlock.h | 112 -- kiki.cabal | 69 +- lib/Base58.hs | 70 + lib/Compat.hs | 58 + lib/ControlMaybe.hs | 29 + lib/CryptoCoins.hs | 70 + lib/DotLock.hs | 45 + lib/FunctorToMaybe.hs | 69 + lib/Hosts.hs | 314 +++++ lib/KeyRing.hs | 3505 +++++++++++++++++++++++++++++++++++++++++++++++++ lib/PEM.hs | 34 + lib/ProcessUtils.hs | 45 + lib/ScanningParser.hs | 74 ++ lib/TimeUtil.hs | 128 ++ lib/dotlock.c | 1303 ++++++++++++++++++ lib/dotlock.h | 112 ++ 29 files changed, 5912 insertions(+), 5869 deletions(-) delete mode 100644 Base58.hs delete mode 100644 Compat.hs delete mode 100644 ControlMaybe.hs delete mode 100644 CryptoCoins.hs delete mode 100644 DotLock.hs delete mode 100644 FunctorToMaybe.hs delete mode 100644 Hosts.hs delete mode 100644 KeyRing.hs delete mode 100644 PEM.hs delete mode 100644 ProcessUtils.hs delete mode 100644 ScanningParser.hs delete mode 100644 TimeUtil.hs delete mode 100644 dotlock.c delete mode 100644 dotlock.h create mode 100644 lib/Base58.hs create mode 100644 lib/Compat.hs create mode 100644 lib/ControlMaybe.hs create mode 100644 lib/CryptoCoins.hs create mode 100644 lib/DotLock.hs create mode 100644 lib/FunctorToMaybe.hs create mode 100644 lib/Hosts.hs create mode 100644 lib/KeyRing.hs create mode 100644 lib/PEM.hs create mode 100644 lib/ProcessUtils.hs create mode 100644 lib/ScanningParser.hs create mode 100644 lib/TimeUtil.hs create mode 100644 lib/dotlock.c create mode 100644 lib/dotlock.h diff --git a/Base58.hs b/Base58.hs deleted file mode 100644 index 3c1a113..0000000 --- a/Base58.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE CPP #-} -module Base58 where - -#if !defined(VERSION_cryptonite) -import qualified Crypto.Hash.SHA256 as SHA256 -#else -import Crypto.Hash -import Data.ByteArray (convert) -#endif -import qualified Data.ByteString as S -import Data.Maybe -import Data.List -import Data.Word ( Word8 ) -import Control.Monad - -base58chars :: [Char] -base58chars = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" - -base58digits :: [Char] -> Maybe [Int] -base58digits str = sequence mbs - where - mbs = map (flip elemIndex base58chars) str - --- 5HueCGU8rMjxEXxiPuD5BDku4MkFqeZyd4dZ1jvhTVqvbTLvyTJ -base58_decode :: [Char] -> Maybe (Word8,[Word8]) -base58_decode str = do - ds <- base58digits str - let n = foldl' (\a b-> a*58 + b) 0 $ ( map fromIntegral ds :: [Integer] ) - rbytes = unfoldr getbyte n - getbyte d = do - guard (d/=0) - let (q,b) = d `divMod` 256 - return (fromIntegral b,q) - - let (rcksum,rpayload) = splitAt 4 $ rbytes - a_payload = reverse rpayload -#if !defined(VERSION_cryptonite) - hash_result = S.take 4 . SHA256.hash . SHA256.hash . S.pack $ a_payload -#else - hash_result = S.take 4 . convert $ digest - where digest = hash (S.pack a_payload) :: Digest SHA256 -#endif - expected_hash = S.pack $ reverse rcksum - (network_id,payload) = splitAt 1 a_payload - - network_id <- listToMaybe network_id - guard (hash_result==expected_hash) - return (network_id,payload) - -base58_encode :: S.ByteString -> String -base58_encode hsh = replicate zcount '1' ++ map (base58chars !!) (reverse rdigits) - where - zcount = S.length . S.takeWhile (==0) $ hsh -#if !defined(VERSION_cryptonite) - cksum = S.take 4 . SHA256.hash . SHA256.hash $ hsh -#else - cksum = S.take 4 (convert digest2 :: S.ByteString) - where digest2 = hash ( convert digest1 :: S.ByteString) :: Digest SHA256 - digest1 = hash hsh :: Digest SHA256 -#endif - n = foldl' (\a b->a*256+b) 0 . map asInteger $ concatMap S.unpack [hsh, cksum] - asInteger x = fromIntegral x :: Integer - rdigits = unfoldr getdigit n - where - getdigit d = do - guard (d/=0) - let (q,b) = d `divMod` 58 - return (fromIntegral b,q) - - diff --git a/Compat.hs b/Compat.hs deleted file mode 100644 index 3b77851..0000000 --- a/Compat.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE CPP #-} -module Compat where - -import Data.Bits -import Data.Word -import Data.ASN1.Types -import Data.ASN1.Encoding -import Data.ASN1.BinaryEncoding -import Crypto.PubKey.RSA as RSA - -#if defined(VERSION_cryptonite) - -instance ASN1Object PublicKey where - toASN1 pubKey = \xs -> Start Sequence - : IntVal (public_n pubKey) - : IntVal (public_e pubKey) - : End Sequence - : xs - fromASN1 (Start Sequence:IntVal smodulus:IntVal pubexp:End Sequence:xs) = - Right (PublicKey { public_size = calculate_modulus modulus 1 - , public_n = modulus - , public_e = pubexp - } - , xs) - where calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1) - -- some bad implementation will not serialize ASN.1 integer properly, leading - -- to negative modulus. if that's the case, we correct it. - modulus = toPositive smodulus - fromASN1 ( Start Sequence - : IntVal 0 - : Start Sequence - : OID [1, 2, 840, 113549, 1, 1, 1] - : Null - : End Sequence - : OctetString bs - : xs - ) = let inner = either strError fromASN1 $ decodeASN1' BER bs - strError = Left . - ("fromASN1: RSA.PublicKey: " ++) . show - in either Left (\(k, _) -> Right (k, xs)) inner - fromASN1 _ = - Left "fromASN1: RSA.PublicKey: unexpected format" - -#endif - -toPositive :: Integer -> Integer -toPositive int - | int < 0 = uintOfBytes $ bytesOfInt int - | otherwise = int - where uintOfBytes = foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 - bytesOfInt :: Integer -> [Word8] - bytesOfInt n = if testBit (head nints) 7 then nints else 0xff : nints - where nints = reverse $ plusOne $ reverse $ map complement $ bytesOfUInt (abs n) - plusOne [] = [1] - plusOne (x:xs) = if x == 0xff then 0 : plusOne xs else (x+1) : xs - bytesOfUInt x = reverse (list x) - where list i = if i <= 0xff then [fromIntegral i] else (fromIntegral i .&. 0xff) : list (i `shiftR` 8) - diff --git a/ControlMaybe.hs b/ControlMaybe.hs deleted file mode 100644 index 659dab7..0000000 --- a/ControlMaybe.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module ControlMaybe where - --- import GHC.IO.Exception (IOException(..)) -import Control.Exception as Exception (IOException(..),catch) - - -withJust :: Monad m => Maybe x -> (x -> m ()) -> m () -withJust (Just x) f = f x -withJust Nothing f = return () - -whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m () -whenJust acn f = do - x <- acn - withJust x f - - -catchIO_ :: IO a -> IO a -> IO a -catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h) - -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO body handler = Exception.catch body handler - -handleIO_ :: IO a -> IO a -> IO a -handleIO_ = flip catchIO_ - - -handleIO :: (IOException -> IO a) -> IO a -> IO a -handleIO = flip catchIO diff --git a/CryptoCoins.hs b/CryptoCoins.hs deleted file mode 100644 index f417036..0000000 --- a/CryptoCoins.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} -module CryptoCoins where - -import Numeric -import Data.Word -import Data.Maybe - -data CoinNetwork = CoinNetwork - { network_name :: String - , public_byte_id :: Word8 - , private_byte_id :: Word8 - , source_code_uri :: String - } - deriving (Show,Read) - --- For forks of bitcoin, grep sources for PUBKEY_ADDRESS --- That value + 0x80 will be the private_byte_id. --- information source: https://raw.github.com/zamgo/PHPCoinAddress/master/README.md -coin_networks :: [CoinNetwork] -coin_networks = - [ CoinNetwork "bitcoin" 0x00 0x80 "https://github.com/bitcoin/bitcoin" - , CoinNetwork "litecoin" 0x30 0xB0 "https://github.com/litecoin-project/litecoin" - , CoinNetwork "peercoin" 0x37 0xB7 "https://github.com/ppcoin/ppcoin" -- AKA: ppcoin - , CoinNetwork "namecoin" 0x34 0xB4 "https://github.com/namecoin/namecoin" - , CoinNetwork "bbqcoin" 0x05 0xD5 "https://github.com/overware/BBQCoin" - , CoinNetwork "bitbar" 0x19 0x99 "https://github.com/aLQ/bitbar" - , CoinNetwork "bytecoin" 0x12 0x80 "https://github.com/bryan-mills/bytecoin" - , CoinNetwork "chncoin" 0x1C 0x9C "https://github.com/CHNCoin/CHNCoin" - , CoinNetwork "devcoin" 0x00 0x80 "http://sourceforge.net/projects/galacticmilieu/files/DeVCoin" - , CoinNetwork "feathercoin" 0x0E 0x8E "https://github.com/FeatherCoin/FeatherCoin" - , CoinNetwork "freicoin" 0x00 0x80 "https://github.com/freicoin/freicoin" - , CoinNetwork "junkcoin" 0x10 0x90 "https://github.com/js2082/JKC" - , CoinNetwork "mincoin" 0x32 0xB2 "https://github.com/SandyCohen/mincoin" - , CoinNetwork "novacoin" 0x08 0x88 "https://github.com/CryptoManiac/novacoin" - , CoinNetwork "onecoin" 0x73 0xF3 "https://github.com/cre8r/onecoin" - , CoinNetwork "smallchange" 0x3E 0xBE "https://github.com/bfroemel/smallchange" - , CoinNetwork "terracoin" 0x00 0x80 "https://github.com/terracoin/terracoin" - , CoinNetwork "yacoin" 0x4D 0xCD "https://github.com/pocopoco/yacoin" - , CoinNetwork "bitcoin-t" 0x6F 0xEF "" - , CoinNetwork "bbqcoin-t" 0x19 0x99 "" - , CoinNetwork "bitbar-t" 0x73 0xF3 "" - ] - -- fairbrix - - https://github.com/coblee/Fairbrix - -- ixcoin - - https://github.com/ixcoin/ixcoin - -- royalcoin - - http://sourceforge.net/projects/royalcoin/ - -lookupNetwork :: Eq a => (CoinNetwork -> a) -> a -> Maybe CoinNetwork -lookupNetwork f b = listToMaybe $ filter (\n->f n==b) coin_networks - -nameFromSecretByte :: Word8 -> String -nameFromSecretByte b = maybe (defaultName b) network_name (lookupNetwork private_byte_id b) - where - defaultName b = "?coin?"++hexit b - where - hexit b = pad0 $ showHex b "" - where pad0 [c] = '0':c:[] - pad0 cs = take 2 cs - -publicByteFromName :: String -> Word8 -publicByteFromName n = maybe (secretByteFromName n - 0x80) - -- exceptions to the above: bbqcoin, bytecoin - public_byte_id - (lookupNetwork network_name n) - -secretByteFromName :: String -> Word8 -secretByteFromName n = maybe (defaultID n) private_byte_id (lookupNetwork network_name n) - where - defaultID ('?':'c':'o':'i':'n':'?':(readHex->((x,_):_))) - = x - defaultID _ = 0x00 diff --git a/DotLock.hs b/DotLock.hs deleted file mode 100644 index af05f5d..0000000 --- a/DotLock.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module DotLock - ( DotLock - , Flags - , dotlock_init - , dotlock_create - , dotlock_take - , dotlock_release - , dotlock_destroy - , dotlock_remove_lockfiles - , dotlock_set_fd - , dotlock_get_fd - , dotlock_disable - ) where - -import System.Posix.Types (Fd(..)) -import Foreign.C.String -import Foreign.C.Types -import Foreign.Ptr - -newtype DotLock = DotLockPtr (Ptr ()) -type Flags = Int - -foreign import ccall "dotlock_create" _dotlock_create_ptr :: Ptr Char -> Flags -> IO (Ptr ()) - -foreign import ccall "dotlock_create" _dotlock_create :: CString -> Flags -> IO (Ptr ()) - -dotlock_init :: IO () -dotlock_init = do - null_ptr <- _dotlock_create_ptr nullPtr 0 - return () - -dotlock_create :: FilePath -> Flags -> IO (Maybe DotLock) -dotlock_create file flags = do - ptr <- withCString file (flip _dotlock_create flags) - if ptr == nullPtr then return Nothing else return (Just $ DotLockPtr ptr) - - -foreign import ccall "dotlock_take" dotlock_take :: DotLock -> CLong -> IO CInt -foreign import ccall "dotlock_release" dotlock_release :: DotLock -> IO CInt -foreign import ccall "dotlock_destroy" dotlock_destroy :: DotLock -> IO () -foreign import ccall "dotlock_remove_lockfiles" dotlock_remove_lockfiles ::DotLock -> IO () -foreign import ccall "dotlock_set_fd" dotlock_set_fd :: DotLock -> Fd -> IO () -foreign import ccall "dotlock_get_fd" dotlock_get_fd :: DotLock -> IO Fd -foreign import ccall "dotlock_disable" dotlock_disable :: IO () diff --git a/FunctorToMaybe.hs b/FunctorToMaybe.hs deleted file mode 100644 index 658b024..0000000 --- a/FunctorToMaybe.hs +++ /dev/null @@ -1,69 +0,0 @@ ---------------------------------------------------------------------------- --- | --- Module : FunctorToMaybe --- --- Maintainer : joe@jerkface.net --- Stability : experimental --- --- Motivation: When parsing a stream of events, it is often desirable to --- let certain control events pass-through to the output stream without --- interrupting the parse. For example, the conduit package uses --- --- which adds a special command to a stream and the blaze-builder-conduit --- package has that treat the nullary constructor with special significance. --- --- But for other intermediary conduits, the nullary @Flush@ constructor may --- be noise that they should politely preserve in case it is meaningul downstream. --- If --- implemented the 'FunctorToMaybe' type class, then 'functorToEither' could be used to --- seperate the noise from the work-product. --- -{-# LANGUAGE CPP #-} -module FunctorToMaybe where - -#if MIN_VERSION_base(4,6,0) -#else -import Control.Monad.Instances() -#endif - --- | The 'FunctorToMaybe' class genaralizes 'Maybe' in that the --- there may be multiple null elements. --- --- Instances of 'FunctorToMaybe' should satisfy the following laws: --- --- > functorToMaybe (fmap f g) == fmap f (functorToMaybe g) --- -class Functor g => FunctorToMaybe g where - functorToMaybe :: g a -> Maybe a - - -instance FunctorToMaybe Maybe where - functorToMaybe = id -instance FunctorToMaybe (Either a) where - functorToMaybe (Right x) = Just x - functorToMaybe _ = Nothing - - --- | 'functorToEither' is a null-preserving cast. --- --- If @functorToMaybe g == Nothing@, then a casted value is returned with Left. --- If @functorToMaybe g == Just a@, then @Right a@ is returned. --- --- Returning to our --- example, if we define --- --- > instance Flush where --- > functorToMaybe Flush = Nothing --- > functorToMaybe (Chunk a) = Just a --- --- Now stream processors can use 'functorToEither' to transform any nullary constructors while --- while doing its work to transform the data before forwarding it into --- . --- -functorToEither :: FunctorToMaybe f => f a -> Either (f b) a -functorToEither ga = - maybe (Left $ uncast ga) - Right - (functorToMaybe ga) - where - uncast = fmap (error "bad FunctorToMaybe instance") diff --git a/Hosts.hs b/Hosts.hs deleted file mode 100644 index 5f09de1..0000000 --- a/Hosts.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -#if ! MIN_VERSION_network(2,4,0) -{-# LANGUAGE StandaloneDeriving #-} -#endif -module Hosts - ( Hosts - , assignName - , assignName' - , assignNewName - , removeName - , inet_pton - , inet_ntop - , empty - , hasName - , hasAddr - , encode - , decode - , diff - , plus - , filterAddrs - , namesForAddress - ) where - -import Data.Maybe -import Data.Monoid ( (<>) ) -import Data.List as List (foldl', (\\) ) -import Data.Ord -import Data.Char (isSpace) -import qualified Data.Map as Map -import Data.Map (Map) -import qualified Data.ByteString.Lazy.Char8 as L -import System.IO.Unsafe (unsafePerformIO) -import Control.Applicative ( (<$>), (<*>) ) -import Control.Monad (mplus) -import Network.Socket -import ControlMaybe ( handleIO_ ) - -#if ! MIN_VERSION_network(2,4,0) -deriving instance Ord SockAddr -#endif - -inet_pton :: String -> Maybe SockAddr -inet_pton p = n - where - n = unsafePerformIO $ do - handleIO_ (return Nothing) $ do - info <- getAddrInfo safe_hints (Just p) Nothing - return $ fmap addrAddress $ listToMaybe info - safe_hints = Just $ defaultHints { addrFlags=[AI_NUMERICHOST] } - -inet_ntop :: SockAddr -> String -inet_ntop n = p - where - p = case show n of - '[':xs -> fst $ break (==']') xs - xs -> fst $ break (==':') xs - - -data Hosts = Hosts - { lineCount :: Int - , numline :: Map Int L.ByteString - , namenum :: Map L.ByteString [Int] - , addrnum :: Map SockAddr Int - } - -instance Show Hosts where - show = L.unpack . encode - -encode :: Hosts -> L.ByteString -encode = L.unlines . map snd . Map.assocs . numline - -parseLine :: L.ByteString -> (Maybe SockAddr, [L.ByteString]) -parseLine s = (addr,names) - where - (addr0,names) = splitAt 1 $ L.words (uncom s) - addr = do - a <- fmap L.unpack $ listToMaybe addr0 - n <- inet_pton a - return $ n -- inet_ntop n - - uncom s = fst $ L.break (=='#') s - -empty :: Hosts -empty = Hosts { lineCount = 0 - , numline = Map.empty - , addrnum = Map.empty - , namenum = Map.empty - } - -{- -parseHosts fname = do - input <- L.readFile fname - return $ decode input --} - -decode :: L.ByteString -> Hosts -decode input = - let ls = L.lines input - ans = map (\l->(parseLine l,l)) ls - hosts = foldl' upd empty ans - upd hosts ((addr,names),line) = hosts - { lineCount = count - , numline = Map.insert count line (numline hosts) - , addrnum = maybeInsert (addrnum hosts) addr - , namenum = foldl' (\m x->Map.alter (cons count) x m) - (namenum hosts) - names - } - where count = lineCount hosts + 1 - cons v xs = Just $ maybe [v] (v:) xs - maybeInsert m x = maybe m - (\x->Map.insert x count m) - x - in hosts - - -hasName :: L.ByteString -> Hosts -> Bool -hasName name hosts = Map.member name $ namenum hosts - -hasAddr :: SockAddr -> Hosts -> Bool -hasAddr addr hosts = Map.member addr $ addrnum hosts - -scrubName :: - ([L.ByteString] -> [L.ByteString]) -> L.ByteString -> L.ByteString -scrubName f line = line' - where - (x,ign) = L.break (=='#') line - ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x - where oo = (.) . (.) - (a,ws') = splitAt 2 ws - ws'' = f ws' - line' = if null ws'' - then if length a==2 then "" -- "# " <> L.concat a <> ign - else line - else if length a==2 - then L.concat (a ++ ws'') <> ign - else let vs = L.groupBy ( (==EQ) `oo` comparing isSpace) $ L.dropWhile isSpace - $ L.tail ign - where oo = (.) . (.) - (a',vs') = splitAt 2 vs - vs'' = L.concat vs' - vs''' = if L.take 1 vs'' `elem` ["#",""] - then vs'' - else "# " <> vs'' - in L.concat (a'++ws'') <> vs''' - -assignName :: SockAddr -> L.ByteString -> Hosts -> Hosts -assignName addr name hosts = assignName' False addr name hosts - -chaddr :: Int -> SockAddr -> Hosts -> Hosts -chaddr n addr hosts = - hosts { addrnum = Map.insert addr n (addrnum hosts) - , numline = Map.adjust re n (numline hosts) } - where - re line = if length a==2 - then L.pack (inet_ntop addr) <> " " <> L.concat ws' <> ign - else line - where (x,ign) = L.break (=='#') line - ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x - where oo = (.) . (.) - (a,ws') = splitAt 2 ws - -isLonerName line = length ws' <= 2 - where (x,_) = L.break (=='#') line - ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x - where oo = (.) . (.) - (_,ws') = splitAt 2 ws - -scrubTrailingEmpties :: Hosts -> Hosts -scrubTrailingEmpties hosts = - hosts { lineCount = cnt' - , numline = foldl' (flip Map.delete) (numline hosts) es - } - where - cnt = lineCount hosts - es = takeWhile (\n -> Map.lookup n (numline hosts) == Just "") - $ [cnt,cnt-1..] - cnt' = cnt - length es - -cannonizeName :: L.ByteString -> L.ByteString -> L.ByteString -cannonizeName name line = scrubName f line - where - f ws = [name," "] ++ pre ++ drop 2 rst - where - (pre,rst) = break (==name) ws - -removeName name hosts = hosts' - where - hosts' = scrubTrailingEmpties (maybe hosts (removeName0 name hosts) ns) - ns = Map.lookup name (namenum hosts) - - -removeName0 name hosts nums = hosts - { namenum = Map.delete name (namenum hosts) - , numline = foldl' scrub (numline hosts) nums - } - where scrub m num = Map.adjust (scrubName $ filter (/=name)) num m - -assignName' :: Bool -> SockAddr -> L.ByteString -> Hosts -> Hosts -assignName' iscannon addr name hosts = hosts' - where - ns = Map.lookup name (namenum hosts) - a = Map.lookup addr (addrnum hosts) - canonize numline n = Map.adjust (cannonizeName name) n numline - hosts' = do - if (== Just True) $ elem <$> a <*> ns - then if not iscannon then hosts -- address already has name, nothing to do - else hosts { numline = foldl' canonize (numline hosts) $ fromJust ns} - else - let hosts0 = -- remove name if it's present - scrubTrailingEmpties $ maybe hosts (removeName0 name hosts) ns - ns' = fmap (filter $ - isLonerName - . fromJust - . (\n -> Map.lookup n (numline hosts))) - ns - >>= listToMaybe - hosts1 = -- insert name, or add new line - maybe (maybe (newLine hosts0) - (\n -> chaddr n addr $ appendName iscannon name hosts0 n) - ns') - (appendName iscannon name hosts0) - a - in hosts1 - newLine hosts = hosts - { lineCount = cnt - , numline = Map.insert cnt line $ numline hosts - , addrnum = Map.insert addr cnt $ addrnum hosts - , namenum = Map.alter (cons cnt) name $ namenum hosts - } - where cnt = lineCount hosts + 1 - line = L.pack (inet_ntop addr) <> " " <> name - cons v xs = Just $ maybe [v] (v:) xs - -assignNewName :: SockAddr -> L.ByteString -> Hosts -> Hosts -assignNewName addr name hosts = - if hasName name hosts then hosts - else assignName' True addr name hosts - -appendName :: Bool -> L.ByteString -> Hosts -> Int -> Hosts -appendName iscannon name hosts num = hosts - { numline = Map.adjust (scrubName f) num (numline hosts) - , namenum = Map.alter (cons num) name (namenum hosts) - } - where f ws = if iscannon - then [name, " "] ++ ws - else let rs = reverse ws - (sp,rs') = span (L.any isSpace) rs - in reverse $ sp ++ [name," "] ++ rs' - cons v xs = Just $ maybe [v] (v:) xs - --- Returns a list of bytestrings intended to show the --- differences between the two host databases. It is --- assumed that no lines are deleted, only altered or --- appended. -diff :: Hosts -> Hosts -> [L.ByteString] -diff as bs = cs - where - [as',bs'] = map (L.lines . Hosts.encode) [as,bs] - ext xs = map Just xs ++ repeat Nothing - ds = takeWhile (isJust . uncurry mplus) $ zip (ext as') (ext bs') - es = filter (uncurry (/=)) ds - cs = do - (a,b) <- es - [a,b] <- return $ map maybeToList [a,b] - fmap ("- " <>) a ++ fmap ("+ " <>) b - -namesForAddress :: SockAddr -> Hosts -> [L.ByteString] -namesForAddress addr hosts = snd $ _namesForAddress addr hosts - -_namesForAddress :: SockAddr -> Hosts -> (Int, [L.ByteString]) -_namesForAddress addr (Hosts {numline=numline, addrnum=addrnum}) = ns - where - ns = maybe (-1,[]) id $ do - n <- Map.lookup addr addrnum - line <- Map.lookup n numline - return (n, snd $ parseLine line) - - -plus :: Hosts -> Hosts -> Hosts -plus a b = Map.foldlWithKey' mergeAddr a (addrnum b) - where - mergeAddr a addr bnum = a' - where - (anum,ns) = _namesForAddress addr a - bs = maybe [] (List.\\ ns) $ do - line <- Map.lookup bnum (numline b) - return . snd $ parseLine line - a' = if anum/=(-1) then foldl' app a $ reverse bs - else newLine a - app a b = appendName True b a anum -- True to allow b to reassign cannonical name - newLine hosts = hosts - { lineCount = cnt - , numline = Map.insert cnt line $ numline hosts - , addrnum = Map.insert addr cnt $ addrnum hosts - , namenum = foldl' updnamenum (namenum hosts) bs - } - where cnt = lineCount hosts + 1 - line = L.pack (inet_ntop addr) <> " " <> L.intercalate " " bs - cons v xs = Just $ maybe [v] (v:) xs - updnamenum m name = Map.alter (cons cnt) name m - -filterAddrs :: (SockAddr -> Bool) -> Hosts -> Hosts -filterAddrs pred hosts = hosts' - where - als = Map.toList (addrnum hosts) - nl = foldl' f (numline hosts) als - f m (addr,num) = if pred addr - then m - else Map.adjust (scrubName $ const []) num m - lines = L.unlines . Map.elems $ nl - hosts' = decode lines diff --git a/KeyRing.hs b/KeyRing.hs deleted file mode 100644 index 0fbf2c2..0000000 --- a/KeyRing.hs +++ /dev/null @@ -1,3505 +0,0 @@ ---------------------------------------------------------------------------- --- | --- Module : KeyRing --- --- Maintainer : joe@jerkface.net --- Stability : experimental --- --- kiki is a command-line utility for manipulating GnuPG's keyring files. This --- module is the programmer-facing API it uses to do that. --- --- Note: This is *not* a public facing API. I (the author) consider this --- library to be internal to kiki and subject to change at my whim. --- --- Typically, a client to this module would prepare a 'KeyRingOperation' --- describing what he wants done, and then invoke 'runKeyRing' to make it --- happen. -{-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE NoPatternGuards #-} -{-# LANGUAGE ForeignFunctionInterface #-} -module KeyRing - ( - -- * Error Handling - KikiResult(..) - , KikiCondition(..) - , KikiReportAction(..) - , errorString - , reportString - -- * Manipulating Keyrings - , runKeyRing - , KeyRingOperation(..) - , PassphraseSpec(..) - , Transform(..) - -- , PacketUpdate(..) - -- , guardAuthentic - -- * Describing File Operations - , StreamInfo(..) - , Access(..) - , FileType(..) - , InputFile(..) - , KeyFilter(..) - -- * Results of a KeyRing Operation - , KeyRingRuntime(..) - , MappedPacket(..) - , KeyDB - , KeyData(..) - , SubKey(..) - , packet - , locations - , keyflags - -- * Miscelaneous Utilities - , isKey - , derRSA - , derToBase32 - , backsig - , filterMatches - , flattenKeys - , flattenTop - , Hosts.Hosts - , isCryptoCoinKey - , matchpr - , parseSpec - , parseUID - , UserIDRecord(..) - , pkcs8 - , RSAPublicKey(..) - , PKCS8_RSAPublicKey(..) - , rsaKeyFromPacket - , secretToPublic - , selectPublicKey - , selectSecretKey - , usage - , usageString - , walletImportFormat - , writePEM - , getBindings - , accBindings - , isSubkeySignature - , torhash - , ParsedCert(..) - , parseCertBlob - , packetFromPublicRSAKey - , decodeBlob - , selectPublicKeyAndSigs - , x509cert - , getHomeDir - , unconditionally - , SecretPEMData(..) - , readSecretPEMFile - , writeInputFileL - , InputFileContext(..) - , onionNameForContact - , keykey - , keyPacket - , KeySpec(..) - , getHostnames - , secretPemFromPacket - , getCrossSignedSubkeys - ) where - -import System.Environment -import Control.Monad -import Data.Maybe -import Data.Either -import Data.Char -import Data.Ord -import Data.List -import Data.OpenPGP -import Data.Functor -import Data.Monoid -import Data.Tuple ( swap ) -import Data.Bits ( (.|.), (.&.) ) -import Control.Applicative ( Applicative, pure, liftA2, (<*>) ) -import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) -import Control.Arrow ( first, second ) -import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign) -import Data.ByteString.Lazy ( ByteString ) -import Text.Show.Pretty as PP ( ppShow ) -import Data.Binary {- decode, decodeOrFail -} -import ControlMaybe ( handleIO_ ) -import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 - , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) ) -import Data.ASN1.BitArray ( BitArray(..), toBitArray ) -import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' ) -import Data.ASN1.BinaryEncoding ( DER(..) ) -import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds ) -import Data.Time.Clock ( UTCTime ) -import Data.Bits ( Bits, shiftR ) -import Data.Text.Encoding ( encodeUtf8 ) -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile - , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt - , index, break, pack ) -import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, hPutStr, singleton, unfoldr, reverse ) -import qualified Codec.Binary.Base32 as Base32 -import qualified Codec.Binary.Base64 as Base64 -#if !defined(VERSION_cryptonite) -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Crypto.Types.PubKey.ECC as ECC -#else -import qualified Crypto.Hash as Vincent -import Data.ByteArray (convert) -import qualified Crypto.PubKey.ECC.Types as ECC -#endif -import qualified Data.X509 as X509 -import qualified Crypto.PubKey.RSA as RSA -import qualified Codec.Compression.GZip as GZip -import qualified Data.Text as T ( Text, unpack, pack, - strip, reverse, drop, break, dropAround, length ) -import qualified System.Posix.Types as Posix -import System.Posix.Files ( modificationTime, getFileStatus, getFdStatus - , setFileCreationMask, setFileTimes ) -#if MIN_VERSION_x509(1,5,0) -import Data.Hourglass.Types -import Data.Hourglass -#endif -#if MIN_VERSION_unix(2,7,0) -import System.Posix.Files ( setFdTimesHiRes ) -import Foreign.C.Types ( CTime(..), CLong, CInt(..) ) -#else -import Foreign.C.Types ( CTime(..), CLong, CInt(..) ) -import Foreign.Marshal.Array ( withArray ) -import Foreign.Ptr -import Foreign.C.Error ( throwErrnoIfMinus1_ ) -import Foreign.Storable -#endif -import System.FilePath ( takeDirectory ) -import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr) -import Data.IORef -import System.Posix.IO ( fdToHandle ) -import qualified Data.Traversable as Traversable -import Data.Traversable ( sequenceA ) -#if ! MIN_VERSION_base(4,6,0) -import GHC.Exts ( Down(..) ) -#endif -#if MIN_VERSION_binary(0,7,0) -import Debug.Trace -#endif -import Network.Socket -- (SockAddr) -import qualified Data.ByteString.Lazy.Char8 as Char8 -import Compat - -import TimeUtil -import PEM -import ScanningParser -import qualified Hosts -import qualified CryptoCoins -import Base58 -import FunctorToMaybe -import DotLock -import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) - --- DER-encoded elliptic curve ids --- nistp256_id = 0x2a8648ce3d030107 -secp256k1_id :: Integer -secp256k1_id = 0x2b8104000a --- "\x2a\x86\x48\xce\x3d\x03\x01\x07" -{- OID Curve description Curve name - ---------------------------------------------------------------- - 1.2.840.10045.3.1.7 NIST Curve P-256 [FIPS 186-2] "NIST P-256" - 1.3.132.0.34 NIST Curve P-384 [FIPS 186-2] "NIST P-384" - 1.3.132.0.35 NIST Curve P-521 [FIPS 186-2] "NIST P-521" - - Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST - P-521". The hexadecimal representation used in the public and - private key encodings are: - - Curve Name Len Hexadecimal representation of the OID - ---------------------------------------------------------------- - "NIST P-256" 8 0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07 - "NIST P-384" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x22 - "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23 --} - -data HomeDir = - HomeDir { homevar :: String - , appdir :: String - , optfile_alts :: [String] - } - -home :: HomeDir -home = HomeDir - { homevar = "GNUPGHOME" - , appdir = ".gnupg" - , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] - } - -data InputFile = HomeSec - -- ^ A file named secring.gpg located in the home directory. - -- See 'opHome'. - | HomePub - -- ^ A file named pubring.gpg located in the home directory. - -- See 'opHome'. - | ArgFile FilePath - -- ^ Contents will be read or written from the specified path. - | FileDesc Posix.Fd - -- ^ Contents will be read or written from the specified file - -- descriptor. - | Pipe Posix.Fd Posix.Fd - -- ^ Contents will be read from the first descriptor and updated - -- content will be writen to the second. Note: Don't use Pipe - -- for 'Wallet' files. (TODO: Wallet support) - deriving (Eq,Ord,Show) - --- type UsageTag = String -type Initializer = String - -data FileType = KeyRingFile - | PEMFile - | WalletFile - | DNSPresentation - | Hosts - deriving (Eq,Ord,Enum,Show) - --- | Use this type to indicate whether a file of type 'KeyRingFile' is expected --- to contain secret or public PGP key packets. Note that it is not supported --- to mix both in the same file and that the secret key packets include all of --- the information contained in their corresponding public key packets. -data Access = AutoAccess -- ^ secret or public as appropriate based on existing content. - -- (see 'rtRingAccess') - | Sec -- ^ secret information - | Pub -- ^ public information - deriving (Eq,Ord,Show) - --- | Note that the documentation here is intended for when this value is --- assigned to 'fill'. For other usage, see 'spill'. -data KeyFilter = KF_None -- ^ No keys will be imported. - | KF_Match String -- ^ Only the key that matches the spec will be imported. - | KF_Subkeys -- ^ Subkeys will be imported if their owner key is - -- already in the ring. TODO: Even if their signatures - -- are bad? - | KF_Authentic -- ^ Keys are imported if they belong to an authenticated - -- identity (signed or self-authenticating). - | KF_All -- ^ All keys will be imported. - deriving (Eq,Ord,Show) - --- | This type describes how 'runKeyRing' will treat a file. -data StreamInfo = StreamInfo - { access :: Access - -- ^ Indicates whether the file is allowed to contain secret information. - , typ :: FileType - -- ^ Indicates the format and content type of the file. - , fill :: KeyFilter - -- ^ This filter controls what packets will be inserted into a file. - , spill :: KeyFilter - -- - -- ^ Use this to indicate whether or not a file's contents should be - -- available for updating other files. Note that although its type is - -- 'KeyFilter', it is usually interpretted as a boolean flag. Details - -- depend on 'typ' and are as follows: - -- - -- 'KeyRingFile': - -- - -- * 'KF_None' - The file's contents will not be shared. - -- - -- * otherwise - The file's contents will be shared. - -- - -- 'PEMFile': - -- - -- * 'KF_None' - The file's contents will not be shared. - -- - -- * 'KF_Match' - The file's key will be shared with the specified owner - -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be - -- equal to this value; changing the usage or owner of a key is not - -- supported via the fill/spill mechanism. - -- - -- * otherwise - Unspecified. Do not use. - -- - -- 'WalletFile': - -- - -- * The 'spill' setting is ignored and the file's contents are shared. - -- (TODO) - -- - -- 'Hosts': - -- - -- * The 'spill' setting is ignored and the file's contents are shared. - -- (TODO) - -- - , initializer :: Maybe String - -- ^ If 'typ' is 'PEMFile' and an 'initializer' string is set, then it is - -- interpretted as a shell command that may be used to create the key if it - -- does not exist. - , transforms :: [Transform] - -- ^ Per-file transformations that occur before the contents of a file are - -- spilled into the common pool. - } - deriving (Eq,Show) - - -spillable :: StreamInfo -> Bool -spillable (spill -> KF_None) = False -spillable _ = True - -isMutable :: StreamInfo -> Bool -isMutable (fill -> KF_None) = False -isMutable _ = True - -isring :: FileType -> Bool -isring (KeyRingFile {}) = True -isring _ = False - -isSecretKeyFile :: FileType -> Bool -isSecretKeyFile PEMFile = True -isSecretKeyFile DNSPresentation = True -isSecretKeyFile _ = False - -{- -pwfile :: FileType -> Maybe InputFile -pwfile (KeyRingFile f) = f -pwfile _ = Nothing --} - -iswallet :: FileType -> Bool -iswallet (WalletFile {}) = True -iswallet _ = False - -usageFromFilter :: MonadPlus m => KeyFilter -> m String -usageFromFilter (KF_Match usage) = return usage -usageFromFilter _ = mzero - -data KeyRingRuntime = KeyRingRuntime - { rtPubring :: FilePath - -- ^ Path to the file represented by 'HomePub' - , rtSecring :: FilePath - -- ^ Path to the file represented by 'HomeSec' - , rtGrip :: Maybe String - -- ^ Fingerprint or portion of a fingerprint used - -- to identify the working GnuPG identity used to - -- make signatures. - , rtWorkingKey :: Maybe Packet - -- ^ The master key of the working GnuPG identity. - , rtKeyDB :: KeyDB - -- ^ The common information pool where files spilled - -- their content and from which they received new - -- content. - , rtRingAccess :: Map.Map InputFile Access - -- ^ The 'Access' values used for files of type - -- 'KeyRingFile'. If 'AutoAccess' was specified - -- for a file, this 'Map.Map' will indicate the - -- detected value that was used by the algorithm. - , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet) - } - --- | Roster-entry level actions -data PacketUpdate = InducerSignature String [SignatureSubpacket] - | SubKeyDeletion KeyKey KeyKey - --- | This type is used to indicate where to obtain passphrases. -data PassphraseSpec = PassphraseSpec - { passSpecRingFile :: Maybe FilePath - -- ^ If not Nothing, the passphrase is to be used for packets - -- from this file. - , passSpecKeySpec :: Maybe String - -- ^ Non-Nothing value reserved for future use. - -- (TODO: Use this to implement per-key passphrase associations). - , passSpecPassFile :: InputFile - -- ^ The passphrase will be read from this file or file descriptor. - } - -- | Use this to carry pasphrases from a previous run. - | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet)) - -instance Show PassphraseSpec where - show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) - show (PassphraseMemoizer _) = "PassphraseMemoizer" -instance Eq PassphraseSpec where - PassphraseSpec a b c == PassphraseSpec d e f - = and [a==d,b==e,c==f] - _ == _ - = False - - - -data Transform = - Autosign - -- ^ This operation will make signatures for any tor-style UID - -- that matches a tor subkey and thus can be authenticated without - -- requring the judgement of a human user. - -- - -- A tor-style UID is one of the following form: - -- - -- > Anonymous - | DeleteSubKey String - -- ^ Delete the subkey specified by the given fingerprint and any - -- associated signatures on that key. - deriving (Eq,Ord,Show) - --- | This type describes an idempotent transformation (merge or import) on a --- set of GnuPG keyrings and other key files. -data KeyRingOperation = KeyRingOperation - { opFiles :: Map.Map InputFile StreamInfo - -- ^ Indicates files to be read or updated. - , opPassphrases :: [PassphraseSpec] - -- ^ Indicates files or file descriptors where passphrases can be found. - , opTransforms :: [Transform] - -- ^ Transformations to be performed on the key pool after all files have - -- been read and before any have been written. - , opHome :: Maybe FilePath - -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub' - -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted - -- and if that is not set, it falls back to $HOME/.gnupg. - } - deriving (Eq,Show) - -resolveInputFile :: InputFileContext -> InputFile -> [FilePath] -resolveInputFile ctx = resolve - where - resolve HomeSec = return (homesecPath ctx) - resolve HomePub = return (homepubPath ctx) - resolve (ArgFile f) = return f - resolve _ = [] - -resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath -resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str) - where str = case (fdr,fdw) of - (0,1) -> "-" - _ -> "&pipe" ++ show (fdr,fdw) -resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str) - where str = "&" ++ show fd -resolveForReport mctx f = concat $ resolveInputFile ctx f - where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx - -filesToLock :: - KeyRingOperation -> InputFileContext -> [FilePath] -filesToLock k ctx = do - (f,stream) <- Map.toList (opFiles k) - case fill stream of - KF_None -> [] - _ -> resolveInputFile ctx f - - --- kret :: a -> KeyRingOperation a --- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x) - -data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) -data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show - -pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey -pkcs8 (RSAKey n e) = RSAKey8 n e - -instance ASN1Object RSAPublicKey where - -- PKCS #1 RSA Public Key - toASN1 (RSAKey (MPI n) (MPI e)) - = \xs -> Start Sequence - : IntVal n - : IntVal e - : End Sequence - : xs - fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) = - Right (RSAKey (MPI n) (MPI e), xs) - - fromASN1 _ = - Left "fromASN1: RSAPublicKey: unexpected format" - -instance ASN1Object PKCS8_RSAPublicKey where - - -- PKCS #8 Public key data - toASN1 (RSAKey8 (MPI n) (MPI e)) - = \xs -> Start Sequence - : Start Sequence - : OID [1,2,840,113549,1,1,1] - : Null -- Doesn't seem to be neccessary, but i'm adding it - -- to match PEM files I see in the wild. - : End Sequence - : BitString (toBitArray bs 0) - : End Sequence - : xs - where - pubkey = [ Start Sequence, IntVal n, IntVal e, End Sequence ] - bs = encodeASN1' DER pubkey - - fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) = - Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs) - fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:Null:End Sequence:BitString b:End Sequence:xs) = - case decodeASN1' DER bs of - Right as -> fromASN1 as - Left e -> Left ("fromASN1: RSAPublicKey: "++show e) - where - BitArray _ bs = b - fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) = - case decodeASN1' DER bs of - Right as -> fromASN1 as - Left e -> Left ("fromASN1: RSAPublicKey: "++show e) - where - BitArray _ bs = b - - fromASN1 _ = - Left "fromASN1: RSAPublicKey: unexpected format" - -{- -RSAPrivateKey ::= SEQUENCE { - version Version, - modulus INTEGER, -- n - publicExponent INTEGER, -- e - privateExponent INTEGER, -- d - prime1 INTEGER, -- p - prime2 INTEGER, -- q - exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1) - exponent2 INTEGER, -- d mod (q-1) - coefficient INTEGER, -- (inverse of q) mod p - otherPrimeInfos OtherPrimeInfos OPTIONAL - } --} -data RSAPrivateKey = RSAPrivateKey - { rsaN :: MPI - , rsaE :: MPI - , rsaD :: MPI - , rsaP :: MPI - , rsaQ :: MPI - , rsaDmodP1 :: MPI - , rsaDmodQminus1 :: MPI - , rsaCoefficient :: MPI - } - deriving Show - -instance ASN1Object RSAPrivateKey where - toASN1 rsa@(RSAPrivateKey {}) - = \xs -> Start Sequence - : IntVal 0 - : mpiVal rsaN - : mpiVal rsaE - : mpiVal rsaD - : mpiVal rsaP - : mpiVal rsaQ - : mpiVal rsaDmodP1 - : mpiVal rsaDmodQminus1 - : mpiVal rsaCoefficient - : End Sequence - : xs - where mpiVal f = IntVal x where MPI x = f rsa - - fromASN1 ( Start Sequence - : IntVal _ -- version - : IntVal n - : IntVal e - : IntVal d - : IntVal p - : IntVal q - : IntVal dmodp1 - : IntVal dmodqminus1 - : IntVal coefficient - : ys) = - Right ( privkey, tail $ dropWhile notend ys) - where - notend (End Sequence) = False - notend _ = True - privkey = RSAPrivateKey - { rsaN = MPI n - , rsaE = MPI e - , rsaD = MPI d - , rsaP = MPI p - , rsaQ = MPI q - , rsaDmodP1 = MPI dmodp1 - , rsaDmodQminus1 = MPI dmodqminus1 - , rsaCoefficient = MPI coefficient - } - fromASN1 _ = - Left "fromASN1: RSAPrivateKey: unexpected format" - - - --- | This type is used to indicate success or failure --- and in the case of success, return the computed object. --- The 'FunctorToMaybe' class is implemented to facilitate --- branching on failture. -data KikiCondition a = KikiSuccess a - | FailedToLock [FilePath] - | BadPassphrase - | FailedToMakeSignature - | CantFindHome - | AmbiguousKeySpec FilePath - | CannotImportMasterKey - | NoWorkingKey - deriving ( Functor, Show ) - -instance FunctorToMaybe KikiCondition where - functorToMaybe (KikiSuccess a) = Just a - functorToMaybe _ = Nothing - -instance Applicative KikiCondition where - pure a = KikiSuccess a - f <*> a = - case functorToEither f of - Right f -> case functorToEither a of - Right a -> pure (f a) - Left err -> err - Left err -> err - --- | This type is used to describe events triggered by 'runKeyRing'. In --- addition to normal feedback (e.g. 'NewPacket'), it also may indicate --- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a --- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with --- many inputs and outputs, an operation may be partially (or even mostly) --- successful even when I/O failures occured. In this situation, the files may --- not have all the information they were intended to store, but they will be --- in a valid format for GnuPG or kiki to operate on in the future. -data KikiReportAction = - NewPacket String - | MissingPacket String - | ExportedSubkey - | GeneratedSubkeyFile - | NewWalletKey String - | YieldSignature - | YieldSecretKeyPacket String - | UnableToUpdateExpiredSignature - | WarnFailedToMakeSignature - | FailedExternal Int - | ExternallyGeneratedFile - | UnableToExport KeyAlgorithm String - | FailedFileWrite - | HostsDiff ByteString - | DeletedPacket String - deriving Show - -uncamel :: String -> String -uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args - where - (.:) = fmap . fmap - ( firstWord , - otherWords ) = splitAt 1 ws - ws = camel >>= groupBy (\_ c -> isLower c) - ( camel, args) = splitAt 1 $ words str - -reportString :: KikiReportAction -> String -reportString x = uncamel $ show x - -errorString :: KikiCondition a -> String -errorString (KikiSuccess {}) = "success" -errorString e = uncamel . show $ fmap (const ()) e - --- | Errors in kiki are indicated by the returning of this record. -data KikiResult a = KikiResult - { kikiCondition :: KikiCondition a - -- ^ The result or a fatal error condition. - , kikiReport :: KikiReport - -- ^ A list of non-fatal warnings and informational messages - -- along with the files that triggered them. - } - -type KikiReport = [ (FilePath, KikiReportAction) ] - -keyPacket :: KeyData -> Packet -keyPacket (KeyData k _ _ _) = packet k - -subkeyMappedPacket :: SubKey -> MappedPacket -subkeyMappedPacket (SubKey k _ ) = k - - -usage :: SignatureSubpacket -> Maybe String -usage (NotationDataPacket - { human_readable = True - , notation_name = "usage@" - , notation_value = u - }) = Just u -usage _ = Nothing - -x509cert :: SignatureSubpacket -> Maybe Char8.ByteString -x509cert (NotationDataPacket - { human_readable = False - , notation_name = "x509cert@" - , notation_value = u - }) = Just (Char8.pack u) -x509cert _ = Nothing - -makeInducerSig - :: Packet - -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver --- torsig g topk wkun uid timestamp extras = todo -makeInducerSig topk wkun uid extras - = CertificationSignature (secretToPublic topk) - uid - (sigpackets 0x13 - subpackets - subpackets_unh) - where - subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] - tsign - ++ extras - subpackets_unh = [IssuerPacket (fingerprint wkun)] - tsign = if keykey wkun == keykey topk - then [] -- tsign doesnt make sense for self-signatures - else [ TrustSignaturePacket 1 120 - , RegularExpressionPacket regex] - -- <[^>]+[@.]asdf\.nowhere>$ - regex = "<[^>]+[@.]"++hostname++">$" - -- regex = username ++ "@" ++ hostname - -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String - hostname = subdomain' pu ++ "\\." ++ topdomain' pu - pu = parseUID uidstr where UserIDPacket uidstr = uid - subdomain' = escape . T.unpack . uid_subdomain - topdomain' = escape . T.unpack . uid_topdomain - escape s = concatMap echar s - where - echar '|' = "\\|" - echar '*' = "\\*" - echar '+' = "\\+" - echar '?' = "\\?" - echar '.' = "\\." - echar '^' = "\\^" - echar '$' = "\\$" - echar '\\' = "\\\\" - echar '[' = "\\[" - echar ']' = "\\]" - echar c = [c] - - -keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags -keyflags flgs@(KeyFlagsPacket {}) = - Just . toEnum $ - ( bit 0x1 certify_keys - .|. bit 0x2 sign_data - .|. bit 0x4 encrypt_communication - .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags - -- other flags: - -- split_key - -- authentication (ssh-client) - -- group_key - where - bit v f = if f flgs then v else 0 -keyflags _ = Nothing - - -data PGPKeyFlags = - Special - | Vouch -- Signkey - | Sign - | VouchSign - | Communication - | VouchCommunication - | SignCommunication - | VouchSignCommunication - | Storage - | VouchStorage - | SignStorage - | VouchSignStorage - | Encrypt - | VouchEncrypt - | SignEncrypt - | VouchSignEncrypt - deriving (Eq,Show,Read,Enum) - - -usageString :: PGPKeyFlags -> String -usageString flgs = - case flgs of - Special -> "special" - Vouch -> "vouch" -- signkey - Sign -> "sign" - VouchSign -> "vouch-sign" - Communication -> "communication" - VouchCommunication -> "vouch-communication" - SignCommunication -> "sign-communication" - VouchSignCommunication -> "vouch-sign-communication" - Storage -> "storage" - VouchStorage -> "vouch-storage" - SignStorage -> "sign-storage" - VouchSignStorage -> "vouch-sign-storage" - Encrypt -> "encrypt" - VouchEncrypt -> "vouch-encrypt" - SignEncrypt -> "sign-encrypt" - VouchSignEncrypt -> "vouch-sign-encrypt" - - - - --- matchpr computes the fingerprint of the given key truncated to --- be the same lenght as the given fingerprint for comparison. -matchpr :: String -> Packet -> String -matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp - -keyFlags :: t -> [Packet] -> [SignatureSubpacket] -keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) - -keyFlags0 :: t -> [Packet] -> [SignatureSubpacket] -keyFlags0 wkun uidsigs = concat - [ keyflags - , preferredsym - , preferredhash - , preferredcomp - , features ] - - where - subs = concatMap hashed_subpackets uidsigs - keyflags = filterOr isflags subs $ - KeyFlagsPacket { certify_keys = True - , sign_data = True - , encrypt_communication = False - , encrypt_storage = False - , split_key = False - , authentication = False - , group_key = False - } - preferredsym = filterOr ispreferedsym subs $ - PreferredSymmetricAlgorithmsPacket - [ AES256 - , AES192 - , AES128 - , CAST5 - , TripleDES - ] - preferredhash = filterOr ispreferedhash subs $ - PreferredHashAlgorithmsPacket - [ SHA256 - , SHA1 - , SHA384 - , SHA512 - , SHA224 - ] - preferredcomp = filterOr ispreferedcomp subs $ - PreferredCompressionAlgorithmsPacket - [ ZLIB - , BZip2 - , ZIP - ] - features = filterOr isfeatures subs $ - FeaturesPacket { supports_mdc = True - } - - filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs - - isflags (KeyFlagsPacket {}) = True - isflags _ = False - ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True - ispreferedsym _ = False - ispreferedhash (PreferredHashAlgorithmsPacket {}) = True - ispreferedhash _ = False - ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True - ispreferedcomp _ = False - isfeatures (FeaturesPacket {}) = True - isfeatures _ = False - - -matchSpec :: KeySpec -> KeyData -> Bool -matchSpec (KeyGrip grip) (KeyData p _ _ _) - | matchpr grip (packet p)==grip = True - | otherwise = False - -matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps - where - ps = map (packet .fst) sigs - match p = isSignaturePacket p - && has_tag tag p - && has_issuer key p - has_issuer key p = isJust $ do - issuer <- signature_issuer p - guard $ matchpr issuer key == issuer - has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) - || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) - -matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us - where - us = filter (isInfixOf pat) $ Map.keys uids - -data UserIDRecord = UserIDRecord { - uid_full :: String, - uid_realname :: T.Text, - uid_user :: T.Text, - uid_subdomain :: T.Text, - uid_topdomain :: T.Text -} - deriving Show - -parseUID :: String -> UserIDRecord -parseUID str = UserIDRecord { - uid_full = str, - uid_realname = realname, - uid_user = user, - uid_subdomain = subdomain, - uid_topdomain = topdomain - } - where - text = T.pack str - (T.strip-> realname, T.dropAround isBracket-> email) - = T.break (=='<') text - (user, T.drop 1-> hostname) = T.break (=='@') email - ( T.reverse -> topdomain, - T.reverse . T.drop 1 -> subdomain) - = T.break (=='.') . T.reverse $ hostname -isBracket :: Char -> Bool -isBracket '<' = True -isBracket '>' = True -isBracket _ = False - - - - -data KeySpec = - KeyGrip String -- fp: - | KeyTag Packet String -- fp:????/t: - | KeyUidMatch String -- u: - deriving Show - -data MatchingField = UserIDField | KeyTypeField deriving (Show,Eq,Ord,Enum) -data SingleKeySpec = FingerprintMatch String - | SubstringMatch (Maybe MatchingField) String - | EmptyMatch - | AnyMatch - | WorkingKeyMatch - deriving (Show,Eq,Ord) - --- A pair of specs. The first specifies an identity and the second --- specifies a specific key (possibly master) associated with that --- identity. --- --- When no slash is specified, context will decide whether the SingleKeySpec --- is specifying an identity or a key belonging to the working identity. -type Spec = (SingleKeySpec,SingleKeySpec) - -parseSingleSpec :: String -> SingleKeySpec -parseSingleSpec "*" = AnyMatch -parseSingleSpec "-" = WorkingKeyMatch -parseSingleSpec "" = EmptyMatch -parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag -parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag -parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp -parseSingleSpec str - | is40digitHex str = FingerprintMatch str - | otherwise = SubstringMatch Nothing str - -is40digitHex xs = ys == xs && length ys==40 - where - ys = filter ishex xs - ishex c | '0' <= c && c <= '9' = True - | 'A' <= c && c <= 'F' = True - | 'a' <= c && c <= 'f' = True - ishex c = False - - - -- t:tor -- (FingerprintMatch "", SubstringMatch "tor") - -- u:joe -- (SubstringMatch "joe", FingerprintMatch "") - -- u:joe/ -- (SubstringMatch "joe", FingerprintMatch "!") - -- fp:4A39F/tor -- (FingerprintMatch "4A39F", SubstringMatch "tor") - -- u:joe/tor -- (SubstringMatch "joe", SubstringMatch "tor") - -- u:joe/t:tor -- (SubstringMatch "joe", SubstringMatch "tor") - -- u:joe/fp:4abf30 -- (SubstringMatch "joe", FingerprintMatch "4abf30") - -- joe/tor -- (SubstringMatch "joe", SubstringMatch "tor") - --- | Parse a key specification. --- The first argument is a grip for the default working key. -parseSpec :: String -> String -> (KeySpec,Maybe String) -parseSpec wkgrip spec = - if not slashed - then - case prespec of - AnyMatch -> (KeyGrip "", Nothing) - EmptyMatch -> error "Bad key spec." - WorkingKeyMatch -> (KeyGrip wkgrip, Nothing) - SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag) - SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str) - SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) - FingerprintMatch fp -> (KeyGrip fp, Nothing) - else - case (prespec,postspec) of - (FingerprintMatch fp, SubstringMatch st t) - | st /= Just UserIDField -> (KeyGrip fp, Just t) - (SubstringMatch mt u, _) - | postspec `elem` [AnyMatch,EmptyMatch] - && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing) - (SubstringMatch mt u, SubstringMatch st t) - | mt /= Just KeyTypeField - && st /= Just UserIDField -> (KeyUidMatch u, Just t) - (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec" - (_,FingerprintMatch fp) -> error "todo: support /fp: spec" - (FingerprintMatch fp,_) -> error "todo: support fp:/ spec" - _ -> error "Bad key spec." - where - (preslash,slashon) = break (=='/') spec - slashed = not $ null $ take 1 slashon - postslash = drop 1 slashon - - prespec = parseSingleSpec preslash - postspec = parseSingleSpec postslash - -{- - - BUGGY -parseSpec grip spec = (topspec,subspec) - where - (topspec0,subspec0) = unprefix '/' spec - (toptyp,top) = unprefix ':' topspec0 - (subtyp,sub) = unprefix ':' subspec0 - topspec = case () of - _ | null top && or [ subtyp=="fp" - , null subtyp && is40digitHex sub - ] - -> KeyGrip sub - _ | null top && null grip -> KeyUidMatch sub - _ | null top -> KeyGrip grip - _ | toptyp=="fp" || (null toptyp && is40digitHex top) - -> KeyGrip top - _ | toptyp=="u" -> KeyUidMatch top - _ -> KeyUidMatch top - subspec = case subtyp of - "t" -> Just sub - "fp" | top=="" -> Nothing - "" | top=="" && is40digitHex sub -> Nothing - "" -> listToMaybe sub >> Just sub - _ -> Nothing - - is40digitHex xs = ys == xs && length ys==40 - where - ys = filter ishex xs - ishex c | '0' <= c && c <= '9' = True - | 'A' <= c && c <= 'F' = True - | 'a' <= c && c <= 'f' = True - ishex c = False - - -- | Split a string into two at the first occurance of the given - -- delimiter. If the delimeter does not occur, then the first - -- item of the returned pair is empty and the second item is the - -- input string. - unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p)) - where p = break (==c) spec --} - - -filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] -filterMatches spec ks = filter (matchSpec spec . snd) ks - -filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData -filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' - where - matchAll = KeyGrip "" - - subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip) - subkeySpec (topspec,Just mtag) = (topspec , KeyTag (packet p) mtag) - - match spec mps - = not . null - . snd - . seek_key spec - . map packet - $ mps - - old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub) - - oldOrMatch spec sub = old sub - || match spec (flattenSub "" True sub) - - subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty) - then oldOrMatch subspec - else old) - subs - where - (topspec,subspec) = subkeySpec spec - -selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db - -selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db - -selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])] -selectPublicKeyAndSigs (spec,mtag) db = - case mtag of - Nothing -> do - (kk,r) <- Map.toList $ fmap (findbyspec spec) db - (sub,sigs) <- r - return (kk,sub,sigs) - Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag - where - topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) - - findbyspec (KeyGrip g) kd = do - filter ismatch $ - topresult kd - : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs)) - (Map.elems $ keySubKeys kd) - where - ismatch (p,sigs) = matchpr g p ==g - findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] - - findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag - where - gettag (SubKey sub sigs) = do - let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs - (hastag,_) <- maybeToList mb - guard hastag - return $ (kk, packet sub, map (packet . fst) sigs) - -selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectKey0 wantPublic (spec,mtag) db = do - let Message ps = flattenKeys wantPublic db - ys = snd $ seek_key spec ps - flip (maybe (listToMaybe ys)) mtag $ \tag -> do - case ys of - y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 - [] -> Nothing - -{- -selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] -selectAll wantPublic (spec,mtag) db = do - let Message ps = flattenKeys wantPublic db - ys = snd $ seek_key spec ps - y <- take 1 ys - case mtag of - Nothing -> return (y,Nothing) - Just tag -> - let search ys1 = do - let zs = snd $ seek_key (KeyTag y tag) ys1 - z <- take 1 zs - (y,Just z):search (drop 1 zs) - in search (drop 1 ys) --} - -seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) -seek_key (KeyGrip grip) sec = (pre, subs) - where - (pre,subs) = break pred sec - pred p@(SecretKeyPacket {}) = matchpr grip p == grip - pred p@(PublicKeyPacket {}) = matchpr grip p == grip - pred _ = False - -seek_key (KeyTag key tag) ps - | null bs = (ps, []) - | null qs = - let (as', bs') = seek_key (KeyTag key tag) (tail bs) in - (as ++ (head bs : as'), bs') - | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (\p -> isSignaturePacket p - && has_tag tag p - && isJust (signature_issuer p) - && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) - ps - (rs,qs) = break isKey (reverse as) - - has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) - || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) - -seek_key (KeyUidMatch pat) ps - | null bs = (ps, []) - | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in - (as ++ (head bs : as'), bs') - | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (isInfixOf pat . uidStr) ps - (rs,qs) = break isKey (reverse as) - - uidStr (UserIDPacket s) = s - uidStr _ = "" - - -data InputFileContext = InputFileContext - { homesecPath :: FilePath - , homepubPath :: FilePath - } - -readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString -readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents -readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents -readInputFileS ctx inp = do - let fname = resolveInputFile ctx inp - fmap S.concat $ mapM S.readFile fname - -readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString -readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents -readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents -readInputFileL ctx inp = do - let fname = resolveInputFile ctx inp - fmap L.concat $ mapM L.readFile fname - - -writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs) -writeInputFileL ctx (FileDesc fd) bs = fdToHandle fd >>= (`L.hPut` bs) -writeInputFileL ctx inp bs = do - let fname = resolveInputFile ctx inp - mapM_ (`L.writeFile` bs) fname - --- writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () --- writeStamped0 :: InputFileContext -> InputFile - -getWriteFD :: InputFile -> Maybe Posix.Fd -getWriteFD (Pipe _ fd) = Just fd -getWriteFD (FileDesc fd) = Just fd -getWriteFD _ = Nothing - -writeStamped0 :: InputFileContext - -> InputFile - -> Posix.EpochTime - -> (Either Handle FilePath -> t -> IO ()) - -> t - -> IO () -writeStamped0 ctx (getWriteFD -> Just fd) stamp dowrite bs = do - h <- fdToHandle fd - dowrite (Left h) bs - handleIO_ (return ()) - $ setFdTimesHiRes fd (realToFrac stamp) (realToFrac stamp) -writeStamped0 ctx inp stamp dowrite bs = do - let fname = resolveInputFile ctx inp - forM_ fname $ \fname -> do - createDirectoryIfMissing True $ takeDirectory fname - dowrite (Right fname) bs - setFileTimes fname stamp stamp - -{- This may be useful later. Commented for now, as it is not used. - - -writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () -writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs --} - -writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () -writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str - -getInputFileTime :: InputFileContext -> InputFile -> IO CTime -getInputFileTime ctx (Pipe fdr fdw) = do - mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr - maybe tryw return mt - where - tryw = do - handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?") - $ modificationTime <$> getFdStatus fdw -getInputFileTime ctx (FileDesc fd) = do - handleIO_ (error $ "&"++show fd++": modificaiton time?") $ - modificationTime <$> getFdStatus fd -getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do - handleIO_ (error $ fname++": modificaiton time?") $ - modificationTime <$> getFileStatus fname - -{- - - This may be useful later. Commented for now as it is not used. - - -doesInputFileExist :: InputFileContext -> InputFile -> IO Bool -doesInputFileExist ctx f = do - case resolveInputFile ctx f of - [n] -> doesFileExist n - _ -> return True --} - - -cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString) -cachedContents maybePrompt ctx fd = do - ref <- newIORef Nothing - return $ get maybePrompt ref fd - where - trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs - - get maybePrompt ref fd = do - pw <- readIORef ref - flip (flip maybe return) pw $ do - if fd == FileDesc 0 then case maybePrompt of - Just prompt -> S.hPutStr stderr prompt - Nothing -> return () - else return () - pw <- fmap trimCR $ readInputFileS ctx fd - writeIORef ref (Just pw) - return pw - -importSecretKey :: - (MappedPacket -> IO (KikiCondition Packet)) - -> KikiCondition - (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) - -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) - -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -importSecretKey doDecrypt db' tup = do - try db' $ \(db',report0) -> do - r <- doImport doDecrypt - db' - tup - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) - - -mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext - -> IO - (KikiCondition - ( ( Map.Map [Char8.ByteString] KeyData - , ( [Hosts.Hosts] - , [Hosts.Hosts] - , Hosts.Hosts - , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))] - , [SockAddr])) - , [(FilePath,KikiReportAction)])) -mergeHostFiles krd db ctx = do - let hns = files ishosts - ishosts Hosts = True - ishosts _ = False - files istyp = do - (f,stream) <- Map.toList (opFiles krd) - guard (istyp $ typ stream) - return f - - hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL ctx) hns - - let gpgnames = map getHostnames $ Map.elems db - os = do - (addr,(ns,_)) <- gpgnames - n <- ns - return (addr,n) - setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os - -- we ensure .onion names are set properly - hostdbs = map setOnions hostdbs0 - outgoing_names = do - (addr,(_,gns)) <- gpgnames - guard . not $ null gns - guard $ all (null . Hosts.namesForAddress addr) hostdbs0 - return addr - -- putStrLn $ "hostdbs = " ++ show hostdbs - - -- 1. let U = union all the host dbs - -- preserving whitespace and comments of the first - let u0 = foldl' Hosts.plus Hosts.empty hostdbs - -- we filter U to be only finger-dresses - u1 = Hosts.filterAddrs (hasFingerDress db) u0 - - -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h - {- - putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}" - putStrLn $ "--> " ++ show (nf (head hostdbs)) - putStrLn $ "u0 = {\n" ++ show u0 ++ "}" - putStrLn $ "--> " ++ show (nf u0) - putStrLn $ "u1 = {\n" ++ show u1 ++ "}" - putStrLn $ "--> " ++ show (nf u1) - -} - - -- 2. replace gpg annotations with those in U - -- forM use_db - db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db - - return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[]) - -writeHostsFiles - :: KeyRingOperation -> InputFileContext - -> ([Hosts.Hosts], - [Hosts.Hosts], - Hosts.Hosts, - [(SockAddr, (t1, [Char8.ByteString]))], - [SockAddr]) - -> IO [(FilePath, KikiReportAction)] -writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do - let hns = files isMutableHosts - isMutableHosts (fill -> KF_None) = False - isMutableHosts (typ -> Hosts) = True - isMutableHosts _ = False - files istyp = do - (f,stream) <- Map.toList (opFiles krd) - guard (istyp stream) - return f -- resolveInputFile ctx f - - -- 3. add hostnames from gpg for addresses not in U - let u = foldl' f u1 ans - ans = reverse $ do - (addr,(_,ns)) <- gpgnames - guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0 - n <- ns - return (addr,n) - f h (addr,n) = Hosts.assignNewName addr n h - - -- 4. for each host db H, union H with U and write it out as H' - -- only if there is a non-empty diff - rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do - let h = h1 `Hosts.plus` u - d = Hosts.diff h0 h - rs = map ((fname,) . HostsDiff) d - unless (null d) $ writeInputFileL ctx fname $ Hosts.encode h - return $ map (first $ resolveForReport $ Just ctx) rs - return $ concat rss - -isSecretKey :: Packet -> Bool -isSecretKey (SecretKeyPacket {}) = True -isSecretKey _ = False - -buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation - -> IO (KikiCondition ((KeyDB - ,Maybe String - ,Maybe MappedPacket - ,([Hosts.Hosts], - [Hosts.Hosts], - Hosts.Hosts, - [(SockAddr, (KeyKey, KeyKey))], - [SockAddr]) - ,Map.Map InputFile Access - ,MappedPacket -> IO (KikiCondition Packet) - ,Map.Map InputFile Message - ) - ,[(FilePath,KikiReportAction)])) -buildKeyDB ctx grip0 keyring = do - let - files isring = do - (f,stream) <- Map.toList (opFiles keyring) - guard (isring $ typ stream) - resolveInputFile ctx f - - ringMap = Map.filter (isring . typ) $ opFiles keyring - - readp f stream = fmap readp0 $ readPacketsFromFile ctx f - where - readp0 ps = (stream { access = acc' }, ps) - where acc' = case access stream of - AutoAccess -> - case ps of - Message ((PublicKeyPacket {}):_) -> Pub - Message ((SecretKeyPacket {}):_) -> Sec - _ -> AutoAccess - acc -> acc - - readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) - - -- KeyRings (todo: KikiCondition reporting?) - (spilled,mwk,grip,accs,keys,unspilled) <- do -#if MIN_VERSION_containers(0,5,0) - ringPackets <- Map.traverseWithKey readp ringMap -#else - ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap -#endif - let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) - - let grip = grip0 `mplus` (fingerprint <$> fstkey) - where - fstkey = do - (_,Message ps) <- Map.lookup HomeSec ringPackets - listToMaybe ps - (spilled,unspilled) = Map.partition (spillable . fst) ringPackets - keys :: Map.Map KeyKey MappedPacket - keys = Map.foldl slurpkeys Map.empty - $ Map.mapWithKey filterSecrets ringPackets - where - filterSecrets f (_,Message ps) = - filter (isSecretKey . packet) - $ zipWith (mappedPacketWithHint fname) ps [1..] - where fname = resolveForReport (Just ctx) f - slurpkeys m ps = m `Map.union` Map.fromList ps' - where ps' = zip (map (keykey . packet) ps) ps - wk = listToMaybe $ do - fp <- maybeToList grip - let matchfp mp = not (is_subkey p) && matchpr fp p == fp - where p = packet mp - Map.elems $ Map.filter matchfp keys - accs = fmap (access . fst) ringPackets - return (spilled,wk,grip,accs,keys,fmap snd unspilled) - - doDecrypt <- makeMemoizingDecrypter keyring ctx keys - - let wk = fmap packet mwk - rt0 = KeyRingRuntime { rtPubring = homepubPath ctx - , rtSecring = homesecPath ctx - , rtGrip = grip - , rtWorkingKey = wk - , rtRingAccess = accs - , rtKeyDB = Map.empty - , rtPassphrases = doDecrypt - } - transformed0 <- - let trans f (info,ps) = do - let manip = combineTransforms (transforms info) - rt1 = rt0 { rtKeyDB = merge Map.empty f ps } - acc = Just Sec /= Map.lookup f accs - r <- performManipulations doDecrypt rt1 mwk manip - try r $ \(rt2,report) -> do - return $ KikiSuccess (report,(info,flattenKeys acc $ rtKeyDB rt2)) -#if MIN_VERSION_containers(0,5,0) - in fmap sequenceA $ Map.traverseWithKey trans spilled -#else - in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled -#endif - try transformed0 $ \transformed -> do - let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed - where - mergeIt db f (_,(info,ps)) = merge db f ps - reportTrans = concat $ Map.elems $ fmap fst transformed - - -- Wallets - let importWalletKey wk db' (top,fname,sub,tag) = do - try db' $ \(db',report0) -> do - r <- doImportG doDecrypt - db' - (fmap keykey $ maybeToList wk) - [mkUsage tag] - fname - sub - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) - - wms <- mapM (readw wk) (files iswallet) - let wallet_keys = do - maybeToList wk - (fname,xs) <- wms - (_,sub,(_,m)) <- xs - (tag,top) <- Map.toList m - return (top,fname,sub,tag) - db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys - try db $ \(db,reportWallets) -> do - - -- PEM files - let pems = do - (n,stream) <- Map.toList $ opFiles keyring - grip <- maybeToList grip - n <- resolveInputFile ctx n - guard $ spillable stream && isSecretKeyFile (typ stream) - let us = mapMaybe usageFromFilter [fill stream,spill stream] - usage <- take 1 us - guard $ all (==usage) $ drop 1 us - -- TODO: KikiCondition reporting for spill/fill usage mismatch? - let (topspec,subspec) = parseSpec grip usage - ms = map fst $ filterMatches topspec (Map.toList db) - cmd = initializer stream - return (n,subspec,ms,stream, cmd) - imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems - db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports - try db $ \(db,reportPEMs) -> do - - r <- mergeHostFiles keyring db ctx - try r $ \((db,hs),reportHosts) -> do - - return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) - , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts ) - -torhash :: Packet -> String -torhash key = fromMaybe "" $ derToBase32 <$> derRSA key - -derToBase32 :: ByteString -> String -#if !defined(VERSION_cryptonite) -derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy -#else -derToBase32 = map toLower . Base32.encode . S.unpack . sha1 - where - sha1 :: L.ByteString -> S.ByteString - sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1) -#endif - -derRSA :: Packet -> Maybe ByteString -derRSA rsa = do - k <- rsaKeyFromPacket rsa - return $ encodeASN1 DER (toASN1 k []) - -unconditionally :: IO (KikiCondition a) -> IO a -unconditionally action = do - r <- action - case r of - KikiSuccess x -> return x - e -> error $ errorString e - -try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b) -try x body = - case functorToEither x of - Left e -> return e - Right x -> body x - - -data ParsedCert = ParsedCert - { pcertKey :: Packet - , pcertTimestamp :: UTCTime - , pcertBlob :: L.ByteString - } - deriving (Show,Eq) -data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert - deriving (Show,Eq) - -spemPacket (PEMPacket p) = Just p -spemPacket _ = Nothing - -spemCert (PEMCertificate p) = Just p -spemCert _ = Nothing - -toStrict :: L.ByteString -> S.ByteString -toStrict = foldr1 (<>) . L.toChunks - --- No instance for (ASN1Object RSA.PublicKey) - -parseCertBlob comp bs = do - asn1 <- either (const Nothing) Just - $ decodeASN1 DER bs - let asn1' = drop 2 asn1 - cert <- either (const Nothing) (Just . fst) (fromASN1 asn1') - let _ = cert :: X509.Certificate - notBefore :: UTCTime -#if MIN_VERSION_x509(1,5,0) - notBefore = toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano - where (vincentTime,_) = X509.certValidity cert -#else - (notBefore,_) = X509.certValidity cert -#endif - case X509.certPubKey cert of - X509.PubKeyRSA key -> do - let withoutkey = - let ekey = toStrict $ encodeASN1 DER (toASN1 key []) - (pre,post) = S.breakSubstring ekey $ toStrict bs - post' = S.drop (S.length ekey) post - len :: Word16 - len = if S.null post then maxBound - else fromIntegral $ S.length pre - in if len < 4096 - then encode len <> GZip.compress (Char8.fromChunks [pre,post']) - else bs - return - ParsedCert { pcertKey = packetFromPublicRSAKey notBefore - (MPI $ RSA.public_n key) - (MPI $ RSA.public_e key) - , pcertTimestamp = notBefore - , pcertBlob = if comp then withoutkey - else bs - } - _ -> Nothing - -packetFromPublicRSAKey notBefore n e = - PublicKeyPacket { version = 4 - , timestamp = round $ utcTimeToPOSIXSeconds notBefore - , key_algorithm = RSA - , key = [('n',n),('e',e)] - , is_subkey = True - , v3_days_of_validity = Nothing - } - -decodeBlob cert = - if 0 /= (bs `L.index` 0) .&. 0x10 - then bs - else let (keypos0,bs') = L.splitAt 2 bs - keypos :: Word16 - keypos = decode keypos0 - ds = GZip.decompress bs' - (prekey,postkey) = L.splitAt (fromIntegral keypos) ds - in prekey <> key <> postkey - where - bs = pcertBlob cert - key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert - -extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey -extractRSAKeyFields kvs = do - let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs - n <- lookup "Modulus" kvs' - e <- lookup "PublicExponent" kvs' - d <- lookup "PrivateExponent" kvs' - p <- lookup "Prime1" kvs' -- p - q <- lookup "Prime2" kvs' -- q - dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1) - dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1) - u <- lookup "Coefficient" kvs' - {- - case (d,p,dmodp1) of - (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return () - _ -> error "dmodp fail!" - case (d,q,dmodqminus1) of - (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return () - _ -> error "dmodq fail!" - -} - return $ RSAPrivateKey - { rsaN = n - , rsaE = e - , rsaD = d - , rsaP = p - , rsaQ = q - , rsaDmodP1 = dmodp1 - , rsaDmodQminus1 = dmodqminus1 - , rsaCoefficient = u } - where - parseField blob = MPI <$> m - where m = bigendian <$> Base64.decode (Char8.unpack blob) - - bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs - where - nlen = length bs - -rsaToPGP stamp rsa = SecretKeyPacket - { version = 4 - , timestamp = fromTime stamp -- toEnum (fromEnum stamp) - , key_algorithm = RSA - , key = [ -- public fields... - ('n',rsaN rsa) - ,('e',rsaE rsa) - -- secret fields - ,('d',rsaD rsa) - ,('p',rsaQ rsa) -- Note: p & q swapped - ,('q',rsaP rsa) -- Note: p & q swapped - ,('u',rsaCoefficient rsa) - ] - -- , ecc_curve = def - , s2k_useage = 0 - , s2k = S2K 100 "" - , symmetric_algorithm = Unencrypted - , encrypted_data = "" - , is_subkey = True - } - -readSecretDNSFile :: InputFile -> IO Packet -readSecretDNSFile fname = do - let ctx = InputFileContext "" "" - stamp <- getInputFileTime ctx fname - input <- readInputFileL ctx fname - let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1) - . Char8.break (==':')) - $ Char8.lines input - alg = maybe RSA parseAlg $ lookup "Algorithm" kvs - parseAlg spec = case Char8.words spec of - nstr:_ -> case read (Char8.unpack nstr) :: Int of - 2 -> DH - 3 -> DSA -- SHA1 - 5 -> RSA -- SHA1 - 6 -> DSA -- NSEC3-SHA1 (RFC5155) - 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155) - 8 -> RSA -- SHA256 - 10 -> RSA -- SHA512 (RFC5702) - -- 12 -> GOST - 13 -> ECDSA -- P-256 SHA256 (RFC6605) - 14 -> ECDSA -- P-384 SHA384 (RFC6605) - _ -> RSA - case alg of - RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs - - -readSecretPEMFile :: InputFile -> IO [SecretPEMData] -readSecretPEMFile fname = do - -- warn $ fname ++ ": reading ..." - let ctx = InputFileContext "" "" - -- Note: The key's timestamp is included in it's fingerprint. - -- Therefore, we should attempt to preserve it. - stamp <- getInputFileTime ctx fname - input <- readInputFileL ctx fname - let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input - pkcs1 = fmap (parseRSAPrivateKey . pemBlob) - $ pemParser $ Just "RSA PRIVATE KEY" - cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob) - $ pemParser $ Just "CERTIFICATE" - parseRSAPrivateKey dta = do - let e = decodeASN1 DER dta - asn1 <- either (const $ mzero) return e - rsa <- either (const mzero) (return . fst) (fromASN1 asn1) - let _ = rsa :: RSAPrivateKey - return $ PEMPacket $ rsaToPGP stamp rsa - dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta - mergeDate (_,obj) (Left tm) = (fromTime tm,obj) - mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key') - where key' = if tm < fromTime (timestamp key) - then key { timestamp = fromTime tm } - else key - mergeDate (tm,_) (Right mb) = (tm,mb) - return $ dta - -doImport - :: Ord k => - (MappedPacket -> IO (KikiCondition Packet)) - -> Map.Map k KeyData - -> (FilePath, Maybe [Char], [k], StreamInfo, t) - -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) -doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do - flip (maybe $ return CannotImportMasterKey) - subspec $ \tag -> do - (certs,keys) <- case typ of - PEMFile -> do - ps <- readSecretPEMFile (ArgFile fname) - let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) - = partition (isJust . spemCert) ps - return (certs,keys) - DNSPresentation -> do - p <- readSecretDNSFile (ArgFile fname) - return ([],[p]) - -- TODO Probably we need to move to a new design where signature - -- packets are merged into the database in one phase with null - -- signatures, and then the signatures are made in the next phase. - -- This would let us merge annotations (like certificates) from - -- seperate files. - foldM (importKey tag certs) (KikiSuccess (db,[])) keys - where - importKey tag certs prior key = do - try prior $ \(db,report) -> do - let (m0,tailms) = splitAt 1 ms - if (not (null tailms) || null m0) - then return $ AmbiguousKeySpec fname - else do - let kk = keykey key - cs = filter (\c -> kk==keykey (pcertKey c)) certs - blobs = map mkCertNotation $ nub $ map pcertBlob cs - mkCertNotation bs = NotationDataPacket - { human_readable = False - , notation_name = "x509cert@" - , notation_value = Char8.unpack bs } - datedKey = key { timestamp = fromTime $ minimum dates } - dates = fromTime (timestamp key) : map pcertTimestamp certs - r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey - try r $ \(db',report') -> do - return $ KikiSuccess (db',report++report') - -doImportG - :: Ord k => - (MappedPacket -> IO (KikiCondition Packet)) - -> Map.Map k KeyData - -> [k] - -> [SignatureSubpacket] - -> [Char] - -> Packet - -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) -doImportG doDecrypt db m0 tags fname key = do - let kk = head m0 - Just (KeyData top topsigs uids subs) = Map.lookup kk db - subkk = keykey key - (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) - []) - ( (False,) . addOrigin ) - (Map.lookup subkk subs) - where - addOrigin (SubKey mp sigs) = - let mp' = mp - { locations = Map.insert fname - (origin (packet mp) (-1)) - (locations mp) } - in SubKey mp' sigs - subs' = Map.insert subkk subkey subs - - istor = do - guard ("tor" `elem` mapMaybe usage tags) - return $ "Anonymous " - - uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do - let has_torid = do - -- TODO: check for omitted real name field - (sigtrusts,om) <- Map.lookup idstr uids - listToMaybe $ do - s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) - signatures_over $ verify (Message [packet top]) s - flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do - wkun <- doDecrypt top - - try wkun $ \wkun -> do - - let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) - uid = UserIDPacket idstr - -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags - tor_ov = makeInducerSig (packet top) wkun uid keyflags - sig_ov <- pgpSign (Message [wkun]) - tor_ov - SHA1 - (fingerprint wkun) - flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) - (sig_ov >>= listToMaybe . signatures_over) - $ \sig -> do - let om = Map.singleton fname (origin sig (-1)) - trust = Map.empty - return $ KikiSuccess - ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} - , trust)],om) uids - , [] ) - - try uids' $ \(uids',report) -> do - - let SubKey subkey_p subsigs = subkey - wk = packet top - (xs',minsig,ys') = findTag tags wk key subsigs - doInsert mbsig db = do - -- NEW SUBKEY BINDING SIGNATURE - sig' <- makeSig doDecrypt top fname subkey_p tags mbsig - try sig' $ \(sig',report) -> do - report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] - let subs' = Map.insert subkk - (SubKey subkey_p $ xs'++[sig']++ys') - subs - return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db - , report ) - - report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) - else id - s = show (fmap fst minsig,fingerprint key) - in return (f report) - - case minsig of - Nothing -> doInsert Nothing db -- we need to create a new sig - Just (True,sig) -> -- we can deduce is_new == False - -- we may need to add a tor id - return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db - , report ) - Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag - -isCryptoCoinKey :: Packet -> Bool -isCryptoCoinKey p = - and [ isKey p - , key_algorithm p == ECDSA - , lookup 'c' (key p) == Just (MPI secp256k1_id) - ] - -getCryptoCoinTag :: Packet -> Maybe CryptoCoins.CoinNetwork -getCryptoCoinTag p | isSignaturePacket p = do - -- CryptoCoins.secret - let sps = hashed_subpackets p ++ unhashed_subpackets p - u <- listToMaybe $ mapMaybe usage sps - CryptoCoins.lookupNetwork CryptoCoins.network_name u -getCryptoCoinTag _ = Nothing - - -coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPacket)] -coinKeysOwnedBy db wk = do - wk <- maybeToList wk - let kk = keykey wk - KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db - (subkk,SubKey mp sigs) <- Map.toList subs - let sub = packet mp - guard $ isCryptoCoinKey sub - tag <- take 1 $ mapMaybe (getCryptoCoinTag . packet . fst) sigs - return (tag,mp) - -walletImportFormat :: Word8 -> Packet -> String -walletImportFormat idbyte k = secret_base58_foo - where - -- isSecret (SecretKeyPacket {}) = True - -- isSecret _ = False - secret_base58_foo = base58_encode seckey - Just d = lookup 'd' (key k) - (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d) - seckey = S.cons idbyte bigendian - -writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)]) -writeWalletKeys krd db wk = do - let cs = db `coinKeysOwnedBy` wk - -- export wallet keys - isMutableWallet (fill -> KF_None) = False - isMutableWallet (typ -> WalletFile {}) = True - isMutableWallet _ = False - files pred = do - (f,stream) <- Map.toList (opFiles krd) - guard (pred stream) - resolveInputFile (InputFileContext "" "") f - let writeWallet report n = do - let cs' = do - (nw,mp) <- cs - -- let fns = Map.keys (locations mp) - -- trace ("COIN KEY: "++show fns) $ return () - guard . not $ Map.member n (locations mp) - let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp) - return (CryptoCoins.network_name nw,wip) - handleIO_ (return report) $ do - -- TODO: This AppendMode stratagy is not easy to adapt from FilePath-based - -- to InputFile-based. - withFile n AppendMode $ \fh -> do - rs <- forM cs' $ \(net,wip) -> do - hPutStrLn fh wip - return (n, NewWalletKey net) - return (report ++ rs) - report <- foldM writeWallet [] (files isMutableWallet) - return $ KikiSuccess report - -ifSecret :: Packet -> t -> t -> t -ifSecret (SecretKeyPacket {}) t f = t -ifSecret _ t f = f - -showPacket :: Packet -> String -showPacket p | isKey p = (if is_subkey p - then showPacket0 p - else ifSecret p "----Secret-----" "----Public-----") - ++ " "++show (key_algorithm p)++" "++fingerprint p - | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) - | otherwise = showPacket0 p -showPacket0 p = concat . take 1 $ words (show p) - - --- | returns Just True so as to indicate that --- the public portions of keys will be imported -importPublic :: Maybe Bool -importPublic = Just True - --- | returns False True so as to indicate that --- the public portions of keys will be imported -importSecret :: Maybe Bool -importSecret = Just False - - --- TODO: Do we need to memoize this? -guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe () -guardAuthentic rt keydata = guard (isauth rt keydata) - -isauth :: KeyRingRuntime -> KeyData -> Bool -isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk - where wk = workingKey (rtGrip rt) (rtKeyDB rt) - dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt) - $ locations p - has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids - where - goodsig (uidstr,(sigs,_)) = not . null $ do - sig0 <- fmap (packet . fst) sigs - pre_ov <- signatures (Message [packet k, UserIDPacket uidstr, sig0]) - signatures_over $ verify (Message [wk]) pre_ov - - workingKey grip use_db = listToMaybe $ do - fp <- maybeToList grip - elm <- Map.elems use_db - guard $ matchSpec (KeyGrip fp) elm - return $ keyPacket elm - -writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message - -> [(FilePath,KikiReportAction)] - {- - -> KeyDB -> Maybe Packet - -> FilePath -> FilePath - -} - -> IO (KikiCondition [(FilePath,KikiReportAction)]) -writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do - let isring (KeyRingFile {}) = True - isring _ = False - db = rtKeyDB rt - secring = rtSecring rt - pubring = rtPubring rt - ctx = InputFileContext secring pubring - let s = do - (f,f0,stream) <- do - (f0,stream) <- Map.toList (opFiles krd) - guard (isring $ typ stream) - f <- resolveInputFile ctx f0 - return (f,f0,stream) - let db' = fromMaybe db $ do - msg <- Map.lookup f0 unspilled - return $ merge db f0 msg - x = do - let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool - wantedForFill acc KF_None = importByExistingMaster - -- Note the KF_None case is almost irrelevent as it will be - -- filtered later when isMutable returns False. - -- We use importByExistingMaster in order to generate - -- MissingPacket warnings. To disable those warnings, use - -- const Nothing instead. - wantedForFill acc (KF_Match {}) = importByExistingMaster - wantedForFill acc KF_Subkeys = importByExistingMaster - wantedForFill acc KF_Authentic = \kd -> do guardAuthentic rt kd - importByAccess acc kd - wantedForFill acc KF_All = importByAccess acc - importByAccess Pub kd = importPublic - importByAccess Sec kd = importSecret - importByAccess AutoAccess kd = - mplus (importByExistingMaster kd) - (error $ f ++ ": write public or secret key to file?") - importByExistingMaster kd@(KeyData p _ _ _) = - fmap originallyPublic $ Map.lookup f $ locations p - d <- sortByHint f keyMappedPacket (Map.elems db') - acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt) - only_public <- maybeToList $ wantedForFill acc (fill stream) d - guard $ only_public || isSecretKey (keyPacket d) - case fill stream of - KF_Match usage -> do grip <- maybeToList $ rtGrip rt - flattenTop f only_public - $ filterNewSubs f (parseSpec grip usage) d - _ -> flattenTop f only_public d - new_packets = filter isnew x - where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) - -- TODO: We depend on an exact string match between the reported - -- file origin of the deleted packet and the path of the file we are - -- writing. Verify that this is a safe assumption. - isdeleted (f',DeletedPacket _) = f'==f - isdeleted _ = False - guard (not (null new_packets) || any isdeleted report_manips) - return ((f0,isMutable stream),(new_packets,x)) - let (towrites,report) = (\f -> foldl f ([],[]) s) $ - \(ws,report) ((f,mutable),(new_packets,x)) -> - if mutable - then - let rs = flip map new_packets - $ \c -> (concat $ resolveInputFile ctx f, NewPacket $ showPacket (packet c)) - in (ws++[(f,x)],report++rs) - else - let rs = flip map new_packets - $ \c -> (concat $ resolveInputFile ctx f,MissingPacket (showPacket (packet c))) - in (ws,report++rs) - forM_ towrites $ \(f,x) -> do - let m = Message $ map packet x - -- warn $ "writing "++f - writeInputFileL ctx f (encode m) - return $ KikiSuccess report - - -{- -getSubkeysForExport kk subspec db = do - kd <- maybeToList $ Map.lookup kk db - subkeysForExport subspec kd --} - --- | If provided Nothing for the first argument, this function returns the --- master key of the given identity. Otherwise, it returns all the subkeys of --- the given identity which have a usage tag that matches the first argument. -subkeysForExport :: Maybe String -> KeyData -> [MappedPacket] -subkeysForExport subspec (KeyData key _ _ subkeys) = do - let subs tag = do - e <- Map.elems subkeys - guard $ doSearch key tag e - return $ subkeyMappedPacket e - maybe [key] subs subspec - where - doSearch key tag (SubKey sub_mp sigtrusts) = - let (_,v,_) = findTag [mkUsage tag] - (packet key) - (packet sub_mp) - sigtrusts - in fmap fst v==Just True - -writePEM :: String -> String -> String -writePEM typ dta = pem - where - pem = unlines . concat $ - [ ["-----BEGIN " <> typ <> "-----"] - , split64s dta - , ["-----END " <> typ <> "-----"] ] - split64s :: String -> [String] - split64s "" = [] - split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta - - -- 64 byte lines - -rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey -rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do - -- public fields... - n <- lookup 'n' $ key pkt - e <- lookup 'e' $ key pkt - -- secret fields - MPI d <- lookup 'd' $ key pkt - MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped - MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped - - -- Note: Here we fail if 'u' key is missing. - -- Ideally, it would be better to compute (inverse q) mod p - -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg - -- (package constructive-algebra) - coefficient <- lookup 'u' $ key pkt - - let dmodp1 = MPI $ d `mod` (p - 1) - dmodqminus1 = MPI $ d `mod` (q - 1) - return $ RSAPrivateKey - { rsaN = n - , rsaE = e - , rsaD = MPI d - , rsaP = MPI p - , rsaQ = MPI q - , rsaDmodP1 = dmodp1 - , rsaDmodQminus1 = dmodqminus1 - , rsaCoefficient = coefficient } -rsaPrivateKeyFromPacket _ = Nothing - -secretPemFromPacket packet = pemFromPacket Sec packet - -pemFromPacket Sec packet = - case key_algorithm packet of - RSA -> do - rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey - let asn1 = toASN1 rsa [] - bs = encodeASN1 DER asn1 - dta = Base64.encode (L.unpack bs) - output = writePEM "RSA PRIVATE KEY" dta - Just output - algo -> Nothing -pemFromPacket Pub packet = - case key_algorithm packet of - RSA -> do - rsa <- rsaKeyFromPacket packet - let asn1 = toASN1 (pkcs8 rsa) [] - bs = encodeASN1 DER asn1 - dta = Base64.encode (L.unpack bs) - output = writePEM "PUBLIC KEY" dta - Just output - algo -> Nothing -pemFromPacket AutoAccess p@(PublicKeyPacket {}) = pemFromPacket Pub p -pemFromPacket AutoAccess p@(SecretKeyPacket {}) = pemFromPacket Sec p -pemFromPacket AutoAccess _ = Nothing - -writeKeyToFile :: - Bool -> StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)] -writeKeyToFile False stream@(StreamInfo { typ = PEMFile }) fname packet = do - case pemFromPacket (access stream) packet of - Just output -> do - let stamp = toEnum . fromEnum $ timestamp packet - handleIO_ (return [(fname, FailedFileWrite)]) $ do - saved_mask <- setFileCreationMask 0o077 - -- Note: The key's timestamp is included in it's fingerprint. - -- Therefore, we should attempt to preserve it. - writeStamped (InputFileContext "" "") fname stamp output - setFileCreationMask saved_mask - return [(fname, ExportedSubkey)] - Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)] - -writeKeyToFile False StreamInfo { typ = DNSPresentation } fname packet = do - case key_algorithm packet of - RSA -> do - flip (maybe (return [])) - (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey - $ \rsa -> do - let -- asn1 = toASN1 rsa [] - -- bs = encodeASN1 DER asn1 - -- dta = Base64.encode (L.unpack bs) - b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i) - where - MPI i = ac rsa - i2bs_unsized :: Integer -> S.ByteString - i2bs_unsized 0 = S.singleton 0 - i2bs_unsized i = S.reverse $ S.unfoldr go i - where go i' = if i' <= 0 then Nothing - else Just (fromIntegral i', (i' `shiftR` 8)) - output = unlines - [ "Private-key-format: v1.2" - , "Algorithm: 8 (RSASHA256)" - , "Modulus: " ++ b64 rsaN rsa - , "PublicExponent: " ++ b64 rsaE rsa - , "PrivateExponent: " ++ b64 rsaD rsa - , "Prime1: " ++ b64 rsaP rsa - , "Prime2: " ++ b64 rsaQ rsa - , "Exponent1: " ++ b64 rsaDmodP1 rsa - , "Exponent2: " ++ b64 rsaDmodQminus1 rsa - , "Coefficient: " ++ b64 rsaCoefficient rsa - ] - stamp = toEnum . fromEnum $ timestamp packet - handleIO_ (return [(fname, FailedFileWrite)]) $ do - saved_mask <- setFileCreationMask 0o077 - -- Note: The key's timestamp is included in it's fingerprint. - -- Therefore, we should attempt to preserve it. - writeStamped (InputFileContext "" "") fname stamp output - setFileCreationMask saved_mask - return [(fname, ExportedSubkey)] - algo -> return [(fname, UnableToExport algo $ fingerprint packet)] - -writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet)) - -> KeyDB - -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)] - -> IO (KikiCondition [(FilePath,KikiReportAction)]) -writePEMKeys doDecrypt db exports = do - ds <- mapM decryptKeys exports - let ds' = map functorToEither ds - if null (lefts ds') - then do - rs <- mapM (\(f,stream,p) -> writeKeyToFile False stream (ArgFile f) p) - (rights ds') - return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs) - else do - return (head $ lefts ds') - where - decryptKeys (fname,subspec,[p],stream@(StreamInfo { access=Pub })) - = return $ KikiSuccess (fname,stream,packet p) -- public keys are never encrypted. - decryptKeys (fname,subspec,[p],stream) = do - pun <- doDecrypt p - try pun $ \pun -> do - return $ KikiSuccess (fname,stream,pun) - -makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext - -> Map.Map KeyKey MappedPacket - -> IO (MappedPacket -> IO (KikiCondition Packet)) -makeMemoizingDecrypter operation ctx keys = - if null chains then do - -- (*) Notice we do not pass ctx to resolveForReport. - -- This is because the merge function does not currently use a context - -- and the pws map keys must match the MappedPacket locations. - -- TODO: Perhaps these should both be of type InputFile rather than - -- FilePath? - -- pws :: Map.Map FilePath (IO S.ByteString) - {- - pws <- - Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) - (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above - $ Map.filter (isJust . pwfile . typ) $ opFiles operation) - -} - let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" - pws2 <- - Traversable.mapM (cachedContents prompt ctx) - $ Map.fromList $ mapMaybe - (\spec -> (,passSpecPassFile spec) `fmap` do - guard $ isNothing $ passSpecKeySpec spec - passSpecRingFile spec) - passspecs - defpw <- do - Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) - $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) - && isNothing (passSpecKeySpec sp)) - $ opPassphrases operation - unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) - return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw - else let PassphraseMemoizer f = head chains - in return f - where - (chains,passspecs) = partition isChain $ opPassphrases operation - where isChain (PassphraseMemoizer {}) = True - isChain _ = False - doDecrypt :: IORef (Map.Map KeyKey Packet) - -> Map.Map FilePath (IO S.ByteString) - -> Maybe (IO S.ByteString) - -> MappedPacket - -> IO (KikiCondition Packet) - doDecrypt unkeysRef pws defpw mp0 = do - unkeys <- readIORef unkeysRef - let mp = fromMaybe mp0 $ do - k <- Map.lookup kk keys - return $ mergeKeyPacket "decrypt" mp0 k - wk = packet mp0 - kk = keykey wk - fs = Map.keys $ locations mp - - decryptIt [] = return BadPassphrase - decryptIt (getpw:getpws) = do - -- TODO: This function should use mergeKeyPacket to - -- combine the packet with it's unspilled version before - -- attempting to decrypt it. - pw <- getpw - let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp) - case symmetric_algorithm wkun of - Unencrypted -> do - writeIORef unkeysRef (Map.insert kk wkun unkeys) - return $ KikiSuccess wkun - _ -> decryptIt getpws - - getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw - - case symmetric_algorithm wk of - Unencrypted -> return (KikiSuccess wk) - _ -> maybe (decryptIt getpws) - (return . KikiSuccess) - $ Map.lookup kk unkeys - -performManipulations :: - (MappedPacket -> IO (KikiCondition Packet)) - -> KeyRingRuntime - -> Maybe MappedPacket - -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) - -> IO (KikiCondition (KeyRingRuntime,KikiReport)) -performManipulations doDecrypt rt wk manip = do - let db = rtKeyDB rt - performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd - r <- Traversable.mapM performAll db - try (sequenceA r) $ \db -> do - return $ KikiSuccess (rt { rtKeyDB = fmap fst db }, concatMap snd $ Map.elems db) - where - perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) - perform kd (InducerSignature uid subpaks) = do - try kd $ \(kd,report) -> do - flip (maybe $ return NoWorkingKey) wk $ \wk' -> do - wkun' <- doDecrypt wk' - try wkun' $ \wkun -> do - let flgs = if keykey (keyPacket kd) == keykey wkun - then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs) - else [] - sigOver = makeInducerSig (keyPacket kd) - wkun - (UserIDPacket uid) - $ flgs ++ subpaks - om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid - toMappedPacket om p = (mappedPacket "" p) {locations=om} - selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard - . (== keykey whosign) - . keykey)) vs - keys = map keyPacket $ Map.elems (rtKeyDB rt) - overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig]) - vs :: [ ( Packet -- signature - , Maybe SignatureOver -- Nothing means non-verified - , Packet ) -- key who signed - ] - vs = do - x <- maybeToList $ Map.lookup uid (keyUids kd) - sig <- map (packet . fst) (fst x) - o <- overs sig - k <- keys - let ov = verify (Message [k]) $ o - signatures_over ov - return (sig,Just ov,k) - additional new_sig = do - new_sig <- maybeToList new_sig - guard (null $ selfsigs) - signatures_over new_sig - sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) - let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) - f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x - , om `Map.union` snd x ) - -- XXX: Shouldn't this signature generation show up in the KikiReport ? - return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report ) - - perform kd (SubKeyDeletion topk subk) = do - try kd $ \(kd,report) -> do - let kk = keykey $ packet $ keyMappedPacket kd - kd' | kk /= topk = kd - | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd } - pred k _ = k /= subk - ps = concat $ maybeToList $ do - SubKey mp sigs <- Map.lookup subk (keySubKeys kd) - return $ packet mp : concatMap (\(p,ts) -> packet p : Map.elems ts) sigs - ctx = InputFileContext (rtSecring rt) (rtPubring rt) - rings = [HomeSec, HomePub] >>= resolveInputFile ctx - return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ]) - -initializeMissingPEMFiles :: - KeyRingOperation - -> InputFileContext -> Maybe String - -> (MappedPacket -> IO (KikiCondition Packet)) - -> KeyDB - -> IO (KikiCondition ( (KeyDB,[( FilePath - , Maybe String - , [MappedPacket] - , StreamInfo )]) - , [(FilePath,KikiReportAction)])) -initializeMissingPEMFiles operation ctx grip decrypt db = do - nonexistents <- - filterM (fmap not . doesFileExist . fst) - $ do (f,t) <- Map.toList (opFiles operation) - f <- resolveInputFile ctx f - return (f,t) - - let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do - (fname,stream) <- nonexistents - guard $ isMutable stream - guard $ isSecretKeyFile (typ stream) - usage <- usageFromFilter (fill stream) -- TODO: Error if no result? - let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage - -- ms will contain duplicates if a top key has multiple matching - -- subkeys. This is intentional. - -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db - -- ms = filterMatches topspec $ Map.toList db - ns = do - (kk,kd) <- filterMatches topspec $ Map.toList db - return (kk , subkeysForExport subspec kd) - return (fname,subspec,ns,stream) - (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) - notmissing - exports = map (\(f,subspec,ns,stream) -> (f,subspec,ns >>= snd,stream)) exports0 - - ambiguity (f,topspec,subspec,_) = do - return $ AmbiguousKeySpec f - - ifnotnull (x:xs) f g = f x - ifnotnull _ f g = g - - ifnotnull ambiguous ambiguity $ do - - -- create nonexistent files via external commands - do - let cmds = mapMaybe getcmd missing - where - getcmd (fname,subspec,ms,stream) = do - cmd <- initializer stream - return (fname,subspec,ms,stream,cmd) - rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do - e <- systemEnv [ ("file",fname) - , ("usage",fromMaybe "" subspec) ] - cmd - case e of - ExitFailure num -> return (tup,FailedExternal num) - ExitSuccess -> return (tup,ExternallyGeneratedFile) - - v <- foldM (importSecretKey decrypt) - (KikiSuccess (db,[])) $ do - ((f,subspec,ms,stream,cmd),r) <- rs - guard $ case r of - ExternallyGeneratedFile -> True - _ -> False - return (f,subspec,map fst ms,stream,cmd) - - try v $ \(db,import_rs) -> do - return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs - ++ import_rs) -{- -interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData -interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" -interpretManip kd manip = return kd --} - -combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] -combineTransforms trans rt kd = updates - where - updates = -- kManip operation rt kd ++ - concatMap (\t -> resolveTransform t rt kd) sanitized - sanitized = group (sort trans) >>= take 1 - -isSubkeySignature (SubkeySignature {}) = True -isSubkeySignature _ = False - --- Returned data is simmilar to getBindings but the Word8 codes --- are ORed together. -accBindings :: - Bits t => - [(t, (Packet, Packet), [a], [a1], [a2])] - -> [(t, (Packet, Packet), [a], [a1], [a2])] -accBindings bs = as - where - gs = groupBy samePair . sortBy (comparing bindingPair) $ bs - as = map (foldl1 combine) gs - bindingPair (_,p,_,_,_) = pub2 p - where - pub2 (a,b) = (pub a, pub b) - pub a = fingerprint_material a - samePair a b = bindingPair a == bindingPair b - combine (ac,p,akind,ahashed,aclaimaints) - (bc,_,bkind,bhashed,bclaimaints) - = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) - - - -verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) - where - verified = do - sig <- signatures (Message nonkeys) - let v = verify (Message keys) sig - guard (not . null $ signatures_over v) - return v - (top,othersigs) = partition isSubkeySignature verified - embedded = do - sub <- top - let sigover = signatures_over sub - unhashed = sigover >>= unhashed_subpackets - subsigs = mapMaybe backsig unhashed - -- This should consist only of 0x19 values - -- subtypes = map signature_type subsigs - -- trace ("subtypes = "++show subtypes) (return ()) - -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ()) - sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) - let v = verify (Message [subkey sub]) sig - guard (not . null $ signatures_over v) - return v - -smallpr k = drop 24 $ fingerprint k - -disjoint_fp ks = {- concatMap group2 $ -} transpose grouped - where - grouped = groupBy samepr . sortBy (comparing smallpr) $ ks - samepr a b = smallpr a == smallpr b - - {- - -- useful for testing - group2 :: [a] -> [[a]] - group2 (x:y:ys) = [x,y]:group2 ys - group2 [x] = [[x]] - group2 [] = [] - -} - - -getBindings :: - [Packet] - -> - ( [([Packet],[SignatureOver])] -- other signatures with key sets - -- that were used for the verifications - , [(Word8, - (Packet, Packet), -- (topkey,subkey) - [String], -- usage flags - [SignatureSubpacket], -- hashed data - [Packet])] -- binding signatures - ) -getBindings pkts = (sigs,bindings) - where - (sigs,concat->bindings) = unzip $ do - let (keys,_) = partition isKey pkts - keys <- disjoint_fp keys - let (bs,sigs) = verifyBindings keys pkts - return . ((keys,sigs),) $ do - b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs - i <- map signature_issuer (signatures_over b) - i <- maybeToList i - who <- maybeToList $ find_key fingerprint (Message keys) i - let (code,claimants) = - case () of - _ | who == topkey b -> (1,[]) - _ | who == subkey b -> (2,[]) - _ -> (0,[who]) - let hashed = signatures_over b >>= hashed_subpackets - kind = guard (code==1) >> hashed >>= maybeToList . usage - return (code,(topkey b,subkey b), kind, hashed,claimants) - -resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] -resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops - where - ops = map (\u -> InducerSignature u []) us - us = filter torStyle $ Map.keys umap - torStyle str = and [ uid_topdomain parsed == "onion" - , uid_realname parsed `elem` ["","Anonymous"] - , uid_user parsed == "root" - , fmap (match . fst) (lookup (packet k) torbindings) - == Just True ] - where parsed = parseUID str - match = (==subdom) . take (fromIntegral len) - subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] - subdom = Char8.unpack subdom0 - len = T.length (uid_subdomain parsed) - torbindings = getTorKeys (map packet $ flattenTop "" True kd) - getTorKeys pub = do - xs <- groupBindings pub - (_,(top,sub),us,_,_) <- xs - guard ("tor" `elem` us) - let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub - return (top,(torhash,sub)) - - groupBindings pub = gs - where (_,bindings) = getBindings pub - bindings' = accBindings bindings - code (c,(m,s),_,_,_) = (fingerprint_material m,-c) - ownerkey (_,(a,_),_,_,_) = a - sameMaster (ownerkey->a) (ownerkey->b) - = fingerprint_material a==fingerprint_material b - gs = groupBy sameMaster (sortBy (comparing code) bindings') - - -resolveTransform (DeleteSubKey fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk - where - topk = keykey $ packet k -- key to master of key to be deleted - subk = do - (k,sub) <- Map.toList submap - guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) - return k - - --- | Load and update key files according to the specified 'KeyRingOperation'. -runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) -runKeyRing operation = do - homedir <- getHomeDir (opHome operation) - let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) - -- FIXME: try' should probably accept a list of KikiReportActions. - -- This would be useful for reporting on disk writes that have already - -- succeded prior to this termination. - try' v body = - case functorToEither v of - Left e -> return $ KikiResult e [] - Right wkun -> body wkun - try' homedir $ \(homedir,secring,pubring,grip0) -> do - let ctx = InputFileContext secring pubring - tolocks = filesToLock operation ctx - secring <- return Nothing - pubring <- return Nothing - lks <- forM tolocks $ \f -> do - lk <- dotlock_create f 0 - v <- flip (maybe $ return Nothing) lk $ \lk -> do - e <- dotlock_take lk (-1) - if e==0 then return $ Just lk - else dotlock_destroy lk >> return Nothing - return (v,f) - let (lked, map snd -> failed_locks) = partition (isJust . fst) lks - ret <- - if not $ null failed_locks - then return $ KikiResult (FailedToLock failed_locks) [] - else do - - -- merge all keyrings, PEM files, and wallets - bresult <- buildKeyDB ctx grip0 operation - try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do - - externals_ret <- initializeMissingPEMFiles operation - ctx - grip - decrypt - db - try' externals_ret $ \((db,exports),report_externals) -> do - - let rt = KeyRingRuntime - { rtPubring = homepubPath ctx - , rtSecring = homesecPath ctx - , rtGrip = grip - , rtWorkingKey = fmap packet wk - , rtKeyDB = db - , rtRingAccess = accs - , rtPassphrases = decrypt - } - - r <- performManipulations decrypt - rt - wk - (combineTransforms $ opTransforms operation) - try' r $ \(rt,report_manips) -> do - - r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) - try' r $ \report_wallets -> do - - r <- writeRingKeys operation rt unspilled report_manips - try' r $ \report_rings -> do - - r <- writePEMKeys decrypt (rtKeyDB rt) exports - try' r $ \report_pems -> do - - import_hosts <- writeHostsFiles operation ctx hs - - return $ KikiResult (KikiSuccess rt) - $ concat [ report_imports - , report_externals - , report_manips - , report_wallets - , report_rings - , report_pems ] - - forM_ lked $ \(Just lk, fname) -> dotlock_release lk - - return ret - -parseOptionFile :: FilePath -> IO [String] -parseOptionFile fname = do - xs <- fmap lines (readFile fname) - let ys = filter notComment xs - notComment ('#':_) = False - notComment cs = not (all isSpace cs) - return ys - --- | returns ( home directory --- , path to secret ring --- , path to public ring --- , fingerprint of working key --- ) -getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String)) -getHomeDir protohome = do - homedir <- envhomedir protohome - flip (maybe (return CantFindHome)) - homedir $ \homedir -> do - -- putStrLn $ "homedir = " ++show homedir - let secring = homedir ++ "/" ++ "secring.gpg" - pubring = homedir ++ "/" ++ "pubring.gpg" - -- putStrLn $ "secring = " ++ show secring - workingkey <- getWorkingKey homedir - return $ KikiSuccess (homedir,secring,pubring,workingkey) - where - envhomedir opt = do - gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home) - homed <- fmap (mfilter (/="") . Just) getHomeDirectory - let homegnupg = (++('/':(appdir home))) <$> homed - let val = (opt `mplus` gnupghome `mplus` homegnupg) - return $ val - - -- TODO: rename this to getGrip - getWorkingKey homedir = do - let o = Nothing - h = Just homedir - ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> - let optfiles = map (second ((h++"/")++)) - (maybe optfile_alts' (:[]) o') - optfile_alts' = zip (False:repeat True) (optfile_alts home) - o' = fmap (False,) o - in filterM (doesFileExist . snd) optfiles - args <- flip (maybe $ return []) ofile $ - \(forgive,fname) -> parseOptionFile fname - let config = map (topair . words) args - where topair (x:xs) = (x,xs) - return $ lookup "default-key" config >>= listToMaybe - -#if MIN_VERSION_base(4,6,0) -#else -lookupEnv :: String -> IO (Maybe String) -lookupEnv var = - handleIO_ (return Nothing) $ fmap Just (getEnv var) -#endif - -isKey :: Packet -> Bool -isKey (PublicKeyPacket {}) = True -isKey (SecretKeyPacket {}) = True -isKey _ = False - -isUserID :: Packet -> Bool -isUserID (UserIDPacket {}) = True -isUserID _ = False - -isTrust :: Packet -> Bool -isTrust (TrustPacket {}) = True -isTrust _ = False - -sigpackets :: - Monad m => - Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet -sigpackets typ hashed unhashed = return $ - signaturePacket - 4 -- version - typ -- 0x18 subkey binding sig, or 0x19 back-signature - RSA - SHA1 - hashed - unhashed - 0 -- Word16 -- Left 16 bits of the signed hash value - [] -- [MPI] - -secretToPublic :: Packet -> Packet -secretToPublic pkt@(SecretKeyPacket {}) = - PublicKeyPacket { version = version pkt - , timestamp = timestamp pkt - , key_algorithm = key_algorithm pkt - -- , ecc_curve = ecc_curve pkt - , key = let seckey = key pkt - pubs = public_key_fields (key_algorithm pkt) - in filter (\(k,v) -> k `elem` pubs) seckey - , is_subkey = is_subkey pkt - , v3_days_of_validity = Nothing - } -secretToPublic pkt = pkt - - - -slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) -slurpWIPKeys stamp "" = ([],[]) -slurpWIPKeys stamp cs = - let (b58,xs) = Char8.span (`elem` base58chars) cs - mb = decode_btc_key stamp (Char8.unpack b58) - in if L.null b58 - then let (ys,xs') = Char8.break (`elem` base58chars) cs - (ks,js) = slurpWIPKeys stamp xs' - in (ks,ys:js) - else let (ks,js) = slurpWIPKeys stamp xs - in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb - - -decode_btc_key :: - Enum timestamp => timestamp -> String -> Maybe (Word8, Message) -decode_btc_key timestamp str = do - (network_id,us) <- base58_decode str - return . (network_id,) $ Message $ do - let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer]) - {- - xy = secp256k1_G `pmul` d - x = getx xy - y = gety xy - -- y² = x³ + 7 (mod p) - y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve) - y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve) - -} - secp256k1 = ECC.getCurveByName ECC.SEC_p256k1 - ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1 - -- pub = cannonical_eckey x y - -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub - -- address = base58_encode hash - -- pubstr = concatMap (printf "%02x") $ pub - -- _ = pubstr :: String - return $ {- trace (unlines ["pub="++show pubstr - ,"add="++show address - ,"y ="++show y - ,"y' ="++show y' - ,"y''="++show y'']) -} - SecretKeyPacket - { version = 4 - , timestamp = toEnum (fromEnum timestamp) - , key_algorithm = ECDSA - , key = [ -- public fields... - ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve) - ,('l',MPI 256) - ,('x',MPI x) - ,('y',MPI y) - -- secret fields - ,('d',MPI d) - ] - , s2k_useage = 0 - , s2k = S2K 100 "" - , symmetric_algorithm = Unencrypted - , encrypted_data = "" - , is_subkey = True - } - -rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey -rsaKeyFromPacket p | isKey p = do - n <- lookup 'n' $ key p - e <- lookup 'e' $ key p - return $ RSAKey n e - -rsaKeyFromPacket _ = Nothing - - -readPacketsFromWallet :: - Maybe Packet - -> InputFile - -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -readPacketsFromWallet wk fname = do - let ctx = InputFileContext "" "" - timestamp <- getInputFileTime ctx fname - input <- readInputFileL ctx fname - let (ks,_) = slurpWIPKeys timestamp input - unless (null ks) $ do - -- decrypt wk - -- create sigs - -- return key/sig pairs - return () - return $ do - wk <- maybeToList wk - guard (not $ null ks) - let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk)) - where tag = CryptoCoins.nameFromSecretByte tagbyte - (wk,MarkerPacket,(MarkerPacket,Map.empty)) - :map prep ks - -readPacketsFromFile :: InputFileContext -> InputFile -> IO Message -readPacketsFromFile ctx fname = do - -- warn $ fname ++ ": reading..." - input <- readInputFileL ctx fname -#if MIN_VERSION_binary(0,7,0) - return $ - case decodeOrFail input of - Right (_,_,msg ) -> msg - Left (_,_,_) -> - -- FIXME - -- trace (fname++": read fail") $ - Message [] -#else - return $ decode input -#endif - --- | Get the time stamp of a signature. --- --- Warning: This function checks unhashed_subpackets if no timestamp occurs in --- the hashed section. TODO: change this? --- -signature_time :: SignatureOver -> Word32 -signature_time ov = case (if null cs then ds else cs) of - [] -> minBound - xs -> maximum xs - where - ps = signatures_over ov - ss = filter isSignaturePacket ps - cs = concatMap (concatMap creationTime . hashed_subpackets) ss - ds = concatMap (concatMap creationTime . unhashed_subpackets) ss - creationTime (SignatureCreationTimePacket t) = [t] - creationTime _ = [] - -splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t]) -splitAtMinBy comp xs = minimumBy comp' xxs - where - xxs = zip (inits xs) (tails xs) - comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs) - compM (Just a) (Just b) = comp a b - compM Nothing mb = GT - compM _ _ = LT - - - --- | Given list of subpackets, a master key, one of its subkeys and a --- list of signatures on that subkey, yields: --- --- * preceding list of signatures --- --- * The most recent valid signature made by the master key along with a --- flag that indicates whether or not all of the supplied subpackets occur in --- it or, if no valid signature from the working key is present, Nothing. --- --- * following list of signatures --- -findTag :: - [SignatureSubpacket] - -> Packet - -> Packet - -> [(MappedPacket, b)] - -> ([(MappedPacket, b)], - Maybe (Bool, (MappedPacket, b)), - [(MappedPacket, b)]) -findTag tag topk subkey subsigs = (xs',minsig,ys') - where - vs = map (\sig -> - (sig, do - sig <- Just (packet . fst $ sig) - guard (isSignaturePacket sig) - guard $ flip isSuffixOf - (fingerprint topk) - . fromMaybe "%bad%" - . signature_issuer - $ sig - listToMaybe $ - map (signature_time . verify (Message [topk])) - (signatures $ Message [topk,subkey,sig]))) - subsigs - (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs - xs' = map fst xs - ys' = map fst $ if isNothing minsig then ys else drop 1 ys - minsig = do - (sig,ov) <- listToMaybe ys - ov - let hshed = hashed_subpackets $ packet $ fst sig - return ( null $ tag \\ hshed, sig) - -mkUsage :: String -> SignatureSubpacket -mkUsage tag = NotationDataPacket - { human_readable = True - , notation_name = "usage@" - , notation_value = tag - } - -makeSig :: - (MappedPacket -> IO (KikiCondition Packet)) - -> MappedPacket - -> [Char] - -> MappedPacket - -> [SignatureSubpacket] - -> Maybe (MappedPacket, Map.Map k a) - -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction])) -makeSig doDecrypt top fname subkey_p tags mbsig = do - let wk = packet top - wkun <- doDecrypt top - try wkun $ \wkun -> do - let grip = fingerprint wk - addOrigin new_sig = - flip (maybe $ return FailedToMakeSignature) - (new_sig >>= listToMaybe . signatures_over) - $ \new_sig -> do - let mp' = mappedPacket fname new_sig - return $ KikiSuccess (mp', Map.empty) - parsedkey = [packet subkey_p] - hashed0 = KeyFlagsPacket - { certify_keys = False - , sign_data = False - , encrypt_communication = False - , encrypt_storage = False - , split_key = False - , authentication = True - , group_key = False } - : tags - -- implicitly added: - -- , SignatureCreationTimePacket (fromIntegral timestamp) - subgrip = fingerprint (head parsedkey) - - back_sig <- pgpSign (Message parsedkey) - (SubkeySignature wk - (head parsedkey) - (sigpackets 0x19 - hashed0 - [IssuerPacket subgrip])) - (if key_algorithm (head parsedkey)==ECDSA - then SHA256 - else SHA1) - subgrip - let iss = IssuerPacket (fingerprint wk) - cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig) - unhashed0 = maybe [iss] cons_iss back_sig - - new_sig <- pgpSign (Message [wkun]) - (SubkeySignature wk - (head parsedkey) - (sigpackets 0x18 - hashed0 - unhashed0)) - SHA1 - grip - let newSig = do - r <- addOrigin new_sig - return $ fmap (,[]) r - flip (maybe newSig) mbsig $ \(mp,trustmap) -> do - let sig = packet mp - isCreation (SignatureCreationTimePacket {}) = True - isCreation _ = False - isExpiration (SignatureExpirationTimePacket {}) = True - isExpiration _ = False - (cs,ps) = partition isCreation (hashed_subpackets sig) - (es,qs) = partition isExpiration ps - stamp = listToMaybe . sortBy (comparing Down) $ - map unwrap cs where unwrap (SignatureCreationTimePacket x) = x - exp = listToMaybe $ sort $ - map unwrap es where unwrap (SignatureExpirationTimePacket x) = x - expires = liftA2 (+) stamp exp - timestamp <- now - if fmap ( (< timestamp) . fromIntegral) expires == Just True then - return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] ) - else do - let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) - $ maybeToList $ do - e <- expires - return $ SignatureExpirationTimePacket (e - fromIntegral timestamp) - sig' = sig { hashed_subpackets = times ++ (qs `union` tags) } - new_sig <- pgpSign (Message [wkun]) - (SubkeySignature wk - (packet subkey_p) - [sig'] ) - SHA1 - (fingerprint wk) - newsig <- addOrigin new_sig - return $ fmap (,[]) newsig - - - -data OriginFlags = OriginFlags { - originallyPublic :: Bool, - originalNum :: Int - } - deriving Show -type OriginMap = Map.Map FilePath OriginFlags -data MappedPacket = MappedPacket - { packet :: Packet - , locations :: OriginMap - } deriving Show - -type TrustMap = Map.Map FilePath Packet -type SigAndTrust = ( MappedPacket - , TrustMap ) -- trust packets - -type KeyKey = [ByteString] -data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show - --- | This is a GPG Identity which includes a master key and all its UIDs and --- subkeys and associated signatures. -data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key - , keySigAndTrusts :: [SigAndTrust] -- sigs on main key - , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids - , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys - } deriving Show - -type KeyDB = Map.Map KeyKey KeyData - -origin :: Packet -> Int -> OriginFlags -origin p n = OriginFlags ispub n - where - ispub = case p of - SecretKeyPacket {} -> False - _ -> True - -mappedPacket :: FilePath -> Packet -> MappedPacket -mappedPacket filename p = MappedPacket - { packet = p - , locations = Map.singleton filename (origin p (-1)) - } - -mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket -mappedPacketWithHint filename p hint = MappedPacket - { packet = p - , locations = Map.singleton filename (origin p hint) - } - -keykey :: Packet -> KeyKey -keykey key = - -- Note: The key's timestamp is normally included in it's fingerprint. - -- This is undesirable for kiki because it causes the same - -- key to be imported multiple times and show as apparently - -- distinct keys with different fingerprints. - -- Thus, we will remove the timestamp. - fingerprint_material (key {timestamp=0}) -- TODO: smaller key? - -uidkey :: Packet -> String -uidkey (UserIDPacket str) = str - -merge :: KeyDB -> InputFile -> Message -> KeyDB -merge db inputfile (Message ps) = merge_ db filename qs - where - filename = resolveForReport Nothing inputfile - - qs = scanPackets filename ps - - scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] - scanPackets filename [] = [] - scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps - where - ret p = (p,Map.empty) - doit (top,sub,prev) p = - case p of - _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) - _ | isKey p && is_subkey p -> (top,p,ret p) - _ | isUserID p -> (top,p,ret p) - _ | isTrust p -> (top,sub,updateTrust top sub prev p) - _ -> (top,sub,ret p) - - updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public - updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public - updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret - - -{- -onionName :: KeyData -> (SockAddr,L.ByteString) -onionName kd = (addr,name) - where - (addr,(name:_,_)) = getHostnames kd --} -keyCompare :: String -> Packet -> Packet -> Ordering -keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT -keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT -keyCompare what a b | keykey a==keykey b = EQ -keyCompare what a b = error $ unlines ["Unable to merge "++what++":" - , fingerprint a - , PP.ppShow a - , fingerprint b - , PP.ppShow b - ] - -mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket -mergeKeyPacket what key p = - key { packet = minimumBy (keyCompare what) [packet key,packet p] - , locations = Map.union (locations key) (locations p) - } - - -merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] - -> KeyDB -merge_ db filename qs = foldl mergeit db (zip [0..] qs) - where - asMapped n p = mappedPacketWithHint filename p n - asSigAndTrust n (p,tm) = (asMapped n p,tm) - emptyUids = Map.empty - -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets - mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB - mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db - where - -- NOTE: - -- if a keyring file has both a public key packet and a secret key packet - -- for the same key, then only one of them will survive, which ever is - -- later in the file. - -- - -- This is due to the use of statements like - -- (Map.insert filename (origin p n) (locations key)) - -- - update :: Maybe KeyData -> Maybe KeyData - update v | isKey p && not (is_subkey p) - = case v of - Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty - Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p - -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p) - sigs - uids - subkeys - _ -> error . concat $ ["Unexpected master key merge error: " - ,show (fingerprint top, fingerprint p)] - update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p - = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) - update (Just (KeyData key sigs uids subkeys)) | isUserID p - = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) - subkeys - update (Just (KeyData key sigs uids subkeys)) - = case sub of - MarkerPacket -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys - UserIDPacket {} -> Just $ KeyData key - sigs - (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) - subkeys - _ | isKey sub -> Just $ KeyData key - sigs - uids - (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys) - _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1) - update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1) - - mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p - - mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey - mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) [] - mergeSubkey n p (Just (SubKey key sigs)) = Just $ - SubKey (mergeKeyPacket "subs" key $ asMapped n p) - sigs - - mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap) - mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n)) - mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m) - mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p - - whatP (a,_) = concat . take 1 . words . show $ a - - - mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust] - mergeSig n sig sigs = - let (xs,ys) = break (isSameSig sig) sigs - in if null ys - then sigs++[first (asMapped n) sig] - else let y:ys'=ys - in xs ++ (mergeSameSig n sig y : ys') - where - isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b = - a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } - isSameSig (a,_) (MappedPacket {packet=b},_) = a==b - - mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap) - mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) - | isSignaturePacket a && isSignaturePacket b = - ( m { packet = b { unhashed_subpackets = - union (unhashed_subpackets b) (unhashed_subpackets a) - } - , locations = Map.insert filename (origin a n) locs } - -- TODO: when merging items, we should delete invalidated origins - -- from the orgin map. - , tb `Map.union` ta ) - - mergeSameSig n a b = b -- trace ("discarding dup "++show a) b - - mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m) - mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty) - - mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs) - mergeSubSig n sig Nothing = error $ - "Unable to merge subkey signature: "++(words (show sig) >>= take 1) - -unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] -unsig fname isPublic (sig,trustmap) = - sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) - where - f n _ = n==fname -- && trace ("fname=n="++show n) True - asMapped n p = let m = mappedPacket fname p - in m { locations = fmap (\x->x {originalNum=n}) (locations m) } - -concatSort :: - FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a] -concatSort fname getp f = concat . sortByHint fname getp . map f - -sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] -sortByHint fname f = sortBy (comparing gethint) - where - gethint = maybe defnum originalNum . Map.lookup fname . locations . f - defnum = -1 - -flattenKeys :: Bool -> KeyDB -> Message -flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) - where - prefilter = if isPublic then id else filter isSecret - where - isSecret (_,(KeyData - (MappedPacket { packet=(SecretKeyPacket {})}) - _ - _ - _)) = True - isSecret _ = False - - -flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] -flattenTop fname ispub (KeyData key sigs uids subkeys) = - unk ispub key : - ( flattenAllUids fname ispub uids - ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) - -flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] -flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs - -unk :: Bool -> MappedPacket -> MappedPacket -unk isPublic = if isPublic then toPacket secretToPublic else id - where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} - -flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] -flattenAllUids fname ispub uids = - concatSort fname head (flattenUid fname ispub) (Map.assocs uids) - -flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] -flattenUid fname ispub (str,(sigs,om)) = - (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs - -getCrossSignedSubkeys :: Packet -> Map.Map KeyKey SubKey -> String -> [Packet] -getCrossSignedSubkeys topk subs tag = do - SubKey k sigs <- Map.elems subs - let subk = packet k - let sigs' = do - torsig <- filter (has_tag tag) $ map (packet . fst) sigs - sig <- (signatures $ Message [topk,subk,torsig]) - let v = verify (Message [topk]) sig - -- Require parent's signature - guard (not . null $ signatures_over v) - let unhashed = unhashed_subpackets torsig - subsigs = mapMaybe backsig unhashed - -- This should consist only of 0x19 values - -- subtypes = map signature_type subsigs - sig' <- signatures . Message $ [topk,subk]++subsigs - let v' = verify (Message [subk]) sig' - -- Require subkey's signature - guard . not . null $ signatures_over v' - return torsig - guard (not $ null sigs') - return subk - where - has_tag tag p = isSignaturePacket p - && or [ tag `elem` mapMaybe usage (hashed_subpackets p) - , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] - - --- | --- Returns (ip6 fingerprint address,(onion names,other host names)) --- --- Requires a validly cross-signed tor key for each onion name returned. --- (Signature checks are performed.) -getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString])) -getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames)) - where - othernames = do - mp <- flattenAllUids "" True uids - let p = packet mp - guard $ isSignaturePacket p - uh <- unhashed_subpackets p - case uh of - NotationDataPacket True "hostname@" v - -> return $ Char8.pack v - _ -> mzero - - addr = fingerdress topk - -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key? - topk = packet topmp - torkeys = getCrossSignedSubkeys topk subs "tor" - - -- subkeyPacket (SubKey k _ ) = k - onames :: [L.ByteString] - onames = map ( (<> ".onion") - . Char8.pack - . take 16 - . torhash ) - torkeys - -hasFingerDress :: KeyDB -> SockAddr -> Bool -hasFingerDress db addr | socketFamily addr/=AF_INET6 = False -hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db) - where - (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr - g' = map toUpper g - --- We return into IO in case we want to make a signature here. -setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData -setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) = - -- TODO: we are removing the origin from the UID OriginMap, - -- when we should be removing origins from the locations - -- field of the sig's MappedPacket records. - -- Call getHostnames and compare to see if no-op. - if not (pred addr) || names0 == names \\ onions - then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) - , " file: "++show (map Char8.unpack names) - , " pred: "++show (pred addr)]) -} - (return kd) - else do - -- We should be sure to remove origins so that the data is written - -- (but only if something changed). - -- Filter all hostnames present in uids - -- Write notations into first uid - {- - trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) - , " file: "++show (map Char8.unpack names) ]) $ do - -} - return $ KeyData topmp topsigs uids1 subs - where - topk = packet topmp - addr = fingerdress topk - names :: [Char8.ByteString] - names = Hosts.namesForAddress addr hosts - (_,(onions,names0)) = getHostnames kd - notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions) - isName (NotationDataPacket True "hostname@" _) = True - isName _ = False - uids0 = fmap zapIfHasName uids - fstuid = head $ do - p <- map packet $ flattenAllUids "" True uids - guard $ isUserID p - return $ uidkey p - uids1 = Map.adjust addnames fstuid uids0 - addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin - where - (ss,ts) = splitAt 1 sigs - f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm) - else (sig, tm) - where p' = (packet sig) { unhashed_subpackets=uh } - uh = unhashed_subpackets (packet sig) ++ notations - zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin - else (sigs,om) - where - (bs, sigs') = unzip $ map unhash sigs - - unhash (sig,tm) = ( not (null ns) - , ( sig { packet = p', locations = Map.empty } - , tm ) ) - where - psig = packet sig - p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps } - else psig - uh = unhashed_subpackets psig - (ns,ps) = partition isName uh - -fingerdress :: Packet -> SockAddr -fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str - where - zero = SockAddrInet 0 0 - addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk) - colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs - colons xs = xs - -backsig :: SignatureSubpacket -> Maybe Packet -backsig (EmbeddedSignaturePacket s) = Just s -backsig _ = Nothing - -socketFamily :: SockAddr -> Family -socketFamily (SockAddrInet _ _) = AF_INET -socketFamily (SockAddrInet6 {}) = AF_INET6 -socketFamily (SockAddrUnix _) = AF_UNIX - -#if ! MIN_VERSION_unix(2,7,0) -setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO () -setFdTimesHiRes (Posix.Fd fd) atime mtime = - withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> - throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times) - -data CTimeSpec = CTimeSpec Posix.EpochTime CLong -instance Storable CTimeSpec where - sizeOf _ = (16) - alignment _ = alignment (undefined :: CInt) - poke p (CTimeSpec sec nsec) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p sec - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p nsec - peek p = do - sec <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p - nsec <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p - return $ CTimeSpec sec nsec - -toCTimeSpec :: POSIXTime -> CTimeSpec -toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^(9::Int) * frac) - where - (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac') - (sec', frac') = properFraction $ toRational t - -foreign import ccall unsafe "futimens" - c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt -#endif - -onionNameForContact :: KeyKey -> KeyDB -> Maybe String -onionNameForContact kk db = do - contact <- Map.lookup kk db - let (_,(name:_,_)) = getHostnames contact - return $ Char8.unpack name diff --git a/PEM.hs b/PEM.hs deleted file mode 100644 index e07b3d4..0000000 --- a/PEM.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module PEM where - -import Data.Monoid -import qualified Data.ByteString.Lazy as LW -import qualified Data.ByteString.Lazy.Char8 as L -import Control.Monad -import Control.Applicative -import qualified Codec.Binary.Base64 as Base64 -import ScanningParser - -data PEMBlob = PEMBlob { pemType :: L.ByteString - , pemBlob :: L.ByteString - } - deriving (Eq,Show) - -pemParser mtyp = ScanningParser (maybe fndany fndtyp mtyp) pbdy - where - hdr typ = "-----BEGIN " <> typ <> "-----" - fndtyp typ bs = if bs==hdr typ then Just typ else Nothing - fndany bs = do - guard $ "-----BEGIN " `L.isPrefixOf` bs - let x0 = L.drop 11 bs - guard $ "-----" `LW.isSuffixOf` x0 - let typ = L.take (L.length x0 - 5) x0 - return typ - - pbdy typ xs = (mblob, drop 1 rs) - where - (ys,rs) = span (/="-----END " <> typ <> "-----") xs - mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta) - dta = case ys of - [] -> "" - dta_lines -> L.concat dta_lines diff --git a/ProcessUtils.hs b/ProcessUtils.hs deleted file mode 100644 index 4e3ac38..0000000 --- a/ProcessUtils.hs +++ /dev/null @@ -1,45 +0,0 @@ -module ProcessUtils - ( ExitCode(ExitFailure,ExitSuccess) - , systemEnv - ) where - -import GHC.IO.Exception ( ioException, IOErrorType(..) ) -import System.Process -import System.Posix.Signals -import System.Process.Internals (runGenProcess_,defaultSignal) -import System.Environment -import Data.Maybe ( isNothing ) -import System.IO.Error ( mkIOError, ioeSetErrorString ) -import System.Exit ( ExitCode(..) ) - - --- | systemEnv --- This is like System.Process.system except that it lets you set --- some environment variables. -systemEnv :: [(String, String)] -> String -> IO ExitCode -systemEnv _ "" = - ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command") -systemEnv vars cmd = do - env0 <- getEnvironment - let env1 = filter (isNothing . flip lookup vars . fst) env0 - env = vars ++ env1 - syncProcess "system" $ (shell cmd) {env=Just env} - where - -- This is a non-exported function from System.Process - syncProcess fun c = do - -- The POSIX version of system needs to do some manipulation of signal - -- handlers. Since we're going to be synchronously waiting for the child, - -- we want to ignore ^C in the parent, but handle it the default way - -- in the child (using SIG_DFL isn't really correct, it should be the - -- original signal handler, but the GHC RTS will have already set up - -- its own handler and we don't want to use that). - old_int <- installHandler sigINT Ignore Nothing - old_quit <- installHandler sigQUIT Ignore Nothing - (_,_,_,p) <- runGenProcess_ fun c - (Just defaultSignal) (Just defaultSignal) - r <- waitForProcess p - _ <- installHandler sigINT old_int Nothing - _ <- installHandler sigQUIT old_quit Nothing - return r - - diff --git a/ScanningParser.hs b/ScanningParser.hs deleted file mode 100644 index f99e120..0000000 --- a/ScanningParser.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} -module ScanningParser - ( ScanningParser(..) - , scanAndParse - , scanAndParse1 - ) where - -import Data.Maybe -import Data.List -import Control.Applicative -import Control.Monad -import Data.Monoid - --- | This type provides the means to parse a stream of 'tok' and extract all --- the 'obj' parses that occur. --- --- Use Functor and Monoid interfaces to combine parsers. For example, --- --- > parserAorB = fmap Left parserA <> fmap Right parserB --- -data ScanningParser tok obj = forall partial. ScanningParser - { findFirst :: tok -> Maybe partial - -- ^ If the token starts an object, returns a partial parse. - , parseBody :: partial -> [tok] -> (Maybe obj,[tok]) - -- ^ Given a partial parse and the stream of tokens that follow, attempt to - -- parse an object and return the unconsumed tokens. - } - -instance Functor (ScanningParser a) where - fmap f (ScanningParser ffst pbody) - = ScanningParser ffst (\b -> first (fmap f) . pbody b) - where - first f (x,y) = (f x, y) - - -instance Monoid (ScanningParser a b) where - mempty = ScanningParser (const Nothing) (const $ const (Nothing,[])) - mappend (ScanningParser ffstA pbdyA) - (ScanningParser ffstB pbdyB) - = ScanningParser ffst pbody - where - ffst x = mplus (Left <$> ffstA x) - (Right <$> ffstB x) - pbody (Left apart) = pbdyA apart - pbody (Right bpart) = pbdyB bpart - - --- | Apply a 'ScanningParser' to a list of tokens, yielding a list of parsed --- objects. -scanAndParse :: ScanningParser a c -> [a] -> [c] -scanAndParse psr [] = [] -scanAndParse psr@(ScanningParser ffst pbdy) ts = do - (b,xs) <- take 1 $ mapMaybe findfst' tss - let (mc,ts') = pbdy b xs - rec = scanAndParse psr ts' - maybe rec (:rec) mc - where - tss = tails ts - findfst' ts = do - x <- listToMaybe ts - b <- ffst x - return (b,drop 1 ts) - -scanAndParse1 :: ScanningParser a c -> [a] -> (Maybe c, [a]) -scanAndParse1 psr@(ScanningParser ffst pbdy) ts = - maybe (Nothing,[]) (uncurry pbdy) mb - where - mb = listToMaybe $ mapMaybe findfst' tss - tss = tails ts - findfst' ts = do - x <- listToMaybe ts - b <- ffst x - return (b,drop 1 ts) diff --git a/TimeUtil.hs b/TimeUtil.hs deleted file mode 100644 index 879bc32..0000000 --- a/TimeUtil.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE CPP #-} -module TimeUtil - ( now - , IsTime(..) - , fromTime - , toUTC - , parseRFC2822 - , printRFC2822 - , dateParser - ) where - -import Data.Time.LocalTime -import Data.Time.Format -import Data.Time.Clock -import Data.Time.Clock.POSIX -#if !MIN_VERSION_time(1,5,0) -import System.Locale (defaultTimeLocale) -#endif -import Data.String -import Control.Applicative -import Data.Maybe -import Data.Char -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy.Char8 as L -import Foreign.C.Types ( CTime(..) ) -import Data.Word ( Word32 ) - -import ScanningParser - -class IsTime a where - fromZonedTime :: ZonedTime -> a - toZonedTime :: a -> IO ZonedTime - -instance IsTime ZonedTime where - fromZonedTime x = x - toZonedTime x = return x - -instance IsTime UTCTime where - toZonedTime t = utcToLocalZonedTime t - fromZonedTime zt = zonedTimeToUTC zt - -instance IsTime Integer where - toZonedTime t = utcToLocalZonedTime utime - where - utime = posixSecondsToUTCTime (fromIntegral t) - fromZonedTime zt = round $ utcTimeToPOSIXSeconds utime - where - utime = zonedTimeToUTC zt - -printRFC2822 :: (IsString b, IsTime a) => a -> IO b -printRFC2822 tm = do - zt@(ZonedTime lt z) <- toZonedTime tm - let rfc2822 = formatTime defaultTimeLocale "%a, %0e %b %Y %T" zt ++ printZone - timeZoneStr = timeZoneOffsetString z - printZone = " " ++ timeZoneStr ++ " (" ++ fromString (show z) ++ ")" - return $ fromString $ rfc2822 - -parseRFC2822 :: IsTime b => S.ByteString -> Maybe b -parseRFC2822 str = - case mapMaybe (\f->parseTime defaultTimeLocale f str') formatRFC2822 of - [] -> Nothing - (zt:_) -> Just $ fromZonedTime zt - where - str' = S.unpack stripped - stripped = strip $ str - strip bs = bs3 - where - (_,bs0) = S.span isSpace bs - (bs1,_) = S.spanEnd isSpace bs0 - (bs2,cp) = S.spanEnd (==')') bs1 - bs3 = if S.null cp - then bs2 - else let (op,_) = S.spanEnd (/='(') bs2 - in fst $ S.spanEnd isSpace $ S.init op - formatRFC2822 = [ "%a, %e %b %Y %T GMT" - , "%a, %e %b %Y %T %z" - , "%e %b %Y %T GMT" - , "%e %b %Y %T %z" - , "%a, %e %b %Y %R GMT" - , "%a, %e %b %Y %R %z" - , "%e %b %Y %R GMT" - , "%e %b %Y %R %z" - ] - -now :: IO Integer -now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime - -dateParser :: ScanningParser L.ByteString UTCTime -dateParser = ScanningParser ffst pbdy - where - ffst bs = do - let (h,bs') = L.splitAt 6 bs - if h=="Date: " - then return $ parseRFC2822 $ foldr1 S.append $ L.toChunks bs' - else Nothing - pbdy date xs = (date,xs) - -class IsUTC a where - fromUTC :: UTCTime -> a - toUTC :: a -> UTCTime - -fromTime :: ( IsUTC a, IsUTC b ) => a -> b -fromTime = fromUTC . toUTC - -instance IsUTC UTCTime where - fromUTC = id - toUTC = id - -instance IsUTC CTime where - fromUTC utc = CTime (round $ utcTimeToPOSIXSeconds utc) - toUTC (CTime t) = posixSecondsToUTCTime (realToFrac t) - -instance IsUTC Word32 where - fromUTC utc = round $ utcTimeToPOSIXSeconds utc - toUTC t = posixSecondsToUTCTime (realToFrac t) - -{- -main = do - nowtime <- now - printRFC2822 nowtime >>= putStrLn - let test1 = "Thu, 08 May 2014 23:24:47 -0400" - test2 = " Thu, 08 May 2014 23:24:47 -0400 (EDT) " - putStrLn $ show (parseRFC2822 test1 :: Maybe Integer) - putStrLn $ show (parseRFC2822 test2 :: Maybe Integer) - return () --} diff --git a/dotlock.c b/dotlock.c deleted file mode 100644 index c111159..0000000 --- a/dotlock.c +++ /dev/null @@ -1,1303 +0,0 @@ -/* dotlock.c - dotfile locking - * Copyright (C) 1998, 2000, 2001, 2003, 2004, - * 2005, 2006, 2008, 2010, 2011 Free Software Foundation, Inc. - * - * This file is part of JNLIB, which is a subsystem of GnuPG. - * - * JNLIB is free software; you can redistribute it and/or modify it - * under the terms of either - * - * - the GNU Lesser General Public License as published by the Free - * Software Foundation; either version 3 of the License, or (at - * your option) any later version. - * - * or - * - * - the GNU General Public License as published by the Free - * Software Foundation; either version 2 of the License, or (at - * your option) any later version. - * - * or both in parallel, as here. - * - * JNLIB is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copies of the GNU General Public License - * and the GNU Lesser General Public License along with this program; - * if not, see . - * - * ALTERNATIVELY, this file may be distributed under the terms of the - * following license, in which case the provisions of this license are - * required INSTEAD OF the GNU Lesser General License or the GNU - * General Public License. If you wish to allow use of your version of - * this file only under the terms of the GNU Lesser General License or - * the GNU General Public License, and not to allow others to use your - * version of this file under the terms of the following license, - * indicate your decision by deleting this paragraph and the license - * below. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, and the entire permission notice in its entirety, - * including the disclaimer of warranties. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. The name of the author may not be used to endorse or promote - * products derived from this software without specific prior - * written permission. - * - * THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED - * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, - * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED - * OF THE POSSIBILITY OF SUCH DAMAGE. - */ - -/* - Overview: - ========= - - This module implements advisory file locking in a portable way. - Due to the problems with POSIX fcntl locking a separate lock file - is used. It would be possible to use fcntl locking on this lock - file and thus avoid the weird auto unlock bug of POSIX while still - having an unproved better performance of fcntl locking. However - there are still problems left, thus we resort to use a hardlink - which has the well defined property that a link call will fail if - the target file already exists. - - Given that hardlinks are also available on NTFS file systems since - Windows XP; it will be possible to enhance this module to use - hardlinks even on Windows and thus allow Windows and Posix clients - to use locking on the same directory. This is not yet implemented; - instead we use a lockfile on Windows along with W32 style file - locking. - - On FAT file systems hardlinks are not supported. Thus this method - does not work. Our solution is to use a O_EXCL locking instead. - Querying the type of the file system is not easy to do in a - portable way (e.g. Linux has a statfs, BSDs have a the same call - but using different structures and constants). What we do instead - is to check at runtime whether link(2) works for a specific lock - file. - - - How to use: - =========== - - At program initialization time, the module should be explicitly - initialized: - - dotlock_create (NULL, 0); - - This installs an atexit handler and may also initialize mutex etc. - It is optional for non-threaded applications. Only the first call - has an effect. This needs to be done before any extra threads are - started. - - To create a lock file (which prepares it but does not take the - lock) you do: - - dotlock_t h - - h = dotlock_create (fname, 0); - if (!h) - error ("error creating lock file: %s\n", strerror (errno)); - - It is important to handle the error. For example on a read-only - file system a lock can't be created (but is usually not needed). - FNAME is the file you want to lock; the actual lockfile is that - name with the suffix ".lock" appended. On success a handle to be - used with the other functions is returned or NULL on error. Note - that the handle shall only be used by one thread at a time. This - function creates a unique file temporary file (".#lk*") in the same - directory as FNAME and returns a handle for further operations. - The module keeps track of theses unique files so that they will be - unlinked using the atexit handler. If you don't need the lock file - anymore, you may also explicitly remove it with a call to: - - dotlock_destroy (h); - - To actually lock the file, you use: - - if (dotlock_take (h, -1)) - error ("error taking lock: %s\n", strerror (errno)); - - This function will wait until the lock is acquired. If an - unexpected error occurs if will return non-zero and set ERRNO. If - you pass (0) instead of (-1) the function does not wait in case the - file is already locked but returns -1 and sets ERRNO to EACCES. - Any other positive value for the second parameter is considered a - timeout valuie in milliseconds. - - To release the lock you call: - - if (dotlock_release (h)) - error ("error releasing lock: %s\n", strerror (errno)); - - or, if the lock file is not anymore needed, you may just call - dotlock_destroy. However dotlock_release does some extra checks - before releasing the lock and prints diagnostics to help detecting - bugs. - - If you want to explicitly destroy all lock files you may call - - dotlock_remove_lockfiles (); - - which is the core of the installed atexit handler. In case your - application wants to disable locking completely it may call - - disable_locking () - - before any locks are created. - - There are two convenience functions to store an integer (e.g. a - file descriptor) value with the handle: - - void dotlock_set_fd (dotlock_t h, int fd); - int dotlock_get_fd (dotlock_t h); - - If nothing has been stored dotlock_get_fd returns -1. - - - - How to build: - ============= - - This module was originally developed for GnuPG but later changed to - allow its use without any GnuPG dependency. If you want to use it - with you application you may simply use it and it should figure out - most things automagically. - - You may use the common config.h file to pass macros, but take care - to pass -DHAVE_CONFIG_H to the compiler. Macros used by this - module are: - - DOTLOCK_USE_PTHREAD - Define if POSIX threads are in use. - - DOTLOCK_GLIB_LOGGING - Define this to use Glib logging functions. - - DOTLOCK_EXT_SYM_PREFIX - Prefix all external symbols with the - string to which this macro evaluates. - - GNUPG_MAJOR_VERSION - Defined when used by GnuPG. - - HAVE_DOSISH_SYSTEM - Defined for Windows etc. Will be - automatically defined if a the target is - Windows. - - HAVE_POSIX_SYSTEM - Internally defined to !HAVE_DOSISH_SYSTEM. - - HAVE_SIGNAL_H - Should be defined on Posix systems. If config.h - is not used defaults to defined. - - DIRSEP_C - Separation character for file name parts. - Usually not redefined. - - EXTSEP_S - Separation string for file name suffixes. - Usually not redefined. - - HAVE_W32CE_SYSTEM - Currently only used by GnuPG. - - Note that there is a test program t-dotlock which has compile - instructions at its end. At least for SMBFS and CIFS it is - important that 64 bit versions of stat are used; most programming - environments do this these days, just in case you want to compile - it on the command line, remember to pass -D_FILE_OFFSET_BITS=64 - - - Bugs: - ===== - - On Windows this module is not yet thread-safe. - - - Miscellaneous notes: - ==================== - - On hardlinks: - - Hardlinks are supported under Windows with NTFS since XP/Server2003. - - In Linux 2.6.33 both SMBFS and CIFS seem to support hardlinks. - - NFS supports hard links. But there are solvable problems. - - FAT does not support links - - On the file locking API: - - CIFS on Linux 2.6.33 supports several locking methods. - SMBFS seems not to support locking. No closer checks done. - - NFS supports Posix locks. flock is emulated in the server. - However there are a couple of problems; see below. - - FAT does not support locks. - - An advantage of fcntl locking is that R/W locks can be - implemented which is not easy with a straight lock file. - - On O_EXCL: - - Does not work reliable on NFS - - Should work on CIFS and SMBFS but how can we delete lockfiles? - - On NFS problems: - - Locks vanish if the server crashes and reboots. - - Client crashes keep the lock in the server until the client - re-connects. - - Communication problems may return unreliable error codes. The - MUA Postfix's workaround is to compare the link count after - seeing an error for link. However that gives a race. If using a - unique file to link to a lockfile and using stat to check the - link count instead of looking at the error return of link(2) is - the best solution. - - O_EXCL seems to have a race and may re-create a file anyway. - -*/ - -#ifdef HAVE_CONFIG_H -# include -#endif - -/* Some quick replacements for stuff we usually expect to be defined - in config.h. Define HAVE_POSIX_SYSTEM for better readability. */ -#if !defined (HAVE_DOSISH_SYSTEM) && defined(_WIN32) -# define HAVE_DOSISH_SYSTEM 1 -#endif -#if !defined (HAVE_DOSISH_SYSTEM) && !defined (HAVE_POSIX_SYSTEM) -# define HAVE_POSIX_SYSTEM 1 -#endif - -/* With no config.h assume that we have sitgnal.h. */ -#if !defined (HAVE_CONFIG_H) && defined (HAVE_POSIX_SYSTEM) -# define HAVE_SIGNAL_H 1 -#endif - -/* Standard headers. */ -#include -#include -#include -#include -#include -#include -#include -#ifdef HAVE_DOSISH_SYSTEM -# define WIN32_LEAN_AND_MEAN /* We only need the OS core stuff. */ -# include -#else -# include -# include -# include -#endif -#include -#include -#include -#include -#ifdef HAVE_SIGNAL_H -# include -#endif -#ifdef DOTLOCK_USE_PTHREAD -# include -#endif - -#ifdef DOTLOCK_GLIB_LOGGING -# include -#endif - -#ifdef GNUPG_MAJOR_VERSION -# include "libjnlib-config.h" -#endif -#ifdef HAVE_W32CE_SYSTEM -# include "utf8conv.h" /* WindowsCE requires filename conversion. */ -#endif - -#include "dotlock.h" - - -/* Define constants for file name construction. */ -#if !defined(DIRSEP_C) && !defined(EXTSEP_S) -# ifdef HAVE_DOSISH_SYSTEM -# define DIRSEP_C '\\' -# define EXTSEP_S "." -#else -# define DIRSEP_C '/' -# define EXTSEP_S "." -# endif -#endif - -/* In GnuPG we use wrappers around the malloc fucntions. If they are - not defined we assume that this code is used outside of GnuPG and - fall back to the regular malloc functions. */ -#ifndef jnlib_malloc -# define jnlib_malloc(a) malloc ((a)) -# define jnlib_calloc(a,b) calloc ((a), (b)) -# define jnlib_free(a) free ((a)) -#endif - -/* Wrapper to set ERRNO. */ -#ifndef jnlib_set_errno -# ifdef HAVE_W32CE_SYSTEM -# define jnlib_set_errno(e) gpg_err_set_errno ((e)) -# else -# define jnlib_set_errno(e) do { errno = (e); } while (0) -# endif -#endif - -/* Gettext macro replacement. */ -#ifndef _ -# define _(a) (a) -#endif - -#ifdef GNUPG_MAJOR_VERSION -# define my_info_0(a) log_info ((a)) -# define my_info_1(a,b) log_info ((a), (b)) -# define my_info_2(a,b,c) log_info ((a), (b), (c)) -# define my_info_3(a,b,c,d) log_info ((a), (b), (c), (d)) -# define my_error_0(a) log_error ((a)) -# define my_error_1(a,b) log_error ((a), (b)) -# define my_error_2(a,b,c) log_error ((a), (b), (c)) -# define my_debug_1(a,b) log_debug ((a), (b)) -# define my_fatal_0(a) log_fatal ((a)) -#elif defined (DOTLOCK_GLIB_LOGGING) -# define my_info_0(a) g_message ((a)) -# define my_info_1(a,b) g_message ((a), (b)) -# define my_info_2(a,b,c) g_message ((a), (b), (c)) -# define my_info_3(a,b,c,d) g_message ((a), (b), (c), (d)) -# define my_error_0(a) g_warning ((a)) -# define my_error_1(a,b) g_warning ((a), (b)) -# define my_error_2(a,b,c) g_warning ((a), (b), (c)) -# define my_debug_1(a,b) g_debug ((a), (b)) -# define my_fatal_0(a) g_error ((a)) -#else -# define my_info_0(a) fprintf (stderr, (a)) -# define my_info_1(a,b) fprintf (stderr, (a), (b)) -# define my_info_2(a,b,c) fprintf (stderr, (a), (b), (c)) -# define my_info_3(a,b,c,d) fprintf (stderr, (a), (b), (c), (d)) -# define my_error_0(a) fprintf (stderr, (a)) -# define my_error_1(a,b) fprintf (stderr, (a), (b)) -# define my_error_2(a,b,c) fprintf (stderr, (a), (b), (c)) -# define my_debug_1(a,b) fprintf (stderr, (a), (b)) -# define my_fatal_0(a) do { fprintf (stderr,(a)); fflush (stderr); \ - abort (); } while (0) -#endif - - - - - -/* The object describing a lock. */ -struct dotlock_handle -{ - struct dotlock_handle *next; - char *lockname; /* Name of the actual lockfile. */ - unsigned int locked:1; /* Lock status. */ - unsigned int disable:1; /* If true, locking is disabled. */ - unsigned int use_o_excl:1; /* Use open (O_EXCL) for locking. */ - - int extra_fd; /* A place for the caller to store an FD. */ - -#ifdef HAVE_DOSISH_SYSTEM - HANDLE lockhd; /* The W32 handle of the lock file. */ -#else /*!HAVE_DOSISH_SYSTEM */ - char *tname; /* Name of the lockfile template. */ - size_t nodename_off; /* Offset in TNAME of the nodename part. */ - size_t nodename_len; /* Length of the nodename part. */ -#endif /*!HAVE_DOSISH_SYSTEM */ -}; - - -/* A list of of all lock handles. The volatile attribute might help - if used in an atexit handler. */ -static volatile dotlock_t all_lockfiles; -#ifdef DOTLOCK_USE_PTHREAD -static pthread_mutex_t all_lockfiles_mutex = PTHREAD_MUTEX_INITIALIZER; -# define LOCK_all_lockfiles() do { \ - if (pthread_mutex_lock (&all_lockfiles_mutex)) \ - my_fatal_0 ("locking all_lockfiles_mutex failed\n"); \ - } while (0) -# define UNLOCK_all_lockfiles() do { \ - if (pthread_mutex_unlock (&all_lockfiles_mutex)) \ - my_fatal_0 ("unlocking all_lockfiles_mutex failed\n"); \ - } while (0) -#else /*!DOTLOCK_USE_PTHREAD*/ -# define LOCK_all_lockfiles() do { } while (0) -# define UNLOCK_all_lockfiles() do { } while (0) -#endif /*!DOTLOCK_USE_PTHREAD*/ - -/* If this has the value true all locking is disabled. */ -static int never_lock; - - - - - -/* Entirely disable all locking. This function should be called - before any locking is done. It may be called right at startup of - the process as it only sets a global value. */ -void -dotlock_disable (void) -{ - never_lock = 1; -} - - -#ifdef HAVE_POSIX_SYSTEM -static int -maybe_deadlock (dotlock_t h) -{ - dotlock_t r; - int res = 0; - - LOCK_all_lockfiles (); - for (r=all_lockfiles; r; r = r->next) - { - if ( r != h && r->locked ) - { - res = 1; - break; - } - } - UNLOCK_all_lockfiles (); - return res; -} -#endif /*HAVE_POSIX_SYSTEM*/ - - -/* Read the lock file and return the pid, returns -1 on error. True - will be stored in the integer at address SAME_NODE if the lock file - has been created on the same node. */ -#ifdef HAVE_POSIX_SYSTEM -static int -read_lockfile (dotlock_t h, int *same_node ) -{ - char buffer_space[10+1+70+1]; /* 70 is just an estimated value; node - names are usually shorter. */ - int fd; - int pid = -1; - char *buffer, *p; - size_t expected_len; - int res, nread; - - *same_node = 0; - expected_len = 10 + 1 + h->nodename_len + 1; - if ( expected_len >= sizeof buffer_space) - { - buffer = jnlib_malloc (expected_len); - if (!buffer) - return -1; - } - else - buffer = buffer_space; - - if ( (fd = open (h->lockname, O_RDONLY)) == -1 ) - { - int e = errno; - my_info_2 ("error opening lockfile '%s': %s\n", - h->lockname, strerror(errno) ); - if (buffer != buffer_space) - jnlib_free (buffer); - jnlib_set_errno (e); /* Need to return ERRNO here. */ - return -1; - } - - p = buffer; - nread = 0; - do - { - res = read (fd, p, expected_len - nread); - if (res == -1 && errno == EINTR) - continue; - if (res < 0) - { - my_info_1 ("error reading lockfile '%s'\n", h->lockname ); - close (fd); - if (buffer != buffer_space) - jnlib_free (buffer); - jnlib_set_errno (0); /* Do not return an inappropriate ERRNO. */ - return -1; - } - p += res; - nread += res; - } - while (res && nread != expected_len); - close(fd); - - if (nread < 11) - { - my_info_1 ("invalid size of lockfile '%s'\n", h->lockname); - if (buffer != buffer_space) - jnlib_free (buffer); - jnlib_set_errno (0); /* Better don't return an inappropriate ERRNO. */ - return -1; - } - - if (buffer[10] != '\n' - || (buffer[10] = 0, pid = atoi (buffer)) == -1 - || !pid ) - { - my_error_2 ("invalid pid %d in lockfile '%s'\n", pid, h->lockname); - if (buffer != buffer_space) - jnlib_free (buffer); - jnlib_set_errno (0); - return -1; - } - - if (nread == expected_len - && !memcmp (h->tname+h->nodename_off, buffer+11, h->nodename_len) - && buffer[11+h->nodename_len] == '\n') - *same_node = 1; - - if (buffer != buffer_space) - jnlib_free (buffer); - return pid; -} -#endif /*HAVE_POSIX_SYSTEM */ - - -/* Check whether the file system which stores TNAME supports - hardlinks. Instead of using the non-portable statsfs call which - differs between various Unix versions, we do a runtime test. - Returns: 0 supports hardlinks; 1 no hardlink support, -1 unknown - (test error). */ -#ifdef HAVE_POSIX_SYSTEM -static int -use_hardlinks_p (const char *tname) -{ - char *lname; - struct stat sb; - unsigned int nlink; - int res; - - if (stat (tname, &sb)) - return -1; - nlink = (unsigned int)sb.st_nlink; - - lname = jnlib_malloc (strlen (tname) + 1 + 1); - if (!lname) - return -1; - strcpy (lname, tname); - strcat (lname, "x"); - - /* We ignore the return value of link() because it is unreliable. */ - (void) link (tname, lname); - - if (stat (tname, &sb)) - res = -1; /* Ooops. */ - else if (sb.st_nlink == nlink + 1) - res = 0; /* Yeah, hardlinks are supported. */ - else - res = 1; /* No hardlink support. */ - - unlink (lname); - jnlib_free (lname); - return res; -} -#endif /*HAVE_POSIX_SYSTEM */ - - - -#ifdef HAVE_POSIX_SYSTEM -/* Locking core for Unix. It used a temporary file and the link - system call to make locking an atomic operation. */ -static dotlock_t -dotlock_create_unix (dotlock_t h, const char *file_to_lock) -{ - int fd = -1; - char pidstr[16]; - const char *nodename; - const char *dirpart; - int dirpartlen; - struct utsname utsbuf; - size_t tnamelen; - - snprintf (pidstr, sizeof pidstr, "%10d\n", (int)getpid() ); - - /* Create a temporary file. */ - if ( uname ( &utsbuf ) ) - nodename = "unknown"; - else - nodename = utsbuf.nodename; - - if ( !(dirpart = strrchr (file_to_lock, DIRSEP_C)) ) - { - dirpart = EXTSEP_S; - dirpartlen = 1; - } - else - { - dirpartlen = dirpart - file_to_lock; - dirpart = file_to_lock; - } - - LOCK_all_lockfiles (); - h->next = all_lockfiles; - all_lockfiles = h; - - tnamelen = dirpartlen + 6 + 30 + strlen(nodename) + 10 + 1; - h->tname = jnlib_malloc (tnamelen + 1); - if (!h->tname) - { - all_lockfiles = h->next; - UNLOCK_all_lockfiles (); - jnlib_free (h); - return NULL; - } - h->nodename_len = strlen (nodename); - - snprintf (h->tname, tnamelen, "%.*s/.#lk%p.", dirpartlen, dirpart, h ); - h->nodename_off = strlen (h->tname); - snprintf (h->tname+h->nodename_off, tnamelen - h->nodename_off, - "%s.%d", nodename, (int)getpid ()); - - do - { - jnlib_set_errno (0); - fd = open (h->tname, O_WRONLY|O_CREAT|O_EXCL, - S_IRUSR|S_IRGRP|S_IROTH|S_IWUSR ); - } - while (fd == -1 && errno == EINTR); - - if ( fd == -1 ) - { - all_lockfiles = h->next; - UNLOCK_all_lockfiles (); - my_error_2 (_("failed to create temporary file '%s': %s\n"), - h->tname, strerror(errno)); - jnlib_free (h->tname); - jnlib_free (h); - return NULL; - } - if ( write (fd, pidstr, 11 ) != 11 ) - goto write_failed; - if ( write (fd, nodename, strlen (nodename) ) != strlen (nodename) ) - goto write_failed; - if ( write (fd, "\n", 1 ) != 1 ) - goto write_failed; - if ( close (fd) ) - goto write_failed; - - /* Check whether we support hard links. */ - switch (use_hardlinks_p (h->tname)) - { - case 0: /* Yes. */ - break; - case 1: /* No. */ - unlink (h->tname); - h->use_o_excl = 1; - break; - default: - my_error_2 ("can't check whether hardlinks are supported for '%s': %s\n", - h->tname, strerror(errno)); - goto write_failed; - } - - h->lockname = jnlib_malloc (strlen (file_to_lock) + 6 ); - if (!h->lockname) - { - all_lockfiles = h->next; - UNLOCK_all_lockfiles (); - unlink (h->tname); - jnlib_free (h->tname); - jnlib_free (h); - return NULL; - } - strcpy (stpcpy (h->lockname, file_to_lock), EXTSEP_S "lock"); - UNLOCK_all_lockfiles (); - if (h->use_o_excl) - my_debug_1 ("locking for '%s' done via O_EXCL\n", h->lockname); - - return h; - - write_failed: - all_lockfiles = h->next; - UNLOCK_all_lockfiles (); - my_error_2 (_("error writing to '%s': %s\n"), h->tname, strerror (errno)); - close (fd); - unlink (h->tname); - jnlib_free (h->tname); - jnlib_free (h); - return NULL; -} -#endif /*HAVE_POSIX_SYSTEM*/ - - -#ifdef HAVE_DOSISH_SYSTEM -/* Locking core for Windows. This version does not need a temporary - file but uses the plain lock file along with record locking. We - create this file here so that we later only need to do the file - locking. For error reporting it is useful to keep the name of the - file in the handle. */ -static dotlock_t -dotlock_create_w32 (dotlock_t h, const char *file_to_lock) -{ - LOCK_all_lockfiles (); - h->next = all_lockfiles; - all_lockfiles = h; - - h->lockname = jnlib_malloc ( strlen (file_to_lock) + 6 ); - if (!h->lockname) - { - all_lockfiles = h->next; - UNLOCK_all_lockfiles (); - jnlib_free (h); - return NULL; - } - strcpy (stpcpy(h->lockname, file_to_lock), EXTSEP_S "lock"); - - /* If would be nice if we would use the FILE_FLAG_DELETE_ON_CLOSE - along with FILE_SHARE_DELETE but that does not work due to a race - condition: Despite the OPEN_ALWAYS flag CreateFile may return an - error and we can't reliable create/open the lock file unless we - would wait here until it works - however there are other valid - reasons why a lock file can't be created and thus the process - would not stop as expected but spin until Windows crashes. Our - solution is to keep the lock file open; that does not harm. */ - { -#ifdef HAVE_W32CE_SYSTEM - wchar_t *wname = utf8_to_wchar (h->lockname); - - if (wname) - h->lockhd = CreateFile (wname, - GENERIC_READ|GENERIC_WRITE, - FILE_SHARE_READ|FILE_SHARE_WRITE, - NULL, OPEN_ALWAYS, 0, NULL); - else - h->lockhd = INVALID_HANDLE_VALUE; - jnlib_free (wname); -#else - h->lockhd = CreateFile (h->lockname, - GENERIC_READ|GENERIC_WRITE, - FILE_SHARE_READ|FILE_SHARE_WRITE, - NULL, OPEN_ALWAYS, 0, NULL); -#endif - } - if (h->lockhd == INVALID_HANDLE_VALUE) - { - all_lockfiles = h->next; - UNLOCK_all_lockfiles (); - my_error_2 (_("can't create '%s': %s\n"), h->lockname, w32_strerror (-1)); - jnlib_free (h->lockname); - jnlib_free (h); - return NULL; - } - return h; -} -#endif /*HAVE_DOSISH_SYSTEM*/ - - -/* Create a lockfile for a file name FILE_TO_LOCK and returns an - object of type dotlock_t which may be used later to actually acquire - the lock. A cleanup routine gets installed to cleanup left over - locks or other files used internally by the lock mechanism. - - Calling this function with NULL does only install the atexit - handler and may thus be used to assure that the cleanup is called - after all other atexit handlers. - - This function creates a lock file in the same directory as - FILE_TO_LOCK using that name and a suffix of ".lock". Note that on - POSIX systems a temporary file ".#lk..pid[.threadid] is - used. - - FLAGS must be 0. - - The function returns an new handle which needs to be released using - destroy_dotlock but gets also released at the termination of the - process. On error NULL is returned. - */ - -dotlock_t -dotlock_create (const char *file_to_lock, unsigned int flags) -{ - static int initialized; - dotlock_t h; - - if ( !initialized ) - { - atexit (dotlock_remove_lockfiles); - initialized = 1; - } - - if ( !file_to_lock ) - return NULL; /* Only initialization was requested. */ - - if (flags) - { - jnlib_set_errno (EINVAL); - return NULL; - } - - h = jnlib_calloc (1, sizeof *h); - if (!h) - return NULL; - h->extra_fd = -1; - - if (never_lock) - { - h->disable = 1; - LOCK_all_lockfiles (); - h->next = all_lockfiles; - all_lockfiles = h; - UNLOCK_all_lockfiles (); - return h; - } - -#ifdef HAVE_DOSISH_SYSTEM - return dotlock_create_w32 (h, file_to_lock); -#else /*!HAVE_DOSISH_SYSTEM */ - return dotlock_create_unix (h, file_to_lock); -#endif /*!HAVE_DOSISH_SYSTEM*/ -} - - - -/* Convenience function to store a file descriptor (or any any other - integer value) in the context of handle H. */ -void -dotlock_set_fd (dotlock_t h, int fd) -{ - h->extra_fd = fd; -} - -/* Convenience function to retrieve a file descriptor (or any any other - integer value) stored in the context of handle H. */ -int -dotlock_get_fd (dotlock_t h) -{ - return h->extra_fd; -} - - - -#ifdef HAVE_POSIX_SYSTEM -/* Unix specific code of destroy_dotlock. */ -static void -dotlock_destroy_unix (dotlock_t h) -{ - if (h->locked && h->lockname) - unlink (h->lockname); - if (h->tname && !h->use_o_excl) - unlink (h->tname); - jnlib_free (h->tname); -} -#endif /*HAVE_POSIX_SYSTEM*/ - - -#ifdef HAVE_DOSISH_SYSTEM -/* Windows specific code of destroy_dotlock. */ -static void -dotlock_destroy_w32 (dotlock_t h) -{ - if (h->locked) - { - OVERLAPPED ovl; - - memset (&ovl, 0, sizeof ovl); - UnlockFileEx (h->lockhd, 0, 1, 0, &ovl); - } - CloseHandle (h->lockhd); -} -#endif /*HAVE_DOSISH_SYSTEM*/ - - -/* Destroy the locck handle H and release the lock. */ -void -dotlock_destroy (dotlock_t h) -{ - dotlock_t hprev, htmp; - - if ( !h ) - return; - - /* First remove the handle from our global list of all locks. */ - LOCK_all_lockfiles (); - for (hprev=NULL, htmp=all_lockfiles; htmp; hprev=htmp, htmp=htmp->next) - if (htmp == h) - { - if (hprev) - hprev->next = htmp->next; - else - all_lockfiles = htmp->next; - h->next = NULL; - break; - } - UNLOCK_all_lockfiles (); - - /* Then destroy the lock. */ - if (!h->disable) - { -#ifdef HAVE_DOSISH_SYSTEM - dotlock_destroy_w32 (h); -#else /* !HAVE_DOSISH_SYSTEM */ - dotlock_destroy_unix (h); -#endif /* HAVE_DOSISH_SYSTEM */ - jnlib_free (h->lockname); - } - jnlib_free(h); -} - - - -#ifdef HAVE_POSIX_SYSTEM -/* Unix specific code of make_dotlock. Returns 0 on success and -1 on - error. */ -static int -dotlock_take_unix (dotlock_t h, long timeout) -{ - int wtime = 0; - int sumtime = 0; - int pid; - int lastpid = -1; - int ownerchanged; - const char *maybe_dead=""; - int same_node; - - again: - if (h->use_o_excl) - { - /* No hardlink support - use open(O_EXCL). */ - int fd; - - do - { - jnlib_set_errno (0); - fd = open (h->lockname, O_WRONLY|O_CREAT|O_EXCL, - S_IRUSR|S_IRGRP|S_IROTH|S_IWUSR ); - } - while (fd == -1 && errno == EINTR); - - if (fd == -1 && errno == EEXIST) - ; /* Lock held by another process. */ - else if (fd == -1) - { - my_error_2 ("lock not made: open(O_EXCL) of '%s' failed: %s\n", - h->lockname, strerror (errno)); - return -1; - } - else - { - char pidstr[16]; - - snprintf (pidstr, sizeof pidstr, "%10d\n", (int)getpid()); - if (write (fd, pidstr, 11 ) == 11 - && write (fd, h->tname + h->nodename_off,h->nodename_len) - == h->nodename_len - && write (fd, "\n", 1) == 1 - && !close (fd)) - { - h->locked = 1; - return 0; - } - /* Write error. */ - my_error_2 ("lock not made: writing to '%s' failed: %s\n", - h->lockname, strerror (errno)); - close (fd); - unlink (h->lockname); - return -1; - } - } - else /* Standard method: Use hardlinks. */ - { - struct stat sb; - - /* We ignore the return value of link() because it is unreliable. */ - (void) link (h->tname, h->lockname); - - if (stat (h->tname, &sb)) - { - my_error_1 ("lock not made: Oops: stat of tmp file failed: %s\n", - strerror (errno)); - /* In theory this might be a severe error: It is possible - that link succeeded but stat failed due to changed - permissions. We can't do anything about it, though. */ - return -1; - } - - if (sb.st_nlink == 2) - { - h->locked = 1; - return 0; /* Okay. */ - } - } - - /* Check for stale lock files. */ - if ( (pid = read_lockfile (h, &same_node)) == -1 ) - { - if ( errno != ENOENT ) - { - my_info_0 ("cannot read lockfile\n"); - return -1; - } - my_info_0 ("lockfile disappeared\n"); - goto again; - } - else if ( pid == getpid() && same_node ) - { - my_info_0 ("Oops: lock already held by us\n"); - h->locked = 1; - return 0; /* okay */ - } - else if ( same_node && kill (pid, 0) && errno == ESRCH ) - { - /* Note: It is unlikley that we get a race here unless a pid is - reused too fast or a new process with the same pid as the one - of the stale file tries to lock right at the same time as we. */ - my_info_1 (_("removing stale lockfile (created by %d)\n"), pid); - unlink (h->lockname); - goto again; - } - - if (lastpid == -1) - lastpid = pid; - ownerchanged = (pid != lastpid); - - if (timeout) - { - struct timeval tv; - - /* Wait until lock has been released. We use increasing retry - intervals of 50ms, 100ms, 200ms, 400ms, 800ms, 2s, 4s and 8s - but reset it if the lock owner meanwhile changed. */ - if (!wtime || ownerchanged) - wtime = 50; - else if (wtime < 800) - wtime *= 2; - else if (wtime == 800) - wtime = 2000; - else if (wtime < 8000) - wtime *= 2; - - if (timeout > 0) - { - if (wtime > timeout) - wtime = timeout; - timeout -= wtime; - } - - sumtime += wtime; - if (sumtime >= 1500) - { - sumtime = 0; - my_info_3 (_("waiting for lock (held by %d%s) %s...\n"), - pid, maybe_dead, maybe_deadlock(h)? _("(deadlock?) "):""); - } - - - tv.tv_sec = wtime / 1000; - tv.tv_usec = (wtime % 1000) * 1000; - select (0, NULL, NULL, NULL, &tv); - goto again; - } - - jnlib_set_errno (EACCES); - return -1; -} -#endif /*HAVE_POSIX_SYSTEM*/ - - -#ifdef HAVE_DOSISH_SYSTEM -/* Windows specific code of make_dotlock. Returns 0 on success and -1 on - error. */ -static int -dotlock_take_w32 (dotlock_t h, long timeout) -{ - int wtime = 0; - int w32err; - OVERLAPPED ovl; - - again: - /* Lock one byte at offset 0. The offset is given by OVL. */ - memset (&ovl, 0, sizeof ovl); - if (LockFileEx (h->lockhd, (LOCKFILE_EXCLUSIVE_LOCK - | LOCKFILE_FAIL_IMMEDIATELY), 0, 1, 0, &ovl)) - { - h->locked = 1; - return 0; /* okay */ - } - - w32err = GetLastError (); - if (w32err != ERROR_LOCK_VIOLATION) - { - my_error_2 (_("lock '%s' not made: %s\n"), - h->lockname, w32_strerror (w32err)); - return -1; - } - - if (timeout) - { - /* Wait until lock has been released. We use retry intervals of - 50ms, 100ms, 200ms, 400ms, 800ms, 2s, 4s and 8s. */ - if (!wtime) - wtime = 50; - else if (wtime < 800) - wtime *= 2; - else if (wtime == 800) - wtime = 2000; - else if (wtime < 8000) - wtime *= 2; - - if (timeout > 0) - { - if (wtime > timeout) - wtime = timeout; - timeout -= wtime; - } - - if (wtime >= 800) - my_info_1 (_("waiting for lock %s...\n"), h->lockname); - - Sleep (wtime); - goto again; - } - - return -1; -} -#endif /*HAVE_DOSISH_SYSTEM*/ - - -/* Take a lock on H. A value of 0 for TIMEOUT returns immediately if - the lock can't be taked, -1 waits forever (hopefully not), other - values wait for TIMEOUT milliseconds. Returns: 0 on success */ -int -dotlock_take (dotlock_t h, long timeout) -{ - int ret; - - if ( h->disable ) - return 0; /* Locks are completely disabled. Return success. */ - - if ( h->locked ) - { - my_debug_1 ("Oops, '%s' is already locked\n", h->lockname); - return 0; - } - -#ifdef HAVE_DOSISH_SYSTEM - ret = dotlock_take_w32 (h, timeout); -#else /*!HAVE_DOSISH_SYSTEM*/ - ret = dotlock_take_unix (h, timeout); -#endif /*!HAVE_DOSISH_SYSTEM*/ - - return ret; -} - - - -#ifdef HAVE_POSIX_SYSTEM -/* Unix specific code of release_dotlock. */ -static int -dotlock_release_unix (dotlock_t h) -{ - int pid, same_node; - - pid = read_lockfile (h, &same_node); - if ( pid == -1 ) - { - my_error_0 ("release_dotlock: lockfile error\n"); - return -1; - } - if ( pid != getpid() || !same_node ) - { - my_error_1 ("release_dotlock: not our lock (pid=%d)\n", pid); - return -1; - } - - if ( unlink( h->lockname ) ) - { - my_error_1 ("release_dotlock: error removing lockfile '%s'\n", - h->lockname); - return -1; - } - /* Fixme: As an extra check we could check whether the link count is - now really at 1. */ - return 0; -} -#endif /*HAVE_POSIX_SYSTEM */ - - -#ifdef HAVE_DOSISH_SYSTEM -/* Windows specific code of release_dotlock. */ -static int -dotlock_release_w32 (dotlock_t h) -{ - OVERLAPPED ovl; - - memset (&ovl, 0, sizeof ovl); - if (!UnlockFileEx (h->lockhd, 0, 1, 0, &ovl)) - { - my_error_2 ("release_dotlock: error removing lockfile '%s': %s\n", - h->lockname, w32_strerror (-1)); - return -1; - } - - return 0; -} -#endif /*HAVE_DOSISH_SYSTEM */ - - -/* Release a lock. Returns 0 on success. */ -int -dotlock_release (dotlock_t h) -{ - int ret; - - /* To avoid atexit race conditions we first check whether there are - any locks left. It might happen that another atexit handler - tries to release the lock while the atexit handler of this module - already ran and thus H is undefined. */ - LOCK_all_lockfiles (); - ret = !all_lockfiles; - UNLOCK_all_lockfiles (); - if (ret) - return 0; - - if ( h->disable ) - return 0; - - if ( !h->locked ) - { - my_debug_1 ("Oops, '%s' is not locked\n", h->lockname); - return 0; - } - -#ifdef HAVE_DOSISH_SYSTEM - ret = dotlock_release_w32 (h); -#else - ret = dotlock_release_unix (h); -#endif - - if (!ret) - h->locked = 0; - return ret; -} - - - -/* Remove all lockfiles. This is called by the atexit handler - installed by this module but may also be called by other - termination handlers. */ -void -dotlock_remove_lockfiles (void) -{ - dotlock_t h, h2; - - /* First set the lockfiles list to NULL so that for example - dotlock_release is ware that this fucntion is currently - running. */ - LOCK_all_lockfiles (); - h = all_lockfiles; - all_lockfiles = NULL; - UNLOCK_all_lockfiles (); - - while ( h ) - { - h2 = h->next; - dotlock_destroy (h); - h = h2; - } -} diff --git a/dotlock.h b/dotlock.h deleted file mode 100644 index 3fb9bcb..0000000 --- a/dotlock.h +++ /dev/null @@ -1,112 +0,0 @@ -/* dotlock.h - dotfile locking declarations - * Copyright (C) 2000, 2001, 2006, 2011 Free Software Foundation, Inc. - * - * This file is part of JNLIB, which is a subsystem of GnuPG. - * - * JNLIB is free software; you can redistribute it and/or modify it - * under the terms of either - * - * - the GNU Lesser General Public License as published by the Free - * Software Foundation; either version 3 of the License, or (at - * your option) any later version. - * - * or - * - * - the GNU General Public License as published by the Free - * Software Foundation; either version 2 of the License, or (at - * your option) any later version. - * - * or both in parallel, as here. - * - * JNLIB is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copies of the GNU General Public License - * and the GNU Lesser General Public License along with this program; - * if not, see . - * - * ALTERNATIVELY, this file may be distributed under the terms of the - * following license, in which case the provisions of this license are - * required INSTEAD OF the GNU Lesser General License or the GNU - * General Public License. If you wish to allow use of your version of - * this file only under the terms of the GNU Lesser General License or - * the GNU General Public License, and not to allow others to use your - * version of this file under the terms of the following license, - * indicate your decision by deleting this paragraph and the license - * below. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, and the entire permission notice in its entirety, - * including the disclaimer of warranties. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. The name of the author may not be used to endorse or promote - * products derived from this software without specific prior - * written permission. - * - * THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED - * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, - * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED - * OF THE POSSIBILITY OF SUCH DAMAGE. - */ - -#ifndef LIBJNLIB_DOTLOCK_H -#define LIBJNLIB_DOTLOCK_H - -/* See dotlock.c for a description. */ - -#ifdef DOTLOCK_EXT_SYM_PREFIX -# ifndef _DOTLOCK_PREFIX -# define _DOTLOCK_PREFIX1(x,y) x ## y -# define _DOTLOCK_PREFIX2(x,y) _DOTLOCK_PREFIX1(x,y) -# define _DOTLOCK_PREFIX(x) _DOTLOCK_PREFIX2(DOTLOCK_EXT_SYM_PREFIX,x) -# endif /*_DOTLOCK_PREFIX*/ -# define dotlock_disable _DOTLOCK_PREFIX(dotlock_disable) -# define dotlock_create _DOTLOCK_PREFIX(dotlock_create) -# define dotlock_set_fd _DOTLOCK_PREFIX(dotlock_set_fd) -# define dotlock_get_fd _DOTLOCK_PREFIX(dotlock_get_fd) -# define dotlock_destroy _DOTLOCK_PREFIX(dotlock_destroy) -# define dotlock_take _DOTLOCK_PREFIX(dotlock_take) -# define dotlock_release _DOTLOCK_PREFIX(dotlock_release) -# define dotlock_remove_lockfiles _DOTLOCK_PREFIX(dotlock_remove_lockfiles) -#endif /*DOTLOCK_EXT_SYM_PREFIX*/ - -#ifdef __cplusplus -extern "C" -{ -#if 0 -} -#endif -#endif - - -struct dotlock_handle; -typedef struct dotlock_handle *dotlock_t; - -void dotlock_disable (void); -dotlock_t dotlock_create (const char *file_to_lock, unsigned int flags); -void dotlock_set_fd (dotlock_t h, int fd); -int dotlock_get_fd (dotlock_t h); -void dotlock_destroy (dotlock_t h); -int dotlock_take (dotlock_t h, long timeout); -int dotlock_release (dotlock_t h); -void dotlock_remove_lockfiles (void); - -#ifdef __cplusplus -} -#endif -#endif /*LIBJNLIB_DOTLOCK_H*/ diff --git a/kiki.cabal b/kiki.cabal index 176d09c..c79f313 100644 --- a/kiki.cabal +++ b/kiki.cabal @@ -1,7 +1,7 @@ Name: kiki Version: 0.0.3 -cabal-version: >= 1.6 +cabal-version: >= 1.8 Synopsis: A bridge between (cryptographic) keys Description: gpg operations... TODO License: Undecided @@ -23,15 +23,20 @@ Executable kiki Main-is: kiki.hs -- base >=4.6 due to use of readEither in KikiD.Message Build-Depends: base >=4.6.0.0, - directory -any, - openpgp-util -any, - asn1-types -any, asn1-encoding -any, - dataenc -any, text -any, pretty -any, pretty-show -any, - bytestring -any, binary -any, - unix, time, - containers -any, process -any, filepath -any, - network -any, old-locale -any, zlib -any, - tar + asn1-encoding, + asn1-types, + binary, + bytestring, + containers, + dataenc, + directory, + filepath, + tar, + text, + time, + unix, + openpgp-util, + kiki if !flag(cryptonite) Build-Depends: crypto-pubkey >=0.2.3, cryptohash -any, crypto-pubkey-types -any @@ -41,12 +46,50 @@ Executable kiki Build-Depends: x509 <1.6 else Build-Depends: cryptonite, x509 >=1.6, memory, hourglass - ghc-options: -O2 -fwarn-unused-binds -fwarn-unused-imports - c-sources: dotlock.c Executable hosts Main-is: hosts.hs + buildable: False c-sources: dotlock.c library - exposed-modules: KeyRing + hs-source-dirs: lib + exposed-modules: KeyRing, + ScanningParser, + PEM, + DotLock, + Base58, + CryptoCoins, + ProcessUtils + other-modules: Hosts, + TimeUtil, + Compat, + FunctorToMaybe + + Build-Depends: base >=4.6.0.0, + asn1-encoding, + asn1-types, + binary, + bytestring, + containers, + dataenc, + directory, + filepath, + network, + pretty-show, + process, + text, + time, + unix, + zlib, + openpgp-util + if !flag(cryptonite) + Build-Depends: crypto-pubkey >=0.2.3, cryptohash -any, + crypto-pubkey-types -any + if flag(hourglass) + Build-Depends: hourglass -any, x509 >=1.5 && <1.6 + else + Build-Depends: x509 <1.6 + else + Build-Depends: cryptonite, x509 >=1.6, memory, hourglass + c-sources: lib/dotlock.c 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 @@ +{-# LANGUAGE CPP #-} +module Base58 where + +#if !defined(VERSION_cryptonite) +import qualified Crypto.Hash.SHA256 as SHA256 +#else +import Crypto.Hash +import Data.ByteArray (convert) +#endif +import qualified Data.ByteString as S +import Data.Maybe +import Data.List +import Data.Word ( Word8 ) +import Control.Monad + +base58chars :: [Char] +base58chars = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" + +base58digits :: [Char] -> Maybe [Int] +base58digits str = sequence mbs + where + mbs = map (flip elemIndex base58chars) str + +-- 5HueCGU8rMjxEXxiPuD5BDku4MkFqeZyd4dZ1jvhTVqvbTLvyTJ +base58_decode :: [Char] -> Maybe (Word8,[Word8]) +base58_decode str = do + ds <- base58digits str + let n = foldl' (\a b-> a*58 + b) 0 $ ( map fromIntegral ds :: [Integer] ) + rbytes = unfoldr getbyte n + getbyte d = do + guard (d/=0) + let (q,b) = d `divMod` 256 + return (fromIntegral b,q) + + let (rcksum,rpayload) = splitAt 4 $ rbytes + a_payload = reverse rpayload +#if !defined(VERSION_cryptonite) + hash_result = S.take 4 . SHA256.hash . SHA256.hash . S.pack $ a_payload +#else + hash_result = S.take 4 . convert $ digest + where digest = hash (S.pack a_payload) :: Digest SHA256 +#endif + expected_hash = S.pack $ reverse rcksum + (network_id,payload) = splitAt 1 a_payload + + network_id <- listToMaybe network_id + guard (hash_result==expected_hash) + return (network_id,payload) + +base58_encode :: S.ByteString -> String +base58_encode hsh = replicate zcount '1' ++ map (base58chars !!) (reverse rdigits) + where + zcount = S.length . S.takeWhile (==0) $ hsh +#if !defined(VERSION_cryptonite) + cksum = S.take 4 . SHA256.hash . SHA256.hash $ hsh +#else + cksum = S.take 4 (convert digest2 :: S.ByteString) + where digest2 = hash ( convert digest1 :: S.ByteString) :: Digest SHA256 + digest1 = hash hsh :: Digest SHA256 +#endif + n = foldl' (\a b->a*256+b) 0 . map asInteger $ concatMap S.unpack [hsh, cksum] + asInteger x = fromIntegral x :: Integer + rdigits = unfoldr getdigit n + where + getdigit d = do + guard (d/=0) + let (q,b) = d `divMod` 58 + return (fromIntegral b,q) + + 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 @@ +{-# LANGUAGE CPP #-} +module Compat where + +import Data.Bits +import Data.Word +import Data.ASN1.Types +import Data.ASN1.Encoding +import Data.ASN1.BinaryEncoding +import Crypto.PubKey.RSA as RSA + +#if defined(VERSION_cryptonite) + +instance ASN1Object PublicKey where + toASN1 pubKey = \xs -> Start Sequence + : IntVal (public_n pubKey) + : IntVal (public_e pubKey) + : End Sequence + : xs + fromASN1 (Start Sequence:IntVal smodulus:IntVal pubexp:End Sequence:xs) = + Right (PublicKey { public_size = calculate_modulus modulus 1 + , public_n = modulus + , public_e = pubexp + } + , xs) + where calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1) + -- some bad implementation will not serialize ASN.1 integer properly, leading + -- to negative modulus. if that's the case, we correct it. + modulus = toPositive smodulus + fromASN1 ( Start Sequence + : IntVal 0 + : Start Sequence + : OID [1, 2, 840, 113549, 1, 1, 1] + : Null + : End Sequence + : OctetString bs + : xs + ) = let inner = either strError fromASN1 $ decodeASN1' BER bs + strError = Left . + ("fromASN1: RSA.PublicKey: " ++) . show + in either Left (\(k, _) -> Right (k, xs)) inner + fromASN1 _ = + Left "fromASN1: RSA.PublicKey: unexpected format" + +#endif + +toPositive :: Integer -> Integer +toPositive int + | int < 0 = uintOfBytes $ bytesOfInt int + | otherwise = int + where uintOfBytes = foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 + bytesOfInt :: Integer -> [Word8] + bytesOfInt n = if testBit (head nints) 7 then nints else 0xff : nints + where nints = reverse $ plusOne $ reverse $ map complement $ bytesOfUInt (abs n) + plusOne [] = [1] + plusOne (x:xs) = if x == 0xff then 0 : plusOne xs else (x+1) : xs + bytesOfUInt x = reverse (list x) + where list i = if i <= 0xff then [fromIntegral i] else (fromIntegral i .&. 0xff) : list (i `shiftR` 8) + 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 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module ControlMaybe where + +-- import GHC.IO.Exception (IOException(..)) +import Control.Exception as Exception (IOException(..),catch) + + +withJust :: Monad m => Maybe x -> (x -> m ()) -> m () +withJust (Just x) f = f x +withJust Nothing f = return () + +whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m () +whenJust acn f = do + x <- acn + withJust x f + + +catchIO_ :: IO a -> IO a -> IO a +catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h) + +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO body handler = Exception.catch body handler + +handleIO_ :: IO a -> IO a -> IO a +handleIO_ = flip catchIO_ + + +handleIO :: (IOException -> IO a) -> IO a -> IO a +handleIO = 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 @@ +{-# LANGUAGE ViewPatterns #-} +module CryptoCoins where + +import Numeric +import Data.Word +import Data.Maybe + +data CoinNetwork = CoinNetwork + { network_name :: String + , public_byte_id :: Word8 + , private_byte_id :: Word8 + , source_code_uri :: String + } + deriving (Show,Read) + +-- For forks of bitcoin, grep sources for PUBKEY_ADDRESS +-- That value + 0x80 will be the private_byte_id. +-- information source: https://raw.github.com/zamgo/PHPCoinAddress/master/README.md +coin_networks :: [CoinNetwork] +coin_networks = + [ CoinNetwork "bitcoin" 0x00 0x80 "https://github.com/bitcoin/bitcoin" + , CoinNetwork "litecoin" 0x30 0xB0 "https://github.com/litecoin-project/litecoin" + , CoinNetwork "peercoin" 0x37 0xB7 "https://github.com/ppcoin/ppcoin" -- AKA: ppcoin + , CoinNetwork "namecoin" 0x34 0xB4 "https://github.com/namecoin/namecoin" + , CoinNetwork "bbqcoin" 0x05 0xD5 "https://github.com/overware/BBQCoin" + , CoinNetwork "bitbar" 0x19 0x99 "https://github.com/aLQ/bitbar" + , CoinNetwork "bytecoin" 0x12 0x80 "https://github.com/bryan-mills/bytecoin" + , CoinNetwork "chncoin" 0x1C 0x9C "https://github.com/CHNCoin/CHNCoin" + , CoinNetwork "devcoin" 0x00 0x80 "http://sourceforge.net/projects/galacticmilieu/files/DeVCoin" + , CoinNetwork "feathercoin" 0x0E 0x8E "https://github.com/FeatherCoin/FeatherCoin" + , CoinNetwork "freicoin" 0x00 0x80 "https://github.com/freicoin/freicoin" + , CoinNetwork "junkcoin" 0x10 0x90 "https://github.com/js2082/JKC" + , CoinNetwork "mincoin" 0x32 0xB2 "https://github.com/SandyCohen/mincoin" + , CoinNetwork "novacoin" 0x08 0x88 "https://github.com/CryptoManiac/novacoin" + , CoinNetwork "onecoin" 0x73 0xF3 "https://github.com/cre8r/onecoin" + , CoinNetwork "smallchange" 0x3E 0xBE "https://github.com/bfroemel/smallchange" + , CoinNetwork "terracoin" 0x00 0x80 "https://github.com/terracoin/terracoin" + , CoinNetwork "yacoin" 0x4D 0xCD "https://github.com/pocopoco/yacoin" + , CoinNetwork "bitcoin-t" 0x6F 0xEF "" + , CoinNetwork "bbqcoin-t" 0x19 0x99 "" + , CoinNetwork "bitbar-t" 0x73 0xF3 "" + ] + -- fairbrix - - https://github.com/coblee/Fairbrix + -- ixcoin - - https://github.com/ixcoin/ixcoin + -- royalcoin - - http://sourceforge.net/projects/royalcoin/ + +lookupNetwork :: Eq a => (CoinNetwork -> a) -> a -> Maybe CoinNetwork +lookupNetwork f b = listToMaybe $ filter (\n->f n==b) coin_networks + +nameFromSecretByte :: Word8 -> String +nameFromSecretByte b = maybe (defaultName b) network_name (lookupNetwork private_byte_id b) + where + defaultName b = "?coin?"++hexit b + where + hexit b = pad0 $ showHex b "" + where pad0 [c] = '0':c:[] + pad0 cs = take 2 cs + +publicByteFromName :: String -> Word8 +publicByteFromName n = maybe (secretByteFromName n - 0x80) + -- exceptions to the above: bbqcoin, bytecoin + public_byte_id + (lookupNetwork network_name n) + +secretByteFromName :: String -> Word8 +secretByteFromName n = maybe (defaultID n) private_byte_id (lookupNetwork network_name n) + where + defaultID ('?':'c':'o':'i':'n':'?':(readHex->((x,_):_))) + = x + 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 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module DotLock + ( DotLock + , Flags + , dotlock_init + , dotlock_create + , dotlock_take + , dotlock_release + , dotlock_destroy + , dotlock_remove_lockfiles + , dotlock_set_fd + , dotlock_get_fd + , dotlock_disable + ) where + +import System.Posix.Types (Fd(..)) +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr + +newtype DotLock = DotLockPtr (Ptr ()) +type Flags = Int + +foreign import ccall "dotlock_create" _dotlock_create_ptr :: Ptr Char -> Flags -> IO (Ptr ()) + +foreign import ccall "dotlock_create" _dotlock_create :: CString -> Flags -> IO (Ptr ()) + +dotlock_init :: IO () +dotlock_init = do + null_ptr <- _dotlock_create_ptr nullPtr 0 + return () + +dotlock_create :: FilePath -> Flags -> IO (Maybe DotLock) +dotlock_create file flags = do + ptr <- withCString file (flip _dotlock_create flags) + if ptr == nullPtr then return Nothing else return (Just $ DotLockPtr ptr) + + +foreign import ccall "dotlock_take" dotlock_take :: DotLock -> CLong -> IO CInt +foreign import ccall "dotlock_release" dotlock_release :: DotLock -> IO CInt +foreign import ccall "dotlock_destroy" dotlock_destroy :: DotLock -> IO () +foreign import ccall "dotlock_remove_lockfiles" dotlock_remove_lockfiles ::DotLock -> IO () +foreign import ccall "dotlock_set_fd" dotlock_set_fd :: DotLock -> Fd -> IO () +foreign import ccall "dotlock_get_fd" dotlock_get_fd :: DotLock -> IO Fd +foreign 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 @@ +--------------------------------------------------------------------------- +-- | +-- Module : FunctorToMaybe +-- +-- Maintainer : joe@jerkface.net +-- Stability : experimental +-- +-- Motivation: When parsing a stream of events, it is often desirable to +-- let certain control events pass-through to the output stream without +-- interrupting the parse. For example, the conduit package uses +-- +-- which adds a special command to a stream and the blaze-builder-conduit +-- package has that treat the nullary constructor with special significance. +-- +-- But for other intermediary conduits, the nullary @Flush@ constructor may +-- be noise that they should politely preserve in case it is meaningul downstream. +-- If +-- implemented the 'FunctorToMaybe' type class, then 'functorToEither' could be used to +-- seperate the noise from the work-product. +-- +{-# LANGUAGE CPP #-} +module FunctorToMaybe where + +#if MIN_VERSION_base(4,6,0) +#else +import Control.Monad.Instances() +#endif + +-- | The 'FunctorToMaybe' class genaralizes 'Maybe' in that the +-- there may be multiple null elements. +-- +-- Instances of 'FunctorToMaybe' should satisfy the following laws: +-- +-- > functorToMaybe (fmap f g) == fmap f (functorToMaybe g) +-- +class Functor g => FunctorToMaybe g where + functorToMaybe :: g a -> Maybe a + + +instance FunctorToMaybe Maybe where + functorToMaybe = id +instance FunctorToMaybe (Either a) where + functorToMaybe (Right x) = Just x + functorToMaybe _ = Nothing + + +-- | 'functorToEither' is a null-preserving cast. +-- +-- If @functorToMaybe g == Nothing@, then a casted value is returned with Left. +-- If @functorToMaybe g == Just a@, then @Right a@ is returned. +-- +-- Returning to our +-- example, if we define +-- +-- > instance Flush where +-- > functorToMaybe Flush = Nothing +-- > functorToMaybe (Chunk a) = Just a +-- +-- Now stream processors can use 'functorToEither' to transform any nullary constructors while +-- while doing its work to transform the data before forwarding it into +-- . +-- +functorToEither :: FunctorToMaybe f => f a -> Either (f b) a +functorToEither ga = + maybe (Left $ uncast ga) + Right + (functorToMaybe ga) + where + 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 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +#if ! MIN_VERSION_network(2,4,0) +{-# LANGUAGE StandaloneDeriving #-} +#endif +module Hosts + ( Hosts + , assignName + , assignName' + , assignNewName + , removeName + , inet_pton + , inet_ntop + , empty + , hasName + , hasAddr + , encode + , decode + , diff + , plus + , filterAddrs + , namesForAddress + ) where + +import Data.Maybe +import Data.Monoid ( (<>) ) +import Data.List as List (foldl', (\\) ) +import Data.Ord +import Data.Char (isSpace) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.ByteString.Lazy.Char8 as L +import System.IO.Unsafe (unsafePerformIO) +import Control.Applicative ( (<$>), (<*>) ) +import Control.Monad (mplus) +import Network.Socket +import ControlMaybe ( handleIO_ ) + +#if ! MIN_VERSION_network(2,4,0) +deriving instance Ord SockAddr +#endif + +inet_pton :: String -> Maybe SockAddr +inet_pton p = n + where + n = unsafePerformIO $ do + handleIO_ (return Nothing) $ do + info <- getAddrInfo safe_hints (Just p) Nothing + return $ fmap addrAddress $ listToMaybe info + safe_hints = Just $ defaultHints { addrFlags=[AI_NUMERICHOST] } + +inet_ntop :: SockAddr -> String +inet_ntop n = p + where + p = case show n of + '[':xs -> fst $ break (==']') xs + xs -> fst $ break (==':') xs + + +data Hosts = Hosts + { lineCount :: Int + , numline :: Map Int L.ByteString + , namenum :: Map L.ByteString [Int] + , addrnum :: Map SockAddr Int + } + +instance Show Hosts where + show = L.unpack . encode + +encode :: Hosts -> L.ByteString +encode = L.unlines . map snd . Map.assocs . numline + +parseLine :: L.ByteString -> (Maybe SockAddr, [L.ByteString]) +parseLine s = (addr,names) + where + (addr0,names) = splitAt 1 $ L.words (uncom s) + addr = do + a <- fmap L.unpack $ listToMaybe addr0 + n <- inet_pton a + return $ n -- inet_ntop n + + uncom s = fst $ L.break (=='#') s + +empty :: Hosts +empty = Hosts { lineCount = 0 + , numline = Map.empty + , addrnum = Map.empty + , namenum = Map.empty + } + +{- +parseHosts fname = do + input <- L.readFile fname + return $ decode input +-} + +decode :: L.ByteString -> Hosts +decode input = + let ls = L.lines input + ans = map (\l->(parseLine l,l)) ls + hosts = foldl' upd empty ans + upd hosts ((addr,names),line) = hosts + { lineCount = count + , numline = Map.insert count line (numline hosts) + , addrnum = maybeInsert (addrnum hosts) addr + , namenum = foldl' (\m x->Map.alter (cons count) x m) + (namenum hosts) + names + } + where count = lineCount hosts + 1 + cons v xs = Just $ maybe [v] (v:) xs + maybeInsert m x = maybe m + (\x->Map.insert x count m) + x + in hosts + + +hasName :: L.ByteString -> Hosts -> Bool +hasName name hosts = Map.member name $ namenum hosts + +hasAddr :: SockAddr -> Hosts -> Bool +hasAddr addr hosts = Map.member addr $ addrnum hosts + +scrubName :: + ([L.ByteString] -> [L.ByteString]) -> L.ByteString -> L.ByteString +scrubName f line = line' + where + (x,ign) = L.break (=='#') line + ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x + where oo = (.) . (.) + (a,ws') = splitAt 2 ws + ws'' = f ws' + line' = if null ws'' + then if length a==2 then "" -- "# " <> L.concat a <> ign + else line + else if length a==2 + then L.concat (a ++ ws'') <> ign + else let vs = L.groupBy ( (==EQ) `oo` comparing isSpace) $ L.dropWhile isSpace + $ L.tail ign + where oo = (.) . (.) + (a',vs') = splitAt 2 vs + vs'' = L.concat vs' + vs''' = if L.take 1 vs'' `elem` ["#",""] + then vs'' + else "# " <> vs'' + in L.concat (a'++ws'') <> vs''' + +assignName :: SockAddr -> L.ByteString -> Hosts -> Hosts +assignName addr name hosts = assignName' False addr name hosts + +chaddr :: Int -> SockAddr -> Hosts -> Hosts +chaddr n addr hosts = + hosts { addrnum = Map.insert addr n (addrnum hosts) + , numline = Map.adjust re n (numline hosts) } + where + re line = if length a==2 + then L.pack (inet_ntop addr) <> " " <> L.concat ws' <> ign + else line + where (x,ign) = L.break (=='#') line + ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x + where oo = (.) . (.) + (a,ws') = splitAt 2 ws + +isLonerName line = length ws' <= 2 + where (x,_) = L.break (=='#') line + ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x + where oo = (.) . (.) + (_,ws') = splitAt 2 ws + +scrubTrailingEmpties :: Hosts -> Hosts +scrubTrailingEmpties hosts = + hosts { lineCount = cnt' + , numline = foldl' (flip Map.delete) (numline hosts) es + } + where + cnt = lineCount hosts + es = takeWhile (\n -> Map.lookup n (numline hosts) == Just "") + $ [cnt,cnt-1..] + cnt' = cnt - length es + +cannonizeName :: L.ByteString -> L.ByteString -> L.ByteString +cannonizeName name line = scrubName f line + where + f ws = [name," "] ++ pre ++ drop 2 rst + where + (pre,rst) = break (==name) ws + +removeName name hosts = hosts' + where + hosts' = scrubTrailingEmpties (maybe hosts (removeName0 name hosts) ns) + ns = Map.lookup name (namenum hosts) + + +removeName0 name hosts nums = hosts + { namenum = Map.delete name (namenum hosts) + , numline = foldl' scrub (numline hosts) nums + } + where scrub m num = Map.adjust (scrubName $ filter (/=name)) num m + +assignName' :: Bool -> SockAddr -> L.ByteString -> Hosts -> Hosts +assignName' iscannon addr name hosts = hosts' + where + ns = Map.lookup name (namenum hosts) + a = Map.lookup addr (addrnum hosts) + canonize numline n = Map.adjust (cannonizeName name) n numline + hosts' = do + if (== Just True) $ elem <$> a <*> ns + then if not iscannon then hosts -- address already has name, nothing to do + else hosts { numline = foldl' canonize (numline hosts) $ fromJust ns} + else + let hosts0 = -- remove name if it's present + scrubTrailingEmpties $ maybe hosts (removeName0 name hosts) ns + ns' = fmap (filter $ + isLonerName + . fromJust + . (\n -> Map.lookup n (numline hosts))) + ns + >>= listToMaybe + hosts1 = -- insert name, or add new line + maybe (maybe (newLine hosts0) + (\n -> chaddr n addr $ appendName iscannon name hosts0 n) + ns') + (appendName iscannon name hosts0) + a + in hosts1 + newLine hosts = hosts + { lineCount = cnt + , numline = Map.insert cnt line $ numline hosts + , addrnum = Map.insert addr cnt $ addrnum hosts + , namenum = Map.alter (cons cnt) name $ namenum hosts + } + where cnt = lineCount hosts + 1 + line = L.pack (inet_ntop addr) <> " " <> name + cons v xs = Just $ maybe [v] (v:) xs + +assignNewName :: SockAddr -> L.ByteString -> Hosts -> Hosts +assignNewName addr name hosts = + if hasName name hosts then hosts + else assignName' True addr name hosts + +appendName :: Bool -> L.ByteString -> Hosts -> Int -> Hosts +appendName iscannon name hosts num = hosts + { numline = Map.adjust (scrubName f) num (numline hosts) + , namenum = Map.alter (cons num) name (namenum hosts) + } + where f ws = if iscannon + then [name, " "] ++ ws + else let rs = reverse ws + (sp,rs') = span (L.any isSpace) rs + in reverse $ sp ++ [name," "] ++ rs' + cons v xs = Just $ maybe [v] (v:) xs + +-- Returns a list of bytestrings intended to show the +-- differences between the two host databases. It is +-- assumed that no lines are deleted, only altered or +-- appended. +diff :: Hosts -> Hosts -> [L.ByteString] +diff as bs = cs + where + [as',bs'] = map (L.lines . Hosts.encode) [as,bs] + ext xs = map Just xs ++ repeat Nothing + ds = takeWhile (isJust . uncurry mplus) $ zip (ext as') (ext bs') + es = filter (uncurry (/=)) ds + cs = do + (a,b) <- es + [a,b] <- return $ map maybeToList [a,b] + fmap ("- " <>) a ++ fmap ("+ " <>) b + +namesForAddress :: SockAddr -> Hosts -> [L.ByteString] +namesForAddress addr hosts = snd $ _namesForAddress addr hosts + +_namesForAddress :: SockAddr -> Hosts -> (Int, [L.ByteString]) +_namesForAddress addr (Hosts {numline=numline, addrnum=addrnum}) = ns + where + ns = maybe (-1,[]) id $ do + n <- Map.lookup addr addrnum + line <- Map.lookup n numline + return (n, snd $ parseLine line) + + +plus :: Hosts -> Hosts -> Hosts +plus a b = Map.foldlWithKey' mergeAddr a (addrnum b) + where + mergeAddr a addr bnum = a' + where + (anum,ns) = _namesForAddress addr a + bs = maybe [] (List.\\ ns) $ do + line <- Map.lookup bnum (numline b) + return . snd $ parseLine line + a' = if anum/=(-1) then foldl' app a $ reverse bs + else newLine a + app a b = appendName True b a anum -- True to allow b to reassign cannonical name + newLine hosts = hosts + { lineCount = cnt + , numline = Map.insert cnt line $ numline hosts + , addrnum = Map.insert addr cnt $ addrnum hosts + , namenum = foldl' updnamenum (namenum hosts) bs + } + where cnt = lineCount hosts + 1 + line = L.pack (inet_ntop addr) <> " " <> L.intercalate " " bs + cons v xs = Just $ maybe [v] (v:) xs + updnamenum m name = Map.alter (cons cnt) name m + +filterAddrs :: (SockAddr -> Bool) -> Hosts -> Hosts +filterAddrs pred hosts = hosts' + where + als = Map.toList (addrnum hosts) + nl = foldl' f (numline hosts) als + f m (addr,num) = if pred addr + then m + else Map.adjust (scrubName $ const []) num m + lines = L.unlines . Map.elems $ nl + 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 @@ +--------------------------------------------------------------------------- +-- | +-- Module : KeyRing +-- +-- Maintainer : joe@jerkface.net +-- Stability : experimental +-- +-- kiki is a command-line utility for manipulating GnuPG's keyring files. This +-- module is the programmer-facing API it uses to do that. +-- +-- Note: This is *not* a public facing API. I (the author) consider this +-- library to be internal to kiki and subject to change at my whim. +-- +-- Typically, a client to this module would prepare a 'KeyRingOperation' +-- describing what he wants done, and then invoke 'runKeyRing' to make it +-- happen. +{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE NoPatternGuards #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module KeyRing + ( + -- * Error Handling + KikiResult(..) + , KikiCondition(..) + , KikiReportAction(..) + , errorString + , reportString + -- * Manipulating Keyrings + , runKeyRing + , KeyRingOperation(..) + , PassphraseSpec(..) + , Transform(..) + -- , PacketUpdate(..) + -- , guardAuthentic + -- * Describing File Operations + , StreamInfo(..) + , Access(..) + , FileType(..) + , InputFile(..) + , KeyFilter(..) + -- * Results of a KeyRing Operation + , KeyRingRuntime(..) + , MappedPacket(..) + , KeyDB + , KeyData(..) + , SubKey(..) + , packet + , locations + , keyflags + -- * Miscelaneous Utilities + , isKey + , derRSA + , derToBase32 + , backsig + , filterMatches + , flattenKeys + , flattenTop + , Hosts.Hosts + , isCryptoCoinKey + , matchpr + , parseSpec + , parseUID + , UserIDRecord(..) + , pkcs8 + , RSAPublicKey(..) + , PKCS8_RSAPublicKey(..) + , rsaKeyFromPacket + , secretToPublic + , selectPublicKey + , selectSecretKey + , usage + , usageString + , walletImportFormat + , writePEM + , getBindings + , accBindings + , isSubkeySignature + , torhash + , ParsedCert(..) + , parseCertBlob + , packetFromPublicRSAKey + , decodeBlob + , selectPublicKeyAndSigs + , x509cert + , getHomeDir + , unconditionally + , SecretPEMData(..) + , readSecretPEMFile + , writeInputFileL + , InputFileContext(..) + , onionNameForContact + , keykey + , keyPacket + , KeySpec(..) + , getHostnames + , secretPemFromPacket + , getCrossSignedSubkeys + ) where + +import System.Environment +import Control.Monad +import Data.Maybe +import Data.Either +import Data.Char +import Data.Ord +import Data.List +import Data.OpenPGP +import Data.Functor +import Data.Monoid +import Data.Tuple ( swap ) +import Data.Bits ( (.|.), (.&.) ) +import Control.Applicative ( Applicative, pure, liftA2, (<*>) ) +import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) +import Control.Arrow ( first, second ) +import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign) +import Data.ByteString.Lazy ( ByteString ) +import Text.Show.Pretty as PP ( ppShow ) +import Data.Binary {- decode, decodeOrFail -} +import ControlMaybe ( handleIO_ ) +import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 + , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) ) +import Data.ASN1.BitArray ( BitArray(..), toBitArray ) +import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' ) +import Data.ASN1.BinaryEncoding ( DER(..) ) +import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds ) +import Data.Time.Clock ( UTCTime ) +import Data.Bits ( Bits, shiftR ) +import Data.Text.Encoding ( encodeUtf8 ) +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile + , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt + , index, break, pack ) +import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, hPutStr, singleton, unfoldr, reverse ) +import qualified Codec.Binary.Base32 as Base32 +import qualified Codec.Binary.Base64 as Base64 +#if !defined(VERSION_cryptonite) +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Crypto.Types.PubKey.ECC as ECC +#else +import qualified Crypto.Hash as Vincent +import Data.ByteArray (convert) +import qualified Crypto.PubKey.ECC.Types as ECC +#endif +import qualified Data.X509 as X509 +import qualified Crypto.PubKey.RSA as RSA +import qualified Codec.Compression.GZip as GZip +import qualified Data.Text as T ( Text, unpack, pack, + strip, reverse, drop, break, dropAround, length ) +import qualified System.Posix.Types as Posix +import System.Posix.Files ( modificationTime, getFileStatus, getFdStatus + , setFileCreationMask, setFileTimes ) +#if MIN_VERSION_x509(1,5,0) +import Data.Hourglass.Types +import Data.Hourglass +#endif +#if MIN_VERSION_unix(2,7,0) +import System.Posix.Files ( setFdTimesHiRes ) +import Foreign.C.Types ( CTime(..), CLong, CInt(..) ) +#else +import Foreign.C.Types ( CTime(..), CLong, CInt(..) ) +import Foreign.Marshal.Array ( withArray ) +import Foreign.Ptr +import Foreign.C.Error ( throwErrnoIfMinus1_ ) +import Foreign.Storable +#endif +import System.FilePath ( takeDirectory ) +import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr) +import Data.IORef +import System.Posix.IO ( fdToHandle ) +import qualified Data.Traversable as Traversable +import Data.Traversable ( sequenceA ) +#if ! MIN_VERSION_base(4,6,0) +import GHC.Exts ( Down(..) ) +#endif +#if MIN_VERSION_binary(0,7,0) +import Debug.Trace +#endif +import Network.Socket -- (SockAddr) +import qualified Data.ByteString.Lazy.Char8 as Char8 +import Compat + +import TimeUtil +import PEM +import ScanningParser +import qualified Hosts +import qualified CryptoCoins +import Base58 +import FunctorToMaybe +import DotLock +import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) + +-- DER-encoded elliptic curve ids +-- nistp256_id = 0x2a8648ce3d030107 +secp256k1_id :: Integer +secp256k1_id = 0x2b8104000a +-- "\x2a\x86\x48\xce\x3d\x03\x01\x07" +{- OID Curve description Curve name + ---------------------------------------------------------------- + 1.2.840.10045.3.1.7 NIST Curve P-256 [FIPS 186-2] "NIST P-256" + 1.3.132.0.34 NIST Curve P-384 [FIPS 186-2] "NIST P-384" + 1.3.132.0.35 NIST Curve P-521 [FIPS 186-2] "NIST P-521" + + Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST + P-521". The hexadecimal representation used in the public and + private key encodings are: + + Curve Name Len Hexadecimal representation of the OID + ---------------------------------------------------------------- + "NIST P-256" 8 0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07 + "NIST P-384" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x22 + "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23 +-} + +data HomeDir = + HomeDir { homevar :: String + , appdir :: String + , optfile_alts :: [String] + } + +home :: HomeDir +home = HomeDir + { homevar = "GNUPGHOME" + , appdir = ".gnupg" + , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] + } + +data InputFile = HomeSec + -- ^ A file named secring.gpg located in the home directory. + -- See 'opHome'. + | HomePub + -- ^ A file named pubring.gpg located in the home directory. + -- See 'opHome'. + | ArgFile FilePath + -- ^ Contents will be read or written from the specified path. + | FileDesc Posix.Fd + -- ^ Contents will be read or written from the specified file + -- descriptor. + | Pipe Posix.Fd Posix.Fd + -- ^ Contents will be read from the first descriptor and updated + -- content will be writen to the second. Note: Don't use Pipe + -- for 'Wallet' files. (TODO: Wallet support) + deriving (Eq,Ord,Show) + +-- type UsageTag = String +type Initializer = String + +data FileType = KeyRingFile + | PEMFile + | WalletFile + | DNSPresentation + | Hosts + deriving (Eq,Ord,Enum,Show) + +-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected +-- to contain secret or public PGP key packets. Note that it is not supported +-- to mix both in the same file and that the secret key packets include all of +-- the information contained in their corresponding public key packets. +data Access = AutoAccess -- ^ secret or public as appropriate based on existing content. + -- (see 'rtRingAccess') + | Sec -- ^ secret information + | Pub -- ^ public information + deriving (Eq,Ord,Show) + +-- | Note that the documentation here is intended for when this value is +-- assigned to 'fill'. For other usage, see 'spill'. +data KeyFilter = KF_None -- ^ No keys will be imported. + | KF_Match String -- ^ Only the key that matches the spec will be imported. + | KF_Subkeys -- ^ Subkeys will be imported if their owner key is + -- already in the ring. TODO: Even if their signatures + -- are bad? + | KF_Authentic -- ^ Keys are imported if they belong to an authenticated + -- identity (signed or self-authenticating). + | KF_All -- ^ All keys will be imported. + deriving (Eq,Ord,Show) + +-- | This type describes how 'runKeyRing' will treat a file. +data StreamInfo = StreamInfo + { access :: Access + -- ^ Indicates whether the file is allowed to contain secret information. + , typ :: FileType + -- ^ Indicates the format and content type of the file. + , fill :: KeyFilter + -- ^ This filter controls what packets will be inserted into a file. + , spill :: KeyFilter + -- + -- ^ Use this to indicate whether or not a file's contents should be + -- available for updating other files. Note that although its type is + -- 'KeyFilter', it is usually interpretted as a boolean flag. Details + -- depend on 'typ' and are as follows: + -- + -- 'KeyRingFile': + -- + -- * 'KF_None' - The file's contents will not be shared. + -- + -- * otherwise - The file's contents will be shared. + -- + -- 'PEMFile': + -- + -- * 'KF_None' - The file's contents will not be shared. + -- + -- * 'KF_Match' - The file's key will be shared with the specified owner + -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be + -- equal to this value; changing the usage or owner of a key is not + -- supported via the fill/spill mechanism. + -- + -- * otherwise - Unspecified. Do not use. + -- + -- 'WalletFile': + -- + -- * The 'spill' setting is ignored and the file's contents are shared. + -- (TODO) + -- + -- 'Hosts': + -- + -- * The 'spill' setting is ignored and the file's contents are shared. + -- (TODO) + -- + , initializer :: Maybe String + -- ^ If 'typ' is 'PEMFile' and an 'initializer' string is set, then it is + -- interpretted as a shell command that may be used to create the key if it + -- does not exist. + , transforms :: [Transform] + -- ^ Per-file transformations that occur before the contents of a file are + -- spilled into the common pool. + } + deriving (Eq,Show) + + +spillable :: StreamInfo -> Bool +spillable (spill -> KF_None) = False +spillable _ = True + +isMutable :: StreamInfo -> Bool +isMutable (fill -> KF_None) = False +isMutable _ = True + +isring :: FileType -> Bool +isring (KeyRingFile {}) = True +isring _ = False + +isSecretKeyFile :: FileType -> Bool +isSecretKeyFile PEMFile = True +isSecretKeyFile DNSPresentation = True +isSecretKeyFile _ = False + +{- +pwfile :: FileType -> Maybe InputFile +pwfile (KeyRingFile f) = f +pwfile _ = Nothing +-} + +iswallet :: FileType -> Bool +iswallet (WalletFile {}) = True +iswallet _ = False + +usageFromFilter :: MonadPlus m => KeyFilter -> m String +usageFromFilter (KF_Match usage) = return usage +usageFromFilter _ = mzero + +data KeyRingRuntime = KeyRingRuntime + { rtPubring :: FilePath + -- ^ Path to the file represented by 'HomePub' + , rtSecring :: FilePath + -- ^ Path to the file represented by 'HomeSec' + , rtGrip :: Maybe String + -- ^ Fingerprint or portion of a fingerprint used + -- to identify the working GnuPG identity used to + -- make signatures. + , rtWorkingKey :: Maybe Packet + -- ^ The master key of the working GnuPG identity. + , rtKeyDB :: KeyDB + -- ^ The common information pool where files spilled + -- their content and from which they received new + -- content. + , rtRingAccess :: Map.Map InputFile Access + -- ^ The 'Access' values used for files of type + -- 'KeyRingFile'. If 'AutoAccess' was specified + -- for a file, this 'Map.Map' will indicate the + -- detected value that was used by the algorithm. + , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet) + } + +-- | Roster-entry level actions +data PacketUpdate = InducerSignature String [SignatureSubpacket] + | SubKeyDeletion KeyKey KeyKey + +-- | This type is used to indicate where to obtain passphrases. +data PassphraseSpec = PassphraseSpec + { passSpecRingFile :: Maybe FilePath + -- ^ If not Nothing, the passphrase is to be used for packets + -- from this file. + , passSpecKeySpec :: Maybe String + -- ^ Non-Nothing value reserved for future use. + -- (TODO: Use this to implement per-key passphrase associations). + , passSpecPassFile :: InputFile + -- ^ The passphrase will be read from this file or file descriptor. + } + -- | Use this to carry pasphrases from a previous run. + | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet)) + +instance Show PassphraseSpec where + show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) + show (PassphraseMemoizer _) = "PassphraseMemoizer" +instance Eq PassphraseSpec where + PassphraseSpec a b c == PassphraseSpec d e f + = and [a==d,b==e,c==f] + _ == _ + = False + + + +data Transform = + Autosign + -- ^ This operation will make signatures for any tor-style UID + -- that matches a tor subkey and thus can be authenticated without + -- requring the judgement of a human user. + -- + -- A tor-style UID is one of the following form: + -- + -- > Anonymous + | DeleteSubKey String + -- ^ Delete the subkey specified by the given fingerprint and any + -- associated signatures on that key. + deriving (Eq,Ord,Show) + +-- | This type describes an idempotent transformation (merge or import) on a +-- set of GnuPG keyrings and other key files. +data KeyRingOperation = KeyRingOperation + { opFiles :: Map.Map InputFile StreamInfo + -- ^ Indicates files to be read or updated. + , opPassphrases :: [PassphraseSpec] + -- ^ Indicates files or file descriptors where passphrases can be found. + , opTransforms :: [Transform] + -- ^ Transformations to be performed on the key pool after all files have + -- been read and before any have been written. + , opHome :: Maybe FilePath + -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub' + -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted + -- and if that is not set, it falls back to $HOME/.gnupg. + } + deriving (Eq,Show) + +resolveInputFile :: InputFileContext -> InputFile -> [FilePath] +resolveInputFile ctx = resolve + where + resolve HomeSec = return (homesecPath ctx) + resolve HomePub = return (homepubPath ctx) + resolve (ArgFile f) = return f + resolve _ = [] + +resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath +resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str) + where str = case (fdr,fdw) of + (0,1) -> "-" + _ -> "&pipe" ++ show (fdr,fdw) +resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str) + where str = "&" ++ show fd +resolveForReport mctx f = concat $ resolveInputFile ctx f + where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx + +filesToLock :: + KeyRingOperation -> InputFileContext -> [FilePath] +filesToLock k ctx = do + (f,stream) <- Map.toList (opFiles k) + case fill stream of + KF_None -> [] + _ -> resolveInputFile ctx f + + +-- kret :: a -> KeyRingOperation a +-- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x) + +data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) +data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show + +pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey +pkcs8 (RSAKey n e) = RSAKey8 n e + +instance ASN1Object RSAPublicKey where + -- PKCS #1 RSA Public Key + toASN1 (RSAKey (MPI n) (MPI e)) + = \xs -> Start Sequence + : IntVal n + : IntVal e + : End Sequence + : xs + fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) = + Right (RSAKey (MPI n) (MPI e), xs) + + fromASN1 _ = + Left "fromASN1: RSAPublicKey: unexpected format" + +instance ASN1Object PKCS8_RSAPublicKey where + + -- PKCS #8 Public key data + toASN1 (RSAKey8 (MPI n) (MPI e)) + = \xs -> Start Sequence + : Start Sequence + : OID [1,2,840,113549,1,1,1] + : Null -- Doesn't seem to be neccessary, but i'm adding it + -- to match PEM files I see in the wild. + : End Sequence + : BitString (toBitArray bs 0) + : End Sequence + : xs + where + pubkey = [ Start Sequence, IntVal n, IntVal e, End Sequence ] + bs = encodeASN1' DER pubkey + + fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) = + Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs) + fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:Null:End Sequence:BitString b:End Sequence:xs) = + case decodeASN1' DER bs of + Right as -> fromASN1 as + Left e -> Left ("fromASN1: RSAPublicKey: "++show e) + where + BitArray _ bs = b + fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) = + case decodeASN1' DER bs of + Right as -> fromASN1 as + Left e -> Left ("fromASN1: RSAPublicKey: "++show e) + where + BitArray _ bs = b + + fromASN1 _ = + Left "fromASN1: RSAPublicKey: unexpected format" + +{- +RSAPrivateKey ::= SEQUENCE { + version Version, + modulus INTEGER, -- n + publicExponent INTEGER, -- e + privateExponent INTEGER, -- d + prime1 INTEGER, -- p + prime2 INTEGER, -- q + exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1) + exponent2 INTEGER, -- d mod (q-1) + coefficient INTEGER, -- (inverse of q) mod p + otherPrimeInfos OtherPrimeInfos OPTIONAL + } +-} +data RSAPrivateKey = RSAPrivateKey + { rsaN :: MPI + , rsaE :: MPI + , rsaD :: MPI + , rsaP :: MPI + , rsaQ :: MPI + , rsaDmodP1 :: MPI + , rsaDmodQminus1 :: MPI + , rsaCoefficient :: MPI + } + deriving Show + +instance ASN1Object RSAPrivateKey where + toASN1 rsa@(RSAPrivateKey {}) + = \xs -> Start Sequence + : IntVal 0 + : mpiVal rsaN + : mpiVal rsaE + : mpiVal rsaD + : mpiVal rsaP + : mpiVal rsaQ + : mpiVal rsaDmodP1 + : mpiVal rsaDmodQminus1 + : mpiVal rsaCoefficient + : End Sequence + : xs + where mpiVal f = IntVal x where MPI x = f rsa + + fromASN1 ( Start Sequence + : IntVal _ -- version + : IntVal n + : IntVal e + : IntVal d + : IntVal p + : IntVal q + : IntVal dmodp1 + : IntVal dmodqminus1 + : IntVal coefficient + : ys) = + Right ( privkey, tail $ dropWhile notend ys) + where + notend (End Sequence) = False + notend _ = True + privkey = RSAPrivateKey + { rsaN = MPI n + , rsaE = MPI e + , rsaD = MPI d + , rsaP = MPI p + , rsaQ = MPI q + , rsaDmodP1 = MPI dmodp1 + , rsaDmodQminus1 = MPI dmodqminus1 + , rsaCoefficient = MPI coefficient + } + fromASN1 _ = + Left "fromASN1: RSAPrivateKey: unexpected format" + + + +-- | This type is used to indicate success or failure +-- and in the case of success, return the computed object. +-- The 'FunctorToMaybe' class is implemented to facilitate +-- branching on failture. +data KikiCondition a = KikiSuccess a + | FailedToLock [FilePath] + | BadPassphrase + | FailedToMakeSignature + | CantFindHome + | AmbiguousKeySpec FilePath + | CannotImportMasterKey + | NoWorkingKey + deriving ( Functor, Show ) + +instance FunctorToMaybe KikiCondition where + functorToMaybe (KikiSuccess a) = Just a + functorToMaybe _ = Nothing + +instance Applicative KikiCondition where + pure a = KikiSuccess a + f <*> a = + case functorToEither f of + Right f -> case functorToEither a of + Right a -> pure (f a) + Left err -> err + Left err -> err + +-- | This type is used to describe events triggered by 'runKeyRing'. In +-- addition to normal feedback (e.g. 'NewPacket'), it also may indicate +-- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a +-- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with +-- many inputs and outputs, an operation may be partially (or even mostly) +-- successful even when I/O failures occured. In this situation, the files may +-- not have all the information they were intended to store, but they will be +-- in a valid format for GnuPG or kiki to operate on in the future. +data KikiReportAction = + NewPacket String + | MissingPacket String + | ExportedSubkey + | GeneratedSubkeyFile + | NewWalletKey String + | YieldSignature + | YieldSecretKeyPacket String + | UnableToUpdateExpiredSignature + | WarnFailedToMakeSignature + | FailedExternal Int + | ExternallyGeneratedFile + | UnableToExport KeyAlgorithm String + | FailedFileWrite + | HostsDiff ByteString + | DeletedPacket String + deriving Show + +uncamel :: String -> String +uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args + where + (.:) = fmap . fmap + ( firstWord , + otherWords ) = splitAt 1 ws + ws = camel >>= groupBy (\_ c -> isLower c) + ( camel, args) = splitAt 1 $ words str + +reportString :: KikiReportAction -> String +reportString x = uncamel $ show x + +errorString :: KikiCondition a -> String +errorString (KikiSuccess {}) = "success" +errorString e = uncamel . show $ fmap (const ()) e + +-- | Errors in kiki are indicated by the returning of this record. +data KikiResult a = KikiResult + { kikiCondition :: KikiCondition a + -- ^ The result or a fatal error condition. + , kikiReport :: KikiReport + -- ^ A list of non-fatal warnings and informational messages + -- along with the files that triggered them. + } + +type KikiReport = [ (FilePath, KikiReportAction) ] + +keyPacket :: KeyData -> Packet +keyPacket (KeyData k _ _ _) = packet k + +subkeyMappedPacket :: SubKey -> MappedPacket +subkeyMappedPacket (SubKey k _ ) = k + + +usage :: SignatureSubpacket -> Maybe String +usage (NotationDataPacket + { human_readable = True + , notation_name = "usage@" + , notation_value = u + }) = Just u +usage _ = Nothing + +x509cert :: SignatureSubpacket -> Maybe Char8.ByteString +x509cert (NotationDataPacket + { human_readable = False + , notation_name = "x509cert@" + , notation_value = u + }) = Just (Char8.pack u) +x509cert _ = Nothing + +makeInducerSig + :: Packet + -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver +-- torsig g topk wkun uid timestamp extras = todo +makeInducerSig topk wkun uid extras + = CertificationSignature (secretToPublic topk) + uid + (sigpackets 0x13 + subpackets + subpackets_unh) + where + subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] + tsign + ++ extras + subpackets_unh = [IssuerPacket (fingerprint wkun)] + tsign = if keykey wkun == keykey topk + then [] -- tsign doesnt make sense for self-signatures + else [ TrustSignaturePacket 1 120 + , RegularExpressionPacket regex] + -- <[^>]+[@.]asdf\.nowhere>$ + regex = "<[^>]+[@.]"++hostname++">$" + -- regex = username ++ "@" ++ hostname + -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String + hostname = subdomain' pu ++ "\\." ++ topdomain' pu + pu = parseUID uidstr where UserIDPacket uidstr = uid + subdomain' = escape . T.unpack . uid_subdomain + topdomain' = escape . T.unpack . uid_topdomain + escape s = concatMap echar s + where + echar '|' = "\\|" + echar '*' = "\\*" + echar '+' = "\\+" + echar '?' = "\\?" + echar '.' = "\\." + echar '^' = "\\^" + echar '$' = "\\$" + echar '\\' = "\\\\" + echar '[' = "\\[" + echar ']' = "\\]" + echar c = [c] + + +keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags +keyflags flgs@(KeyFlagsPacket {}) = + Just . toEnum $ + ( bit 0x1 certify_keys + .|. bit 0x2 sign_data + .|. bit 0x4 encrypt_communication + .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags + -- other flags: + -- split_key + -- authentication (ssh-client) + -- group_key + where + bit v f = if f flgs then v else 0 +keyflags _ = Nothing + + +data PGPKeyFlags = + Special + | Vouch -- Signkey + | Sign + | VouchSign + | Communication + | VouchCommunication + | SignCommunication + | VouchSignCommunication + | Storage + | VouchStorage + | SignStorage + | VouchSignStorage + | Encrypt + | VouchEncrypt + | SignEncrypt + | VouchSignEncrypt + deriving (Eq,Show,Read,Enum) + + +usageString :: PGPKeyFlags -> String +usageString flgs = + case flgs of + Special -> "special" + Vouch -> "vouch" -- signkey + Sign -> "sign" + VouchSign -> "vouch-sign" + Communication -> "communication" + VouchCommunication -> "vouch-communication" + SignCommunication -> "sign-communication" + VouchSignCommunication -> "vouch-sign-communication" + Storage -> "storage" + VouchStorage -> "vouch-storage" + SignStorage -> "sign-storage" + VouchSignStorage -> "vouch-sign-storage" + Encrypt -> "encrypt" + VouchEncrypt -> "vouch-encrypt" + SignEncrypt -> "sign-encrypt" + VouchSignEncrypt -> "vouch-sign-encrypt" + + + + +-- matchpr computes the fingerprint of the given key truncated to +-- be the same lenght as the given fingerprint for comparison. +matchpr :: String -> Packet -> String +matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp + +keyFlags :: t -> [Packet] -> [SignatureSubpacket] +keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) + +keyFlags0 :: t -> [Packet] -> [SignatureSubpacket] +keyFlags0 wkun uidsigs = concat + [ keyflags + , preferredsym + , preferredhash + , preferredcomp + , features ] + + where + subs = concatMap hashed_subpackets uidsigs + keyflags = filterOr isflags subs $ + KeyFlagsPacket { certify_keys = True + , sign_data = True + , encrypt_communication = False + , encrypt_storage = False + , split_key = False + , authentication = False + , group_key = False + } + preferredsym = filterOr ispreferedsym subs $ + PreferredSymmetricAlgorithmsPacket + [ AES256 + , AES192 + , AES128 + , CAST5 + , TripleDES + ] + preferredhash = filterOr ispreferedhash subs $ + PreferredHashAlgorithmsPacket + [ SHA256 + , SHA1 + , SHA384 + , SHA512 + , SHA224 + ] + preferredcomp = filterOr ispreferedcomp subs $ + PreferredCompressionAlgorithmsPacket + [ ZLIB + , BZip2 + , ZIP + ] + features = filterOr isfeatures subs $ + FeaturesPacket { supports_mdc = True + } + + filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs + + isflags (KeyFlagsPacket {}) = True + isflags _ = False + ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True + ispreferedsym _ = False + ispreferedhash (PreferredHashAlgorithmsPacket {}) = True + ispreferedhash _ = False + ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True + ispreferedcomp _ = False + isfeatures (FeaturesPacket {}) = True + isfeatures _ = False + + +matchSpec :: KeySpec -> KeyData -> Bool +matchSpec (KeyGrip grip) (KeyData p _ _ _) + | matchpr grip (packet p)==grip = True + | otherwise = False + +matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps + where + ps = map (packet .fst) sigs + match p = isSignaturePacket p + && has_tag tag p + && has_issuer key p + has_issuer key p = isJust $ do + issuer <- signature_issuer p + guard $ matchpr issuer key == issuer + has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) + || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) + +matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us + where + us = filter (isInfixOf pat) $ Map.keys uids + +data UserIDRecord = UserIDRecord { + uid_full :: String, + uid_realname :: T.Text, + uid_user :: T.Text, + uid_subdomain :: T.Text, + uid_topdomain :: T.Text +} + deriving Show + +parseUID :: String -> UserIDRecord +parseUID str = UserIDRecord { + uid_full = str, + uid_realname = realname, + uid_user = user, + uid_subdomain = subdomain, + uid_topdomain = topdomain + } + where + text = T.pack str + (T.strip-> realname, T.dropAround isBracket-> email) + = T.break (=='<') text + (user, T.drop 1-> hostname) = T.break (=='@') email + ( T.reverse -> topdomain, + T.reverse . T.drop 1 -> subdomain) + = T.break (=='.') . T.reverse $ hostname +isBracket :: Char -> Bool +isBracket '<' = True +isBracket '>' = True +isBracket _ = False + + + + +data KeySpec = + KeyGrip String -- fp: + | KeyTag Packet String -- fp:????/t: + | KeyUidMatch String -- u: + deriving Show + +data MatchingField = UserIDField | KeyTypeField deriving (Show,Eq,Ord,Enum) +data SingleKeySpec = FingerprintMatch String + | SubstringMatch (Maybe MatchingField) String + | EmptyMatch + | AnyMatch + | WorkingKeyMatch + deriving (Show,Eq,Ord) + +-- A pair of specs. The first specifies an identity and the second +-- specifies a specific key (possibly master) associated with that +-- identity. +-- +-- When no slash is specified, context will decide whether the SingleKeySpec +-- is specifying an identity or a key belonging to the working identity. +type Spec = (SingleKeySpec,SingleKeySpec) + +parseSingleSpec :: String -> SingleKeySpec +parseSingleSpec "*" = AnyMatch +parseSingleSpec "-" = WorkingKeyMatch +parseSingleSpec "" = EmptyMatch +parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag +parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag +parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp +parseSingleSpec str + | is40digitHex str = FingerprintMatch str + | otherwise = SubstringMatch Nothing str + +is40digitHex xs = ys == xs && length ys==40 + where + ys = filter ishex xs + ishex c | '0' <= c && c <= '9' = True + | 'A' <= c && c <= 'F' = True + | 'a' <= c && c <= 'f' = True + ishex c = False + + + -- t:tor -- (FingerprintMatch "", SubstringMatch "tor") + -- u:joe -- (SubstringMatch "joe", FingerprintMatch "") + -- u:joe/ -- (SubstringMatch "joe", FingerprintMatch "!") + -- fp:4A39F/tor -- (FingerprintMatch "4A39F", SubstringMatch "tor") + -- u:joe/tor -- (SubstringMatch "joe", SubstringMatch "tor") + -- u:joe/t:tor -- (SubstringMatch "joe", SubstringMatch "tor") + -- u:joe/fp:4abf30 -- (SubstringMatch "joe", FingerprintMatch "4abf30") + -- joe/tor -- (SubstringMatch "joe", SubstringMatch "tor") + +-- | Parse a key specification. +-- The first argument is a grip for the default working key. +parseSpec :: String -> String -> (KeySpec,Maybe String) +parseSpec wkgrip spec = + if not slashed + then + case prespec of + AnyMatch -> (KeyGrip "", Nothing) + EmptyMatch -> error "Bad key spec." + WorkingKeyMatch -> (KeyGrip wkgrip, Nothing) + SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag) + SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str) + SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) + FingerprintMatch fp -> (KeyGrip fp, Nothing) + else + case (prespec,postspec) of + (FingerprintMatch fp, SubstringMatch st t) + | st /= Just UserIDField -> (KeyGrip fp, Just t) + (SubstringMatch mt u, _) + | postspec `elem` [AnyMatch,EmptyMatch] + && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing) + (SubstringMatch mt u, SubstringMatch st t) + | mt /= Just KeyTypeField + && st /= Just UserIDField -> (KeyUidMatch u, Just t) + (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec" + (_,FingerprintMatch fp) -> error "todo: support /fp: spec" + (FingerprintMatch fp,_) -> error "todo: support fp:/ spec" + _ -> error "Bad key spec." + where + (preslash,slashon) = break (=='/') spec + slashed = not $ null $ take 1 slashon + postslash = drop 1 slashon + + prespec = parseSingleSpec preslash + postspec = parseSingleSpec postslash + +{- + - BUGGY +parseSpec grip spec = (topspec,subspec) + where + (topspec0,subspec0) = unprefix '/' spec + (toptyp,top) = unprefix ':' topspec0 + (subtyp,sub) = unprefix ':' subspec0 + topspec = case () of + _ | null top && or [ subtyp=="fp" + , null subtyp && is40digitHex sub + ] + -> KeyGrip sub + _ | null top && null grip -> KeyUidMatch sub + _ | null top -> KeyGrip grip + _ | toptyp=="fp" || (null toptyp && is40digitHex top) + -> KeyGrip top + _ | toptyp=="u" -> KeyUidMatch top + _ -> KeyUidMatch top + subspec = case subtyp of + "t" -> Just sub + "fp" | top=="" -> Nothing + "" | top=="" && is40digitHex sub -> Nothing + "" -> listToMaybe sub >> Just sub + _ -> Nothing + + is40digitHex xs = ys == xs && length ys==40 + where + ys = filter ishex xs + ishex c | '0' <= c && c <= '9' = True + | 'A' <= c && c <= 'F' = True + | 'a' <= c && c <= 'f' = True + ishex c = False + + -- | Split a string into two at the first occurance of the given + -- delimiter. If the delimeter does not occur, then the first + -- item of the returned pair is empty and the second item is the + -- input string. + unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p)) + where p = break (==c) spec +-} + + +filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] +filterMatches spec ks = filter (matchSpec spec . snd) ks + +filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData +filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' + where + matchAll = KeyGrip "" + + subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip) + subkeySpec (topspec,Just mtag) = (topspec , KeyTag (packet p) mtag) + + match spec mps + = not . null + . snd + . seek_key spec + . map packet + $ mps + + old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub) + + oldOrMatch spec sub = old sub + || match spec (flattenSub "" True sub) + + subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty) + then oldOrMatch subspec + else old) + subs + where + (topspec,subspec) = subkeySpec spec + +selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet +selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db + +selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet +selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db + +selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])] +selectPublicKeyAndSigs (spec,mtag) db = + case mtag of + Nothing -> do + (kk,r) <- Map.toList $ fmap (findbyspec spec) db + (sub,sigs) <- r + return (kk,sub,sigs) + Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag + where + topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) + + findbyspec (KeyGrip g) kd = do + filter ismatch $ + topresult kd + : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs)) + (Map.elems $ keySubKeys kd) + where + ismatch (p,sigs) = matchpr g p ==g + findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] + + findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag + where + gettag (SubKey sub sigs) = do + let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs + (hastag,_) <- maybeToList mb + guard hastag + return $ (kk, packet sub, map (packet . fst) sigs) + +selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet +selectKey0 wantPublic (spec,mtag) db = do + let Message ps = flattenKeys wantPublic db + ys = snd $ seek_key spec ps + flip (maybe (listToMaybe ys)) mtag $ \tag -> do + case ys of + y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 + [] -> Nothing + +{- +selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] +selectAll wantPublic (spec,mtag) db = do + let Message ps = flattenKeys wantPublic db + ys = snd $ seek_key spec ps + y <- take 1 ys + case mtag of + Nothing -> return (y,Nothing) + Just tag -> + let search ys1 = do + let zs = snd $ seek_key (KeyTag y tag) ys1 + z <- take 1 zs + (y,Just z):search (drop 1 zs) + in search (drop 1 ys) +-} + +seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) +seek_key (KeyGrip grip) sec = (pre, subs) + where + (pre,subs) = break pred sec + pred p@(SecretKeyPacket {}) = matchpr grip p == grip + pred p@(PublicKeyPacket {}) = matchpr grip p == grip + pred _ = False + +seek_key (KeyTag key tag) ps + | null bs = (ps, []) + | null qs = + let (as', bs') = seek_key (KeyTag key tag) (tail bs) in + (as ++ (head bs : as'), bs') + | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) + where + (as,bs) = break (\p -> isSignaturePacket p + && has_tag tag p + && isJust (signature_issuer p) + && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) + ps + (rs,qs) = break isKey (reverse as) + + has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) + || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) + +seek_key (KeyUidMatch pat) ps + | null bs = (ps, []) + | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in + (as ++ (head bs : as'), bs') + | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) + where + (as,bs) = break (isInfixOf pat . uidStr) ps + (rs,qs) = break isKey (reverse as) + + uidStr (UserIDPacket s) = s + uidStr _ = "" + + +data InputFileContext = InputFileContext + { homesecPath :: FilePath + , homepubPath :: FilePath + } + +readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString +readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents +readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents +readInputFileS ctx inp = do + let fname = resolveInputFile ctx inp + fmap S.concat $ mapM S.readFile fname + +readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString +readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents +readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents +readInputFileL ctx inp = do + let fname = resolveInputFile ctx inp + fmap L.concat $ mapM L.readFile fname + + +writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs) +writeInputFileL ctx (FileDesc fd) bs = fdToHandle fd >>= (`L.hPut` bs) +writeInputFileL ctx inp bs = do + let fname = resolveInputFile ctx inp + mapM_ (`L.writeFile` bs) fname + +-- writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () +-- writeStamped0 :: InputFileContext -> InputFile + +getWriteFD :: InputFile -> Maybe Posix.Fd +getWriteFD (Pipe _ fd) = Just fd +getWriteFD (FileDesc fd) = Just fd +getWriteFD _ = Nothing + +writeStamped0 :: InputFileContext + -> InputFile + -> Posix.EpochTime + -> (Either Handle FilePath -> t -> IO ()) + -> t + -> IO () +writeStamped0 ctx (getWriteFD -> Just fd) stamp dowrite bs = do + h <- fdToHandle fd + dowrite (Left h) bs + handleIO_ (return ()) + $ setFdTimesHiRes fd (realToFrac stamp) (realToFrac stamp) +writeStamped0 ctx inp stamp dowrite bs = do + let fname = resolveInputFile ctx inp + forM_ fname $ \fname -> do + createDirectoryIfMissing True $ takeDirectory fname + dowrite (Right fname) bs + setFileTimes fname stamp stamp + +{- This may be useful later. Commented for now, as it is not used. + - +writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () +writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs +-} + +writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () +writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str + +getInputFileTime :: InputFileContext -> InputFile -> IO CTime +getInputFileTime ctx (Pipe fdr fdw) = do + mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr + maybe tryw return mt + where + tryw = do + handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?") + $ modificationTime <$> getFdStatus fdw +getInputFileTime ctx (FileDesc fd) = do + handleIO_ (error $ "&"++show fd++": modificaiton time?") $ + modificationTime <$> getFdStatus fd +getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do + handleIO_ (error $ fname++": modificaiton time?") $ + modificationTime <$> getFileStatus fname + +{- + - This may be useful later. Commented for now as it is not used. + - +doesInputFileExist :: InputFileContext -> InputFile -> IO Bool +doesInputFileExist ctx f = do + case resolveInputFile ctx f of + [n] -> doesFileExist n + _ -> return True +-} + + +cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString) +cachedContents maybePrompt ctx fd = do + ref <- newIORef Nothing + return $ get maybePrompt ref fd + where + trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs + + get maybePrompt ref fd = do + pw <- readIORef ref + flip (flip maybe return) pw $ do + if fd == FileDesc 0 then case maybePrompt of + Just prompt -> S.hPutStr stderr prompt + Nothing -> return () + else return () + pw <- fmap trimCR $ readInputFileS ctx fd + writeIORef ref (Just pw) + return pw + +importSecretKey :: + (MappedPacket -> IO (KikiCondition Packet)) + -> KikiCondition + (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) + -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) + -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) +importSecretKey doDecrypt db' tup = do + try db' $ \(db',report0) -> do + r <- doImport doDecrypt + db' + tup + try r $ \(db'',report) -> do + return $ KikiSuccess (db'', report0 ++ report) + + +mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext + -> IO + (KikiCondition + ( ( Map.Map [Char8.ByteString] KeyData + , ( [Hosts.Hosts] + , [Hosts.Hosts] + , Hosts.Hosts + , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))] + , [SockAddr])) + , [(FilePath,KikiReportAction)])) +mergeHostFiles krd db ctx = do + let hns = files ishosts + ishosts Hosts = True + ishosts _ = False + files istyp = do + (f,stream) <- Map.toList (opFiles krd) + guard (istyp $ typ stream) + return f + + hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL ctx) hns + + let gpgnames = map getHostnames $ Map.elems db + os = do + (addr,(ns,_)) <- gpgnames + n <- ns + return (addr,n) + setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os + -- we ensure .onion names are set properly + hostdbs = map setOnions hostdbs0 + outgoing_names = do + (addr,(_,gns)) <- gpgnames + guard . not $ null gns + guard $ all (null . Hosts.namesForAddress addr) hostdbs0 + return addr + -- putStrLn $ "hostdbs = " ++ show hostdbs + + -- 1. let U = union all the host dbs + -- preserving whitespace and comments of the first + let u0 = foldl' Hosts.plus Hosts.empty hostdbs + -- we filter U to be only finger-dresses + u1 = Hosts.filterAddrs (hasFingerDress db) u0 + + -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h + {- + putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}" + putStrLn $ "--> " ++ show (nf (head hostdbs)) + putStrLn $ "u0 = {\n" ++ show u0 ++ "}" + putStrLn $ "--> " ++ show (nf u0) + putStrLn $ "u1 = {\n" ++ show u1 ++ "}" + putStrLn $ "--> " ++ show (nf u1) + -} + + -- 2. replace gpg annotations with those in U + -- forM use_db + db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db + + return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[]) + +writeHostsFiles + :: KeyRingOperation -> InputFileContext + -> ([Hosts.Hosts], + [Hosts.Hosts], + Hosts.Hosts, + [(SockAddr, (t1, [Char8.ByteString]))], + [SockAddr]) + -> IO [(FilePath, KikiReportAction)] +writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do + let hns = files isMutableHosts + isMutableHosts (fill -> KF_None) = False + isMutableHosts (typ -> Hosts) = True + isMutableHosts _ = False + files istyp = do + (f,stream) <- Map.toList (opFiles krd) + guard (istyp stream) + return f -- resolveInputFile ctx f + + -- 3. add hostnames from gpg for addresses not in U + let u = foldl' f u1 ans + ans = reverse $ do + (addr,(_,ns)) <- gpgnames + guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0 + n <- ns + return (addr,n) + f h (addr,n) = Hosts.assignNewName addr n h + + -- 4. for each host db H, union H with U and write it out as H' + -- only if there is a non-empty diff + rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do + let h = h1 `Hosts.plus` u + d = Hosts.diff h0 h + rs = map ((fname,) . HostsDiff) d + unless (null d) $ writeInputFileL ctx fname $ Hosts.encode h + return $ map (first $ resolveForReport $ Just ctx) rs + return $ concat rss + +isSecretKey :: Packet -> Bool +isSecretKey (SecretKeyPacket {}) = True +isSecretKey _ = False + +buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation + -> IO (KikiCondition ((KeyDB + ,Maybe String + ,Maybe MappedPacket + ,([Hosts.Hosts], + [Hosts.Hosts], + Hosts.Hosts, + [(SockAddr, (KeyKey, KeyKey))], + [SockAddr]) + ,Map.Map InputFile Access + ,MappedPacket -> IO (KikiCondition Packet) + ,Map.Map InputFile Message + ) + ,[(FilePath,KikiReportAction)])) +buildKeyDB ctx grip0 keyring = do + let + files isring = do + (f,stream) <- Map.toList (opFiles keyring) + guard (isring $ typ stream) + resolveInputFile ctx f + + ringMap = Map.filter (isring . typ) $ opFiles keyring + + readp f stream = fmap readp0 $ readPacketsFromFile ctx f + where + readp0 ps = (stream { access = acc' }, ps) + where acc' = case access stream of + AutoAccess -> + case ps of + Message ((PublicKeyPacket {}):_) -> Pub + Message ((SecretKeyPacket {}):_) -> Sec + _ -> AutoAccess + acc -> acc + + readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) + + -- KeyRings (todo: KikiCondition reporting?) + (spilled,mwk,grip,accs,keys,unspilled) <- do +#if MIN_VERSION_containers(0,5,0) + ringPackets <- Map.traverseWithKey readp ringMap +#else + ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap +#endif + let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) + + let grip = grip0 `mplus` (fingerprint <$> fstkey) + where + fstkey = do + (_,Message ps) <- Map.lookup HomeSec ringPackets + listToMaybe ps + (spilled,unspilled) = Map.partition (spillable . fst) ringPackets + keys :: Map.Map KeyKey MappedPacket + keys = Map.foldl slurpkeys Map.empty + $ Map.mapWithKey filterSecrets ringPackets + where + filterSecrets f (_,Message ps) = + filter (isSecretKey . packet) + $ zipWith (mappedPacketWithHint fname) ps [1..] + where fname = resolveForReport (Just ctx) f + slurpkeys m ps = m `Map.union` Map.fromList ps' + where ps' = zip (map (keykey . packet) ps) ps + wk = listToMaybe $ do + fp <- maybeToList grip + let matchfp mp = not (is_subkey p) && matchpr fp p == fp + where p = packet mp + Map.elems $ Map.filter matchfp keys + accs = fmap (access . fst) ringPackets + return (spilled,wk,grip,accs,keys,fmap snd unspilled) + + doDecrypt <- makeMemoizingDecrypter keyring ctx keys + + let wk = fmap packet mwk + rt0 = KeyRingRuntime { rtPubring = homepubPath ctx + , rtSecring = homesecPath ctx + , rtGrip = grip + , rtWorkingKey = wk + , rtRingAccess = accs + , rtKeyDB = Map.empty + , rtPassphrases = doDecrypt + } + transformed0 <- + let trans f (info,ps) = do + let manip = combineTransforms (transforms info) + rt1 = rt0 { rtKeyDB = merge Map.empty f ps } + acc = Just Sec /= Map.lookup f accs + r <- performManipulations doDecrypt rt1 mwk manip + try r $ \(rt2,report) -> do + return $ KikiSuccess (report,(info,flattenKeys acc $ rtKeyDB rt2)) +#if MIN_VERSION_containers(0,5,0) + in fmap sequenceA $ Map.traverseWithKey trans spilled +#else + in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled +#endif + try transformed0 $ \transformed -> do + let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed + where + mergeIt db f (_,(info,ps)) = merge db f ps + reportTrans = concat $ Map.elems $ fmap fst transformed + + -- Wallets + let importWalletKey wk db' (top,fname,sub,tag) = do + try db' $ \(db',report0) -> do + r <- doImportG doDecrypt + db' + (fmap keykey $ maybeToList wk) + [mkUsage tag] + fname + sub + try r $ \(db'',report) -> do + return $ KikiSuccess (db'', report0 ++ report) + + wms <- mapM (readw wk) (files iswallet) + let wallet_keys = do + maybeToList wk + (fname,xs) <- wms + (_,sub,(_,m)) <- xs + (tag,top) <- Map.toList m + return (top,fname,sub,tag) + db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys + try db $ \(db,reportWallets) -> do + + -- PEM files + let pems = do + (n,stream) <- Map.toList $ opFiles keyring + grip <- maybeToList grip + n <- resolveInputFile ctx n + guard $ spillable stream && isSecretKeyFile (typ stream) + let us = mapMaybe usageFromFilter [fill stream,spill stream] + usage <- take 1 us + guard $ all (==usage) $ drop 1 us + -- TODO: KikiCondition reporting for spill/fill usage mismatch? + let (topspec,subspec) = parseSpec grip usage + ms = map fst $ filterMatches topspec (Map.toList db) + cmd = initializer stream + return (n,subspec,ms,stream, cmd) + imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems + db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports + try db $ \(db,reportPEMs) -> do + + r <- mergeHostFiles keyring db ctx + try r $ \((db,hs),reportHosts) -> do + + return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) + , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts ) + +torhash :: Packet -> String +torhash key = fromMaybe "" $ derToBase32 <$> derRSA key + +derToBase32 :: ByteString -> String +#if !defined(VERSION_cryptonite) +derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy +#else +derToBase32 = map toLower . Base32.encode . S.unpack . sha1 + where + sha1 :: L.ByteString -> S.ByteString + sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1) +#endif + +derRSA :: Packet -> Maybe ByteString +derRSA rsa = do + k <- rsaKeyFromPacket rsa + return $ encodeASN1 DER (toASN1 k []) + +unconditionally :: IO (KikiCondition a) -> IO a +unconditionally action = do + r <- action + case r of + KikiSuccess x -> return x + e -> error $ errorString e + +try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b) +try x body = + case functorToEither x of + Left e -> return e + Right x -> body x + + +data ParsedCert = ParsedCert + { pcertKey :: Packet + , pcertTimestamp :: UTCTime + , pcertBlob :: L.ByteString + } + deriving (Show,Eq) +data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert + deriving (Show,Eq) + +spemPacket (PEMPacket p) = Just p +spemPacket _ = Nothing + +spemCert (PEMCertificate p) = Just p +spemCert _ = Nothing + +toStrict :: L.ByteString -> S.ByteString +toStrict = foldr1 (<>) . L.toChunks + +-- No instance for (ASN1Object RSA.PublicKey) + +parseCertBlob comp bs = do + asn1 <- either (const Nothing) Just + $ decodeASN1 DER bs + let asn1' = drop 2 asn1 + cert <- either (const Nothing) (Just . fst) (fromASN1 asn1') + let _ = cert :: X509.Certificate + notBefore :: UTCTime +#if MIN_VERSION_x509(1,5,0) + notBefore = toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano + where (vincentTime,_) = X509.certValidity cert +#else + (notBefore,_) = X509.certValidity cert +#endif + case X509.certPubKey cert of + X509.PubKeyRSA key -> do + let withoutkey = + let ekey = toStrict $ encodeASN1 DER (toASN1 key []) + (pre,post) = S.breakSubstring ekey $ toStrict bs + post' = S.drop (S.length ekey) post + len :: Word16 + len = if S.null post then maxBound + else fromIntegral $ S.length pre + in if len < 4096 + then encode len <> GZip.compress (Char8.fromChunks [pre,post']) + else bs + return + ParsedCert { pcertKey = packetFromPublicRSAKey notBefore + (MPI $ RSA.public_n key) + (MPI $ RSA.public_e key) + , pcertTimestamp = notBefore + , pcertBlob = if comp then withoutkey + else bs + } + _ -> Nothing + +packetFromPublicRSAKey notBefore n e = + PublicKeyPacket { version = 4 + , timestamp = round $ utcTimeToPOSIXSeconds notBefore + , key_algorithm = RSA + , key = [('n',n),('e',e)] + , is_subkey = True + , v3_days_of_validity = Nothing + } + +decodeBlob cert = + if 0 /= (bs `L.index` 0) .&. 0x10 + then bs + else let (keypos0,bs') = L.splitAt 2 bs + keypos :: Word16 + keypos = decode keypos0 + ds = GZip.decompress bs' + (prekey,postkey) = L.splitAt (fromIntegral keypos) ds + in prekey <> key <> postkey + where + bs = pcertBlob cert + key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert + +extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey +extractRSAKeyFields kvs = do + let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs + n <- lookup "Modulus" kvs' + e <- lookup "PublicExponent" kvs' + d <- lookup "PrivateExponent" kvs' + p <- lookup "Prime1" kvs' -- p + q <- lookup "Prime2" kvs' -- q + dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1) + dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1) + u <- lookup "Coefficient" kvs' + {- + case (d,p,dmodp1) of + (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return () + _ -> error "dmodp fail!" + case (d,q,dmodqminus1) of + (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return () + _ -> error "dmodq fail!" + -} + return $ RSAPrivateKey + { rsaN = n + , rsaE = e + , rsaD = d + , rsaP = p + , rsaQ = q + , rsaDmodP1 = dmodp1 + , rsaDmodQminus1 = dmodqminus1 + , rsaCoefficient = u } + where + parseField blob = MPI <$> m + where m = bigendian <$> Base64.decode (Char8.unpack blob) + + bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs + where + nlen = length bs + +rsaToPGP stamp rsa = SecretKeyPacket + { version = 4 + , timestamp = fromTime stamp -- toEnum (fromEnum stamp) + , key_algorithm = RSA + , key = [ -- public fields... + ('n',rsaN rsa) + ,('e',rsaE rsa) + -- secret fields + ,('d',rsaD rsa) + ,('p',rsaQ rsa) -- Note: p & q swapped + ,('q',rsaP rsa) -- Note: p & q swapped + ,('u',rsaCoefficient rsa) + ] + -- , ecc_curve = def + , s2k_useage = 0 + , s2k = S2K 100 "" + , symmetric_algorithm = Unencrypted + , encrypted_data = "" + , is_subkey = True + } + +readSecretDNSFile :: InputFile -> IO Packet +readSecretDNSFile fname = do + let ctx = InputFileContext "" "" + stamp <- getInputFileTime ctx fname + input <- readInputFileL ctx fname + let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1) + . Char8.break (==':')) + $ Char8.lines input + alg = maybe RSA parseAlg $ lookup "Algorithm" kvs + parseAlg spec = case Char8.words spec of + nstr:_ -> case read (Char8.unpack nstr) :: Int of + 2 -> DH + 3 -> DSA -- SHA1 + 5 -> RSA -- SHA1 + 6 -> DSA -- NSEC3-SHA1 (RFC5155) + 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155) + 8 -> RSA -- SHA256 + 10 -> RSA -- SHA512 (RFC5702) + -- 12 -> GOST + 13 -> ECDSA -- P-256 SHA256 (RFC6605) + 14 -> ECDSA -- P-384 SHA384 (RFC6605) + _ -> RSA + case alg of + RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs + + +readSecretPEMFile :: InputFile -> IO [SecretPEMData] +readSecretPEMFile fname = do + -- warn $ fname ++ ": reading ..." + let ctx = InputFileContext "" "" + -- Note: The key's timestamp is included in it's fingerprint. + -- Therefore, we should attempt to preserve it. + stamp <- getInputFileTime ctx fname + input <- readInputFileL ctx fname + let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input + pkcs1 = fmap (parseRSAPrivateKey . pemBlob) + $ pemParser $ Just "RSA PRIVATE KEY" + cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob) + $ pemParser $ Just "CERTIFICATE" + parseRSAPrivateKey dta = do + let e = decodeASN1 DER dta + asn1 <- either (const $ mzero) return e + rsa <- either (const mzero) (return . fst) (fromASN1 asn1) + let _ = rsa :: RSAPrivateKey + return $ PEMPacket $ rsaToPGP stamp rsa + dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta + mergeDate (_,obj) (Left tm) = (fromTime tm,obj) + mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key') + where key' = if tm < fromTime (timestamp key) + then key { timestamp = fromTime tm } + else key + mergeDate (tm,_) (Right mb) = (tm,mb) + return $ dta + +doImport + :: Ord k => + (MappedPacket -> IO (KikiCondition Packet)) + -> Map.Map k KeyData + -> (FilePath, Maybe [Char], [k], StreamInfo, t) + -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) +doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do + flip (maybe $ return CannotImportMasterKey) + subspec $ \tag -> do + (certs,keys) <- case typ of + PEMFile -> do + ps <- readSecretPEMFile (ArgFile fname) + let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) + = partition (isJust . spemCert) ps + return (certs,keys) + DNSPresentation -> do + p <- readSecretDNSFile (ArgFile fname) + return ([],[p]) + -- TODO Probably we need to move to a new design where signature + -- packets are merged into the database in one phase with null + -- signatures, and then the signatures are made in the next phase. + -- This would let us merge annotations (like certificates) from + -- seperate files. + foldM (importKey tag certs) (KikiSuccess (db,[])) keys + where + importKey tag certs prior key = do + try prior $ \(db,report) -> do + let (m0,tailms) = splitAt 1 ms + if (not (null tailms) || null m0) + then return $ AmbiguousKeySpec fname + else do + let kk = keykey key + cs = filter (\c -> kk==keykey (pcertKey c)) certs + blobs = map mkCertNotation $ nub $ map pcertBlob cs + mkCertNotation bs = NotationDataPacket + { human_readable = False + , notation_name = "x509cert@" + , notation_value = Char8.unpack bs } + datedKey = key { timestamp = fromTime $ minimum dates } + dates = fromTime (timestamp key) : map pcertTimestamp certs + r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey + try r $ \(db',report') -> do + return $ KikiSuccess (db',report++report') + +doImportG + :: Ord k => + (MappedPacket -> IO (KikiCondition Packet)) + -> Map.Map k KeyData + -> [k] + -> [SignatureSubpacket] + -> [Char] + -> Packet + -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) +doImportG doDecrypt db m0 tags fname key = do + let kk = head m0 + Just (KeyData top topsigs uids subs) = Map.lookup kk db + subkk = keykey key + (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) + []) + ( (False,) . addOrigin ) + (Map.lookup subkk subs) + where + addOrigin (SubKey mp sigs) = + let mp' = mp + { locations = Map.insert fname + (origin (packet mp) (-1)) + (locations mp) } + in SubKey mp' sigs + subs' = Map.insert subkk subkey subs + + istor = do + guard ("tor" `elem` mapMaybe usage tags) + return $ "Anonymous " + + uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do + let has_torid = do + -- TODO: check for omitted real name field + (sigtrusts,om) <- Map.lookup idstr uids + listToMaybe $ do + s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) + signatures_over $ verify (Message [packet top]) s + flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do + wkun <- doDecrypt top + + try wkun $ \wkun -> do + + let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) + uid = UserIDPacket idstr + -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags + tor_ov = makeInducerSig (packet top) wkun uid keyflags + sig_ov <- pgpSign (Message [wkun]) + tor_ov + SHA1 + (fingerprint wkun) + flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) + (sig_ov >>= listToMaybe . signatures_over) + $ \sig -> do + let om = Map.singleton fname (origin sig (-1)) + trust = Map.empty + return $ KikiSuccess + ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} + , trust)],om) uids + , [] ) + + try uids' $ \(uids',report) -> do + + let SubKey subkey_p subsigs = subkey + wk = packet top + (xs',minsig,ys') = findTag tags wk key subsigs + doInsert mbsig db = do + -- NEW SUBKEY BINDING SIGNATURE + sig' <- makeSig doDecrypt top fname subkey_p tags mbsig + try sig' $ \(sig',report) -> do + report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] + let subs' = Map.insert subkk + (SubKey subkey_p $ xs'++[sig']++ys') + subs + return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db + , report ) + + report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) + else id + s = show (fmap fst minsig,fingerprint key) + in return (f report) + + case minsig of + Nothing -> doInsert Nothing db -- we need to create a new sig + Just (True,sig) -> -- we can deduce is_new == False + -- we may need to add a tor id + return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db + , report ) + Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag + +isCryptoCoinKey :: Packet -> Bool +isCryptoCoinKey p = + and [ isKey p + , key_algorithm p == ECDSA + , lookup 'c' (key p) == Just (MPI secp256k1_id) + ] + +getCryptoCoinTag :: Packet -> Maybe CryptoCoins.CoinNetwork +getCryptoCoinTag p | isSignaturePacket p = do + -- CryptoCoins.secret + let sps = hashed_subpackets p ++ unhashed_subpackets p + u <- listToMaybe $ mapMaybe usage sps + CryptoCoins.lookupNetwork CryptoCoins.network_name u +getCryptoCoinTag _ = Nothing + + +coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPacket)] +coinKeysOwnedBy db wk = do + wk <- maybeToList wk + let kk = keykey wk + KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db + (subkk,SubKey mp sigs) <- Map.toList subs + let sub = packet mp + guard $ isCryptoCoinKey sub + tag <- take 1 $ mapMaybe (getCryptoCoinTag . packet . fst) sigs + return (tag,mp) + +walletImportFormat :: Word8 -> Packet -> String +walletImportFormat idbyte k = secret_base58_foo + where + -- isSecret (SecretKeyPacket {}) = True + -- isSecret _ = False + secret_base58_foo = base58_encode seckey + Just d = lookup 'd' (key k) + (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d) + seckey = S.cons idbyte bigendian + +writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)]) +writeWalletKeys krd db wk = do + let cs = db `coinKeysOwnedBy` wk + -- export wallet keys + isMutableWallet (fill -> KF_None) = False + isMutableWallet (typ -> WalletFile {}) = True + isMutableWallet _ = False + files pred = do + (f,stream) <- Map.toList (opFiles krd) + guard (pred stream) + resolveInputFile (InputFileContext "" "") f + let writeWallet report n = do + let cs' = do + (nw,mp) <- cs + -- let fns = Map.keys (locations mp) + -- trace ("COIN KEY: "++show fns) $ return () + guard . not $ Map.member n (locations mp) + let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp) + return (CryptoCoins.network_name nw,wip) + handleIO_ (return report) $ do + -- TODO: This AppendMode stratagy is not easy to adapt from FilePath-based + -- to InputFile-based. + withFile n AppendMode $ \fh -> do + rs <- forM cs' $ \(net,wip) -> do + hPutStrLn fh wip + return (n, NewWalletKey net) + return (report ++ rs) + report <- foldM writeWallet [] (files isMutableWallet) + return $ KikiSuccess report + +ifSecret :: Packet -> t -> t -> t +ifSecret (SecretKeyPacket {}) t f = t +ifSecret _ t f = f + +showPacket :: Packet -> String +showPacket p | isKey p = (if is_subkey p + then showPacket0 p + else ifSecret p "----Secret-----" "----Public-----") + ++ " "++show (key_algorithm p)++" "++fingerprint p + | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) + | otherwise = showPacket0 p +showPacket0 p = concat . take 1 $ words (show p) + + +-- | returns Just True so as to indicate that +-- the public portions of keys will be imported +importPublic :: Maybe Bool +importPublic = Just True + +-- | returns False True so as to indicate that +-- the public portions of keys will be imported +importSecret :: Maybe Bool +importSecret = Just False + + +-- TODO: Do we need to memoize this? +guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe () +guardAuthentic rt keydata = guard (isauth rt keydata) + +isauth :: KeyRingRuntime -> KeyData -> Bool +isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk + where wk = workingKey (rtGrip rt) (rtKeyDB rt) + dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt) + $ locations p + has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids + where + goodsig (uidstr,(sigs,_)) = not . null $ do + sig0 <- fmap (packet . fst) sigs + pre_ov <- signatures (Message [packet k, UserIDPacket uidstr, sig0]) + signatures_over $ verify (Message [wk]) pre_ov + + workingKey grip use_db = listToMaybe $ do + fp <- maybeToList grip + elm <- Map.elems use_db + guard $ matchSpec (KeyGrip fp) elm + return $ keyPacket elm + +writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message + -> [(FilePath,KikiReportAction)] + {- + -> KeyDB -> Maybe Packet + -> FilePath -> FilePath + -} + -> IO (KikiCondition [(FilePath,KikiReportAction)]) +writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do + let isring (KeyRingFile {}) = True + isring _ = False + db = rtKeyDB rt + secring = rtSecring rt + pubring = rtPubring rt + ctx = InputFileContext secring pubring + let s = do + (f,f0,stream) <- do + (f0,stream) <- Map.toList (opFiles krd) + guard (isring $ typ stream) + f <- resolveInputFile ctx f0 + return (f,f0,stream) + let db' = fromMaybe db $ do + msg <- Map.lookup f0 unspilled + return $ merge db f0 msg + x = do + let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool + wantedForFill acc KF_None = importByExistingMaster + -- Note the KF_None case is almost irrelevent as it will be + -- filtered later when isMutable returns False. + -- We use importByExistingMaster in order to generate + -- MissingPacket warnings. To disable those warnings, use + -- const Nothing instead. + wantedForFill acc (KF_Match {}) = importByExistingMaster + wantedForFill acc KF_Subkeys = importByExistingMaster + wantedForFill acc KF_Authentic = \kd -> do guardAuthentic rt kd + importByAccess acc kd + wantedForFill acc KF_All = importByAccess acc + importByAccess Pub kd = importPublic + importByAccess Sec kd = importSecret + importByAccess AutoAccess kd = + mplus (importByExistingMaster kd) + (error $ f ++ ": write public or secret key to file?") + importByExistingMaster kd@(KeyData p _ _ _) = + fmap originallyPublic $ Map.lookup f $ locations p + d <- sortByHint f keyMappedPacket (Map.elems db') + acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt) + only_public <- maybeToList $ wantedForFill acc (fill stream) d + guard $ only_public || isSecretKey (keyPacket d) + case fill stream of + KF_Match usage -> do grip <- maybeToList $ rtGrip rt + flattenTop f only_public + $ filterNewSubs f (parseSpec grip usage) d + _ -> flattenTop f only_public d + new_packets = filter isnew x + where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) + -- TODO: We depend on an exact string match between the reported + -- file origin of the deleted packet and the path of the file we are + -- writing. Verify that this is a safe assumption. + isdeleted (f',DeletedPacket _) = f'==f + isdeleted _ = False + guard (not (null new_packets) || any isdeleted report_manips) + return ((f0,isMutable stream),(new_packets,x)) + let (towrites,report) = (\f -> foldl f ([],[]) s) $ + \(ws,report) ((f,mutable),(new_packets,x)) -> + if mutable + then + let rs = flip map new_packets + $ \c -> (concat $ resolveInputFile ctx f, NewPacket $ showPacket (packet c)) + in (ws++[(f,x)],report++rs) + else + let rs = flip map new_packets + $ \c -> (concat $ resolveInputFile ctx f,MissingPacket (showPacket (packet c))) + in (ws,report++rs) + forM_ towrites $ \(f,x) -> do + let m = Message $ map packet x + -- warn $ "writing "++f + writeInputFileL ctx f (encode m) + return $ KikiSuccess report + + +{- +getSubkeysForExport kk subspec db = do + kd <- maybeToList $ Map.lookup kk db + subkeysForExport subspec kd +-} + +-- | If provided Nothing for the first argument, this function returns the +-- master key of the given identity. Otherwise, it returns all the subkeys of +-- the given identity which have a usage tag that matches the first argument. +subkeysForExport :: Maybe String -> KeyData -> [MappedPacket] +subkeysForExport subspec (KeyData key _ _ subkeys) = do + let subs tag = do + e <- Map.elems subkeys + guard $ doSearch key tag e + return $ subkeyMappedPacket e + maybe [key] subs subspec + where + doSearch key tag (SubKey sub_mp sigtrusts) = + let (_,v,_) = findTag [mkUsage tag] + (packet key) + (packet sub_mp) + sigtrusts + in fmap fst v==Just True + +writePEM :: String -> String -> String +writePEM typ dta = pem + where + pem = unlines . concat $ + [ ["-----BEGIN " <> typ <> "-----"] + , split64s dta + , ["-----END " <> typ <> "-----"] ] + split64s :: String -> [String] + split64s "" = [] + split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta + + -- 64 byte lines + +rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey +rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do + -- public fields... + n <- lookup 'n' $ key pkt + e <- lookup 'e' $ key pkt + -- secret fields + MPI d <- lookup 'd' $ key pkt + MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped + MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped + + -- Note: Here we fail if 'u' key is missing. + -- Ideally, it would be better to compute (inverse q) mod p + -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg + -- (package constructive-algebra) + coefficient <- lookup 'u' $ key pkt + + let dmodp1 = MPI $ d `mod` (p - 1) + dmodqminus1 = MPI $ d `mod` (q - 1) + return $ RSAPrivateKey + { rsaN = n + , rsaE = e + , rsaD = MPI d + , rsaP = MPI p + , rsaQ = MPI q + , rsaDmodP1 = dmodp1 + , rsaDmodQminus1 = dmodqminus1 + , rsaCoefficient = coefficient } +rsaPrivateKeyFromPacket _ = Nothing + +secretPemFromPacket packet = pemFromPacket Sec packet + +pemFromPacket Sec packet = + case key_algorithm packet of + RSA -> do + rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey + let asn1 = toASN1 rsa [] + bs = encodeASN1 DER asn1 + dta = Base64.encode (L.unpack bs) + output = writePEM "RSA PRIVATE KEY" dta + Just output + algo -> Nothing +pemFromPacket Pub packet = + case key_algorithm packet of + RSA -> do + rsa <- rsaKeyFromPacket packet + let asn1 = toASN1 (pkcs8 rsa) [] + bs = encodeASN1 DER asn1 + dta = Base64.encode (L.unpack bs) + output = writePEM "PUBLIC KEY" dta + Just output + algo -> Nothing +pemFromPacket AutoAccess p@(PublicKeyPacket {}) = pemFromPacket Pub p +pemFromPacket AutoAccess p@(SecretKeyPacket {}) = pemFromPacket Sec p +pemFromPacket AutoAccess _ = Nothing + +writeKeyToFile :: + Bool -> StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)] +writeKeyToFile False stream@(StreamInfo { typ = PEMFile }) fname packet = do + case pemFromPacket (access stream) packet of + Just output -> do + let stamp = toEnum . fromEnum $ timestamp packet + handleIO_ (return [(fname, FailedFileWrite)]) $ do + saved_mask <- setFileCreationMask 0o077 + -- Note: The key's timestamp is included in it's fingerprint. + -- Therefore, we should attempt to preserve it. + writeStamped (InputFileContext "" "") fname stamp output + setFileCreationMask saved_mask + return [(fname, ExportedSubkey)] + Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)] + +writeKeyToFile False StreamInfo { typ = DNSPresentation } fname packet = do + case key_algorithm packet of + RSA -> do + flip (maybe (return [])) + (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey + $ \rsa -> do + let -- asn1 = toASN1 rsa [] + -- bs = encodeASN1 DER asn1 + -- dta = Base64.encode (L.unpack bs) + b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i) + where + MPI i = ac rsa + i2bs_unsized :: Integer -> S.ByteString + i2bs_unsized 0 = S.singleton 0 + i2bs_unsized i = S.reverse $ S.unfoldr go i + where go i' = if i' <= 0 then Nothing + else Just (fromIntegral i', (i' `shiftR` 8)) + output = unlines + [ "Private-key-format: v1.2" + , "Algorithm: 8 (RSASHA256)" + , "Modulus: " ++ b64 rsaN rsa + , "PublicExponent: " ++ b64 rsaE rsa + , "PrivateExponent: " ++ b64 rsaD rsa + , "Prime1: " ++ b64 rsaP rsa + , "Prime2: " ++ b64 rsaQ rsa + , "Exponent1: " ++ b64 rsaDmodP1 rsa + , "Exponent2: " ++ b64 rsaDmodQminus1 rsa + , "Coefficient: " ++ b64 rsaCoefficient rsa + ] + stamp = toEnum . fromEnum $ timestamp packet + handleIO_ (return [(fname, FailedFileWrite)]) $ do + saved_mask <- setFileCreationMask 0o077 + -- Note: The key's timestamp is included in it's fingerprint. + -- Therefore, we should attempt to preserve it. + writeStamped (InputFileContext "" "") fname stamp output + setFileCreationMask saved_mask + return [(fname, ExportedSubkey)] + algo -> return [(fname, UnableToExport algo $ fingerprint packet)] + +writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet)) + -> KeyDB + -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)] + -> IO (KikiCondition [(FilePath,KikiReportAction)]) +writePEMKeys doDecrypt db exports = do + ds <- mapM decryptKeys exports + let ds' = map functorToEither ds + if null (lefts ds') + then do + rs <- mapM (\(f,stream,p) -> writeKeyToFile False stream (ArgFile f) p) + (rights ds') + return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs) + else do + return (head $ lefts ds') + where + decryptKeys (fname,subspec,[p],stream@(StreamInfo { access=Pub })) + = return $ KikiSuccess (fname,stream,packet p) -- public keys are never encrypted. + decryptKeys (fname,subspec,[p],stream) = do + pun <- doDecrypt p + try pun $ \pun -> do + return $ KikiSuccess (fname,stream,pun) + +makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext + -> Map.Map KeyKey MappedPacket + -> IO (MappedPacket -> IO (KikiCondition Packet)) +makeMemoizingDecrypter operation ctx keys = + if null chains then do + -- (*) Notice we do not pass ctx to resolveForReport. + -- This is because the merge function does not currently use a context + -- and the pws map keys must match the MappedPacket locations. + -- TODO: Perhaps these should both be of type InputFile rather than + -- FilePath? + -- pws :: Map.Map FilePath (IO S.ByteString) + {- + pws <- + Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) + (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above + $ Map.filter (isJust . pwfile . typ) $ opFiles operation) + -} + let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" + pws2 <- + Traversable.mapM (cachedContents prompt ctx) + $ Map.fromList $ mapMaybe + (\spec -> (,passSpecPassFile spec) `fmap` do + guard $ isNothing $ passSpecKeySpec spec + passSpecRingFile spec) + passspecs + defpw <- do + Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) + $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) + && isNothing (passSpecKeySpec sp)) + $ opPassphrases operation + unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) + return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw + else let PassphraseMemoizer f = head chains + in return f + where + (chains,passspecs) = partition isChain $ opPassphrases operation + where isChain (PassphraseMemoizer {}) = True + isChain _ = False + doDecrypt :: IORef (Map.Map KeyKey Packet) + -> Map.Map FilePath (IO S.ByteString) + -> Maybe (IO S.ByteString) + -> MappedPacket + -> IO (KikiCondition Packet) + doDecrypt unkeysRef pws defpw mp0 = do + unkeys <- readIORef unkeysRef + let mp = fromMaybe mp0 $ do + k <- Map.lookup kk keys + return $ mergeKeyPacket "decrypt" mp0 k + wk = packet mp0 + kk = keykey wk + fs = Map.keys $ locations mp + + decryptIt [] = return BadPassphrase + decryptIt (getpw:getpws) = do + -- TODO: This function should use mergeKeyPacket to + -- combine the packet with it's unspilled version before + -- attempting to decrypt it. + pw <- getpw + let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp) + case symmetric_algorithm wkun of + Unencrypted -> do + writeIORef unkeysRef (Map.insert kk wkun unkeys) + return $ KikiSuccess wkun + _ -> decryptIt getpws + + getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw + + case symmetric_algorithm wk of + Unencrypted -> return (KikiSuccess wk) + _ -> maybe (decryptIt getpws) + (return . KikiSuccess) + $ Map.lookup kk unkeys + +performManipulations :: + (MappedPacket -> IO (KikiCondition Packet)) + -> KeyRingRuntime + -> Maybe MappedPacket + -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) + -> IO (KikiCondition (KeyRingRuntime,KikiReport)) +performManipulations doDecrypt rt wk manip = do + let db = rtKeyDB rt + performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd + r <- Traversable.mapM performAll db + try (sequenceA r) $ \db -> do + return $ KikiSuccess (rt { rtKeyDB = fmap fst db }, concatMap snd $ Map.elems db) + where + perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) + perform kd (InducerSignature uid subpaks) = do + try kd $ \(kd,report) -> do + flip (maybe $ return NoWorkingKey) wk $ \wk' -> do + wkun' <- doDecrypt wk' + try wkun' $ \wkun -> do + let flgs = if keykey (keyPacket kd) == keykey wkun + then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs) + else [] + sigOver = makeInducerSig (keyPacket kd) + wkun + (UserIDPacket uid) + $ flgs ++ subpaks + om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid + toMappedPacket om p = (mappedPacket "" p) {locations=om} + selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard + . (== keykey whosign) + . keykey)) vs + keys = map keyPacket $ Map.elems (rtKeyDB rt) + overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig]) + vs :: [ ( Packet -- signature + , Maybe SignatureOver -- Nothing means non-verified + , Packet ) -- key who signed + ] + vs = do + x <- maybeToList $ Map.lookup uid (keyUids kd) + sig <- map (packet . fst) (fst x) + o <- overs sig + k <- keys + let ov = verify (Message [k]) $ o + signatures_over ov + return (sig,Just ov,k) + additional new_sig = do + new_sig <- maybeToList new_sig + guard (null $ selfsigs) + signatures_over new_sig + sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) + let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) + f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x + , om `Map.union` snd x ) + -- XXX: Shouldn't this signature generation show up in the KikiReport ? + return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report ) + + perform kd (SubKeyDeletion topk subk) = do + try kd $ \(kd,report) -> do + let kk = keykey $ packet $ keyMappedPacket kd + kd' | kk /= topk = kd + | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd } + pred k _ = k /= subk + ps = concat $ maybeToList $ do + SubKey mp sigs <- Map.lookup subk (keySubKeys kd) + return $ packet mp : concatMap (\(p,ts) -> packet p : Map.elems ts) sigs + ctx = InputFileContext (rtSecring rt) (rtPubring rt) + rings = [HomeSec, HomePub] >>= resolveInputFile ctx + return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ]) + +initializeMissingPEMFiles :: + KeyRingOperation + -> InputFileContext -> Maybe String + -> (MappedPacket -> IO (KikiCondition Packet)) + -> KeyDB + -> IO (KikiCondition ( (KeyDB,[( FilePath + , Maybe String + , [MappedPacket] + , StreamInfo )]) + , [(FilePath,KikiReportAction)])) +initializeMissingPEMFiles operation ctx grip decrypt db = do + nonexistents <- + filterM (fmap not . doesFileExist . fst) + $ do (f,t) <- Map.toList (opFiles operation) + f <- resolveInputFile ctx f + return (f,t) + + let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do + (fname,stream) <- nonexistents + guard $ isMutable stream + guard $ isSecretKeyFile (typ stream) + usage <- usageFromFilter (fill stream) -- TODO: Error if no result? + let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage + -- ms will contain duplicates if a top key has multiple matching + -- subkeys. This is intentional. + -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db + -- ms = filterMatches topspec $ Map.toList db + ns = do + (kk,kd) <- filterMatches topspec $ Map.toList db + return (kk , subkeysForExport subspec kd) + return (fname,subspec,ns,stream) + (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) + notmissing + exports = map (\(f,subspec,ns,stream) -> (f,subspec,ns >>= snd,stream)) exports0 + + ambiguity (f,topspec,subspec,_) = do + return $ AmbiguousKeySpec f + + ifnotnull (x:xs) f g = f x + ifnotnull _ f g = g + + ifnotnull ambiguous ambiguity $ do + + -- create nonexistent files via external commands + do + let cmds = mapMaybe getcmd missing + where + getcmd (fname,subspec,ms,stream) = do + cmd <- initializer stream + return (fname,subspec,ms,stream,cmd) + rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do + e <- systemEnv [ ("file",fname) + , ("usage",fromMaybe "" subspec) ] + cmd + case e of + ExitFailure num -> return (tup,FailedExternal num) + ExitSuccess -> return (tup,ExternallyGeneratedFile) + + v <- foldM (importSecretKey decrypt) + (KikiSuccess (db,[])) $ do + ((f,subspec,ms,stream,cmd),r) <- rs + guard $ case r of + ExternallyGeneratedFile -> True + _ -> False + return (f,subspec,map fst ms,stream,cmd) + + try v $ \(db,import_rs) -> do + return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs + ++ import_rs) +{- +interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData +interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" +interpretManip kd manip = return kd +-} + +combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] +combineTransforms trans rt kd = updates + where + updates = -- kManip operation rt kd ++ + concatMap (\t -> resolveTransform t rt kd) sanitized + sanitized = group (sort trans) >>= take 1 + +isSubkeySignature (SubkeySignature {}) = True +isSubkeySignature _ = False + +-- Returned data is simmilar to getBindings but the Word8 codes +-- are ORed together. +accBindings :: + Bits t => + [(t, (Packet, Packet), [a], [a1], [a2])] + -> [(t, (Packet, Packet), [a], [a1], [a2])] +accBindings bs = as + where + gs = groupBy samePair . sortBy (comparing bindingPair) $ bs + as = map (foldl1 combine) gs + bindingPair (_,p,_,_,_) = pub2 p + where + pub2 (a,b) = (pub a, pub b) + pub a = fingerprint_material a + samePair a b = bindingPair a == bindingPair b + combine (ac,p,akind,ahashed,aclaimaints) + (bc,_,bkind,bhashed,bclaimaints) + = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) + + + +verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) + where + verified = do + sig <- signatures (Message nonkeys) + let v = verify (Message keys) sig + guard (not . null $ signatures_over v) + return v + (top,othersigs) = partition isSubkeySignature verified + embedded = do + sub <- top + let sigover = signatures_over sub + unhashed = sigover >>= unhashed_subpackets + subsigs = mapMaybe backsig unhashed + -- This should consist only of 0x19 values + -- subtypes = map signature_type subsigs + -- trace ("subtypes = "++show subtypes) (return ()) + -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ()) + sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) + let v = verify (Message [subkey sub]) sig + guard (not . null $ signatures_over v) + return v + +smallpr k = drop 24 $ fingerprint k + +disjoint_fp ks = {- concatMap group2 $ -} transpose grouped + where + grouped = groupBy samepr . sortBy (comparing smallpr) $ ks + samepr a b = smallpr a == smallpr b + + {- + -- useful for testing + group2 :: [a] -> [[a]] + group2 (x:y:ys) = [x,y]:group2 ys + group2 [x] = [[x]] + group2 [] = [] + -} + + +getBindings :: + [Packet] + -> + ( [([Packet],[SignatureOver])] -- other signatures with key sets + -- that were used for the verifications + , [(Word8, + (Packet, Packet), -- (topkey,subkey) + [String], -- usage flags + [SignatureSubpacket], -- hashed data + [Packet])] -- binding signatures + ) +getBindings pkts = (sigs,bindings) + where + (sigs,concat->bindings) = unzip $ do + let (keys,_) = partition isKey pkts + keys <- disjoint_fp keys + let (bs,sigs) = verifyBindings keys pkts + return . ((keys,sigs),) $ do + b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs + i <- map signature_issuer (signatures_over b) + i <- maybeToList i + who <- maybeToList $ find_key fingerprint (Message keys) i + let (code,claimants) = + case () of + _ | who == topkey b -> (1,[]) + _ | who == subkey b -> (2,[]) + _ -> (0,[who]) + let hashed = signatures_over b >>= hashed_subpackets + kind = guard (code==1) >> hashed >>= maybeToList . usage + return (code,(topkey b,subkey b), kind, hashed,claimants) + +resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] +resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops + where + ops = map (\u -> InducerSignature u []) us + us = filter torStyle $ Map.keys umap + torStyle str = and [ uid_topdomain parsed == "onion" + , uid_realname parsed `elem` ["","Anonymous"] + , uid_user parsed == "root" + , fmap (match . fst) (lookup (packet k) torbindings) + == Just True ] + where parsed = parseUID str + match = (==subdom) . take (fromIntegral len) + subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] + subdom = Char8.unpack subdom0 + len = T.length (uid_subdomain parsed) + torbindings = getTorKeys (map packet $ flattenTop "" True kd) + getTorKeys pub = do + xs <- groupBindings pub + (_,(top,sub),us,_,_) <- xs + guard ("tor" `elem` us) + let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub + return (top,(torhash,sub)) + + groupBindings pub = gs + where (_,bindings) = getBindings pub + bindings' = accBindings bindings + code (c,(m,s),_,_,_) = (fingerprint_material m,-c) + ownerkey (_,(a,_),_,_,_) = a + sameMaster (ownerkey->a) (ownerkey->b) + = fingerprint_material a==fingerprint_material b + gs = groupBy sameMaster (sortBy (comparing code) bindings') + + +resolveTransform (DeleteSubKey fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk + where + topk = keykey $ packet k -- key to master of key to be deleted + subk = do + (k,sub) <- Map.toList submap + guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) + return k + + +-- | Load and update key files according to the specified 'KeyRingOperation'. +runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) +runKeyRing operation = do + homedir <- getHomeDir (opHome operation) + let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) + -- FIXME: try' should probably accept a list of KikiReportActions. + -- This would be useful for reporting on disk writes that have already + -- succeded prior to this termination. + try' v body = + case functorToEither v of + Left e -> return $ KikiResult e [] + Right wkun -> body wkun + try' homedir $ \(homedir,secring,pubring,grip0) -> do + let ctx = InputFileContext secring pubring + tolocks = filesToLock operation ctx + secring <- return Nothing + pubring <- return Nothing + lks <- forM tolocks $ \f -> do + lk <- dotlock_create f 0 + v <- flip (maybe $ return Nothing) lk $ \lk -> do + e <- dotlock_take lk (-1) + if e==0 then return $ Just lk + else dotlock_destroy lk >> return Nothing + return (v,f) + let (lked, map snd -> failed_locks) = partition (isJust . fst) lks + ret <- + if not $ null failed_locks + then return $ KikiResult (FailedToLock failed_locks) [] + else do + + -- merge all keyrings, PEM files, and wallets + bresult <- buildKeyDB ctx grip0 operation + try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do + + externals_ret <- initializeMissingPEMFiles operation + ctx + grip + decrypt + db + try' externals_ret $ \((db,exports),report_externals) -> do + + let rt = KeyRingRuntime + { rtPubring = homepubPath ctx + , rtSecring = homesecPath ctx + , rtGrip = grip + , rtWorkingKey = fmap packet wk + , rtKeyDB = db + , rtRingAccess = accs + , rtPassphrases = decrypt + } + + r <- performManipulations decrypt + rt + wk + (combineTransforms $ opTransforms operation) + try' r $ \(rt,report_manips) -> do + + r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) + try' r $ \report_wallets -> do + + r <- writeRingKeys operation rt unspilled report_manips + try' r $ \report_rings -> do + + r <- writePEMKeys decrypt (rtKeyDB rt) exports + try' r $ \report_pems -> do + + import_hosts <- writeHostsFiles operation ctx hs + + return $ KikiResult (KikiSuccess rt) + $ concat [ report_imports + , report_externals + , report_manips + , report_wallets + , report_rings + , report_pems ] + + forM_ lked $ \(Just lk, fname) -> dotlock_release lk + + return ret + +parseOptionFile :: FilePath -> IO [String] +parseOptionFile fname = do + xs <- fmap lines (readFile fname) + let ys = filter notComment xs + notComment ('#':_) = False + notComment cs = not (all isSpace cs) + return ys + +-- | returns ( home directory +-- , path to secret ring +-- , path to public ring +-- , fingerprint of working key +-- ) +getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String)) +getHomeDir protohome = do + homedir <- envhomedir protohome + flip (maybe (return CantFindHome)) + homedir $ \homedir -> do + -- putStrLn $ "homedir = " ++show homedir + let secring = homedir ++ "/" ++ "secring.gpg" + pubring = homedir ++ "/" ++ "pubring.gpg" + -- putStrLn $ "secring = " ++ show secring + workingkey <- getWorkingKey homedir + return $ KikiSuccess (homedir,secring,pubring,workingkey) + where + envhomedir opt = do + gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home) + homed <- fmap (mfilter (/="") . Just) getHomeDirectory + let homegnupg = (++('/':(appdir home))) <$> homed + let val = (opt `mplus` gnupghome `mplus` homegnupg) + return $ val + + -- TODO: rename this to getGrip + getWorkingKey homedir = do + let o = Nothing + h = Just homedir + ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> + let optfiles = map (second ((h++"/")++)) + (maybe optfile_alts' (:[]) o') + optfile_alts' = zip (False:repeat True) (optfile_alts home) + o' = fmap (False,) o + in filterM (doesFileExist . snd) optfiles + args <- flip (maybe $ return []) ofile $ + \(forgive,fname) -> parseOptionFile fname + let config = map (topair . words) args + where topair (x:xs) = (x,xs) + return $ lookup "default-key" config >>= listToMaybe + +#if MIN_VERSION_base(4,6,0) +#else +lookupEnv :: String -> IO (Maybe String) +lookupEnv var = + handleIO_ (return Nothing) $ fmap Just (getEnv var) +#endif + +isKey :: Packet -> Bool +isKey (PublicKeyPacket {}) = True +isKey (SecretKeyPacket {}) = True +isKey _ = False + +isUserID :: Packet -> Bool +isUserID (UserIDPacket {}) = True +isUserID _ = False + +isTrust :: Packet -> Bool +isTrust (TrustPacket {}) = True +isTrust _ = False + +sigpackets :: + Monad m => + Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet +sigpackets typ hashed unhashed = return $ + signaturePacket + 4 -- version + typ -- 0x18 subkey binding sig, or 0x19 back-signature + RSA + SHA1 + hashed + unhashed + 0 -- Word16 -- Left 16 bits of the signed hash value + [] -- [MPI] + +secretToPublic :: Packet -> Packet +secretToPublic pkt@(SecretKeyPacket {}) = + PublicKeyPacket { version = version pkt + , timestamp = timestamp pkt + , key_algorithm = key_algorithm pkt + -- , ecc_curve = ecc_curve pkt + , key = let seckey = key pkt + pubs = public_key_fields (key_algorithm pkt) + in filter (\(k,v) -> k `elem` pubs) seckey + , is_subkey = is_subkey pkt + , v3_days_of_validity = Nothing + } +secretToPublic pkt = pkt + + + +slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) +slurpWIPKeys stamp "" = ([],[]) +slurpWIPKeys stamp cs = + let (b58,xs) = Char8.span (`elem` base58chars) cs + mb = decode_btc_key stamp (Char8.unpack b58) + in if L.null b58 + then let (ys,xs') = Char8.break (`elem` base58chars) cs + (ks,js) = slurpWIPKeys stamp xs' + in (ks,ys:js) + else let (ks,js) = slurpWIPKeys stamp xs + in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb + + +decode_btc_key :: + Enum timestamp => timestamp -> String -> Maybe (Word8, Message) +decode_btc_key timestamp str = do + (network_id,us) <- base58_decode str + return . (network_id,) $ Message $ do + let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer]) + {- + xy = secp256k1_G `pmul` d + x = getx xy + y = gety xy + -- y² = x³ + 7 (mod p) + y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve) + y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve) + -} + secp256k1 = ECC.getCurveByName ECC.SEC_p256k1 + ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1 + -- pub = cannonical_eckey x y + -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub + -- address = base58_encode hash + -- pubstr = concatMap (printf "%02x") $ pub + -- _ = pubstr :: String + return $ {- trace (unlines ["pub="++show pubstr + ,"add="++show address + ,"y ="++show y + ,"y' ="++show y' + ,"y''="++show y'']) -} + SecretKeyPacket + { version = 4 + , timestamp = toEnum (fromEnum timestamp) + , key_algorithm = ECDSA + , key = [ -- public fields... + ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve) + ,('l',MPI 256) + ,('x',MPI x) + ,('y',MPI y) + -- secret fields + ,('d',MPI d) + ] + , s2k_useage = 0 + , s2k = S2K 100 "" + , symmetric_algorithm = Unencrypted + , encrypted_data = "" + , is_subkey = True + } + +rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey +rsaKeyFromPacket p | isKey p = do + n <- lookup 'n' $ key p + e <- lookup 'e' $ key p + return $ RSAKey n e + +rsaKeyFromPacket _ = Nothing + + +readPacketsFromWallet :: + Maybe Packet + -> InputFile + -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] +readPacketsFromWallet wk fname = do + let ctx = InputFileContext "" "" + timestamp <- getInputFileTime ctx fname + input <- readInputFileL ctx fname + let (ks,_) = slurpWIPKeys timestamp input + unless (null ks) $ do + -- decrypt wk + -- create sigs + -- return key/sig pairs + return () + return $ do + wk <- maybeToList wk + guard (not $ null ks) + let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk)) + where tag = CryptoCoins.nameFromSecretByte tagbyte + (wk,MarkerPacket,(MarkerPacket,Map.empty)) + :map prep ks + +readPacketsFromFile :: InputFileContext -> InputFile -> IO Message +readPacketsFromFile ctx fname = do + -- warn $ fname ++ ": reading..." + input <- readInputFileL ctx fname +#if MIN_VERSION_binary(0,7,0) + return $ + case decodeOrFail input of + Right (_,_,msg ) -> msg + Left (_,_,_) -> + -- FIXME + -- trace (fname++": read fail") $ + Message [] +#else + return $ decode input +#endif + +-- | Get the time stamp of a signature. +-- +-- Warning: This function checks unhashed_subpackets if no timestamp occurs in +-- the hashed section. TODO: change this? +-- +signature_time :: SignatureOver -> Word32 +signature_time ov = case (if null cs then ds else cs) of + [] -> minBound + xs -> maximum xs + where + ps = signatures_over ov + ss = filter isSignaturePacket ps + cs = concatMap (concatMap creationTime . hashed_subpackets) ss + ds = concatMap (concatMap creationTime . unhashed_subpackets) ss + creationTime (SignatureCreationTimePacket t) = [t] + creationTime _ = [] + +splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t]) +splitAtMinBy comp xs = minimumBy comp' xxs + where + xxs = zip (inits xs) (tails xs) + comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs) + compM (Just a) (Just b) = comp a b + compM Nothing mb = GT + compM _ _ = LT + + + +-- | Given list of subpackets, a master key, one of its subkeys and a +-- list of signatures on that subkey, yields: +-- +-- * preceding list of signatures +-- +-- * The most recent valid signature made by the master key along with a +-- flag that indicates whether or not all of the supplied subpackets occur in +-- it or, if no valid signature from the working key is present, Nothing. +-- +-- * following list of signatures +-- +findTag :: + [SignatureSubpacket] + -> Packet + -> Packet + -> [(MappedPacket, b)] + -> ([(MappedPacket, b)], + Maybe (Bool, (MappedPacket, b)), + [(MappedPacket, b)]) +findTag tag topk subkey subsigs = (xs',minsig,ys') + where + vs = map (\sig -> + (sig, do + sig <- Just (packet . fst $ sig) + guard (isSignaturePacket sig) + guard $ flip isSuffixOf + (fingerprint topk) + . fromMaybe "%bad%" + . signature_issuer + $ sig + listToMaybe $ + map (signature_time . verify (Message [topk])) + (signatures $ Message [topk,subkey,sig]))) + subsigs + (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs + xs' = map fst xs + ys' = map fst $ if isNothing minsig then ys else drop 1 ys + minsig = do + (sig,ov) <- listToMaybe ys + ov + let hshed = hashed_subpackets $ packet $ fst sig + return ( null $ tag \\ hshed, sig) + +mkUsage :: String -> SignatureSubpacket +mkUsage tag = NotationDataPacket + { human_readable = True + , notation_name = "usage@" + , notation_value = tag + } + +makeSig :: + (MappedPacket -> IO (KikiCondition Packet)) + -> MappedPacket + -> [Char] + -> MappedPacket + -> [SignatureSubpacket] + -> Maybe (MappedPacket, Map.Map k a) + -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction])) +makeSig doDecrypt top fname subkey_p tags mbsig = do + let wk = packet top + wkun <- doDecrypt top + try wkun $ \wkun -> do + let grip = fingerprint wk + addOrigin new_sig = + flip (maybe $ return FailedToMakeSignature) + (new_sig >>= listToMaybe . signatures_over) + $ \new_sig -> do + let mp' = mappedPacket fname new_sig + return $ KikiSuccess (mp', Map.empty) + parsedkey = [packet subkey_p] + hashed0 = KeyFlagsPacket + { certify_keys = False + , sign_data = False + , encrypt_communication = False + , encrypt_storage = False + , split_key = False + , authentication = True + , group_key = False } + : tags + -- implicitly added: + -- , SignatureCreationTimePacket (fromIntegral timestamp) + subgrip = fingerprint (head parsedkey) + + back_sig <- pgpSign (Message parsedkey) + (SubkeySignature wk + (head parsedkey) + (sigpackets 0x19 + hashed0 + [IssuerPacket subgrip])) + (if key_algorithm (head parsedkey)==ECDSA + then SHA256 + else SHA1) + subgrip + let iss = IssuerPacket (fingerprint wk) + cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig) + unhashed0 = maybe [iss] cons_iss back_sig + + new_sig <- pgpSign (Message [wkun]) + (SubkeySignature wk + (head parsedkey) + (sigpackets 0x18 + hashed0 + unhashed0)) + SHA1 + grip + let newSig = do + r <- addOrigin new_sig + return $ fmap (,[]) r + flip (maybe newSig) mbsig $ \(mp,trustmap) -> do + let sig = packet mp + isCreation (SignatureCreationTimePacket {}) = True + isCreation _ = False + isExpiration (SignatureExpirationTimePacket {}) = True + isExpiration _ = False + (cs,ps) = partition isCreation (hashed_subpackets sig) + (es,qs) = partition isExpiration ps + stamp = listToMaybe . sortBy (comparing Down) $ + map unwrap cs where unwrap (SignatureCreationTimePacket x) = x + exp = listToMaybe $ sort $ + map unwrap es where unwrap (SignatureExpirationTimePacket x) = x + expires = liftA2 (+) stamp exp + timestamp <- now + if fmap ( (< timestamp) . fromIntegral) expires == Just True then + return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] ) + else do + let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) + $ maybeToList $ do + e <- expires + return $ SignatureExpirationTimePacket (e - fromIntegral timestamp) + sig' = sig { hashed_subpackets = times ++ (qs `union` tags) } + new_sig <- pgpSign (Message [wkun]) + (SubkeySignature wk + (packet subkey_p) + [sig'] ) + SHA1 + (fingerprint wk) + newsig <- addOrigin new_sig + return $ fmap (,[]) newsig + + + +data OriginFlags = OriginFlags { + originallyPublic :: Bool, + originalNum :: Int + } + deriving Show +type OriginMap = Map.Map FilePath OriginFlags +data MappedPacket = MappedPacket + { packet :: Packet + , locations :: OriginMap + } deriving Show + +type TrustMap = Map.Map FilePath Packet +type SigAndTrust = ( MappedPacket + , TrustMap ) -- trust packets + +type KeyKey = [ByteString] +data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show + +-- | This is a GPG Identity which includes a master key and all its UIDs and +-- subkeys and associated signatures. +data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key + , keySigAndTrusts :: [SigAndTrust] -- sigs on main key + , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids + , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys + } deriving Show + +type KeyDB = Map.Map KeyKey KeyData + +origin :: Packet -> Int -> OriginFlags +origin p n = OriginFlags ispub n + where + ispub = case p of + SecretKeyPacket {} -> False + _ -> True + +mappedPacket :: FilePath -> Packet -> MappedPacket +mappedPacket filename p = MappedPacket + { packet = p + , locations = Map.singleton filename (origin p (-1)) + } + +mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket +mappedPacketWithHint filename p hint = MappedPacket + { packet = p + , locations = Map.singleton filename (origin p hint) + } + +keykey :: Packet -> KeyKey +keykey key = + -- Note: The key's timestamp is normally included in it's fingerprint. + -- This is undesirable for kiki because it causes the same + -- key to be imported multiple times and show as apparently + -- distinct keys with different fingerprints. + -- Thus, we will remove the timestamp. + fingerprint_material (key {timestamp=0}) -- TODO: smaller key? + +uidkey :: Packet -> String +uidkey (UserIDPacket str) = str + +merge :: KeyDB -> InputFile -> Message -> KeyDB +merge db inputfile (Message ps) = merge_ db filename qs + where + filename = resolveForReport Nothing inputfile + + qs = scanPackets filename ps + + scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] + scanPackets filename [] = [] + scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps + where + ret p = (p,Map.empty) + doit (top,sub,prev) p = + case p of + _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) + _ | isKey p && is_subkey p -> (top,p,ret p) + _ | isUserID p -> (top,p,ret p) + _ | isTrust p -> (top,sub,updateTrust top sub prev p) + _ -> (top,sub,ret p) + + updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public + updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public + updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret + + +{- +onionName :: KeyData -> (SockAddr,L.ByteString) +onionName kd = (addr,name) + where + (addr,(name:_,_)) = getHostnames kd +-} +keyCompare :: String -> Packet -> Packet -> Ordering +keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT +keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT +keyCompare what a b | keykey a==keykey b = EQ +keyCompare what a b = error $ unlines ["Unable to merge "++what++":" + , fingerprint a + , PP.ppShow a + , fingerprint b + , PP.ppShow b + ] + +mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket +mergeKeyPacket what key p = + key { packet = minimumBy (keyCompare what) [packet key,packet p] + , locations = Map.union (locations key) (locations p) + } + + +merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] + -> KeyDB +merge_ db filename qs = foldl mergeit db (zip [0..] qs) + where + asMapped n p = mappedPacketWithHint filename p n + asSigAndTrust n (p,tm) = (asMapped n p,tm) + emptyUids = Map.empty + -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets + mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB + mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db + where + -- NOTE: + -- if a keyring file has both a public key packet and a secret key packet + -- for the same key, then only one of them will survive, which ever is + -- later in the file. + -- + -- This is due to the use of statements like + -- (Map.insert filename (origin p n) (locations key)) + -- + update :: Maybe KeyData -> Maybe KeyData + update v | isKey p && not (is_subkey p) + = case v of + Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty + Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p + -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p) + sigs + uids + subkeys + _ -> error . concat $ ["Unexpected master key merge error: " + ,show (fingerprint top, fingerprint p)] + update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p + = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) + update (Just (KeyData key sigs uids subkeys)) | isUserID p + = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) + subkeys + update (Just (KeyData key sigs uids subkeys)) + = case sub of + MarkerPacket -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys + UserIDPacket {} -> Just $ KeyData key + sigs + (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) + subkeys + _ | isKey sub -> Just $ KeyData key + sigs + uids + (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys) + _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1) + update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1) + + mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p + + mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey + mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) [] + mergeSubkey n p (Just (SubKey key sigs)) = Just $ + SubKey (mergeKeyPacket "subs" key $ asMapped n p) + sigs + + mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap) + mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n)) + mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m) + mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p + + whatP (a,_) = concat . take 1 . words . show $ a + + + mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust] + mergeSig n sig sigs = + let (xs,ys) = break (isSameSig sig) sigs + in if null ys + then sigs++[first (asMapped n) sig] + else let y:ys'=ys + in xs ++ (mergeSameSig n sig y : ys') + where + isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b = + a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } + isSameSig (a,_) (MappedPacket {packet=b},_) = a==b + + mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap) + mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) + | isSignaturePacket a && isSignaturePacket b = + ( m { packet = b { unhashed_subpackets = + union (unhashed_subpackets b) (unhashed_subpackets a) + } + , locations = Map.insert filename (origin a n) locs } + -- TODO: when merging items, we should delete invalidated origins + -- from the orgin map. + , tb `Map.union` ta ) + + mergeSameSig n a b = b -- trace ("discarding dup "++show a) b + + mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m) + mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty) + + mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs) + mergeSubSig n sig Nothing = error $ + "Unable to merge subkey signature: "++(words (show sig) >>= take 1) + +unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] +unsig fname isPublic (sig,trustmap) = + sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) + where + f n _ = n==fname -- && trace ("fname=n="++show n) True + asMapped n p = let m = mappedPacket fname p + in m { locations = fmap (\x->x {originalNum=n}) (locations m) } + +concatSort :: + FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a] +concatSort fname getp f = concat . sortByHint fname getp . map f + +sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] +sortByHint fname f = sortBy (comparing gethint) + where + gethint = maybe defnum originalNum . Map.lookup fname . locations . f + defnum = -1 + +flattenKeys :: Bool -> KeyDB -> Message +flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) + where + prefilter = if isPublic then id else filter isSecret + where + isSecret (_,(KeyData + (MappedPacket { packet=(SecretKeyPacket {})}) + _ + _ + _)) = True + isSecret _ = False + + +flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] +flattenTop fname ispub (KeyData key sigs uids subkeys) = + unk ispub key : + ( flattenAllUids fname ispub uids + ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) + +flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] +flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs + +unk :: Bool -> MappedPacket -> MappedPacket +unk isPublic = if isPublic then toPacket secretToPublic else id + where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} + +flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] +flattenAllUids fname ispub uids = + concatSort fname head (flattenUid fname ispub) (Map.assocs uids) + +flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] +flattenUid fname ispub (str,(sigs,om)) = + (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs + +getCrossSignedSubkeys :: Packet -> Map.Map KeyKey SubKey -> String -> [Packet] +getCrossSignedSubkeys topk subs tag = do + SubKey k sigs <- Map.elems subs + let subk = packet k + let sigs' = do + torsig <- filter (has_tag tag) $ map (packet . fst) sigs + sig <- (signatures $ Message [topk,subk,torsig]) + let v = verify (Message [topk]) sig + -- Require parent's signature + guard (not . null $ signatures_over v) + let unhashed = unhashed_subpackets torsig + subsigs = mapMaybe backsig unhashed + -- This should consist only of 0x19 values + -- subtypes = map signature_type subsigs + sig' <- signatures . Message $ [topk,subk]++subsigs + let v' = verify (Message [subk]) sig' + -- Require subkey's signature + guard . not . null $ signatures_over v' + return torsig + guard (not $ null sigs') + return subk + where + has_tag tag p = isSignaturePacket p + && or [ tag `elem` mapMaybe usage (hashed_subpackets p) + , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] + + +-- | +-- Returns (ip6 fingerprint address,(onion names,other host names)) +-- +-- Requires a validly cross-signed tor key for each onion name returned. +-- (Signature checks are performed.) +getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString])) +getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames)) + where + othernames = do + mp <- flattenAllUids "" True uids + let p = packet mp + guard $ isSignaturePacket p + uh <- unhashed_subpackets p + case uh of + NotationDataPacket True "hostname@" v + -> return $ Char8.pack v + _ -> mzero + + addr = fingerdress topk + -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key? + topk = packet topmp + torkeys = getCrossSignedSubkeys topk subs "tor" + + -- subkeyPacket (SubKey k _ ) = k + onames :: [L.ByteString] + onames = map ( (<> ".onion") + . Char8.pack + . take 16 + . torhash ) + torkeys + +hasFingerDress :: KeyDB -> SockAddr -> Bool +hasFingerDress db addr | socketFamily addr/=AF_INET6 = False +hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db) + where + (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr + g' = map toUpper g + +-- We return into IO in case we want to make a signature here. +setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData +setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) = + -- TODO: we are removing the origin from the UID OriginMap, + -- when we should be removing origins from the locations + -- field of the sig's MappedPacket records. + -- Call getHostnames and compare to see if no-op. + if not (pred addr) || names0 == names \\ onions + then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) + , " file: "++show (map Char8.unpack names) + , " pred: "++show (pred addr)]) -} + (return kd) + else do + -- We should be sure to remove origins so that the data is written + -- (but only if something changed). + -- Filter all hostnames present in uids + -- Write notations into first uid + {- + trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) + , " file: "++show (map Char8.unpack names) ]) $ do + -} + return $ KeyData topmp topsigs uids1 subs + where + topk = packet topmp + addr = fingerdress topk + names :: [Char8.ByteString] + names = Hosts.namesForAddress addr hosts + (_,(onions,names0)) = getHostnames kd + notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions) + isName (NotationDataPacket True "hostname@" _) = True + isName _ = False + uids0 = fmap zapIfHasName uids + fstuid = head $ do + p <- map packet $ flattenAllUids "" True uids + guard $ isUserID p + return $ uidkey p + uids1 = Map.adjust addnames fstuid uids0 + addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin + where + (ss,ts) = splitAt 1 sigs + f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm) + else (sig, tm) + where p' = (packet sig) { unhashed_subpackets=uh } + uh = unhashed_subpackets (packet sig) ++ notations + zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin + else (sigs,om) + where + (bs, sigs') = unzip $ map unhash sigs + + unhash (sig,tm) = ( not (null ns) + , ( sig { packet = p', locations = Map.empty } + , tm ) ) + where + psig = packet sig + p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps } + else psig + uh = unhashed_subpackets psig + (ns,ps) = partition isName uh + +fingerdress :: Packet -> SockAddr +fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str + where + zero = SockAddrInet 0 0 + addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk) + colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs + colons xs = xs + +backsig :: SignatureSubpacket -> Maybe Packet +backsig (EmbeddedSignaturePacket s) = Just s +backsig _ = Nothing + +socketFamily :: SockAddr -> Family +socketFamily (SockAddrInet _ _) = AF_INET +socketFamily (SockAddrInet6 {}) = AF_INET6 +socketFamily (SockAddrUnix _) = AF_UNIX + +#if ! MIN_VERSION_unix(2,7,0) +setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO () +setFdTimesHiRes (Posix.Fd fd) atime mtime = + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times) + +data CTimeSpec = CTimeSpec Posix.EpochTime CLong +instance Storable CTimeSpec where + sizeOf _ = (16) + alignment _ = alignment (undefined :: CInt) + poke p (CTimeSpec sec nsec) = do + ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p sec + ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p nsec + peek p = do + sec <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p + nsec <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p + return $ CTimeSpec sec nsec + +toCTimeSpec :: POSIXTime -> CTimeSpec +toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^(9::Int) * frac) + where + (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac') + (sec', frac') = properFraction $ toRational t + +foreign import ccall unsafe "futimens" + c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt +#endif + +onionNameForContact :: KeyKey -> KeyDB -> Maybe String +onionNameForContact kk db = do + contact <- Map.lookup kk db + let (_,(name:_,_)) = getHostnames contact + 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 @@ +{-# LANGUAGE OverloadedStrings #-} +module PEM where + +import Data.Monoid +import qualified Data.ByteString.Lazy as LW +import qualified Data.ByteString.Lazy.Char8 as L +import Control.Monad +import Control.Applicative +import qualified Codec.Binary.Base64 as Base64 +import ScanningParser + +data PEMBlob = PEMBlob { pemType :: L.ByteString + , pemBlob :: L.ByteString + } + deriving (Eq,Show) + +pemParser mtyp = ScanningParser (maybe fndany fndtyp mtyp) pbdy + where + hdr typ = "-----BEGIN " <> typ <> "-----" + fndtyp typ bs = if bs==hdr typ then Just typ else Nothing + fndany bs = do + guard $ "-----BEGIN " `L.isPrefixOf` bs + let x0 = L.drop 11 bs + guard $ "-----" `LW.isSuffixOf` x0 + let typ = L.take (L.length x0 - 5) x0 + return typ + + pbdy typ xs = (mblob, drop 1 rs) + where + (ys,rs) = span (/="-----END " <> typ <> "-----") xs + mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta) + dta = case ys of + [] -> "" + 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 @@ +module ProcessUtils + ( ExitCode(ExitFailure,ExitSuccess) + , systemEnv + ) where + +import GHC.IO.Exception ( ioException, IOErrorType(..) ) +import System.Process +import System.Posix.Signals +import System.Process.Internals (runGenProcess_,defaultSignal) +import System.Environment +import Data.Maybe ( isNothing ) +import System.IO.Error ( mkIOError, ioeSetErrorString ) +import System.Exit ( ExitCode(..) ) + + +-- | systemEnv +-- This is like System.Process.system except that it lets you set +-- some environment variables. +systemEnv :: [(String, String)] -> String -> IO ExitCode +systemEnv _ "" = + ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command") +systemEnv vars cmd = do + env0 <- getEnvironment + let env1 = filter (isNothing . flip lookup vars . fst) env0 + env = vars ++ env1 + syncProcess "system" $ (shell cmd) {env=Just env} + where + -- This is a non-exported function from System.Process + syncProcess fun c = do + -- The POSIX version of system needs to do some manipulation of signal + -- handlers. Since we're going to be synchronously waiting for the child, + -- we want to ignore ^C in the parent, but handle it the default way + -- in the child (using SIG_DFL isn't really correct, it should be the + -- original signal handler, but the GHC RTS will have already set up + -- its own handler and we don't want to use that). + old_int <- installHandler sigINT Ignore Nothing + old_quit <- installHandler sigQUIT Ignore Nothing + (_,_,_,p) <- runGenProcess_ fun c + (Just defaultSignal) (Just defaultSignal) + r <- waitForProcess p + _ <- installHandler sigINT old_int Nothing + _ <- installHandler sigQUIT old_quit Nothing + return r + + 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 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +module ScanningParser + ( ScanningParser(..) + , scanAndParse + , scanAndParse1 + ) where + +import Data.Maybe +import Data.List +import Control.Applicative +import Control.Monad +import Data.Monoid + +-- | This type provides the means to parse a stream of 'tok' and extract all +-- the 'obj' parses that occur. +-- +-- Use Functor and Monoid interfaces to combine parsers. For example, +-- +-- > parserAorB = fmap Left parserA <> fmap Right parserB +-- +data ScanningParser tok obj = forall partial. ScanningParser + { findFirst :: tok -> Maybe partial + -- ^ If the token starts an object, returns a partial parse. + , parseBody :: partial -> [tok] -> (Maybe obj,[tok]) + -- ^ Given a partial parse and the stream of tokens that follow, attempt to + -- parse an object and return the unconsumed tokens. + } + +instance Functor (ScanningParser a) where + fmap f (ScanningParser ffst pbody) + = ScanningParser ffst (\b -> first (fmap f) . pbody b) + where + first f (x,y) = (f x, y) + + +instance Monoid (ScanningParser a b) where + mempty = ScanningParser (const Nothing) (const $ const (Nothing,[])) + mappend (ScanningParser ffstA pbdyA) + (ScanningParser ffstB pbdyB) + = ScanningParser ffst pbody + where + ffst x = mplus (Left <$> ffstA x) + (Right <$> ffstB x) + pbody (Left apart) = pbdyA apart + pbody (Right bpart) = pbdyB bpart + + +-- | Apply a 'ScanningParser' to a list of tokens, yielding a list of parsed +-- objects. +scanAndParse :: ScanningParser a c -> [a] -> [c] +scanAndParse psr [] = [] +scanAndParse psr@(ScanningParser ffst pbdy) ts = do + (b,xs) <- take 1 $ mapMaybe findfst' tss + let (mc,ts') = pbdy b xs + rec = scanAndParse psr ts' + maybe rec (:rec) mc + where + tss = tails ts + findfst' ts = do + x <- listToMaybe ts + b <- ffst x + return (b,drop 1 ts) + +scanAndParse1 :: ScanningParser a c -> [a] -> (Maybe c, [a]) +scanAndParse1 psr@(ScanningParser ffst pbdy) ts = + maybe (Nothing,[]) (uncurry pbdy) mb + where + mb = listToMaybe $ mapMaybe findfst' tss + tss = tails ts + findfst' ts = do + x <- listToMaybe ts + b <- ffst x + 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 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +module TimeUtil + ( now + , IsTime(..) + , fromTime + , toUTC + , parseRFC2822 + , printRFC2822 + , dateParser + ) where + +import Data.Time.LocalTime +import Data.Time.Format +import Data.Time.Clock +import Data.Time.Clock.POSIX +#if !MIN_VERSION_time(1,5,0) +import System.Locale (defaultTimeLocale) +#endif +import Data.String +import Control.Applicative +import Data.Maybe +import Data.Char +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Foreign.C.Types ( CTime(..) ) +import Data.Word ( Word32 ) + +import ScanningParser + +class IsTime a where + fromZonedTime :: ZonedTime -> a + toZonedTime :: a -> IO ZonedTime + +instance IsTime ZonedTime where + fromZonedTime x = x + toZonedTime x = return x + +instance IsTime UTCTime where + toZonedTime t = utcToLocalZonedTime t + fromZonedTime zt = zonedTimeToUTC zt + +instance IsTime Integer where + toZonedTime t = utcToLocalZonedTime utime + where + utime = posixSecondsToUTCTime (fromIntegral t) + fromZonedTime zt = round $ utcTimeToPOSIXSeconds utime + where + utime = zonedTimeToUTC zt + +printRFC2822 :: (IsString b, IsTime a) => a -> IO b +printRFC2822 tm = do + zt@(ZonedTime lt z) <- toZonedTime tm + let rfc2822 = formatTime defaultTimeLocale "%a, %0e %b %Y %T" zt ++ printZone + timeZoneStr = timeZoneOffsetString z + printZone = " " ++ timeZoneStr ++ " (" ++ fromString (show z) ++ ")" + return $ fromString $ rfc2822 + +parseRFC2822 :: IsTime b => S.ByteString -> Maybe b +parseRFC2822 str = + case mapMaybe (\f->parseTime defaultTimeLocale f str') formatRFC2822 of + [] -> Nothing + (zt:_) -> Just $ fromZonedTime zt + where + str' = S.unpack stripped + stripped = strip $ str + strip bs = bs3 + where + (_,bs0) = S.span isSpace bs + (bs1,_) = S.spanEnd isSpace bs0 + (bs2,cp) = S.spanEnd (==')') bs1 + bs3 = if S.null cp + then bs2 + else let (op,_) = S.spanEnd (/='(') bs2 + in fst $ S.spanEnd isSpace $ S.init op + formatRFC2822 = [ "%a, %e %b %Y %T GMT" + , "%a, %e %b %Y %T %z" + , "%e %b %Y %T GMT" + , "%e %b %Y %T %z" + , "%a, %e %b %Y %R GMT" + , "%a, %e %b %Y %R %z" + , "%e %b %Y %R GMT" + , "%e %b %Y %R %z" + ] + +now :: IO Integer +now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime + +dateParser :: ScanningParser L.ByteString UTCTime +dateParser = ScanningParser ffst pbdy + where + ffst bs = do + let (h,bs') = L.splitAt 6 bs + if h=="Date: " + then return $ parseRFC2822 $ foldr1 S.append $ L.toChunks bs' + else Nothing + pbdy date xs = (date,xs) + +class IsUTC a where + fromUTC :: UTCTime -> a + toUTC :: a -> UTCTime + +fromTime :: ( IsUTC a, IsUTC b ) => a -> b +fromTime = fromUTC . toUTC + +instance IsUTC UTCTime where + fromUTC = id + toUTC = id + +instance IsUTC CTime where + fromUTC utc = CTime (round $ utcTimeToPOSIXSeconds utc) + toUTC (CTime t) = posixSecondsToUTCTime (realToFrac t) + +instance IsUTC Word32 where + fromUTC utc = round $ utcTimeToPOSIXSeconds utc + toUTC t = posixSecondsToUTCTime (realToFrac t) + +{- +main = do + nowtime <- now + printRFC2822 nowtime >>= putStrLn + let test1 = "Thu, 08 May 2014 23:24:47 -0400" + test2 = " Thu, 08 May 2014 23:24:47 -0400 (EDT) " + putStrLn $ show (parseRFC2822 test1 :: Maybe Integer) + putStrLn $ show (parseRFC2822 test2 :: Maybe Integer) + return () +-} 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 @@ +/* dotlock.c - dotfile locking + * Copyright (C) 1998, 2000, 2001, 2003, 2004, + * 2005, 2006, 2008, 2010, 2011 Free Software Foundation, Inc. + * + * This file is part of JNLIB, which is a subsystem of GnuPG. + * + * JNLIB is free software; you can redistribute it and/or modify it + * under the terms of either + * + * - the GNU Lesser General Public License as published by the Free + * Software Foundation; either version 3 of the License, or (at + * your option) any later version. + * + * or + * + * - the GNU General Public License as published by the Free + * Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * or both in parallel, as here. + * + * JNLIB is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copies of the GNU General Public License + * and the GNU Lesser General Public License along with this program; + * if not, see . + * + * ALTERNATIVELY, this file may be distributed under the terms of the + * following license, in which case the provisions of this license are + * required INSTEAD OF the GNU Lesser General License or the GNU + * General Public License. If you wish to allow use of your version of + * this file only under the terms of the GNU Lesser General License or + * the GNU General Public License, and not to allow others to use your + * version of this file under the terms of the following license, + * indicate your decision by deleting this paragraph and the license + * below. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, and the entire permission notice in its entirety, + * including the disclaimer of warranties. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote + * products derived from this software without specific prior + * written permission. + * + * THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED + * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + * DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +/* + Overview: + ========= + + This module implements advisory file locking in a portable way. + Due to the problems with POSIX fcntl locking a separate lock file + is used. It would be possible to use fcntl locking on this lock + file and thus avoid the weird auto unlock bug of POSIX while still + having an unproved better performance of fcntl locking. However + there are still problems left, thus we resort to use a hardlink + which has the well defined property that a link call will fail if + the target file already exists. + + Given that hardlinks are also available on NTFS file systems since + Windows XP; it will be possible to enhance this module to use + hardlinks even on Windows and thus allow Windows and Posix clients + to use locking on the same directory. This is not yet implemented; + instead we use a lockfile on Windows along with W32 style file + locking. + + On FAT file systems hardlinks are not supported. Thus this method + does not work. Our solution is to use a O_EXCL locking instead. + Querying the type of the file system is not easy to do in a + portable way (e.g. Linux has a statfs, BSDs have a the same call + but using different structures and constants). What we do instead + is to check at runtime whether link(2) works for a specific lock + file. + + + How to use: + =========== + + At program initialization time, the module should be explicitly + initialized: + + dotlock_create (NULL, 0); + + This installs an atexit handler and may also initialize mutex etc. + It is optional for non-threaded applications. Only the first call + has an effect. This needs to be done before any extra threads are + started. + + To create a lock file (which prepares it but does not take the + lock) you do: + + dotlock_t h + + h = dotlock_create (fname, 0); + if (!h) + error ("error creating lock file: %s\n", strerror (errno)); + + It is important to handle the error. For example on a read-only + file system a lock can't be created (but is usually not needed). + FNAME is the file you want to lock; the actual lockfile is that + name with the suffix ".lock" appended. On success a handle to be + used with the other functions is returned or NULL on error. Note + that the handle shall only be used by one thread at a time. This + function creates a unique file temporary file (".#lk*") in the same + directory as FNAME and returns a handle for further operations. + The module keeps track of theses unique files so that they will be + unlinked using the atexit handler. If you don't need the lock file + anymore, you may also explicitly remove it with a call to: + + dotlock_destroy (h); + + To actually lock the file, you use: + + if (dotlock_take (h, -1)) + error ("error taking lock: %s\n", strerror (errno)); + + This function will wait until the lock is acquired. If an + unexpected error occurs if will return non-zero and set ERRNO. If + you pass (0) instead of (-1) the function does not wait in case the + file is already locked but returns -1 and sets ERRNO to EACCES. + Any other positive value for the second parameter is considered a + timeout valuie in milliseconds. + + To release the lock you call: + + if (dotlock_release (h)) + error ("error releasing lock: %s\n", strerror (errno)); + + or, if the lock file is not anymore needed, you may just call + dotlock_destroy. However dotlock_release does some extra checks + before releasing the lock and prints diagnostics to help detecting + bugs. + + If you want to explicitly destroy all lock files you may call + + dotlock_remove_lockfiles (); + + which is the core of the installed atexit handler. In case your + application wants to disable locking completely it may call + + disable_locking () + + before any locks are created. + + There are two convenience functions to store an integer (e.g. a + file descriptor) value with the handle: + + void dotlock_set_fd (dotlock_t h, int fd); + int dotlock_get_fd (dotlock_t h); + + If nothing has been stored dotlock_get_fd returns -1. + + + + How to build: + ============= + + This module was originally developed for GnuPG but later changed to + allow its use without any GnuPG dependency. If you want to use it + with you application you may simply use it and it should figure out + most things automagically. + + You may use the common config.h file to pass macros, but take care + to pass -DHAVE_CONFIG_H to the compiler. Macros used by this + module are: + + DOTLOCK_USE_PTHREAD - Define if POSIX threads are in use. + + DOTLOCK_GLIB_LOGGING - Define this to use Glib logging functions. + + DOTLOCK_EXT_SYM_PREFIX - Prefix all external symbols with the + string to which this macro evaluates. + + GNUPG_MAJOR_VERSION - Defined when used by GnuPG. + + HAVE_DOSISH_SYSTEM - Defined for Windows etc. Will be + automatically defined if a the target is + Windows. + + HAVE_POSIX_SYSTEM - Internally defined to !HAVE_DOSISH_SYSTEM. + + HAVE_SIGNAL_H - Should be defined on Posix systems. If config.h + is not used defaults to defined. + + DIRSEP_C - Separation character for file name parts. + Usually not redefined. + + EXTSEP_S - Separation string for file name suffixes. + Usually not redefined. + + HAVE_W32CE_SYSTEM - Currently only used by GnuPG. + + Note that there is a test program t-dotlock which has compile + instructions at its end. At least for SMBFS and CIFS it is + important that 64 bit versions of stat are used; most programming + environments do this these days, just in case you want to compile + it on the command line, remember to pass -D_FILE_OFFSET_BITS=64 + + + Bugs: + ===== + + On Windows this module is not yet thread-safe. + + + Miscellaneous notes: + ==================== + + On hardlinks: + - Hardlinks are supported under Windows with NTFS since XP/Server2003. + - In Linux 2.6.33 both SMBFS and CIFS seem to support hardlinks. + - NFS supports hard links. But there are solvable problems. + - FAT does not support links + + On the file locking API: + - CIFS on Linux 2.6.33 supports several locking methods. + SMBFS seems not to support locking. No closer checks done. + - NFS supports Posix locks. flock is emulated in the server. + However there are a couple of problems; see below. + - FAT does not support locks. + - An advantage of fcntl locking is that R/W locks can be + implemented which is not easy with a straight lock file. + + On O_EXCL: + - Does not work reliable on NFS + - Should work on CIFS and SMBFS but how can we delete lockfiles? + + On NFS problems: + - Locks vanish if the server crashes and reboots. + - Client crashes keep the lock in the server until the client + re-connects. + - Communication problems may return unreliable error codes. The + MUA Postfix's workaround is to compare the link count after + seeing an error for link. However that gives a race. If using a + unique file to link to a lockfile and using stat to check the + link count instead of looking at the error return of link(2) is + the best solution. + - O_EXCL seems to have a race and may re-create a file anyway. + +*/ + +#ifdef HAVE_CONFIG_H +# include +#endif + +/* Some quick replacements for stuff we usually expect to be defined + in config.h. Define HAVE_POSIX_SYSTEM for better readability. */ +#if !defined (HAVE_DOSISH_SYSTEM) && defined(_WIN32) +# define HAVE_DOSISH_SYSTEM 1 +#endif +#if !defined (HAVE_DOSISH_SYSTEM) && !defined (HAVE_POSIX_SYSTEM) +# define HAVE_POSIX_SYSTEM 1 +#endif + +/* With no config.h assume that we have sitgnal.h. */ +#if !defined (HAVE_CONFIG_H) && defined (HAVE_POSIX_SYSTEM) +# define HAVE_SIGNAL_H 1 +#endif + +/* Standard headers. */ +#include +#include +#include +#include +#include +#include +#include +#ifdef HAVE_DOSISH_SYSTEM +# define WIN32_LEAN_AND_MEAN /* We only need the OS core stuff. */ +# include +#else +# include +# include +# include +#endif +#include +#include +#include +#include +#ifdef HAVE_SIGNAL_H +# include +#endif +#ifdef DOTLOCK_USE_PTHREAD +# include +#endif + +#ifdef DOTLOCK_GLIB_LOGGING +# include +#endif + +#ifdef GNUPG_MAJOR_VERSION +# include "libjnlib-config.h" +#endif +#ifdef HAVE_W32CE_SYSTEM +# include "utf8conv.h" /* WindowsCE requires filename conversion. */ +#endif + +#include "dotlock.h" + + +/* Define constants for file name construction. */ +#if !defined(DIRSEP_C) && !defined(EXTSEP_S) +# ifdef HAVE_DOSISH_SYSTEM +# define DIRSEP_C '\\' +# define EXTSEP_S "." +#else +# define DIRSEP_C '/' +# define EXTSEP_S "." +# endif +#endif + +/* In GnuPG we use wrappers around the malloc fucntions. If they are + not defined we assume that this code is used outside of GnuPG and + fall back to the regular malloc functions. */ +#ifndef jnlib_malloc +# define jnlib_malloc(a) malloc ((a)) +# define jnlib_calloc(a,b) calloc ((a), (b)) +# define jnlib_free(a) free ((a)) +#endif + +/* Wrapper to set ERRNO. */ +#ifndef jnlib_set_errno +# ifdef HAVE_W32CE_SYSTEM +# define jnlib_set_errno(e) gpg_err_set_errno ((e)) +# else +# define jnlib_set_errno(e) do { errno = (e); } while (0) +# endif +#endif + +/* Gettext macro replacement. */ +#ifndef _ +# define _(a) (a) +#endif + +#ifdef GNUPG_MAJOR_VERSION +# define my_info_0(a) log_info ((a)) +# define my_info_1(a,b) log_info ((a), (b)) +# define my_info_2(a,b,c) log_info ((a), (b), (c)) +# define my_info_3(a,b,c,d) log_info ((a), (b), (c), (d)) +# define my_error_0(a) log_error ((a)) +# define my_error_1(a,b) log_error ((a), (b)) +# define my_error_2(a,b,c) log_error ((a), (b), (c)) +# define my_debug_1(a,b) log_debug ((a), (b)) +# define my_fatal_0(a) log_fatal ((a)) +#elif defined (DOTLOCK_GLIB_LOGGING) +# define my_info_0(a) g_message ((a)) +# define my_info_1(a,b) g_message ((a), (b)) +# define my_info_2(a,b,c) g_message ((a), (b), (c)) +# define my_info_3(a,b,c,d) g_message ((a), (b), (c), (d)) +# define my_error_0(a) g_warning ((a)) +# define my_error_1(a,b) g_warning ((a), (b)) +# define my_error_2(a,b,c) g_warning ((a), (b), (c)) +# define my_debug_1(a,b) g_debug ((a), (b)) +# define my_fatal_0(a) g_error ((a)) +#else +# define my_info_0(a) fprintf (stderr, (a)) +# define my_info_1(a,b) fprintf (stderr, (a), (b)) +# define my_info_2(a,b,c) fprintf (stderr, (a), (b), (c)) +# define my_info_3(a,b,c,d) fprintf (stderr, (a), (b), (c), (d)) +# define my_error_0(a) fprintf (stderr, (a)) +# define my_error_1(a,b) fprintf (stderr, (a), (b)) +# define my_error_2(a,b,c) fprintf (stderr, (a), (b), (c)) +# define my_debug_1(a,b) fprintf (stderr, (a), (b)) +# define my_fatal_0(a) do { fprintf (stderr,(a)); fflush (stderr); \ + abort (); } while (0) +#endif + + + + + +/* The object describing a lock. */ +struct dotlock_handle +{ + struct dotlock_handle *next; + char *lockname; /* Name of the actual lockfile. */ + unsigned int locked:1; /* Lock status. */ + unsigned int disable:1; /* If true, locking is disabled. */ + unsigned int use_o_excl:1; /* Use open (O_EXCL) for locking. */ + + int extra_fd; /* A place for the caller to store an FD. */ + +#ifdef HAVE_DOSISH_SYSTEM + HANDLE lockhd; /* The W32 handle of the lock file. */ +#else /*!HAVE_DOSISH_SYSTEM */ + char *tname; /* Name of the lockfile template. */ + size_t nodename_off; /* Offset in TNAME of the nodename part. */ + size_t nodename_len; /* Length of the nodename part. */ +#endif /*!HAVE_DOSISH_SYSTEM */ +}; + + +/* A list of of all lock handles. The volatile attribute might help + if used in an atexit handler. */ +static volatile dotlock_t all_lockfiles; +#ifdef DOTLOCK_USE_PTHREAD +static pthread_mutex_t all_lockfiles_mutex = PTHREAD_MUTEX_INITIALIZER; +# define LOCK_all_lockfiles() do { \ + if (pthread_mutex_lock (&all_lockfiles_mutex)) \ + my_fatal_0 ("locking all_lockfiles_mutex failed\n"); \ + } while (0) +# define UNLOCK_all_lockfiles() do { \ + if (pthread_mutex_unlock (&all_lockfiles_mutex)) \ + my_fatal_0 ("unlocking all_lockfiles_mutex failed\n"); \ + } while (0) +#else /*!DOTLOCK_USE_PTHREAD*/ +# define LOCK_all_lockfiles() do { } while (0) +# define UNLOCK_all_lockfiles() do { } while (0) +#endif /*!DOTLOCK_USE_PTHREAD*/ + +/* If this has the value true all locking is disabled. */ +static int never_lock; + + + + + +/* Entirely disable all locking. This function should be called + before any locking is done. It may be called right at startup of + the process as it only sets a global value. */ +void +dotlock_disable (void) +{ + never_lock = 1; +} + + +#ifdef HAVE_POSIX_SYSTEM +static int +maybe_deadlock (dotlock_t h) +{ + dotlock_t r; + int res = 0; + + LOCK_all_lockfiles (); + for (r=all_lockfiles; r; r = r->next) + { + if ( r != h && r->locked ) + { + res = 1; + break; + } + } + UNLOCK_all_lockfiles (); + return res; +} +#endif /*HAVE_POSIX_SYSTEM*/ + + +/* Read the lock file and return the pid, returns -1 on error. True + will be stored in the integer at address SAME_NODE if the lock file + has been created on the same node. */ +#ifdef HAVE_POSIX_SYSTEM +static int +read_lockfile (dotlock_t h, int *same_node ) +{ + char buffer_space[10+1+70+1]; /* 70 is just an estimated value; node + names are usually shorter. */ + int fd; + int pid = -1; + char *buffer, *p; + size_t expected_len; + int res, nread; + + *same_node = 0; + expected_len = 10 + 1 + h->nodename_len + 1; + if ( expected_len >= sizeof buffer_space) + { + buffer = jnlib_malloc (expected_len); + if (!buffer) + return -1; + } + else + buffer = buffer_space; + + if ( (fd = open (h->lockname, O_RDONLY)) == -1 ) + { + int e = errno; + my_info_2 ("error opening lockfile '%s': %s\n", + h->lockname, strerror(errno) ); + if (buffer != buffer_space) + jnlib_free (buffer); + jnlib_set_errno (e); /* Need to return ERRNO here. */ + return -1; + } + + p = buffer; + nread = 0; + do + { + res = read (fd, p, expected_len - nread); + if (res == -1 && errno == EINTR) + continue; + if (res < 0) + { + my_info_1 ("error reading lockfile '%s'\n", h->lockname ); + close (fd); + if (buffer != buffer_space) + jnlib_free (buffer); + jnlib_set_errno (0); /* Do not return an inappropriate ERRNO. */ + return -1; + } + p += res; + nread += res; + } + while (res && nread != expected_len); + close(fd); + + if (nread < 11) + { + my_info_1 ("invalid size of lockfile '%s'\n", h->lockname); + if (buffer != buffer_space) + jnlib_free (buffer); + jnlib_set_errno (0); /* Better don't return an inappropriate ERRNO. */ + return -1; + } + + if (buffer[10] != '\n' + || (buffer[10] = 0, pid = atoi (buffer)) == -1 + || !pid ) + { + my_error_2 ("invalid pid %d in lockfile '%s'\n", pid, h->lockname); + if (buffer != buffer_space) + jnlib_free (buffer); + jnlib_set_errno (0); + return -1; + } + + if (nread == expected_len + && !memcmp (h->tname+h->nodename_off, buffer+11, h->nodename_len) + && buffer[11+h->nodename_len] == '\n') + *same_node = 1; + + if (buffer != buffer_space) + jnlib_free (buffer); + return pid; +} +#endif /*HAVE_POSIX_SYSTEM */ + + +/* Check whether the file system which stores TNAME supports + hardlinks. Instead of using the non-portable statsfs call which + differs between various Unix versions, we do a runtime test. + Returns: 0 supports hardlinks; 1 no hardlink support, -1 unknown + (test error). */ +#ifdef HAVE_POSIX_SYSTEM +static int +use_hardlinks_p (const char *tname) +{ + char *lname; + struct stat sb; + unsigned int nlink; + int res; + + if (stat (tname, &sb)) + return -1; + nlink = (unsigned int)sb.st_nlink; + + lname = jnlib_malloc (strlen (tname) + 1 + 1); + if (!lname) + return -1; + strcpy (lname, tname); + strcat (lname, "x"); + + /* We ignore the return value of link() because it is unreliable. */ + (void) link (tname, lname); + + if (stat (tname, &sb)) + res = -1; /* Ooops. */ + else if (sb.st_nlink == nlink + 1) + res = 0; /* Yeah, hardlinks are supported. */ + else + res = 1; /* No hardlink support. */ + + unlink (lname); + jnlib_free (lname); + return res; +} +#endif /*HAVE_POSIX_SYSTEM */ + + + +#ifdef HAVE_POSIX_SYSTEM +/* Locking core for Unix. It used a temporary file and the link + system call to make locking an atomic operation. */ +static dotlock_t +dotlock_create_unix (dotlock_t h, const char *file_to_lock) +{ + int fd = -1; + char pidstr[16]; + const char *nodename; + const char *dirpart; + int dirpartlen; + struct utsname utsbuf; + size_t tnamelen; + + snprintf (pidstr, sizeof pidstr, "%10d\n", (int)getpid() ); + + /* Create a temporary file. */ + if ( uname ( &utsbuf ) ) + nodename = "unknown"; + else + nodename = utsbuf.nodename; + + if ( !(dirpart = strrchr (file_to_lock, DIRSEP_C)) ) + { + dirpart = EXTSEP_S; + dirpartlen = 1; + } + else + { + dirpartlen = dirpart - file_to_lock; + dirpart = file_to_lock; + } + + LOCK_all_lockfiles (); + h->next = all_lockfiles; + all_lockfiles = h; + + tnamelen = dirpartlen + 6 + 30 + strlen(nodename) + 10 + 1; + h->tname = jnlib_malloc (tnamelen + 1); + if (!h->tname) + { + all_lockfiles = h->next; + UNLOCK_all_lockfiles (); + jnlib_free (h); + return NULL; + } + h->nodename_len = strlen (nodename); + + snprintf (h->tname, tnamelen, "%.*s/.#lk%p.", dirpartlen, dirpart, h ); + h->nodename_off = strlen (h->tname); + snprintf (h->tname+h->nodename_off, tnamelen - h->nodename_off, + "%s.%d", nodename, (int)getpid ()); + + do + { + jnlib_set_errno (0); + fd = open (h->tname, O_WRONLY|O_CREAT|O_EXCL, + S_IRUSR|S_IRGRP|S_IROTH|S_IWUSR ); + } + while (fd == -1 && errno == EINTR); + + if ( fd == -1 ) + { + all_lockfiles = h->next; + UNLOCK_all_lockfiles (); + my_error_2 (_("failed to create temporary file '%s': %s\n"), + h->tname, strerror(errno)); + jnlib_free (h->tname); + jnlib_free (h); + return NULL; + } + if ( write (fd, pidstr, 11 ) != 11 ) + goto write_failed; + if ( write (fd, nodename, strlen (nodename) ) != strlen (nodename) ) + goto write_failed; + if ( write (fd, "\n", 1 ) != 1 ) + goto write_failed; + if ( close (fd) ) + goto write_failed; + + /* Check whether we support hard links. */ + switch (use_hardlinks_p (h->tname)) + { + case 0: /* Yes. */ + break; + case 1: /* No. */ + unlink (h->tname); + h->use_o_excl = 1; + break; + default: + my_error_2 ("can't check whether hardlinks are supported for '%s': %s\n", + h->tname, strerror(errno)); + goto write_failed; + } + + h->lockname = jnlib_malloc (strlen (file_to_lock) + 6 ); + if (!h->lockname) + { + all_lockfiles = h->next; + UNLOCK_all_lockfiles (); + unlink (h->tname); + jnlib_free (h->tname); + jnlib_free (h); + return NULL; + } + strcpy (stpcpy (h->lockname, file_to_lock), EXTSEP_S "lock"); + UNLOCK_all_lockfiles (); + if (h->use_o_excl) + my_debug_1 ("locking for '%s' done via O_EXCL\n", h->lockname); + + return h; + + write_failed: + all_lockfiles = h->next; + UNLOCK_all_lockfiles (); + my_error_2 (_("error writing to '%s': %s\n"), h->tname, strerror (errno)); + close (fd); + unlink (h->tname); + jnlib_free (h->tname); + jnlib_free (h); + return NULL; +} +#endif /*HAVE_POSIX_SYSTEM*/ + + +#ifdef HAVE_DOSISH_SYSTEM +/* Locking core for Windows. This version does not need a temporary + file but uses the plain lock file along with record locking. We + create this file here so that we later only need to do the file + locking. For error reporting it is useful to keep the name of the + file in the handle. */ +static dotlock_t +dotlock_create_w32 (dotlock_t h, const char *file_to_lock) +{ + LOCK_all_lockfiles (); + h->next = all_lockfiles; + all_lockfiles = h; + + h->lockname = jnlib_malloc ( strlen (file_to_lock) + 6 ); + if (!h->lockname) + { + all_lockfiles = h->next; + UNLOCK_all_lockfiles (); + jnlib_free (h); + return NULL; + } + strcpy (stpcpy(h->lockname, file_to_lock), EXTSEP_S "lock"); + + /* If would be nice if we would use the FILE_FLAG_DELETE_ON_CLOSE + along with FILE_SHARE_DELETE but that does not work due to a race + condition: Despite the OPEN_ALWAYS flag CreateFile may return an + error and we can't reliable create/open the lock file unless we + would wait here until it works - however there are other valid + reasons why a lock file can't be created and thus the process + would not stop as expected but spin until Windows crashes. Our + solution is to keep the lock file open; that does not harm. */ + { +#ifdef HAVE_W32CE_SYSTEM + wchar_t *wname = utf8_to_wchar (h->lockname); + + if (wname) + h->lockhd = CreateFile (wname, + GENERIC_READ|GENERIC_WRITE, + FILE_SHARE_READ|FILE_SHARE_WRITE, + NULL, OPEN_ALWAYS, 0, NULL); + else + h->lockhd = INVALID_HANDLE_VALUE; + jnlib_free (wname); +#else + h->lockhd = CreateFile (h->lockname, + GENERIC_READ|GENERIC_WRITE, + FILE_SHARE_READ|FILE_SHARE_WRITE, + NULL, OPEN_ALWAYS, 0, NULL); +#endif + } + if (h->lockhd == INVALID_HANDLE_VALUE) + { + all_lockfiles = h->next; + UNLOCK_all_lockfiles (); + my_error_2 (_("can't create '%s': %s\n"), h->lockname, w32_strerror (-1)); + jnlib_free (h->lockname); + jnlib_free (h); + return NULL; + } + return h; +} +#endif /*HAVE_DOSISH_SYSTEM*/ + + +/* Create a lockfile for a file name FILE_TO_LOCK and returns an + object of type dotlock_t which may be used later to actually acquire + the lock. A cleanup routine gets installed to cleanup left over + locks or other files used internally by the lock mechanism. + + Calling this function with NULL does only install the atexit + handler and may thus be used to assure that the cleanup is called + after all other atexit handlers. + + This function creates a lock file in the same directory as + FILE_TO_LOCK using that name and a suffix of ".lock". Note that on + POSIX systems a temporary file ".#lk..pid[.threadid] is + used. + + FLAGS must be 0. + + The function returns an new handle which needs to be released using + destroy_dotlock but gets also released at the termination of the + process. On error NULL is returned. + */ + +dotlock_t +dotlock_create (const char *file_to_lock, unsigned int flags) +{ + static int initialized; + dotlock_t h; + + if ( !initialized ) + { + atexit (dotlock_remove_lockfiles); + initialized = 1; + } + + if ( !file_to_lock ) + return NULL; /* Only initialization was requested. */ + + if (flags) + { + jnlib_set_errno (EINVAL); + return NULL; + } + + h = jnlib_calloc (1, sizeof *h); + if (!h) + return NULL; + h->extra_fd = -1; + + if (never_lock) + { + h->disable = 1; + LOCK_all_lockfiles (); + h->next = all_lockfiles; + all_lockfiles = h; + UNLOCK_all_lockfiles (); + return h; + } + +#ifdef HAVE_DOSISH_SYSTEM + return dotlock_create_w32 (h, file_to_lock); +#else /*!HAVE_DOSISH_SYSTEM */ + return dotlock_create_unix (h, file_to_lock); +#endif /*!HAVE_DOSISH_SYSTEM*/ +} + + + +/* Convenience function to store a file descriptor (or any any other + integer value) in the context of handle H. */ +void +dotlock_set_fd (dotlock_t h, int fd) +{ + h->extra_fd = fd; +} + +/* Convenience function to retrieve a file descriptor (or any any other + integer value) stored in the context of handle H. */ +int +dotlock_get_fd (dotlock_t h) +{ + return h->extra_fd; +} + + + +#ifdef HAVE_POSIX_SYSTEM +/* Unix specific code of destroy_dotlock. */ +static void +dotlock_destroy_unix (dotlock_t h) +{ + if (h->locked && h->lockname) + unlink (h->lockname); + if (h->tname && !h->use_o_excl) + unlink (h->tname); + jnlib_free (h->tname); +} +#endif /*HAVE_POSIX_SYSTEM*/ + + +#ifdef HAVE_DOSISH_SYSTEM +/* Windows specific code of destroy_dotlock. */ +static void +dotlock_destroy_w32 (dotlock_t h) +{ + if (h->locked) + { + OVERLAPPED ovl; + + memset (&ovl, 0, sizeof ovl); + UnlockFileEx (h->lockhd, 0, 1, 0, &ovl); + } + CloseHandle (h->lockhd); +} +#endif /*HAVE_DOSISH_SYSTEM*/ + + +/* Destroy the locck handle H and release the lock. */ +void +dotlock_destroy (dotlock_t h) +{ + dotlock_t hprev, htmp; + + if ( !h ) + return; + + /* First remove the handle from our global list of all locks. */ + LOCK_all_lockfiles (); + for (hprev=NULL, htmp=all_lockfiles; htmp; hprev=htmp, htmp=htmp->next) + if (htmp == h) + { + if (hprev) + hprev->next = htmp->next; + else + all_lockfiles = htmp->next; + h->next = NULL; + break; + } + UNLOCK_all_lockfiles (); + + /* Then destroy the lock. */ + if (!h->disable) + { +#ifdef HAVE_DOSISH_SYSTEM + dotlock_destroy_w32 (h); +#else /* !HAVE_DOSISH_SYSTEM */ + dotlock_destroy_unix (h); +#endif /* HAVE_DOSISH_SYSTEM */ + jnlib_free (h->lockname); + } + jnlib_free(h); +} + + + +#ifdef HAVE_POSIX_SYSTEM +/* Unix specific code of make_dotlock. Returns 0 on success and -1 on + error. */ +static int +dotlock_take_unix (dotlock_t h, long timeout) +{ + int wtime = 0; + int sumtime = 0; + int pid; + int lastpid = -1; + int ownerchanged; + const char *maybe_dead=""; + int same_node; + + again: + if (h->use_o_excl) + { + /* No hardlink support - use open(O_EXCL). */ + int fd; + + do + { + jnlib_set_errno (0); + fd = open (h->lockname, O_WRONLY|O_CREAT|O_EXCL, + S_IRUSR|S_IRGRP|S_IROTH|S_IWUSR ); + } + while (fd == -1 && errno == EINTR); + + if (fd == -1 && errno == EEXIST) + ; /* Lock held by another process. */ + else if (fd == -1) + { + my_error_2 ("lock not made: open(O_EXCL) of '%s' failed: %s\n", + h->lockname, strerror (errno)); + return -1; + } + else + { + char pidstr[16]; + + snprintf (pidstr, sizeof pidstr, "%10d\n", (int)getpid()); + if (write (fd, pidstr, 11 ) == 11 + && write (fd, h->tname + h->nodename_off,h->nodename_len) + == h->nodename_len + && write (fd, "\n", 1) == 1 + && !close (fd)) + { + h->locked = 1; + return 0; + } + /* Write error. */ + my_error_2 ("lock not made: writing to '%s' failed: %s\n", + h->lockname, strerror (errno)); + close (fd); + unlink (h->lockname); + return -1; + } + } + else /* Standard method: Use hardlinks. */ + { + struct stat sb; + + /* We ignore the return value of link() because it is unreliable. */ + (void) link (h->tname, h->lockname); + + if (stat (h->tname, &sb)) + { + my_error_1 ("lock not made: Oops: stat of tmp file failed: %s\n", + strerror (errno)); + /* In theory this might be a severe error: It is possible + that link succeeded but stat failed due to changed + permissions. We can't do anything about it, though. */ + return -1; + } + + if (sb.st_nlink == 2) + { + h->locked = 1; + return 0; /* Okay. */ + } + } + + /* Check for stale lock files. */ + if ( (pid = read_lockfile (h, &same_node)) == -1 ) + { + if ( errno != ENOENT ) + { + my_info_0 ("cannot read lockfile\n"); + return -1; + } + my_info_0 ("lockfile disappeared\n"); + goto again; + } + else if ( pid == getpid() && same_node ) + { + my_info_0 ("Oops: lock already held by us\n"); + h->locked = 1; + return 0; /* okay */ + } + else if ( same_node && kill (pid, 0) && errno == ESRCH ) + { + /* Note: It is unlikley that we get a race here unless a pid is + reused too fast or a new process with the same pid as the one + of the stale file tries to lock right at the same time as we. */ + my_info_1 (_("removing stale lockfile (created by %d)\n"), pid); + unlink (h->lockname); + goto again; + } + + if (lastpid == -1) + lastpid = pid; + ownerchanged = (pid != lastpid); + + if (timeout) + { + struct timeval tv; + + /* Wait until lock has been released. We use increasing retry + intervals of 50ms, 100ms, 200ms, 400ms, 800ms, 2s, 4s and 8s + but reset it if the lock owner meanwhile changed. */ + if (!wtime || ownerchanged) + wtime = 50; + else if (wtime < 800) + wtime *= 2; + else if (wtime == 800) + wtime = 2000; + else if (wtime < 8000) + wtime *= 2; + + if (timeout > 0) + { + if (wtime > timeout) + wtime = timeout; + timeout -= wtime; + } + + sumtime += wtime; + if (sumtime >= 1500) + { + sumtime = 0; + my_info_3 (_("waiting for lock (held by %d%s) %s...\n"), + pid, maybe_dead, maybe_deadlock(h)? _("(deadlock?) "):""); + } + + + tv.tv_sec = wtime / 1000; + tv.tv_usec = (wtime % 1000) * 1000; + select (0, NULL, NULL, NULL, &tv); + goto again; + } + + jnlib_set_errno (EACCES); + return -1; +} +#endif /*HAVE_POSIX_SYSTEM*/ + + +#ifdef HAVE_DOSISH_SYSTEM +/* Windows specific code of make_dotlock. Returns 0 on success and -1 on + error. */ +static int +dotlock_take_w32 (dotlock_t h, long timeout) +{ + int wtime = 0; + int w32err; + OVERLAPPED ovl; + + again: + /* Lock one byte at offset 0. The offset is given by OVL. */ + memset (&ovl, 0, sizeof ovl); + if (LockFileEx (h->lockhd, (LOCKFILE_EXCLUSIVE_LOCK + | LOCKFILE_FAIL_IMMEDIATELY), 0, 1, 0, &ovl)) + { + h->locked = 1; + return 0; /* okay */ + } + + w32err = GetLastError (); + if (w32err != ERROR_LOCK_VIOLATION) + { + my_error_2 (_("lock '%s' not made: %s\n"), + h->lockname, w32_strerror (w32err)); + return -1; + } + + if (timeout) + { + /* Wait until lock has been released. We use retry intervals of + 50ms, 100ms, 200ms, 400ms, 800ms, 2s, 4s and 8s. */ + if (!wtime) + wtime = 50; + else if (wtime < 800) + wtime *= 2; + else if (wtime == 800) + wtime = 2000; + else if (wtime < 8000) + wtime *= 2; + + if (timeout > 0) + { + if (wtime > timeout) + wtime = timeout; + timeout -= wtime; + } + + if (wtime >= 800) + my_info_1 (_("waiting for lock %s...\n"), h->lockname); + + Sleep (wtime); + goto again; + } + + return -1; +} +#endif /*HAVE_DOSISH_SYSTEM*/ + + +/* Take a lock on H. A value of 0 for TIMEOUT returns immediately if + the lock can't be taked, -1 waits forever (hopefully not), other + values wait for TIMEOUT milliseconds. Returns: 0 on success */ +int +dotlock_take (dotlock_t h, long timeout) +{ + int ret; + + if ( h->disable ) + return 0; /* Locks are completely disabled. Return success. */ + + if ( h->locked ) + { + my_debug_1 ("Oops, '%s' is already locked\n", h->lockname); + return 0; + } + +#ifdef HAVE_DOSISH_SYSTEM + ret = dotlock_take_w32 (h, timeout); +#else /*!HAVE_DOSISH_SYSTEM*/ + ret = dotlock_take_unix (h, timeout); +#endif /*!HAVE_DOSISH_SYSTEM*/ + + return ret; +} + + + +#ifdef HAVE_POSIX_SYSTEM +/* Unix specific code of release_dotlock. */ +static int +dotlock_release_unix (dotlock_t h) +{ + int pid, same_node; + + pid = read_lockfile (h, &same_node); + if ( pid == -1 ) + { + my_error_0 ("release_dotlock: lockfile error\n"); + return -1; + } + if ( pid != getpid() || !same_node ) + { + my_error_1 ("release_dotlock: not our lock (pid=%d)\n", pid); + return -1; + } + + if ( unlink( h->lockname ) ) + { + my_error_1 ("release_dotlock: error removing lockfile '%s'\n", + h->lockname); + return -1; + } + /* Fixme: As an extra check we could check whether the link count is + now really at 1. */ + return 0; +} +#endif /*HAVE_POSIX_SYSTEM */ + + +#ifdef HAVE_DOSISH_SYSTEM +/* Windows specific code of release_dotlock. */ +static int +dotlock_release_w32 (dotlock_t h) +{ + OVERLAPPED ovl; + + memset (&ovl, 0, sizeof ovl); + if (!UnlockFileEx (h->lockhd, 0, 1, 0, &ovl)) + { + my_error_2 ("release_dotlock: error removing lockfile '%s': %s\n", + h->lockname, w32_strerror (-1)); + return -1; + } + + return 0; +} +#endif /*HAVE_DOSISH_SYSTEM */ + + +/* Release a lock. Returns 0 on success. */ +int +dotlock_release (dotlock_t h) +{ + int ret; + + /* To avoid atexit race conditions we first check whether there are + any locks left. It might happen that another atexit handler + tries to release the lock while the atexit handler of this module + already ran and thus H is undefined. */ + LOCK_all_lockfiles (); + ret = !all_lockfiles; + UNLOCK_all_lockfiles (); + if (ret) + return 0; + + if ( h->disable ) + return 0; + + if ( !h->locked ) + { + my_debug_1 ("Oops, '%s' is not locked\n", h->lockname); + return 0; + } + +#ifdef HAVE_DOSISH_SYSTEM + ret = dotlock_release_w32 (h); +#else + ret = dotlock_release_unix (h); +#endif + + if (!ret) + h->locked = 0; + return ret; +} + + + +/* Remove all lockfiles. This is called by the atexit handler + installed by this module but may also be called by other + termination handlers. */ +void +dotlock_remove_lockfiles (void) +{ + dotlock_t h, h2; + + /* First set the lockfiles list to NULL so that for example + dotlock_release is ware that this fucntion is currently + running. */ + LOCK_all_lockfiles (); + h = all_lockfiles; + all_lockfiles = NULL; + UNLOCK_all_lockfiles (); + + while ( h ) + { + h2 = h->next; + dotlock_destroy (h); + h = h2; + } +} 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 @@ +/* dotlock.h - dotfile locking declarations + * Copyright (C) 2000, 2001, 2006, 2011 Free Software Foundation, Inc. + * + * This file is part of JNLIB, which is a subsystem of GnuPG. + * + * JNLIB is free software; you can redistribute it and/or modify it + * under the terms of either + * + * - the GNU Lesser General Public License as published by the Free + * Software Foundation; either version 3 of the License, or (at + * your option) any later version. + * + * or + * + * - the GNU General Public License as published by the Free + * Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * or both in parallel, as here. + * + * JNLIB is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copies of the GNU General Public License + * and the GNU Lesser General Public License along with this program; + * if not, see . + * + * ALTERNATIVELY, this file may be distributed under the terms of the + * following license, in which case the provisions of this license are + * required INSTEAD OF the GNU Lesser General License or the GNU + * General Public License. If you wish to allow use of your version of + * this file only under the terms of the GNU Lesser General License or + * the GNU General Public License, and not to allow others to use your + * version of this file under the terms of the following license, + * indicate your decision by deleting this paragraph and the license + * below. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, and the entire permission notice in its entirety, + * including the disclaimer of warranties. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote + * products derived from this software without specific prior + * written permission. + * + * THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED + * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + * DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#ifndef LIBJNLIB_DOTLOCK_H +#define LIBJNLIB_DOTLOCK_H + +/* See dotlock.c for a description. */ + +#ifdef DOTLOCK_EXT_SYM_PREFIX +# ifndef _DOTLOCK_PREFIX +# define _DOTLOCK_PREFIX1(x,y) x ## y +# define _DOTLOCK_PREFIX2(x,y) _DOTLOCK_PREFIX1(x,y) +# define _DOTLOCK_PREFIX(x) _DOTLOCK_PREFIX2(DOTLOCK_EXT_SYM_PREFIX,x) +# endif /*_DOTLOCK_PREFIX*/ +# define dotlock_disable _DOTLOCK_PREFIX(dotlock_disable) +# define dotlock_create _DOTLOCK_PREFIX(dotlock_create) +# define dotlock_set_fd _DOTLOCK_PREFIX(dotlock_set_fd) +# define dotlock_get_fd _DOTLOCK_PREFIX(dotlock_get_fd) +# define dotlock_destroy _DOTLOCK_PREFIX(dotlock_destroy) +# define dotlock_take _DOTLOCK_PREFIX(dotlock_take) +# define dotlock_release _DOTLOCK_PREFIX(dotlock_release) +# define dotlock_remove_lockfiles _DOTLOCK_PREFIX(dotlock_remove_lockfiles) +#endif /*DOTLOCK_EXT_SYM_PREFIX*/ + +#ifdef __cplusplus +extern "C" +{ +#if 0 +} +#endif +#endif + + +struct dotlock_handle; +typedef struct dotlock_handle *dotlock_t; + +void dotlock_disable (void); +dotlock_t dotlock_create (const char *file_to_lock, unsigned int flags); +void dotlock_set_fd (dotlock_t h, int fd); +int dotlock_get_fd (dotlock_t h); +void dotlock_destroy (dotlock_t h); +int dotlock_take (dotlock_t h, long timeout); +int dotlock_release (dotlock_t h); +void dotlock_remove_lockfiles (void); + +#ifdef __cplusplus +} +#endif +#endif /*LIBJNLIB_DOTLOCK_H*/ -- cgit v1.2.3