never executed always true always false

    1 module PureClaw.Security.Vault.Age
    2   ( -- * Error type
    3     VaultError (..)
    4     -- * Age encryptor handle
    5   , AgeEncryptor (..)
    6   , AgeRecipient (..)
    7   , AgeIdentity (..)
    8   , mkAgeEncryptor
    9   , mkMockAgeEncryptor
   10   , mkFailingAgeEncryptor
   11     -- * Simplified vault encryptor (credentials captured in closure)
   12   , VaultEncryptor (..)
   13   , ageVaultEncryptor
   14   , mkMockVaultEncryptor
   15   ) where
   16 
   17 import Data.Bits (xor)
   18 import Data.ByteString (ByteString)
   19 import Data.ByteString qualified as BS
   20 import Data.Text (Text)
   21 import Data.Text qualified as T
   22 import Data.Text.Encoding qualified as TE
   23 import System.Process.Typed
   24 
   25 -- | Errors that can arise from vault operations.
   26 data VaultError
   27   = VaultLocked
   28   | VaultNotFound
   29   | VaultCorrupted Text
   30   | AgeError Text          -- ^ stderr from age subprocess
   31   | VaultAlreadyExists
   32   | AgeNotInstalled Text   -- ^ message with install hint
   33   deriving stock (Show, Eq)
   34 
   35 -- | An age public-key recipient (e.g. "age1..." or "age-plugin-yubikey-...").
   36 newtype AgeRecipient = AgeRecipient Text
   37   deriving stock (Show, Eq)
   38 
   39 -- | An age identity: a file path or plugin string.
   40 newtype AgeIdentity = AgeIdentity Text
   41   deriving stock (Show, Eq)
   42 
   43 -- | Handle for age encrypt/decrypt operations.
   44 -- Use 'mkAgeEncryptor' for the real subprocess implementation,
   45 -- or 'mkMockAgeEncryptor' in tests.
   46 data AgeEncryptor = AgeEncryptor
   47   { _ae_encrypt :: AgeRecipient -> ByteString -> IO (Either VaultError ByteString)
   48   , _ae_decrypt :: AgeIdentity  -> ByteString -> IO (Either VaultError ByteString)
   49   }
   50 
   51 -- | Construct a real 'AgeEncryptor' that shells out to the @age@ binary.
   52 -- Performs a preflight @age --version@ check; returns
   53 -- @Left (AgeNotInstalled hint)@ if the binary is not on PATH.
   54 mkAgeEncryptor :: IO (Either VaultError AgeEncryptor)
   55 mkAgeEncryptor = do
   56   versionResult <- runProcess (proc "age" ["--version"])
   57   case versionResult of
   58     ExitFailure _ ->
   59       pure (Left (AgeNotInstalled "Install age from https://age-encryption.org"))
   60     ExitSuccess   ->
   61       pure (Right enc)
   62   where
   63     enc :: AgeEncryptor
   64     enc = AgeEncryptor
   65       { _ae_encrypt = \(AgeRecipient recipient) plaintext -> do
   66           let cfg = setStdin (byteStringInput (BS.fromStrict plaintext))
   67                   $ proc "age" ["--encrypt", "--recipient", textToStr recipient]
   68           (exitCode, out, err) <- readProcess cfg
   69           case exitCode of
   70             ExitSuccess   -> pure (Right (BS.toStrict out))
   71             ExitFailure _ -> pure (Left (AgeError (TE.decodeUtf8 (BS.toStrict err))))
   72       , _ae_decrypt = \(AgeIdentity identity) ciphertext -> do
   73           let cfg = setStdin (byteStringInput (BS.fromStrict ciphertext))
   74                   $ proc "age" ["--decrypt", "--identity", textToStr identity]
   75           (exitCode, out, err) <- readProcess cfg
   76           case exitCode of
   77             ExitSuccess   -> pure (Right (BS.toStrict out))
   78             ExitFailure _ -> pure (Left (AgeError (TE.decodeUtf8 (BS.toStrict err))))
   79       }
   80 
   81     textToStr :: Text -> String
   82     textToStr = T.unpack
   83 
   84 -- | A mock 'AgeEncryptor' that XORs each byte with @0xAB@.
   85 -- No real @age@ binary required — suitable for unit tests.
   86 mkMockAgeEncryptor :: AgeEncryptor
   87 mkMockAgeEncryptor = AgeEncryptor
   88   { _ae_encrypt = \_recipient plaintext -> pure (Right (mockXor plaintext))
   89   , _ae_decrypt = \_identity  ciphertext -> pure (Right (mockXor ciphertext))
   90   }
   91   where
   92     mockXor :: ByteString -> ByteString
   93     mockXor = BS.map (`xor` 0xAB)
   94 
   95 -- | A mock 'AgeEncryptor' that always returns the given error.
   96 -- Useful for testing error-path handling in vault operations.
   97 mkFailingAgeEncryptor :: VaultError -> AgeEncryptor
   98 mkFailingAgeEncryptor err = AgeEncryptor
   99   { _ae_encrypt = \_ _ -> pure (Left err)
  100   , _ae_decrypt = \_ _ -> pure (Left err)
  101   }
  102 
  103 -- | Simplified encryptor: credentials are captured in the closure.
  104 -- Replaces the explicit AgeRecipient/AgeIdentity arguments at call sites.
  105 data VaultEncryptor = VaultEncryptor
  106   { _ve_encrypt :: ByteString -> IO (Either VaultError ByteString)
  107   , _ve_decrypt :: ByteString -> IO (Either VaultError ByteString)
  108   }
  109 
  110 -- | Create a 'VaultEncryptor' from an 'AgeEncryptor' with specific recipient/identity.
  111 ageVaultEncryptor :: AgeEncryptor -> Text -> Text -> VaultEncryptor
  112 ageVaultEncryptor enc recipient identity = VaultEncryptor
  113   { _ve_encrypt = _ae_encrypt enc (AgeRecipient recipient)
  114   , _ve_decrypt = _ae_decrypt enc (AgeIdentity identity)
  115   }
  116 
  117 -- | A mock 'VaultEncryptor' for unit tests (XOR like 'mkMockAgeEncryptor').
  118 mkMockVaultEncryptor :: VaultEncryptor
  119 mkMockVaultEncryptor = VaultEncryptor
  120   { _ve_encrypt = pure . Right . mockXor
  121   , _ve_decrypt = pure . Right . mockXor
  122   }
  123   where
  124     mockXor :: ByteString -> ByteString
  125     mockXor = BS.map (`xor` 0xAB)