path: root/KeyRing.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module KeyRing where

import System.Environment
import Control.Monad
import Data.Maybe
import Data.Char
import Data.List
import Data.OpenPGP
import Control.Applicative    ( (<$>) )
import System.Directory       ( getHomeDirectory, doesFileExist )
import Control.Arrow          ( first, second )
import Data.OpenPGP.Util      ( fingerprint )
import Data.ByteString.Lazy   ( ByteString )
import Text.Show.Pretty as PP ( ppShow )
import qualified Data.Map as Map

import DotLock

data HomeDir =
    HomeDir { homevar :: String
            , appdir :: String
            , optfile_alts :: [String]
            }

home = HomeDir
    { homevar = "GNUPGHOME"
    , appdir  = ".gnupg"
    , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
    }

data InputFile = HomeSec | HomePub | ArgFile FilePath

data KeyRingRuntime = KeyRingRuntime
                        { rtPubring :: FilePath
                        , rtSecring :: FilePath
                        , rtRings :: [FilePath]
                        , rtWallets :: [FilePath]
                        , rtGrip :: Maybe String
                        }

data KeyRingData a = KeyRingData
    { filesToLock :: [InputFile]
    , homeSpec :: Maybe String
    , kaction :: KeyRingRuntime -> IO a
    , keyringFiles :: [FilePath]
    , walletFiles :: [FilePath]
    }

todo = error "unimplemented"

data KikiResult = KikiSuccess | FailedToLock [FilePath]

{-
newtype KeyRing a = KeyRing
    { krAction :: KeyRingData b -> IO a
    }
-}

empty = KeyRingData { filesToLock = []
                    , homeSpec = Nothing
                    , kaction = \KeyRingRuntime {} -> return ()
                    , keyringFiles = []
                    , walletFiles = []
                    }

{-
runKeyRing :: KeyRing () -> IO a
runKeyRing keyring = krAction keyring empty
-}


runKeyRing :: KeyRingData a -> IO KikiResult
runKeyRing keyring = do
    (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring)
    let tolocks = map resolve (filesToLock keyring)
                  where resolve (ArgFile f) = f
                        resolve HomePub     = pubring
                        resolve HomeSec     = secring
    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) = partition (isJust . fst) lks
        ret = if null failed then KikiSuccess else FailedToLock failed

    case ret of
      KikiSuccess -> kaction keyring KeyRingRuntime
                        { rtPubring = pubring
                        , rtSecring = secring
                        , rtRings = secring:pubring:keyringFiles keyring
                        , rtWallets = walletFiles keyring
                        , rtGrip = grip0
                        }
      _ -> return undefined

    forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
                                         dotlock_destroy lk
    return ret

parseOptionFile fname = do
    xs <- fmap lines (readFile fname)
    let ys = filter notComment xs
        notComment ('#':_) = False
        notComment cs      = not (all isSpace cs)
    return ys

getHomeDir protohome = do
        homedir <- envhomedir protohome
        flip (maybe (error "Could not determine home directory."))
             homedir $ \homedir -> do
        -- putStrLn $ "homedir = " ++show homedir
        let secring = homedir ++ "/" ++ "secring.gpg"
            pubring = homedir ++ "/" ++ "pubring.gpg"
        -- putStrLn $ "secring = " ++ show secring
        workingkey <- getWorkingKey homedir
        return (homedir,secring,pubring,workingkey)
 where
    envhomedir opt = do
        gnupghome <- lookupEnv (homevar home) >>=
                  \d -> return $ d >>= guard . (/="") >> d
        homed <- flip fmap getHomeDirectory $
                  \d -> fmap (const d) $ guard (d/="")
        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 var =
    handleIO_ (return Nothing) $ fmap Just (getEnv var)
#endif

isKey (PublicKeyPacket {}) = True
isKey (SecretKeyPacket {}) = True
isKey _                    = False

isUserID (UserIDPacket {}) = True
isUserID _                 = False

isTrust (TrustPacket {}) = True
isTrust _                = False


data OriginFlags = OriginFlags {
        originallyPublic :: Bool,
        originalNum :: Int
    }
    deriving Show
type OriginMap = Map.Map FilePath OriginFlags
data MappedPacket = MappedPacket
        { packet :: Packet
        , usage_tag :: Maybe String
        , locations :: OriginMap
        }

type TrustMap = Map.Map FilePath Packet
type SigAndTrust = ( MappedPacket
                   , TrustMap     ) -- trust packets

type KeyKey = [ByteString]
data SubKey = SubKey MappedPacket [SigAndTrust]
data KeyData = KeyData MappedPacket    -- main key
                       [SigAndTrust]  -- sigs on main key
                       (Map.Map String ([SigAndTrust],OriginMap))  -- uids
                       (Map.Map KeyKey SubKey)    -- subkeys

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 filename p = MappedPacket 
    { packet = p
    , usage_tag = Nothing
    , locations = Map.singleton filename (origin p (-1))
    }

keykey key =
    -- Note: The key's timestamp is included in it's fingerprint.
    --       Therefore, the same key with a different timestamp is
    --       considered distinct using this keykey implementation.
    fingerprint_material (key {timestamp=0}) -- TODO: smaller key?

uidkey (UserIDPacket str) = str

merge :: KeyDB -> FilePath -> Message -> KeyDB
merge db filename (Message ps) = merge_ db filename qs
 where
    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)
                _ | otherwise                    -> (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




merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
                -> KeyDB
merge_ db filename qs = foldl mergeit db (zip [0..] qs)
 where
    keycomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
    keycomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
    keycomp a b | keykey a==keykey b = EQ
    keycomp a b = error $ unlines ["Unable to merge keys:"
                                  , fingerprint a
                                  , PP.ppShow a
                                  , fingerprint b
                                  , PP.ppShow b
                                  ]

    asMapped n p = let m = mappedPacket filename p
                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
    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 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 ( (asMapped n (minimumBy keycomp [packet key,p]))
                                          { locations = Map.insert filename (origin p n) (locations key) } )
                                       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 ((asMapped n (minimumBy subcomp [packet key,p]))
                 { locations = Map.insert filename (origin p n) (locations key) })
               sigs
     where
        -- Compare master keys, LT is prefered for merging
        -- Compare subkeys, LT is prefered for merging
        subcomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
        subcomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
        subcomp a b | keykey a==keykey b = EQ
        subcomp a b = error $ unlines ["Unable to merge subs:"
                                      , fingerprint a
                                      , PP.ppShow a
                                      , fingerprint b
                                      , PP.ppShow b
                                      ]
        subcomp_m a b = subcomp (packet a) (packet b)

    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')


    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 =
                            foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) })
           , locations = Map.insert filename (origin a n) locs }
        , tb `Map.union` ta )

     where
        -- TODO: when merging items, we should delete invalidated origins
        -- from the orgin map.
        mergeItem ys x = if x `elem` ys then ys else ys++[x]

    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)