vault-tool-server (empty) → 0.0.0.1
raw patch · 6 files changed
+494/−0 lines, 6 filesdep +aesondep +asyncdep +basesetup-changed
Dependencies added: aeson, async, base, bytestring, filepath, http-client, process, tasty-hunit, temporary, text, vault-tool, vault-tool-server
Files
- LICENSE +20/−0
- README.md +9/−0
- Setup.hs +2/−0
- src/Network/VaultTool/VaultServerProcess.hs +227/−0
- test/test.hs +187/−0
- vault-tool-server.cabal +49/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Bit Connor++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,9 @@+# vault-tool-server++Utility library for spawning a HashiCorp Vault process.++This package also contains the tests for the related+[vault-tool](../vault-tool/) package (as a standard cabal test suite)++Running the test suite requires that the "vault" executable is in your `$PATH`,+or alternatively you may set the `VAULT_EXE` environment variable.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Network/VaultTool/VaultServerProcess.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.VaultTool.VaultServerProcess+ ( VaultServerProcess+ , launchVaultServerProcess+ , shutdownVaultServerProcess+ , withVaultServerProcess++ , VaultBackendConfig+ , withVaultConfigFile+ , vaultConfigDefaultAddress+ , vaultAddress++ , readVaultBackendConfig+ , readVaultUnsealKeys+ ) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async+import Control.Exception (Exception, IOException, catches, Handler(Handler), bracket, bracketOnError, throwIO, try)+import Control.Monad (forever)+import Data.Aeson+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Network.HTTP.Client (HttpException)+import System.Exit (ExitCode)+import System.FilePath ((</>))+import System.IO (Handle, hClose)+import System.IO.Temp+import System.Process+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.IO as T++import Network.VaultTool++-- | The ""backend"" section of the Vault server configuration.+--+-- See <https://www.vaultproject.io/docs/config/index.html>+--+-- > {+-- > "consul": {+-- > "address": "127.0.0.1:8500",+-- > "path": "vault"+-- > }+-- > }+--+-- > {+-- > "file": {+-- > "path": "vault-storage"+-- > }+-- > }+type VaultBackendConfig = Value++data VaultConfig = VaultConfig+ { _VaultConfig_Backend :: VaultBackendConfig+ , _VaultConfig_ListenAddress :: Text+ }+ deriving (Show)++instance ToJSON VaultConfig where+ toJSON VaultConfig{..} = object+ [ "backend" .= _VaultConfig_Backend+ , "listener" .= object+ [ "tcp" .= object+ [ "tls_disable" .= T.pack "true"+ , "address" .= _VaultConfig_ListenAddress+ ]+ ]+ , "disable_mlock" .= True+ ]++vaultConfigDefaultAddress :: VaultBackendConfig -> VaultConfig+vaultConfigDefaultAddress b =+ VaultConfig+ { _VaultConfig_Backend = b+ , _VaultConfig_ListenAddress = defaultAddress+ }+ where+ defaultAddress = "127.0.0.1:8200"++-- | Get the address that can be used to connect to a running Vault server+-- launched with the specified config.+--+-- The returned value will begin with ""http://"" or ""https://"" (depending on+-- the config)+vaultAddress :: VaultConfig -> VaultAddress+vaultAddress VaultConfig{_VaultConfig_ListenAddress} =+ VaultAddress ("http://" `T.append` _VaultConfig_ListenAddress)++readVaultBackendConfig :: FilePath -> IO VaultBackendConfig+readVaultBackendConfig file = do+ fileContents <- BL.readFile file+ case eitherDecode' fileContents of+ Left err -> error $ "Error loading file " ++ show file ++ ": " ++ err+ Right v -> pure v++-- | File should have one line per key (blank lines are ignored)+readVaultUnsealKeys :: FilePath -> IO [VaultUnsealKey]+readVaultUnsealKeys file =+ T.readFile file >>=+ (pure . map VaultUnsealKey . (filter (not . T.null)) . map T.strip . T.lines)++withVaultConfigFile :: VaultConfig -> (FilePath -> IO a) -> IO a+withVaultConfigFile vaultConfig action = do+ withSystemTempDirectory "hs_vault" $ \tmpDir -> do+ let configFile = tmpDir </> "vault.cfg"+ BL.writeFile configFile (encode vaultConfig)+ action configFile++data VaultServerProcess = VaultServerProcess+ { vs_processHandle :: ProcessHandle+ , vs_stdinH :: Handle+ , vs_stdoutH :: Handle+ , vs_stderrH :: Handle+ }++data VaultServerLaunchException+ = VaultServerLaunchException_VaultStartTimeout+ | VaultServerLaunchException_ConnectTimeout+ | VaultServerLaunchException_ExecFailure IOException+ | VaultServerLaunchException_ProcessFailure ExitCode Text+ deriving (Show, Eq)++instance Exception VaultServerLaunchException++withVaultServerProcess :: Maybe FilePath -> FilePath -> VaultAddress -> IO a -> IO a+withVaultServerProcess mbVaultExe vaultConfigFile addr act = do+ bracket (launchVaultServerProcess mbVaultExe vaultConfigFile addr)+ (shutdownVaultServerProcess)+ (const act)++launchVaultServerProcess :: Maybe FilePath -> FilePath -> VaultAddress -> IO VaultServerProcess+launchVaultServerProcess mbVaultExe vaultConfigFile addr = do+ bracketOnError+ (execProcess vaultExe vaultConfigFile)+ shutdownVaultServerProcess+ $ \vs -> do+ withAsync (waitUntilRunningThread (vs_stdoutH vs)) $ \waitUntilRunningA -> do+ withAsync (checkProcessFailureThread vs) $ \startupErrorA -> do+ _ <- waitAnyCancel [waitUntilRunningA, startupErrorA]+ pure vs+ where+ vaultExe = fromMaybe "vault" mbVaultExe+ waitUntilRunningThread stdoutH = do+ withAsync (waitUntilVaultStarted stdoutH) $ \startA -> do+ withAsync (timeout vaultStartTimeoutMilliseconds VaultServerLaunchException_VaultStartTimeout) $ \timeoutA -> do+ _ <- waitAnyCancel [startA, timeoutA]+ pure ()+ withAsync waitUntilVaultConnect $ \connectA -> do+ withAsync (timeout vaultConnectTimeoutMilliseconds VaultServerLaunchException_ConnectTimeout) $ \timeoutA -> do+ _ <- waitAnyCancel [connectA, timeoutA]+ pure ()+ checkProcessFailureThread vs = do+ mbExitCode <- getProcessExitCode (vs_processHandle vs)+ case mbExitCode of+ Just exitCode -> do+ stderrText <- T.hGetContents (vs_stderrH vs)+ throwIO $ VaultServerLaunchException_ProcessFailure exitCode stderrText+ Nothing -> do+ threadDelay (checkExitedSnoozeMilliseconds * 1000)+ checkProcessFailureThread vs+ vaultStartTimeoutMilliseconds = 10000+ vaultConnectTimeoutMilliseconds = 10000+ checkRunningSnoozeMilliseconds = 10+ checkExitedSnoozeMilliseconds = 10+ timeout milliseconds ex = do+ threadDelay (milliseconds * 1000)+ throwIO ex+ waitUntilVaultStarted stdoutH = do+ tryResult <- try $ T.hGetLine stdoutH+ case tryResult of+ Left (_ :: IOException) ->+ -- Wait to be killed+ forever (threadDelay 100000000)+ Right ln -> do+ -- This expects the vault program to output the string below to stdout. Verified to work for Vault versions [0.1.0 .. 0.6.0]+ if vaultStartMessagePrefix `T.isPrefixOf` ln+ then pure ()+ else waitUntilVaultStarted stdoutH+ vaultStartMessagePrefix = "==> Vault server started!"+ waitUntilVaultConnect = do+ running <- vaultIsRunning addr+ if running+ then pure ()+ else do+ threadDelay (checkRunningSnoozeMilliseconds * 1000)+ waitUntilVaultConnect++execProcess :: FilePath -> FilePath -> IO VaultServerProcess+execProcess vaultExe vaultConfigFile = do+ tryResult <- try $ createProcess $ (proc vaultExe ["server", "-config=" ++ vaultConfigFile])+ { env = Just []+ , std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ , close_fds = True+ }+ case tryResult of+ Left ex -> throwIO $ VaultServerLaunchException_ExecFailure ex+ Right (Just stdinH, Just stdoutH, Just stderrH, processHandle) ->+ pure VaultServerProcess+ { vs_processHandle = processHandle+ , vs_stdinH = stdinH+ , vs_stdoutH = stdoutH+ , vs_stderrH = stderrH+ }+ Right _ -> error "execProcess: The Impossible Happened"++shutdownVaultServerProcess :: VaultServerProcess -> IO ()+shutdownVaultServerProcess vs = do+ -- TODO Should send SIGINT instead+ terminateProcess (vs_processHandle vs)+ _ <- waitForProcess (vs_processHandle vs)+ hClose (vs_stdinH vs)+ hClose (vs_stdoutH vs)+ hClose (vs_stderrH vs)++vaultIsRunning :: VaultAddress -> IO Bool+vaultIsRunning addr = do+ (vaultHealth addr >> pure True) `catches`+ [ Handler $ \(_ :: HttpException) -> pure False+ , Handler $ \(_ :: VaultException) -> pure False+ ]
+ test/test.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Data.Aeson+import Data.List (sort)+import GHC.Generics+import System.Environment+import System.IO.Temp (withSystemTempDirectory)+import Test.Tasty.HUnit++import Network.VaultTool+import Network.VaultTool.VaultServerProcess++withTempVaultBackend :: (VaultBackendConfig -> IO a) -> IO a+withTempVaultBackend action = withSystemTempDirectory "hs_vault" $ \tmpDir -> do+ let backendConfig = object+ [ "file" .= object+ [ "path" .= tmpDir+ ]+ ]+ action backendConfig++main :: IO ()+main = withTempVaultBackend $ \vaultBackendConfig -> do+ vaultExe <- lookupEnv "VAULT_EXE"++ let cfg = vaultConfigDefaultAddress vaultBackendConfig+ addr = vaultAddress cfg+ withVaultConfigFile cfg $ \vaultConfigFile ->+ withVaultServerProcess vaultExe vaultConfigFile addr $+ talkToVault addr++-- | The vault must be a newly created, non-initialized vault+--+-- TODO It would be better to break this into lots of individual unit tests+-- instead of this one big-ass test+talkToVault :: VaultAddress -> IO ()+talkToVault addr = do+ health <- vaultHealth addr+ _VaultHealth_Initialized health @?= False++ (unsealKeys, rootToken) <- vaultInit addr 4 2++ length unsealKeys @?= 4++ status0 <- vaultSealStatus addr+ status0 @?= VaultSealStatus+ { _VaultSealStatus_Sealed = True+ , _VaultSealStatus_T = 2+ , _VaultSealStatus_N = 4+ , _VaultSealStatus_Progress = 0+ }++ status1 <- vaultUnseal addr (VaultUnseal_Key (unsealKeys !! 0))+ status1 @?= VaultSealStatus+ { _VaultSealStatus_Sealed = True+ , _VaultSealStatus_T = 2+ , _VaultSealStatus_N = 4+ , _VaultSealStatus_Progress = 1+ }++ status2 <- vaultUnseal addr VaultUnseal_Reset+ status2 @?= VaultSealStatus+ { _VaultSealStatus_Sealed = True+ , _VaultSealStatus_T = 2+ , _VaultSealStatus_N = 4+ , _VaultSealStatus_Progress = 0+ }++ status3 <- vaultUnseal addr (VaultUnseal_Key (unsealKeys !! 1))+ status3 @?= VaultSealStatus+ { _VaultSealStatus_Sealed = True+ , _VaultSealStatus_T = 2+ , _VaultSealStatus_N = 4+ , _VaultSealStatus_Progress = 1+ }++ status4 <- vaultUnseal addr (VaultUnseal_Key (unsealKeys !! 2))+ status4 @?= VaultSealStatus+ { _VaultSealStatus_Sealed = False+ , _VaultSealStatus_T = 2+ , _VaultSealStatus_N = 4+ , _VaultSealStatus_Progress = 0+ }++ conn <- connectToVault addr rootToken+ allMounts <- vaultMounts conn++ fmap _VaultMount_Type (lookup "cubbyhole/" allMounts) @?= Just "cubbyhole"+ fmap _VaultMount_Type (lookup "secret/" allMounts) @?= Just "generic"+ fmap _VaultMount_Type (lookup "sys/" allMounts) @?= Just "system"++ _ <- vaultMountTune conn "cubbyhole"+ _ <- vaultMountTune conn "secret"+ _ <- vaultMountTune conn "sys"++ vaultNewMount conn "mymount" VaultMount+ { _VaultMount_Type = "generic"+ , _VaultMount_Description = Just "blah blah blah"+ , _VaultMount_Config = Just VaultMountConfig+ { _VaultMountConfig_DefaultLeaseTtl = Just 42+ , _VaultMountConfig_MaxLeaseTtl = Nothing+ }+ }++ mounts2 <- vaultMounts conn+ fmap _VaultMount_Description (lookup "mymount/" mounts2) @?= Just "blah blah blah"++ t <- vaultMountTune conn "mymount"+ _VaultMountConfig_DefaultLeaseTtl t @?= 42++ vaultMountSetTune conn "mymount" VaultMountConfig+ { _VaultMountConfig_DefaultLeaseTtl = Just 52+ , _VaultMountConfig_MaxLeaseTtl = Nothing+ }++ t2 <- vaultMountTune conn "mymount"+ _VaultMountConfig_DefaultLeaseTtl t2 @?= 52++ vaultUnmount conn "mymount"++ mounts3 <- vaultMounts conn+ lookup "mymount/" mounts3 @?= Nothing++ vaultWrite conn (VaultSecretPath "secret/big") (object ["A" .= 'a', "B" .= 'b'])++ (_, r) <- vaultRead conn (VaultSecretPath "secret/big")+ case r of+ Left err -> assertFailure $ "Failed to parse secret/big: " ++ (show err)+ Right x -> x @?= object ["A" .= 'a', "B" .= 'b']++ vaultWrite conn (VaultSecretPath "secret/fun") (FunStuff "fun" [1, 2, 3])+ (_, r2) <- vaultRead conn (VaultSecretPath "secret/fun")+ case r2 of+ Left err -> assertFailure $ "Failed to parse secret/big: " ++ (show err)+ Right x -> x @?= (FunStuff "fun" [1, 2, 3])++ (_, r3) <- vaultRead conn (VaultSecretPath "secret/big")+ case r3 of+ Left (v, _) -> v @?= object ["A" .= 'a', "B" .= 'b']+ Right (x :: FunStuff) -> assertFailure $ "Somehow parsed an impossible value" ++ show x++ vaultWrite conn (VaultSecretPath "secret/foo/bar/a") (object ["X" .= 'x'])+ vaultWrite conn (VaultSecretPath "secret/foo/bar/b") (object ["X" .= 'x'])+ vaultWrite conn (VaultSecretPath "secret/foo/bar/a/b/c/d/e/f/g") (object ["X" .= 'x'])+ vaultWrite conn (VaultSecretPath "secret/foo/quack/duck") (object ["X" .= 'x'])++ keys <- vaultList conn (VaultSecretPath "secret/")+ assertBool "Secret in list" $ VaultSecretPath "secret/big" `elem` keys+ vaultDelete conn (VaultSecretPath "secret/big")++ keys2 <- vaultList conn (VaultSecretPath "secret")+ assertBool "Secret not in list" $ not (VaultSecretPath "secret/big" `elem` keys2)++ keys3 <- vaultListRecursive conn (VaultSecretPath "secret/foo/")+ sort keys3 @?= sort+ [ VaultSecretPath "secret/foo/bar/a"+ , VaultSecretPath "secret/foo/bar/b"+ , VaultSecretPath "secret/foo/bar/a/b/c/d/e/f/g"+ , VaultSecretPath "secret/foo/quack/duck"+ ]++ vaultSeal conn++ status5 <- vaultSealStatus addr+ status5 @?= VaultSealStatus+ { _VaultSealStatus_Sealed = True+ , _VaultSealStatus_T = 2+ , _VaultSealStatus_N = 4+ , _VaultSealStatus_Progress = 0+ }++ health2 <- vaultHealth addr+ _VaultHealth_Initialized health2 @?= True+ _VaultHealth_Sealed health2 @?= True++data FunStuff = FunStuff+ { funString :: String+ , funNumbers :: [Int]+ }+ deriving (Show, Eq, Generic)++instance FromJSON FunStuff+instance ToJSON FunStuff
+ vault-tool-server.cabal view
@@ -0,0 +1,49 @@+name: vault-tool-server+version: 0.0.0.1+synopsis: Utility library for spawning a HashiCorp Vault process+description: Utility library for spawning a HashiCorp Vault process+license: MIT+license-file: LICENSE+author: Bit Connor+maintainer: mutantlemon@gmail.com+-- copyright: +category: Network+build-type: Simple+cabal-version: >=1.10+homepage: https://github.com/bitc/hs-vault-tool+bug-reports: https://github.com/bitc/hs-vault-tool/issues+extra-source-files: README.md++source-repository head+ type: git+ location: https://github.com/bitc/hs-vault-tool.git++library+ exposed-modules: Network.VaultTool.VaultServerProcess++ build-depends: base >=4.8 && <4.10,+ vault-tool,+ aeson,+ async,+ bytestring,+ filepath,+ http-client,+ process >= 1.2.0.0,+ temporary,+ text++ hs-source-dirs: src+ default-language: Haskell2010++test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: test.hs++ build-depends: base >=4.8 && <4.10,+ vault-tool,+ vault-tool-server,+ aeson,+ tasty-hunit,+ temporary