path: root/lib/Types.hs

{-# LANGUAGE DeriveFunctor #-}
module Types where

import           Data.Char (isLower,toLower)
import           Data.List (groupBy)
import           Data.Map as Map (Map)
import qualified Data.Map as Map
import           Data.OpenPGP
import           Data.OpenPGP.Util
import           FunctorToMaybe
import qualified Data.ByteString.Lazy as L
import qualified System.Posix.Types as Posix

-- | This type describes an idempotent transformation (merge or import) on a
-- set of GnuPG keyrings and other key files.
data KeyRingOperation = KeyRingOperation
    { opFiles :: 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)

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)
               | Generate Int GenerateKeyParams
               -- ^ New key packets will be generated if there is no
               -- matching content already in the key pool. The integer is
               -- a unique id number so that multiple generations can be
               -- inserted into 'opFiles'
 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 :: Initializer
    -- ^ If 'typ' is 'PEMFile' and an 'External' '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)


-- | 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 { passSpecTranscoder :: PacketTranscoder }
    | PassphraseAgent

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

-- Ord instance for PassphraseSpec generally orders by generality with the most
-- general being greatest and the least general being least.  The one exception
-- is the 'PassphraseMemoizer' which is considered least of all even though it
-- is very general.  This is so an existing memoizer will be tried first, and
-- if there is none, one will be created that tries the others in order of
-- increasing generality.  Key-specialization is considered less general than
-- file-specialization.
instance Ord PassphraseSpec where
    compare (PassphraseMemoizer _) (PassphraseMemoizer _) = EQ
    compare PassphraseAgent PassphraseAgent               = EQ
    compare (PassphraseMemoizer _) _                      = LT
    compare (PassphraseSpec a b c) (PassphraseSpec d e f)
        | fmap (const ()) a == fmap (const ()) d
          && fmap (const ()) b == fmap (const ()) e       = compare (a,b,c) (d,e,f)
    compare (PassphraseSpec (Just _) (Just _) _)  _       = LT
    compare (PassphraseSpec Nothing (Just _) _) _         = LT
    compare (PassphraseSpec (Just _) _  _) _              = LT
    compare PassphraseAgent _                             = GT

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 <root@HOSTNAME.onion>
        | DeleteSubkeyByFingerprint String
        -- ^ Delete the subkey specified by the given fingerprint and any
        -- associated signatures on that key.
        | DeleteSubkeyByUsage String
        -- ^ Delete the subkey specified by the given usage tag and any
        -- associated signatures on that key.
        | RenameSubkeys String String
        -- ^ Replace all subkey signatures matching the first usage tag with
        -- fresh signatures that match the second usage tag.
 deriving (Eq,Ord,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)

data FileType = KeyRingFile
              | PEMFile
              | WalletFile
              | DNSPresentation
              | Hosts
              | SshFile
 deriving (Eq,Ord,Enum,Show)

-- type UsageTag = String
data Initializer = NoCreate | Internal GenerateKeyParams | External String | WarnMissing String
 deriving (Eq,Ord,Show)



type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet)
type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet)

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

-- | The position and acces a packet had before the operation
data OriginFlags = OriginFlags
        { originallyPublic :: Bool
        -- ^ false if SecretKeyPacket
        , originalNum :: Int
        -- ^ packets are numbered, starting from 1..
        } deriving Show

type OriginMap = Map FilePath OriginFlags

type MappedPacket = OriginMapped Packet
data OriginMapped a = MappedPacket
        { packet :: a
        , locations :: OriginMap
        } deriving Show
instance Functor OriginMapped where
    fmap f (MappedPacket x ls) = MappedPacket (f x) ls

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


-- | 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
    | AgentConnectionFailure
    | OperationCanceled
 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

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

errorString :: KikiCondition a -> String
errorString (KikiSuccess {}) = "success"
errorString e = uncamel . show $ fmap (const ()) e



data InputFileContext = InputFileContext
    { homesecPath :: FilePath
    , homepubPath :: FilePath
    }


-- | The 'KeyKey'-type is used to store the information of a key
--   which is used for finger-printing and as a lookup key into
--   maps.  This type may be changed to an actual fingerprint in
--   in the future.
type KeyKey = [L.ByteString]

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?

isKey :: Packet -> Bool
isKey (PublicKeyPacket {}) = True
isKey (SecretKeyPacket {}) = True
isKey _                    = False

isSecretKey :: Packet -> Bool
isSecretKey (SecretKeyPacket {}) = True
isSecretKey _                    = False


isUserID :: Packet -> Bool
isUserID (UserIDPacket {}) = True
isUserID _                 = False

isTrust :: Packet -> Bool
isTrust (TrustPacket {}) = True
isTrust _                = False

-- matchpr computes the fingerprint of the given key truncated to
-- be the same lenght as the given fingerprint for comparison.
--
-- matchpr fp = Data.List.Extra.takeEnd (length fp)
--
matchpr :: String -> Packet -> String
matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp