More robust parsing of Vault responses

vault-tool/src/Network/VaultTool/Transit.hs

@@ -1,15 +1,16 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
 
--- | Implements a subset of the Vault Transit secrets engine API.
--- c.f. https://developer.hashicorp.com/vault/api-docs/secret/transit#encrypt-data
---
--- The Transit secrets engine does not store secrets. Instead, it provides encryption
--- and decryption of data the client intends to persist themselves. The client persists
--- encrypted data and only decrypts it at the point where it's needed. This reduces
--- the risk and loss associated with a data breach.
+{- | Implements a subset of the Vault Transit secrets engine API.
+c.f. https://developer.hashicorp.com/vault/api-docs/secret/transit#encrypt-data
+
+The Transit secrets engine does not store secrets. Instead, it provides encryption
+and decryption of data the client intends to persist themselves. The client persists
+encrypted data and only decrypts it at the point where it's needed. This reduces
+the risk and loss associated with a data breach.
+-}
 module Network.VaultTool.Transit (
     KeyName,
     Base64 (..),
@@ -24,16 +25,17 @@ module Network.VaultTool.Transit (
     decryptText,
 ) where
 
-import Control.Monad ((<=<))
 import Control.Exception (throwIO)
-import GHC.Generics (Generic)
+import Control.Monad ((<=<))
+import qualified Data.Aeson as A
 import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString as B
 import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as C8
 import Data.Text (Text)
-import qualified Data.Aeson as A
-import qualified Data.Aeson.KeyMap as A
+import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import GHC.Generics (Generic)
 
 import Network.VaultTool.Internal (
     newPostRequest,
@@ -69,34 +71,30 @@ decodeBase64 = B64.decode . getBase64
 
 encryptBase64 :: VaultConnection Authenticated -> VaultMountedPath -> KeyName -> Base64 -> IO CipherText
 encryptBase64 conn path key =
-    parseResponse <=< runVaultRequestAuthenticated conn . newPostRequest (mkUri path key) . mkBody
+    maybe
+        (throwIO . userError $ "Unexpected response from vault transit encrypt")
+        (pure . getCyphertext)
+        <=< runVaultRequestAuthenticated conn
+            . newPostRequest (mkUri path key)
+            . mkBody
   where
-    mkUri (VaultMountedPath p) k = p <> "/" <> k
+    mkUri (VaultMountedPath p) k = T.intercalate "/" [p, "encrypt", k]
 
     mkBody = Just . A.object . pure . ("plaintext" A..=)
 
-    parseResponse res =
-        maybe (throwUnexpectedResponse res) pure $
-            pure res >>= A.lookup "data" >>= A.lookup "ciphertext"
-
-    throwUnexpectedResponse =
-        throwIO . userError . ("Unexpected response from vault trainsit encrypt: " <>) . show . A.encode
-
 decryptBase64 :: VaultConnection Authenticated -> VaultMountedPath -> KeyName -> CipherText -> IO Base64
 decryptBase64 conn path key =
-    parseResponse <=< runVaultRequestAuthenticated conn . newPostRequest (mkUri path key) . mkBody
+    maybe
+        (throwIO . userError $ "Unexpected response from vault transit decrypt")
+        (pure . getPlaintext)
+        <=< runVaultRequestAuthenticated conn
+            . newPostRequest (mkUri path key)
+            . mkBody
   where
-    mkUri (VaultMountedPath p) k = p <> "/" <> k
+    mkUri (VaultMountedPath p) k = T.intercalate "/" [p, "decrypt", k]
 
     mkBody = Just . A.object . pure . ("ciphertext" A..=)
 
-    parseResponse res =
-        maybe (throwUnexpectedResponse res) pure $
-            pure res >>= A.lookup "data" >>= A.lookup "plaintext"
-
-    throwUnexpectedResponse =
-        throwIO . userError . ("Unexpected response from vault transit decrypt: " <>) . show . A.encode
-
 encryptByteString :: VaultConnection Authenticated -> VaultMountedPath -> KeyName -> ByteString -> IO CipherText
 encryptByteString conn path key = encryptBase64 conn path key . encodeBase64
 
@@ -106,10 +104,33 @@ decryptByteString conn path key =
   where
     decodeError msg =
         throwIO . userError $
-            "Failed to decode Base64 response value from vault transic decrypt: " <> msg
+            "Failed to decode Base64 response value from vault transit decrypt: " <> msg
 
 encryptText :: VaultConnection Authenticated -> VaultMountedPath -> KeyName -> Text -> IO CipherText
 encryptText conn path key = encryptByteString conn path key . encodeUtf8
 
 decryptText :: VaultConnection Authenticated -> VaultMountedPath -> KeyName -> CipherText -> IO Text
 decryptText conn path key = fmap decodeLatin1 . decryptByteString conn path key
+
+newtype VaultCiphertext
+    = VaultCiphertext {getCyphertext :: CipherText}
+
+instance A.FromJSON VaultCiphertext where
+    parseJSON = A.withObject "VaultCiphertext" $ \obj -> do
+        data' <- obj A..: "data"
+        Base64 ciphertext <- data' A..: "ciphertext"
+        case B.split colon ciphertext of
+            -- Typically, the ciphertext will look like
+            --    "vault:v1:<ciphertext>"
+            ["vault", _version, cphtxt] -> pure $ VaultCiphertext (CipherText $ Base64 cphtxt)
+            _otherwise -> fail "Undecipherable ciphertext"
+      where
+        colon = fromIntegral $ fromEnum ':'
+
+newtype VaultPlaintext a
+    = VaultPlaintext {getPlaintext :: a}
+
+instance (A.FromJSON a) => A.FromJSON (VaultPlaintext a) where
+    parseJSON = A.withObject "VaultPlaintext" $ \obj -> do
+        data' <- obj A..: "data"
+        VaultPlaintext <$> data' A..: "plaintext"