diff --git a/credentials-cli.cabal b/credentials-cli.cabal --- a/credentials-cli.cabal +++ b/credentials-cli.cabal @@ -1,5 +1,5 @@ name: credentials-cli -version: 0.0.1.1 +version: 0.0.2 synopsis: Secure Credentials Administration homepage: https://github.com/brendanhay/credentials license: OtherLicense @@ -57,4 +57,4 @@ , text >= 0.11 , transformers-base >= 0.4 , unordered-containers >= 0.2.5 - , uri-bytestring >= 0.2.1 + , uri-bytestring >= 0.2.2 diff --git a/src/Credentials/CLI/Format.hs b/src/Credentials/CLI/Format.hs --- a/src/Credentials/CLI/Format.hs +++ b/src/Credentials/CLI/Format.hs @@ -20,19 +20,18 @@ import Credentials import Credentials.CLI.Types -import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Aeson (ToJSON (..), object, (.=)) import Data.Bifunctor -import Data.ByteString (ByteString) -import Data.List (foldl', intersperse) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.ByteString (ByteString) +import Data.List (foldl', intersperse) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid import Network.AWS.Data import Options.Applicative.Help hiding (list, string) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as Text +import qualified Data.Text as Text data Status = Deleted diff --git a/src/Credentials/CLI/IO.hs b/src/Credentials/CLI/IO.hs --- a/src/Credentials/CLI/IO.hs +++ b/src/Credentials/CLI/IO.hs @@ -24,6 +24,7 @@ import Data.Aeson.Encode.Pretty import Data.ByteString.Builder (Builder, hPutBuilder, stringUtf8) import Data.Char (isSpace, toLower) +import Data.Functor.Identity (runIdentity) import Data.Monoid import Network.AWS.Data @@ -60,7 +61,7 @@ emit :: Result -> App () emit r = do (f, s) <- asks (format &&& store) - let e = Emit s r + let e = Emit (runIdentity s) r liftIO . hPutBuilder stdout $ case f of Pretty -> build (encodePretty e) <> "\n" diff --git a/src/Credentials/CLI/Options.hs b/src/Credentials/CLI/Options.hs --- a/src/Credentials/CLI/Options.hs +++ b/src/Credentials/CLI/Options.hs @@ -14,6 +14,7 @@ import Data.Bifunctor import Data.List (foldl') +import Data.Maybe (isJust) import Network.AWS.Data import Network.AWS.Data.Text @@ -52,7 +53,7 @@ => Text -- ^ The options' description. -> Text -- ^ A title for the values. -> [(a, String)] -- ^ Possible values and their documentation. - -> a -- ^ A default value. + -> Maybe a -- ^ A default value. -> Maybe Text -- ^ Footer contents. -> Mod OptionFields a completes title note xs x foot = doc <> completeWith (map fst ys) @@ -66,16 +67,23 @@ => Text -> Text -> [(String, String)] - -> a + -> Maybe a -> Maybe Text -> Mod OptionFields a -defaults title note xs x foot = describe title (Just doc) Default <> value x +defaults title note xs x foot = + describe title (Just doc) Default <> maybe mempty value x where doc = maybe table (table .$.) (wrap <$> foot) table = wrap note .$. indent 2 rows - .$. ("Defaults to " <> bold (text (string x)) <> ".") + $$$ ( case x of + Nothing -> mempty + Just y -> "Defaults to " <> bold (text (string y)) <> "." + ) + ($$$) | isJust x = (.$.) + | otherwise = mappend + len = maximum (map (length . fst) xs) rows | [r] <- xs = f r @@ -87,7 +95,7 @@ ts | null v = mempty | otherwise = tupled [text v] -require :: Functor f => (Fact -> f a) -> f a +require :: (Fact -> a) -> a require f = f Required optional :: Alternative f => (Fact -> f a) -> f (Maybe a) diff --git a/src/Credentials/CLI/Types.hs b/src/Credentials/CLI/Types.hs --- a/src/Credentials/CLI/Types.hs +++ b/src/Credentials/CLI/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} @@ -35,7 +36,9 @@ import Data.Conduit import Data.Conduit.Lazy import Data.Data +import Data.Functor.Identity (Identity (..)) import Data.List (sort) +import Data.Maybe (fromMaybe) import Data.Text (Text) import Network.AWS @@ -92,14 +95,17 @@ "echo" -> pure Echo e -> fromTextError $ "Failure parsing format from: " <> e -data Options = Options - { region :: !Region - , store :: !Store +data Options f = Options + { region :: !(f Region) + , store :: !(f Store) , format :: !Format , level :: !LogLevel } -newtype App a = App { unApp :: ReaderT Options AWS a } +deriving instance Show (Options Maybe) +deriving instance Show (Options Identity) + +newtype App a = App { unApp :: ReaderT (Options Identity) AWS a } deriving ( Functor , Applicative @@ -108,7 +114,7 @@ , MonadThrow , MonadCatch , MonadMask - , MonadReader Options + , MonadReader (Options Identity) , MonadBase IO ) @@ -121,7 +127,7 @@ instance MonadRandom App where getRandomBytes = liftIO . getRandomBytes -runApp :: Env -> Options -> App a -> IO a +runApp :: Env -> Options Identity -> App a -> IO a runApp e c = runResourceT . runAWS e . (`runReaderT` c) . unApp runLazy :: Source App a -> App [a] @@ -136,13 +142,21 @@ fromURI u = Table u <$> fromURI u instance ToText Store where - toText = toText . URI.serializeURI' . \case + toText = toText . URI.serializeURIRef' . \case Table u _ -> u instance Show Store where show = Text.unpack . toText instance Pretty Store where pretty = text . show instance ToLog Store where build = build . toText +defaultOptions :: Options Maybe -> Options Identity +defaultOptions x = + let r = fromMaybe defaultRegion (region x) + s = fromMaybe (defaultStore r) (store x) + in x { region = Identity r + , store = Identity s + } + defaultRegion :: Region defaultRegion = Frankfurt @@ -156,11 +170,11 @@ p = Port (_endpointPort e) e = defaultEndpoint dynamoDB r -setStore :: HasEnv a => Options -> a -> a +setStore :: HasEnv a => Options Identity -> a -> a setStore c = configure f where f = case store c of - Table u _ -> g u dynamoDB + Identity (Table u _) -> g u dynamoDB g u | Just h <- host u = setEndpoint (secure u) h (port u) | otherwise = id @@ -185,5 +199,5 @@ key = A.skipSpace *> A.takeWhile1 (/= '=') val = A.char '=' *> A.takeText -ctx :: Alternative f => f Pair -> f Context -ctx f = Context . Map.fromList . map (\(Pair k v) -> (k, v)) <$> many f +fromPairs :: Alternative f => f Pair -> f Context +fromPairs f = Context . Map.fromList . map (\(Pair k v) -> (k, v)) <$> many f diff --git a/src/Credentials/CLI/Types/Protocol.hs b/src/Credentials/CLI/Types/Protocol.hs --- a/src/Credentials/CLI/Types/Protocol.hs +++ b/src/Credentials/CLI/Types/Protocol.hs @@ -60,11 +60,11 @@ path = toText . BS8.dropWhile (== '/') . uriPath host :: URI -> Maybe ByteString -host = preview (uriAuthorityL . _Just . authorityHostL . hostBSL) +host = preview (authorityL . _Just . authorityHostL . hostBSL) secure :: URI -> Bool secure = (== 443) . port port :: URI -> Int port = fromMaybe 443 . preview - (uriAuthorityL . _Just . authorityPortL . _Just . portNumberL) + (authorityL . _Just . authorityPortL . _Just . portNumberL) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -26,7 +27,7 @@ import Control.Monad.Reader import Control.Monad.Trans.Resource -import Credentials hiding (context) +import Credentials import Credentials.CLI.Format import Credentials.CLI.IO import Credentials.CLI.Options @@ -34,8 +35,7 @@ import Data.ByteString.Builder (Builder) import Data.Conduit -import Data.Conduit.Lazy -import Data.List.NonEmpty (NonEmpty) +import Data.Functor.Identity (Identity (..)) import Data.Text (Text) import Network.AWS @@ -45,6 +45,7 @@ import System.IO +import qualified Control.Applicative as App import qualified Data.ByteString.Lazy as LBS import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL @@ -53,17 +54,21 @@ main :: IO () main = do - (opt, mode) <- customExecParser (prefs (showHelpOnError <> columns 90)) options + (defaultOptions -> opt, m) <- + customExecParser (prefs (showHelpOnError <> columns 90)) options lgr <- newLogger (level opt) stderr - env <- newEnv (region opt) Discover <&> (envLogger .~ lgr) . setStore opt + env <- newEnv (runIdentity (region opt)) Discover + <&> (envLogger .~ lgr) . setStore opt - catches (runApp env opt (program opt mode)) + catches (runApp env opt (program opt m)) [ handler _CredentialError (quit 1 . show) ] -program :: Options -> Mode -> App () -program Options{store = store@(Table _ table), ..} = \case +program :: Options Identity -> Mode -> App () +program Options{ store = Identity store@(Table _ table) + , region = Identity region + , ..} = \case List -> do says ("Listing contents of " % store % " in " % region % "...") runLazy (revisions table) >>= @@ -120,7 +125,7 @@ teardown table emit TeardownR -options :: ParserInfo (Options, Mode) +options :: ParserInfo (Options Maybe, Mode) options = info (helper <*> modes) (fullDesc <> headerDoc (Just desc)) where desc = bold "credentials" @@ -135,24 +140,24 @@ \are stored." , mode "select" - (Select <$> context <*> name <*> optional revision) + (Select <$> contextOption <*> nameOption <*> optional revisionOption) "Fetch and decrypt a specific credential revision." "Defaults to the latest available revision, if --revision is not specified." , mode "insert" - (Insert <$> key <*> context <*> name <*> input) + (Insert <$> keyOption <*> contextOption <*> nameOption <*> inputOption) "Write and encrypt a new credential revision." "You can supply the secret value as a string with --secret, or as \ \a file path which contents' will be read by using --path." , mode "delete" - (Delete <$> name <*> require revision <*> force) + (Delete <$> nameOption <*> require revisionOption <*> forceFlag) "Remove a specific credential revision." "Please note that if an application is pinned to the revision specified \ \by --revision, it will no longer be able to decrypt the credential." , mode "truncate" - (Truncate <$> name <*> force) + (Truncate <$> nameOption <*> forceFlag) "Truncate a specific credential's revisions." "This will remove all but the most recent credential revision. \ \That is, after running this command you will have exactly _one_ \ @@ -166,43 +171,54 @@ \the operation will succeed with exit status 0." , mode "teardown" - (Teardown <$> force) + (Teardown <$> forceFlag) "Remove an entire credential store." "Warning: This will completely remove the credential store. For some \ \storage engines this action is irrevocable unless you specifically \ \perform backups for your data." ] -mode :: String -> Parser a -> Text -> Text -> Mod CommandFields (Options, a) -mode n p h f = command n (info ((,) <$> common <*> p) (fullDesc <> desc <> foot)) - where - desc = progDescDoc (Just $ wrap h) - foot = footerDoc (Just $ indent 2 (wrap f) <> line) +mode :: String + -> Parser a + -> Text + -> Text + -> Mod CommandFields (Options Maybe, a) +mode name p desc foot = + command name $ info ((,) <$> commonOptions <*> p) + ( fullDesc <> progDescDoc (Just $ wrap desc) + <> footerDoc (Just $ indent 2 (wrap foot) <> line) + ) -common :: Parser Options -common = Options - <$> textOption +commonOptions :: Parser (Options Maybe) +commonOptions = Options + <$> App.optional (textOption ( short 'r' <> long "region" <> metavar "REGION" <> completes "The AWS region in which to operate." "The following regions are supported:" (map (,mempty) unsafeEnum) - defaultRegion Nothing - ) + Nothing + (Just "Note: this corresponds to both the KMS key region and the \ + \DynamoDB table region.") + )) - <*> textOption + <*> App.optional (textOption ( short 'u' <> long "uri" <> metavar "URI" <> defaults "URI specifying the storage system to use." "The URI format must follow the following protocol:" [ ("dynamo:/[/host[:port]]/table-name", "") + , (show (defaultStore defaultRegion), "") + ] - (defaultStore defaultRegion) - (Just "If no host is specified for AWS services (ie. dynamo:/table-name), \ - \the default AWS endpoints will be used.") - ) + Nothing + (Just "If no host is specified (ie. dynamo:/table-name), \ + \the default AWS endpoint for the given --region will be used. \ + \If an AWS endpoint is specified the endpoint region MUST \ + \correspond with --region, or a signature error will occur.") + )) <*> textOption ( short 'o' @@ -215,7 +231,7 @@ , (Echo, "Untitled textual output with no trailing newline.") , (Print, "Print multi-line user output.") ] - Print Nothing + (Just Print) Nothing ) <*> textOption @@ -229,11 +245,11 @@ , (Trace, "Sensitive signing metadata.") , (Info, "No logging of library routines.") ] - Info Nothing + (Just Info) Nothing ) -key :: Parser KeyId -key = textOption +keyOption :: Parser KeyId +keyOption = textOption ( short 'k' <> long "key" <> metavar "ARN" @@ -244,12 +260,12 @@ , ("12345678-1234-1234-12345", "") , ("alias/MyAliasName", "") ] - defaultKeyId + (Just defaultKeyId) (Just "It's recommended to setup a new key using the default alias.") ) -context :: Parser Context -context = ctx $ textOption +contextOption :: Parser Context +contextOption = fromPairs $ textOption ( short 'c' <> long "context" <> metavar "KEY=VALUE" @@ -260,31 +276,31 @@ ) Optional ) -name :: Parser Name -name = textOption +nameOption :: Parser Name +nameOption = textOption ( short 'n' <> long "name" <> metavar "STRING" <> describe "The unique name of the credential." Nothing Required ) -revision :: Fact -> Parser Revision -revision r = textOption +revisionOption :: Fact -> Parser Revision +revisionOption r = textOption ( short 'v' <> long "revision" <> metavar "STRING" <> describe "The revision of the credential." Nothing r ) -force :: Parser Force -force = flag Prompt NoPrompt +forceFlag :: Parser Force +forceFlag = flag Prompt NoPrompt ( short 'f' <> long "force" <> help "Always overwrite or remove, without an interactive prompt." ) -input :: Parser Input -input = textual <|> filepath +inputOption :: Parser Input +inputOption = textual <|> filepath where textual = Value <$> textOption