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   ) where
   12 
   13 import Data.Bits (xor)
   14 import Data.ByteString (ByteString)
   15 import Data.ByteString qualified as BS
   16 import Data.Text (Text)
   17 import Data.Text qualified as T
   18 import Data.Text.Encoding qualified as TE
   19 import System.Process.Typed
   20 
   21 -- | Errors that can arise from vault operations.
   22 data VaultError
   23   = VaultLocked
   24   | VaultNotFound
   25   | VaultCorrupted Text
   26   | AgeError Text          -- ^ stderr from age subprocess
   27   | VaultAlreadyExists
   28   | AgeNotInstalled Text   -- ^ message with install hint
   29   deriving stock (Show, Eq)
   30 
   31 -- | An age public-key recipient (e.g. "age1..." or "age-plugin-yubikey-...").
   32 newtype AgeRecipient = AgeRecipient Text
   33   deriving stock (Show, Eq)
   34 
   35 -- | An age identity: a file path or plugin string.
   36 newtype AgeIdentity = AgeIdentity Text
   37   deriving stock (Show, Eq)
   38 
   39 -- | Handle for age encrypt/decrypt operations.
   40 -- Use 'mkAgeEncryptor' for the real subprocess implementation,
   41 -- or 'mkMockAgeEncryptor' in tests.
   42 data AgeEncryptor = AgeEncryptor
   43   { _ae_encrypt :: AgeRecipient -> ByteString -> IO (Either VaultError ByteString)
   44   , _ae_decrypt :: AgeIdentity  -> ByteString -> IO (Either VaultError ByteString)
   45   }
   46 
   47 -- | Construct a real 'AgeEncryptor' that shells out to the @age@ binary.
   48 -- Performs a preflight @age --version@ check; returns
   49 -- @Left (AgeNotInstalled hint)@ if the binary is not on PATH.
   50 mkAgeEncryptor :: IO (Either VaultError AgeEncryptor)
   51 mkAgeEncryptor = do
   52   versionResult <- runProcess (proc "age" ["--version"])
   53   case versionResult of
   54     ExitFailure _ ->
   55       pure (Left (AgeNotInstalled "Install age from https://age-encryption.org"))
   56     ExitSuccess   ->
   57       pure (Right enc)
   58   where
   59     enc :: AgeEncryptor
   60     enc = AgeEncryptor
   61       { _ae_encrypt = \(AgeRecipient recipient) plaintext -> do
   62           let cfg = setStdin (byteStringInput (BS.fromStrict plaintext))
   63                   $ proc "age" ["--encrypt", "--recipient", textToStr recipient]
   64           (exitCode, out, err) <- readProcess cfg
   65           case exitCode of
   66             ExitSuccess   -> pure (Right (BS.toStrict out))
   67             ExitFailure _ -> pure (Left (AgeError (TE.decodeUtf8 (BS.toStrict err))))
   68       , _ae_decrypt = \(AgeIdentity identity) ciphertext -> do
   69           let cfg = setStdin (byteStringInput (BS.fromStrict ciphertext))
   70                   $ proc "age" ["--decrypt", "--identity", textToStr identity]
   71           (exitCode, out, err) <- readProcess cfg
   72           case exitCode of
   73             ExitSuccess   -> pure (Right (BS.toStrict out))
   74             ExitFailure _ -> pure (Left (AgeError (TE.decodeUtf8 (BS.toStrict err))))
   75       }
   76 
   77     textToStr :: Text -> String
   78     textToStr = T.unpack
   79 
   80 -- | A mock 'AgeEncryptor' that XORs each byte with @0xAB@.
   81 -- No real @age@ binary required — suitable for unit tests.
   82 mkMockAgeEncryptor :: AgeEncryptor
   83 mkMockAgeEncryptor = AgeEncryptor
   84   { _ae_encrypt = \_recipient plaintext -> pure (Right (mockXor plaintext))
   85   , _ae_decrypt = \_identity  ciphertext -> pure (Right (mockXor ciphertext))
   86   }
   87   where
   88     mockXor :: ByteString -> ByteString
   89     mockXor = BS.map (`xor` 0xAB)
   90 
   91 -- | A mock 'AgeEncryptor' that always returns the given error.
   92 -- Useful for testing error-path handling in vault operations.
   93 mkFailingAgeEncryptor :: VaultError -> AgeEncryptor
   94 mkFailingAgeEncryptor err = AgeEncryptor
   95   { _ae_encrypt = \_ _ -> pure (Left err)
   96   , _ae_decrypt = \_ _ -> pure (Left err)
   97   }