diff --git a/examples/deploy/Deploy/Command.hs b/examples/deploy/Deploy/Command.hs --- a/examples/deploy/Deploy/Command.hs +++ b/examples/deploy/Deploy/Command.hs @@ -26,6 +26,7 @@ | Deploy (Maybe FilePath) HostID | Sign | Verify + | ListHosts | InfoKey (Maybe KeyID ) | InfoSection (Maybe SectionID) | SecretScript @@ -38,20 +39,20 @@ parseCLI = do args <- getArgs case span is_flg args of - (flgs,"ks":args') -> return $ CLI defaultCtxParams $ KS $ flgs++args' - _ -> parseCLI' args - -parseCLI' :: [String] -> IO CLI -parseCLI' = runParse cliInfo + (flgs,"ks":args') -> runParse (pi_cli $ p_ks args') flgs + _ -> runParse (pi_cli p_cli ) args -cliInfo :: ParserInfo CLI -cliInfo = - h_info p_cli $ +pi_cli :: Parser CLI -> ParserInfo CLI +pi_cli psr = + h_info psr $ fullDesc <> progDesc "For carrying out deployments from the keystore." +p_ks :: [String] -> Parser CLI +p_ks args = CLI <$> paramsParser <*> pure (KS args) + p_cli :: Parser CLI -p_cli = CLI <$> paramsParser <*> p_command +p_cli = CLI <$> paramsParser <*> p_command p_command :: Parser Command p_command = @@ -61,6 +62,7 @@ <> command "deploy" pi_deploy <> command "sign" pi_sign <> command "verify" pi_verify + <> command "list-hosts" pi_list_hosts <> command "info-key" pi_info_key <> command "info-section" pi_info_section <> command "secret-script" pi_secret_script @@ -102,6 +104,12 @@ h_info (helper <*> (pure Verify)) (progDesc "verify the keystore") + +pi_list_hosts :: ParserInfo Command +pi_list_hosts = + h_info + (helper <*> (pure ListHosts)) + (progDesc "list the hosts") pi_info_key :: ParserInfo Command pi_info_key = diff --git a/examples/deploy/Deploy/HostSectionKey.hs b/examples/deploy/Deploy/HostSectionKey.hs --- a/examples/deploy/Deploy/HostSectionKey.hs +++ b/examples/deploy/Deploy/HostSectionKey.hs @@ -66,6 +66,7 @@ instance Sections HostID SectionID KeyID where hostSection = host_section + hostRSection = host_resident_section sectionType = section_type superSections = super_sections keyIsHostIndexed = key_is_host_indexed @@ -80,6 +81,15 @@ host_section :: HostID -> SectionID host_section h = + case h of + H_live_eu -> S_eu_admin + H_staging_eu -> S_eu_staging + H_live_us -> S_us_admin + H_staging_us -> S_us_staging + H_dev -> S_dev + +host_resident_section :: HostID -> SectionID +host_resident_section h = case h of H_live_eu -> S_eu_deploy H_staging_eu -> S_eu_staging diff --git a/examples/deploy/deploy.hs b/examples/deploy/deploy.hs --- a/examples/deploy/deploy.hs +++ b/examples/deploy/deploy.hs @@ -13,7 +13,6 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Text.IO as T -import System.Directory import System.IO import Control.Applicative import Control.Exception @@ -29,21 +28,23 @@ let cp0 = cli_params cp = cp0 { cp_store = cp_store cp0 <|> Just ks_fp } case cli_command of - Create -> initialise cp0 no_keys - SampleScript -> mapM_ sample_ln [minBound..maxBound] - KS args -> KS.cli' Nothing args - _ -> - do ic <- load cp + Create -> initialise cp no_keys + ListHosts -> mapM_ (putStrLn . encode) $ [minBound..maxBound :: HostID] + SampleScript -> mapM_ sample_ln [minBound..maxBound] + KS args -> KS.cli' (Just cp) args + _ -> + do ic <- instanceCtx cp let ic_ro = ic { ic_ctx_params = cp {cp_readonly = cp_readonly cp <|> Just True} } case cli_command of Sign -> return () _ -> verify_ks True ic_ro case cli_command of Create -> error "main: Initialise" - Rotate mbh mbs mbk -> rotate ic $ key_prededicate mbh mbs mbk - Deploy mb hst -> deploy ic_ro hst >>= write mb + Rotate mbh mbs mbk -> rotate ic $ key_prededicate mbh mbs mbk + Deploy mb hst -> deploy ic_ro hst >>= write mb Sign -> sign_ks ic_ro Verify -> T.putStrLn "the keystore matches the signature" + ListHosts -> error "main: ListHosts" InfoKey mbk -> T.putStr $ keyHelp mbk InfoSection mbs -> sectionHelp mbs >>= T.putStr SecretScript -> secretKeySummary ic sections >>= T.putStr @@ -52,13 +53,6 @@ KS _ -> error "main: KS" verify_ks False ic_ro -load :: CtxParams -> IO IC -load cp = - do ok <- doesFileExist $ maybe ks_fp id $ cp_store cp - case ok of - True -> instanceCtx cp - False -> error "keystore not present" - sign_ks :: IC -> IO () sign_ks ic = signKeystore ic sections >>= B.writeFile ks_mac_fp @@ -86,4 +80,4 @@ s_ = encode s write :: Maybe FilePath -> LBS.ByteString -> IO () -write = maybe LBS.putStr LBS.writeFile +write = maybe LBS.putStrLn LBS.writeFile diff --git a/keystore.cabal b/keystore.cabal --- a/keystore.cabal +++ b/keystore.cabal @@ -1,5 +1,5 @@ Name: keystore -Version: 0.2.0.1 +Version: 0.3.0.0 Synopsis: Managing stores of secret things Homepage: http://github.com/cdornan/keystore Author: Chris Dornan @@ -50,7 +50,7 @@ Data.KeyStore.Types.Schema Build-depends: - api-tools >= 0.2 , + api-tools >= 0.4 , asn1-types >= 0.2.0 , asn1-encoding >= 0.8.0 , crypto-pubkey >= 0.2.1 , @@ -70,7 +70,7 @@ optparse-applicative >= 0.9.0 , pbkdf >= 1.1.1.0 , safe >= 0.3.3 , - text >= 0.11 , + text >= 0.11.3 , unordered-containers >= 0.2.3.0 , Cabal >= 1.16 , @@ -83,7 +83,7 @@ safecopy >= 0.8.2 , template-haskell , time >= 1.4 , - vector >= 0.10.9 + vector >= 0.10.0.1 Default-Language: Haskell2010 diff --git a/src/Data/KeyStore/CLI.hs b/src/Data/KeyStore/CLI.hs --- a/src/Data/KeyStore/CLI.hs +++ b/src/Data/KeyStore/CLI.hs @@ -18,7 +18,7 @@ version :: String -version = "0.2.0.1" +version = "0.3.0.0" cli :: IO () cli = parseCLI >>= command Nothing @@ -35,8 +35,8 @@ _ -> instanceCtx cp let ic_ro = ro ic case cli_command of - Version -> putStrLn version - Keystore -> putStrLn $ maybe defaultKeyStoreFilePath id $ cp_store cp + Version -> putStrLn version + Keystore -> putStrLn =<< store ic Initialise fp -> newKeyStore fp defaultSettings UpdateSettings fp -> updateSettings ic fp ListSettings -> listSettings ic diff --git a/src/Data/KeyStore/IO.hs b/src/Data/KeyStore/IO.hs --- a/src/Data/KeyStore/IO.hs +++ b/src/Data/KeyStore/IO.hs @@ -23,6 +23,7 @@ , instanceCtx , instanceCtx_ , newKeyStore + , store , listSettings , settings , updateSettings @@ -111,6 +112,10 @@ -- state between calls. instanceCtx_ :: CtxParams -> IC instanceCtx_ cp = IC cp Nothing + +-- | the filepath of the loaded store +store :: IC -> IO FilePath +store ic = run ic storeKS -- | List the JSON settings on stdout. listSettings :: IC -> IO () diff --git a/src/Data/KeyStore/KS/KS.hs b/src/Data/KeyStore/KS/KS.hs --- a/src/Data/KeyStore/KS/KS.hs +++ b/src/Data/KeyStore/KS/KS.hs @@ -21,6 +21,7 @@ , errorKS , throwKS , lookupOpt + , storeKS , getSettings , lookupKey , insertNewKey @@ -133,6 +134,9 @@ throwKS :: Reason -> KS a throwKS = E.throwError + +storeKS :: KS FilePath +storeKS = ctx_store <$> KS ask lookupOpt :: Show a => Opt a -> KS a lookupOpt opt = getSettingsOpt opt <$> getSettings diff --git a/src/Data/KeyStore/Sections.hs b/src/Data/KeyStore/Sections.hs --- a/src/Data/KeyStore/Sections.hs +++ b/src/Data/KeyStore/Sections.hs @@ -144,13 +144,14 @@ retrieve ic h k = either (return . Left) (\nm->Right <$> locateKeys ic nm) ei_nm where ei_nm = case keyIsHostIndexed k of - Nothing -> maybe (Left RDG_key_not_reachable) Right $ - listToMaybe - [ key_nme Nothing s_ k | s_ <- lower_sections s, keyIsInSection k s_ ] - Just hp | hp h -> Right $ key_nme (Just h) s k + Nothing -> ei_nm' Nothing + Just hp | hp h -> ei_nm' $ Just h | otherwise -> Left RDG_no_such_host_key - s = hostSection h + ei_nm' mb_h = maybe (Left RDG_key_not_reachable) Right $ + listToMaybe [ key_nme mb_h s_ k | s_ <- lower_sections s0, keyIsInSection k s_ ] + + s0 = hostSection h signKeystore :: Sections h s k => IC -> SECTIONS h s k -> IO B.ByteString signKeystore ic scn = B.readFile (the_keystore $ ic_ctx_params ic) >>= sign_ ic (sgn_nme $ signing_key scn)