diff --git a/vault-tool-server/test/test.hs b/vault-tool-server/test/test.hs index ead8379..359f061 100644 --- a/vault-tool-server/test/test.hs +++ b/vault-tool-server/test/test.hs @@ -8,16 +8,23 @@ import Control.Exception (catch) import Data.Aeson (FromJSON, ToJSON, (.=), object) import Data.Functor (($>)) import Data.List (sort) +import Data.List.Split (splitOn) +import Data.Maybe (catMaybes) import Data.Text (Text) +import qualified Data.Text as T import GHC.Generics (Generic) +import Network.HTTP.Client (Manager) +import Network.URI (URI (..), parseURI) import System.Environment (lookupEnv) import System.IO.Temp (withSystemTempDirectory) -import Test.Tasty.HUnit ((@?=), assertBool) +import Test.Tasty.HUnit ((@?=), assertBool, assertFailure) import Network.VaultTool ( + Authenticated, VaultAddress, VaultAppRoleParameters (..), VaultAppRoleSecretIdGenerateResponse (..), + VaultConnection, VaultException, VaultHealth (..), VaultMount (..), @@ -49,15 +56,8 @@ import Network.VaultTool ( vaultUnmount, vaultUnseal, ) -import Network.VaultTool.KeyValueV2 ( - VaultSecretVersion (..), - vaultDelete, - vaultRead, - vaultReadVersion, - vaultWrite, - vaultList, - vaultListRecursive, - ) +import qualified Network.VaultTool.KeyValueV2 as KeyValueV2 +import qualified Network.VaultTool.TOTP as TOTP import Network.VaultTool.VaultServerProcess ( VaultBackendConfig, vaultAddress, @@ -194,38 +194,58 @@ talkToVault addr = do mounts3 <- vaultMounts authConn lookup "mymount/" mounts3 @?= Nothing + keyValueV2Tests authConn manager addr + + totpTests authConn + + vaultSeal authConn + + status5 <- vaultSealStatus unauthConn + status5 @?= VaultSealStatus + { _VaultSealStatus_Sealed = True + , _VaultSealStatus_T = 2 + , _VaultSealStatus_N = 4 + , _VaultSealStatus_Progress = 0 + } + + health2 <- vaultHealth unauthConn + _VaultHealth_Initialized health2 @?= True + _VaultHealth_Sealed health2 @?= True + +keyValueV2Tests :: VaultConnection Authenticated -> Manager -> VaultAddress -> IO () +keyValueV2Tests authConn manager addr = do let pathBig = mkVaultSecretPath "big" - vaultWrite authConn pathBig (object ["A" .= 'a', "B" .= 'b']) + KeyValueV2.vaultWrite authConn pathBig (object ["A" .= 'a', "B" .= 'b']) - r <- vaultRead authConn pathBig - vsvData r @?= object ["A" .= 'a', "B" .= 'b'] + r <- KeyValueV2.vaultRead authConn pathBig + KeyValueV2.vsvData r @?= object ["A" .= 'a', "B" .= 'b'] let pathFun = mkVaultSecretPath "fun" - vaultWrite authConn pathFun (FunStuff "fun" [1, 2, 3]) - r2 <- vaultRead authConn pathFun - vsvData r2 @?= (FunStuff "fun" [1, 2, 3]) + KeyValueV2.vaultWrite authConn pathFun (FunStuff "fun" [1, 2, 3]) + r2 <- KeyValueV2.vaultRead authConn pathFun + KeyValueV2.vsvData r2 @?= (FunStuff "fun" [1, 2, 3]) - throws (vaultRead authConn pathBig :: IO (VaultSecretVersion FunStuff)) >>= (@?= True) + throws (KeyValueV2.vaultRead authConn pathBig :: IO (KeyValueV2.VaultSecretVersion FunStuff)) >>= (@?= True) let pathFooBarA = mkVaultSecretPath "foo/bar/a" pathFooBarB = mkVaultSecretPath "foo/bar/b" pathFooBarABCDEFG = mkVaultSecretPath "foo/bar/a/b/c/d/e/f/g" pathFooQuackDuck = mkVaultSecretPath "foo/quack/duck" - vaultWrite authConn pathFooBarA (object ["X" .= 'x']) - vaultWrite authConn pathFooBarB (object ["X" .= 'x']) - vaultWrite authConn pathFooBarABCDEFG (object ["X" .= 'x']) - vaultWrite authConn pathFooQuackDuck (object ["X" .= 'x']) + KeyValueV2.vaultWrite authConn pathFooBarA (object ["X" .= 'x']) + KeyValueV2.vaultWrite authConn pathFooBarB (object ["X" .= 'x']) + KeyValueV2.vaultWrite authConn pathFooBarABCDEFG (object ["X" .= 'x']) + KeyValueV2.vaultWrite authConn pathFooQuackDuck (object ["X" .= 'x']) let emptySecretPath = mkVaultSecretPath "" - keys <- vaultList authConn emptySecretPath + keys <- KeyValueV2.vaultList authConn emptySecretPath assertBool "Secret in list" $ pathBig `elem` keys - vaultDelete authConn pathBig + KeyValueV2.vaultDelete authConn pathBig - keys2 <- vaultList authConn emptySecretPath + keys2 <- KeyValueV2.vaultList authConn emptySecretPath assertBool "Secret not in list" $ not (pathBig `elem` keys2) - keys3 <- vaultListRecursive authConn (mkVaultSecretPath "foo") + keys3 <- KeyValueV2.vaultListRecursive authConn (mkVaultSecretPath "foo") sort keys3 @?= sort [ pathFooBarA , pathFooBarB @@ -234,17 +254,17 @@ talkToVault addr = do ] let pathReadVersionTest = mkVaultSecretPath "read/version/secret" - vaultWrite authConn pathReadVersionTest (FunStuff "x" [1]) - vaultWrite authConn pathReadVersionTest (FunStuff "y" [2, 3]) - v1Resp <- vaultReadVersion authConn pathReadVersionTest (Just 1) - vsvData v1Resp @?= (FunStuff "x" [1]) - v2Resp <- vaultReadVersion authConn pathReadVersionTest Nothing - vsvData v2Resp @?= (FunStuff "y" [2, 3]) + KeyValueV2.vaultWrite authConn pathReadVersionTest (FunStuff "x" [1]) + KeyValueV2.vaultWrite authConn pathReadVersionTest (FunStuff "y" [2, 3]) + v1Resp <- KeyValueV2.vaultReadVersion authConn pathReadVersionTest (Just 1) + KeyValueV2.vsvData v1Resp @?= (FunStuff "x" [1]) + v2Resp <- KeyValueV2.vaultReadVersion authConn pathReadVersionTest Nothing + KeyValueV2.vsvData v2Resp @?= (FunStuff "y" [2, 3]) vaultAuthEnable authConn "approle" let pathSmall = mkVaultSecretPath "small" - vaultWrite authConn pathSmall (object ["X" .= 'x']) + KeyValueV2.vaultWrite authConn pathSmall (object ["X" .= 'x']) vaultPolicyCreate authConn "foo" "path \"secret/small\" { capabilities = [\"read\"] }" @@ -254,21 +274,71 @@ talkToVault addr = do secretId <- _VaultAppRoleSecretIdGenerateResponse_SecretId <$> vaultAppRoleSecretIdGenerate authConn "foo-role" "" arConn <- connectToVaultAppRole manager addr roleId secretId - throws (vaultRead arConn pathSmall :: IO (VaultSecretVersion FunStuff)) >>= (@?= True) - - vaultSeal authConn + throws (KeyValueV2.vaultRead arConn pathSmall :: IO (KeyValueV2.VaultSecretVersion FunStuff)) >>= (@?= True) - status5 <- vaultSealStatus unauthConn - status5 @?= VaultSealStatus - { _VaultSealStatus_Sealed = True - , _VaultSealStatus_T = 2 - , _VaultSealStatus_N = 4 - , _VaultSealStatus_Progress = 0 +totpTests :: VaultConnection Authenticated -> IO () +totpTests authConn = do + vaultNewMount authConn "totp" VaultMount + { _VaultMount_Type = "totp" + , _VaultMount_Description = Just "totp test" + , _VaultMount_Config = Nothing + , _VaultMount_Options = Nothing } - health2 <- vaultHealth unauthConn - _VaultHealth_Initialized health2 @?= True - _VaultHealth_Sealed health2 @?= True + let pathTOTP = (VaultMountedPath "totp") + key1 = "key1" + issuer = "Vault" + account1 = "test1@test.com" + + genKey <- TOTP.generateKey authConn pathTOTP $ mkGenKeyReq key1 issuer account1 + case (parseURI . T.unpack $ TOTP.gkrUrl genKey) of + Nothing -> assertFailure "unable to parse key url" + Just url -> do + uriPath url @?= T.unpack ("/" <> issuer <> ":" <> account1) + let queryArgs = parseQueryString $ uriQuery url + lookup "algorithm" queryArgs @?= Just "SHA1" + lookup "digits" queryArgs @?= Just "6" + lookup "issuer" queryArgs @?= Just (T.unpack issuer) + lookup "period" queryArgs @?= Just "30" + + key <- TOTP.getKey authConn pathTOTP key1 + TOTP.kAccountName key @?= account1 + TOTP.kAlgorithm key @?= TOTP.SHA1 + TOTP.kDigitCount key @?= TOTP.SixDigits + TOTP.kIssuer key @?= issuer + TOTP.kPeriod key @?= 30 + + let key2 = "key2" + account2 = "test2@test.com" + _ <- TOTP.generateKey authConn pathTOTP $ mkGenKeyReq key2 issuer account2 + keys <- TOTP.listKeys authConn pathTOTP + sort (TOTP.unKeyNames keys) @?= [key1, key2] + + TOTP.deleteKey authConn pathTOTP key2 + throws (TOTP.getKey authConn pathTOTP key2) >>= (@?= True) + + code <- TOTP.generateCode authConn pathTOTP key1 + validateCodeResp1 <- TOTP.validateCode authConn pathTOTP key1 code + validateCodeResp1 @?= TOTP.ValidCode + + validateCodeResp2 <- TOTP.validateCode authConn pathTOTP key1 (TOTP.Code "00000") + validateCodeResp2 @?= TOTP.InvalidCode + where + parseQueryString = catMaybes . map (toPair . splitOn "=") . splitOn "&" . drop 1 + toPair [x,y] = Just (x, y) + toPair _ = Nothing + mkGenKeyReq keyName issuer account = + TOTP.GenerateKeyRequest + { TOTP.gkrKeyName = keyName + , TOTP.gkrIssuer = issuer + , TOTP.gkrAccountName = account + , TOTP.gkrKeySize = Nothing + , TOTP.gkrPeriod = Nothing + , TOTP.gkrAlgorithm = Nothing + , TOTP.gkrDigitCount = Nothing + , TOTP.gkrSkew = Nothing + , TOTP.gkrQrSize = Nothing + } data FunStuff = FunStuff { funString :: String diff --git a/vault-tool-server/vault-tool-server.cabal b/vault-tool-server/vault-tool-server.cabal index 0ca6aab..dafcced 100644 --- a/vault-tool-server/vault-tool-server.cabal +++ b/vault-tool-server/vault-tool-server.cabal @@ -45,6 +45,9 @@ test-suite test vault-tool >=0.2.0.0, vault-tool-server, aeson, + http-client, + network-uri, + split, tasty-hunit, temporary, text diff --git a/vault-tool/src/Data/Aeson/Utils.hs b/vault-tool/src/Data/Aeson/Utils.hs new file mode 100644 index 0000000..78cd03b --- /dev/null +++ b/vault-tool/src/Data/Aeson/Utils.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.Aeson.Utils ( + object, + (.=!), + (.=?), + DataWrapper (..) +) where + +import Data.Aeson (FromJSON, KeyValue, ToJSON, Value, (.=), (.:), withObject) +import qualified Data.Aeson as Aeson +import Data.Maybe (catMaybes) +import Data.Text (Text) + +object :: [Maybe (Text, Value)] -> Value +object = Aeson.object . catMaybes + +(.=!) :: (KeyValue a, ToJSON b) => Text -> b -> Maybe a +k .=! v = Just $ k .= v + +(.=?) :: (Functor f, KeyValue a, ToJSON b) => Text -> f b -> f a +k .=? v = (k .=) <$> v + +newtype DataWrapper a = DataWrapper { unDataWrapper :: a } + +instance ToJSON a => ToJSON (DataWrapper a) where + toJSON (DataWrapper x) = object ["data" .=! x] + +instance FromJSON a => FromJSON (DataWrapper a) where + parseJSON = withObject "DataWrapper" $ fmap DataWrapper . (.: "data") diff --git a/vault-tool/src/Network/VaultTool/KeyValueV2.hs b/vault-tool/src/Network/VaultTool/KeyValueV2.hs index 2fcffa9..ca60637 100644 --- a/vault-tool/src/Network/VaultTool/KeyValueV2.hs +++ b/vault-tool/src/Network/VaultTool/KeyValueV2.hs @@ -22,13 +22,11 @@ import Control.Applicative (optional) import Data.Aeson ( FromJSON, ToJSON, - object, parseJSON, - toJSON, withObject, (.:), - (.=), ) +import Data.Aeson.Utils (DataWrapper(..)) import Data.Text (Text) import qualified Data.Text as T import Data.Time (UTCTime) @@ -96,21 +94,13 @@ vaultReadVersion :: Maybe Int -> IO (VaultSecretVersion a) vaultReadVersion conn (VaultSecretPath (mountedPath, searchPath)) version = - runVaultRequestAuthenticated conn (newGetRequest path) >>= \(DataWrapper x) -> pure x + unDataWrapper <$> runVaultRequestAuthenticated conn (newGetRequest path) where path = vaultActionPath ReadSecretVersion mountedPath searchPath <> queryParams queryParams = case version of Nothing -> "" Just n -> "?version=" <> T.pack (show n) -newtype DataWrapper a = DataWrapper a - -instance ToJSON a => ToJSON (DataWrapper a) where - toJSON (DataWrapper x) = object ["data" .= x] - -instance FromJSON a => FromJSON (DataWrapper a) where - parseJSON = withObject "DataWrapper" $ fmap DataWrapper . (.: "data") - {- | -} vaultWrite :: ToJSON a => VaultConnection Authenticated -> VaultSecretPath -> a -> IO () diff --git a/vault-tool/src/Network/VaultTool/TOTP.hs b/vault-tool/src/Network/VaultTool/TOTP.hs new file mode 100644 index 0000000..7730e3c --- /dev/null +++ b/vault-tool/src/Network/VaultTool/TOTP.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | A library for working with Vault's TOTP secrets engine + https://www.vaultproject.io/api-docs/secret/totp + + Unless otherwise specified, all IO functions in this module may + potentially throw 'HttpException' or 'VaultException' +-} +module Network.VaultTool.TOTP ( + GenerateKeyRequest (..), + HashAlgorithm (..), + DigitCount (..), + Skew (..), + GeneratedKey (..), + generateKey, + + Key (..), + getKey, + + KeyNames (..), + listKeys, + + deleteKey, + + Code (..), + generateCode, + + CodeStatus (..), + validateCode, +) where + +import Data.Aeson ( + FromJSON (..), + ToJSON (..), + Value (..), + (.:), + withObject, + ) +import Data.Aeson.Utils (DataWrapper (..), (.=!), (.=?), object) +import Data.Bool (bool) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T + +import Network.VaultTool.Internal ( + newDeleteRequest, + newGetRequest, + newListRequest, + newPostRequest, + runVaultRequestAuthenticated, + runVaultRequestAuthenticated_, + withStatusCodes, + ) +import Network.VaultTool.Types ( + Authenticated, + VaultConnection, + VaultMountedPath (..), + ) + +-- | The data needed for vault to generate a TOTP Key +-- +data GenerateKeyRequest = GenerateKeyRequest + { -- | The name of the key to create + gkrKeyName :: Text, + -- | The name of the key's issuing organization + gkrIssuer :: Text, + -- | The name of the account associated with the key + gkrAccountName :: Text, + -- | The size of the key in bytes (defaults: 20) + gkrKeySize :: Maybe Int, + -- | The length of time in seconds used to generate a counter for the TOTP code calculation (default: 30) + gkrPeriod :: Maybe Int, + -- | The hashing algorithm to use. Options are 'SHA1', 'SHA256', 'SHA512'. (default: 'SHA1') + gkrAlgorithm :: Maybe HashAlgorithm, + -- | The number of digits in the generated TOTP code. Options are 'SixDigits' or 'EightDigits'. (default: 'SixDigits') + gkrDigitCount :: Maybe DigitCount, + -- | The number of delay periods allowed when validating TOTP code. Options are 'NoSkew' or 'OnePeriodSkew'. + -- (default: 'OnePeriodSkew') + gkrSkew :: Maybe Skew, + -- | The pixel size of the square QR code when generating a new key (default: 200) + gkrQrSize :: Maybe Int + } + deriving (Show, Eq) + +instance ToJSON GenerateKeyRequest where + toJSON x = object + [ "generate" .=! True + , "issuer" .=! gkrIssuer x + , "account_name" .=! gkrAccountName x + , "key_size" .=? gkrKeySize x + , "period" .=? gkrPeriod x + , "algorithm" .=? gkrAlgorithm x + , "digits" .=? gkrDigitCount x + , "skew" .=? gkrSkew x + , "qr_size" .=? gkrQrSize x + ] + +data HashAlgorithm = SHA1 | SHA256 | SHA512 + deriving (Show, Eq) + +instance FromJSON HashAlgorithm where + parseJSON (String "SHA1") = pure SHA1 + parseJSON (String "SHA256") = pure SHA256 + parseJSON (String "SHA512") = pure SHA512 + parseJSON x = fail $ "Expected 'SHA1', 'SHA256' or 'SHA512' but received " <> show x + +instance ToJSON HashAlgorithm where + toJSON = \case + SHA1 -> String "SHA1" + SHA256 -> String "SHA256" + SHA512 -> String "SHA512" + +data DigitCount = SixDigits | EightDigits + deriving (Show, Eq) + +instance FromJSON DigitCount where + parseJSON (Number 6) = pure SixDigits + parseJSON (Number 8) = pure EightDigits + parseJSON x = fail $ "Expected 6 or 8 but received " <> show x + +instance ToJSON DigitCount where + toJSON = \case + SixDigits -> Number 6 + EightDigits -> Number 8 + +data Skew = NoSkew | OnePeriodSkew + deriving (Show, Eq) + +instance ToJSON Skew where + toJSON = \case + NoSkew -> Number 0 + OnePeriodSkew -> Number 1 + +-- | The newly generated Vault TOTP key +data GeneratedKey = GeneratedKey + { -- | The resulting base64 encoded QR code PNG + gkrBarcode :: Text, + -- | The resulting otpauth url for the key + gkrUrl :: Text + } + deriving (Show, Eq) + +instance FromJSON GeneratedKey where + parseJSON = withObject "GeneratedKey" $ \v -> + GeneratedKey <$> v .: "barcode" <*> v .: "url" + +-- | Generates a new TOTP code via Vault's TOTP API +generateKey :: VaultConnection Authenticated -> VaultMountedPath -> GenerateKeyRequest -> IO GeneratedKey +generateKey conn path req = fmap unDataWrapper + . runVaultRequestAuthenticated conn + . newPostRequest (mkPathWithKey KeysNamespace path $ gkrKeyName req) + $ Just req + +-- | A TOTP key managed in Vault +data Key = Key + { + -- | The name of the account associated with the key + kAccountName :: Text, + -- | The hashing algorithm to use. Options are 'SHA1', 'SHA256', 'SHA512'. (default: 'SHA1') + kAlgorithm :: HashAlgorithm, + -- | The number of digits in the generated TOTP code. Options are 'SixDigits' or 'EightDigits'. (default: 'SixDigits') + kDigitCount :: DigitCount, + -- | The name of the key's issuing organization + kIssuer :: Text, + -- | The length of time in seconds used to generate a counter for the TOTP code calculation (default: 30) + kPeriod :: Int + } + deriving (Show, Eq) + +instance FromJSON Key where + parseJSON = withObject "Key" $ \v -> Key + <$> v .: "account_name" + <*> v .: "algorithm" + <*> v .: "digits" + <*> v .: "issuer" + <*> v .: "period" + +-- | Returns the key associated with the given key name +getKey :: VaultConnection Authenticated -> VaultMountedPath -> Text -> IO Key +getKey conn path = fmap unDataWrapper + . runVaultRequestAuthenticated conn + . newGetRequest + . mkPathWithKey KeysNamespace path + +-- | Represents a list of key names +newtype KeyNames = KeyNames {unKeyNames :: [Text]} + deriving (Show, Eq) + +instance FromJSON KeyNames where + parseJSON = withObject "KeyNames" $ fmap KeyNames . (.: "keys") + +-- | Returns a list of TOTP keys stored in the given mount path +listKeys :: VaultConnection Authenticated -> VaultMountedPath -> IO KeyNames +listKeys conn = fmap unDataWrapper + . runVaultRequestAuthenticated conn + . newListRequest + . mkPathWithoutKey KeysNamespace + +-- | Deletes the key associated with the given key name +deleteKey :: VaultConnection Authenticated -> VaultMountedPath -> Text -> IO () +deleteKey conn path = runVaultRequestAuthenticated_ conn + . withStatusCodes [200, 204] + . newDeleteRequest + . mkPathWithKey KeysNamespace path + +-- | A six or eight digit TOTP code +newtype Code = Code {unCode :: Text} + deriving (Show, Eq) + +instance FromJSON Code where + parseJSON = withObject "Code" $ fmap Code . (.: "code") + +instance ToJSON Code where + toJSON x = object ["code" .=! unCode x] + +-- | Generates a TOTP 'Code' for the given key +generateCode :: VaultConnection Authenticated -> VaultMountedPath -> Text -> IO Code +generateCode conn path = fmap unDataWrapper + . runVaultRequestAuthenticated conn + . newGetRequest + . mkPathWithKey CodeNamespace path + +-- | Validating a code results in a code status which specifies the code is either valid or invalid +data CodeStatus = InvalidCode | ValidCode + deriving (Show, Eq) + +instance FromJSON CodeStatus where + parseJSON = withObject "Valid" $ fmap (bool InvalidCode ValidCode) . (.: "valid") + +-- | Validate the TOTP 'Code' generated for the given key +validateCode :: VaultConnection Authenticated -> VaultMountedPath -> Text -> Code -> IO CodeStatus +validateCode conn path keyName = fmap unDataWrapper + . runVaultRequestAuthenticated conn + . newPostRequest (mkPathWithKey CodeNamespace path keyName) + . Just + +data EndpointNamespace = KeysNamespace | CodeNamespace + +mkPathWithKey :: EndpointNamespace -> VaultMountedPath -> Text -> Text +mkPathWithKey namespace path = vaultEndpointPath namespace path . Just + +mkPathWithoutKey :: EndpointNamespace -> VaultMountedPath -> Text +mkPathWithoutKey namespace path = vaultEndpointPath namespace path Nothing + +vaultEndpointPath :: EndpointNamespace -> VaultMountedPath -> Maybe Text -> Text +vaultEndpointPath namespace (VaultMountedPath mountedPath) keyName = T.intercalate "/" + $ catMaybes [Just mountedPath, Just (toText namespace), keyName] + where + toText = \case + KeysNamespace -> "keys" + CodeNamespace -> "code" diff --git a/vault-tool/vault-tool.cabal b/vault-tool/vault-tool.cabal index c47c6da..be14eb9 100644 --- a/vault-tool/vault-tool.cabal +++ b/vault-tool/vault-tool.cabal @@ -20,7 +20,9 @@ source-repository head library exposed-modules: Network.VaultTool, - Network.VaultTool.KeyValueV2 + Network.VaultTool.KeyValueV2, + Network.VaultTool.TOTP, + Data.Aeson.Utils other-modules: Network.VaultTool.Internal, Network.VaultTool.Types