diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/credentials-cli.cabal b/credentials-cli.cabal new file mode 100644 --- /dev/null +++ b/credentials-cli.cabal @@ -0,0 +1,60 @@ +name: credentials-cli +version: 0.0.1 +synopsis: Secure Credentials Administration +homepage: https://github.com/brendanhay/credentials +license: OtherLicense +license-file: LICENSE +author: Brendan Hay +maintainer: Brendan Hay +copyright: Copyright (c) 2015-2016 Brendan Hay +category: Network, AWS, Security, Console +build-type: Simple +cabal-version: >= 1.10 + +description: + @credentials@ is a console application used to administer secure credentials + via the library of the same name. + . + You can read more about use-cases and prerequisites . + +source-repository head + type: git + location: git://github.com/brendanhay/credentials.git + +executable credentials + default-language: Haskell2010 + hs-source-dirs: src + main-is: Main.hs + + ghc-options: -Wall -threaded + + other-modules: + Credentials.CLI.Format + , Credentials.CLI.IO + , Credentials.CLI.Options + , Credentials.CLI.Types + , Credentials.CLI.Types.Protocol + + build-depends: + aeson >= 0.8 + , aeson-pretty >= 0.7.2 + , amazonka >= 1.3.7 + , amazonka-core >= 1.3.7 + , amazonka-dynamodb >= 1.3.6 + , attoparsec >= 0.11 + , base >= 4.7 && < 5 + , bytestring >= 0.10 + , conduit >= 1.2 + , conduit-extra >= 1.1 + , cryptonite >= 0.10 + , credentials == 0.0.1 + , exceptions >= 0.6 + , lens >= 4.4 + , mmorph >= 1 + , mtl >= 2.2.1 + , optparse-applicative >= 0.12 + , resourcet >= 1.1 + , text >= 0.11 + , transformers-base >= 0.4 + , unordered-containers >= 0.2.5 + , uri-bytestring >= 0.2.1 diff --git a/src/Credentials/CLI/Format.hs b/src/Credentials/CLI/Format.hs new file mode 100644 --- /dev/null +++ b/src/Credentials/CLI/Format.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- | +-- Module : Credentials.CLI.Format +-- Copyright : (c) 2015-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Credentials.CLI.Format where + +import Credentials +import Credentials.CLI.Types + +import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Bifunctor +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 + +data Status + = Deleted + | Truncated + +instance ToLog Status where + build = build . toText + +instance ToText Status where + toText = \case + Deleted -> "deleted" + Truncated -> "truncated" + +data Emit = Emit { store' :: Store, result :: Result } + +instance ToJSON Emit where + toJSON (Emit s r) = object [toText s .= r] + +instance Pretty Emit where + pretty (Emit s r) = doc s <> char ':' .$. indent 2 (pretty r) + +data Result + = SetupR Setup + | TeardownR + | InsertR Name Revision + | SelectR Name Revision ByteString + | DeleteR Name Revision + | TruncateR Name + | ListR [(Name, NonEmpty Revision)] + +instance ToLog Result where + build = \case + SetupR s -> build s + TeardownR -> build Deleted + InsertR _ r -> build r + SelectR _ _ v -> build v + DeleteR {} -> build Deleted + TruncateR {} -> build Truncated + ListR rs -> foldMap f rs + where + f (n, v :| vs) = + build n % "," % mconcat (intersperse "," $ map build (v:vs)) % "\n" + +instance ToJSON Result where + toJSON = \case + SetupR s -> object ["status" =~ s] + TeardownR -> object ["status" =~ Deleted] + InsertR n r -> object ["name" =~ n, "revision" =~ r] + SelectR n r v -> object ["name" =~ n, "revision" =~ r, "secret" =~ toBS v] + DeleteR n r -> object ["name" =~ n, "revision" =~ r, "status" =~ Deleted] + TruncateR n -> object ["name" =~ n, "status" =~ Truncated] + ListR rs -> object (map go rs) + where + k =~ v = k .= toText v + + go (n, v :| vs) = toText n .= map toText (v:vs) + +instance Pretty Result where + pretty = \case + SetupR s -> stat s + TeardownR -> stat Deleted + InsertR n r -> name n .$. rev r + SelectR n r v -> name n .$. rev r .$. val v + DeleteR n r -> name n .$. rev r .$. stat Deleted + TruncateR n -> name n .$. stat Truncated + ListR rs -> list rs + where + name n = "name:" <+> doc n + rev r = "revision:" <+> doc r + stat s = "status:" <+> doc s + val v = "secret:" <+> doc (toBS v) + + list [] = mempty + list (r:rs) = foldl' (.$.) (f r) (map f rs) + where + f (n, v :| vs) = doc n <> ":" .$. + indent 2 (extractChunk (revs v vs)) + + revs v vs = table $ (v, "# latest") : map (,mempty) vs + + table [] = mempty + table xs = pure $ vcat + [indent 2 (fillBreak n (item k) <+> v) | (k, v) <- ys] + where + n = maximum (map (Text.length . fst) ys) + 2 + ys = map (first toText) xs + + item x = "-" <+> doc x + +doc :: ToText a => a -> Doc +doc = text . string diff --git a/src/Credentials/CLI/IO.hs b/src/Credentials/CLI/IO.hs new file mode 100644 --- /dev/null +++ b/src/Credentials/CLI/IO.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- | +-- Module : Credentials.CLI.IO +-- Copyright : (c) 2015-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Credentials.CLI.IO where + +import Control.Arrow +import Control.Monad.Reader + +import Credentials.CLI.Format +import Credentials.CLI.Types + +import Data.Aeson (ToJSON (..)) +import Data.Aeson.Encode +import Data.Aeson.Encode.Pretty +import Data.ByteString.Builder (Builder, hPutBuilder, stringUtf8) +import Data.Char (isSpace, toLower) +import Data.Monoid + +import Network.AWS.Data + +import Options.Applicative.Help.Pretty + +import System.Exit +import System.IO + +import qualified Data.ByteString.Builder as Build + +default (Builder) + +data Agree + = Yes + | No + | What String + +quit :: ToLog a => Int -> a -> IO () +quit n m = err m >> exitWith (ExitFailure n) + +err :: (MonadIO m, ToLog a) => a -> m () +err x = liftIO $ Build.hPutBuilder stderr ("Error!:\n " <> build x <> "\n") + +says :: ToLog a => a -> App () +says x = say (build x <> "\n") + +say :: ToLog a => a -> App () +say x = do + f <- asks format + when (f == Print) $ + liftIO $ hPutBuilder stderr (build x) + +emit :: Result -> App () +emit r = do + (f, s) <- asks (format &&& store) + let e = Emit s r + liftIO . hPutBuilder stdout $ + case f of + Pretty -> build (encodePretty e) <> "\n" + JSON -> encodeToBuilder (toJSON e) + Echo -> build r + Print -> stringUtf8 + (displayS (renderPretty 0.4 80 (pretty e)) "") <> "\n" + +prompt :: Force -> App () -> App () +prompt NoPrompt io = says "Running ..." >> io +prompt Prompt io = do + say " -> Proceed? [y/n]: " + a <- agree + case a of + Yes -> says "Running ..." >> io + No -> says "Cancelling ..." + What w -> says $ build w <> ", what? Cancelling ..." + +agree :: App Agree +agree = do + r <- map toLower . filter (not . isSpace) <$> liftIO getLine + return $! case r of + "yes" -> Yes + "y" -> Yes + "no" -> No + "n" -> No + "" -> No + x -> What x diff --git a/src/Credentials/CLI/Options.hs b/src/Credentials/CLI/Options.hs new file mode 100644 --- /dev/null +++ b/src/Credentials/CLI/Options.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Credentials.CLI.Options +-- Copyright : (c) 2015-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Credentials.CLI.Options where + +import Credentials.CLI.Types + +import Data.Bifunctor +import Data.List (foldl') + +import Network.AWS.Data +import Network.AWS.Data.Text + +import Options.Applicative hiding (optional) +import Options.Applicative.Help hiding (string) + +import qualified Data.Text as Text +import qualified Options.Applicative as Opt + +data Fact + = Required + | Optional + | Default + +-- | Setup an option with formatted help text. +describe :: Text -- ^ The options' description. + -> Maybe Doc -- ^ The help body (title/footer in tabular). + -> Fact + -> Mod OptionFields a +describe title body r = helpDoc . Just $ wrap title <> doc <> line + where + doc | Just b <- body = pad (maybe b (b .$.) foot) + | otherwise = maybe mempty pad foot + + foot = case r of + Required -> Just ("This is" <+> bold "required.") + Optional -> Just ("This is" <+> bold "optional.") + Default -> Nothing + + pad = mappend line . indent 2 + +-- | Setup a tabular list of possible values for an option, +-- a default value, and an auto-completer. +completes :: ToText a + => Text -- ^ The options' description. + -> Text -- ^ A title for the values. + -> [(a, String)] -- ^ Possible values and their documentation. + -> a -- ^ A default value. + -> Maybe Text -- ^ Footer contents. + -> Mod OptionFields a +completes title note xs x foot = doc <> completeWith (map fst ys) + where + doc = defaults title note ys x foot + ys = map (first string) xs + +-- | Construct a tabular representation displaying the default values, +-- without using ToText for the tabular values. +defaults :: ToText a + => Text + -> Text + -> [(String, String)] + -> a + -> Maybe Text + -> Mod OptionFields a +defaults title note xs x foot = describe title (Just doc) Default <> value x + where + doc = maybe table (table .$.) (wrap <$> foot) + table = wrap note + .$. indent 2 rows + .$. ("Defaults to " <> bold (text (string x)) <> ".") + + len = maximum (map (length . fst) xs) + + rows | [r] <- xs = f r + | r:rs <- xs = foldl' (.$.) (f r) (map f rs) + | otherwise = mempty + where + f (k, v) = "-" <+> bold (text k) <+> indent (len - length k) ts + where + ts | null v = mempty + | otherwise = tupled [text v] + +require :: Functor f => (Fact -> f a) -> f a +require f = f Required + +optional :: Alternative f => (Fact -> f a) -> f (Maybe a) +optional f = Opt.optional (f Optional) + +textOption :: FromText a => Mod OptionFields a -> Parser a +textOption = option (eitherReader (fromText . Text.pack)) + +wrap :: Text -> Doc +wrap = extractChunk . paragraph . Text.unpack diff --git a/src/Credentials/CLI/Types.hs b/src/Credentials/CLI/Types.hs new file mode 100644 --- /dev/null +++ b/src/Credentials/CLI/Types.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Credentials.CLI.Types +-- Copyright : (c) 2015-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Credentials.CLI.Types where + +import Control.Monad.Base +import Control.Monad.Catch +import Control.Monad.Morph (hoist) +import Control.Monad.Reader +import Control.Monad.Trans.Resource + +import Credentials +import Credentials.CLI.Types.Protocol + +import Crypto.Random (MonadRandom (..)) + +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder) +import Data.Conduit +import Data.Conduit.Lazy +import Data.Data +import Data.List (sort) +import Data.Text (Text) + +import Network.AWS +import Network.AWS.Data +import Network.AWS.DynamoDB (dynamoDB) +import Network.AWS.Endpoint + +import Options.Applicative +import Options.Applicative.Help.Pretty (Pretty (..), text) + +import URI.ByteString (Authority (..), Host (..), Port (..), Scheme (..), URI, + URIRef (..)) + +import qualified Data.Attoparsec.Text as A +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as Text +import qualified URI.ByteString as URI + +data Force + = NoPrompt + | Prompt + +data Input + = Value !ByteString + | Path !FilePath + +data Mode + = Setup + | Teardown !Force + | List + | Insert !KeyId !Context !Name !Input + | Select !Context !Name !(Maybe Revision) + | Delete !Name !Revision !Force + | Truncate !Name !Force + +data Format + = Pretty + | JSON + | Echo + | Print + deriving (Eq, Show) + +instance ToText Format where + toText = \case + Pretty -> "pretty" + JSON -> "json" + Echo -> "echo" + Print -> "print" + +instance FromText Format where + parser = takeLowerText >>= \case + "pretty" -> pure Pretty + "json" -> pure JSON + "echo" -> pure Echo + e -> fromTextError $ "Failure parsing format from: " <> e + +data Options = Options + { region :: !Region + , store :: !Store + , format :: !Format + , level :: !LogLevel + } + +newtype App a = App { unApp :: ReaderT Options AWS a } + deriving + ( Functor + , Applicative + , Monad + , MonadIO + , MonadThrow + , MonadCatch + , MonadMask + , MonadReader Options + , MonadBase IO + ) + +instance MonadAWS App where + liftAWS = App . lift + +instance MonadResource App where + liftResourceT = App . liftResourceT + +instance MonadRandom App where + getRandomBytes = liftIO . getRandomBytes + +runApp :: Env -> Options -> App a -> IO a +runApp e c = runResourceT . runAWS e . (`runReaderT` c) . unApp + +runLazy :: Source App a -> App [a] +runLazy = App . lazyConsume . hoist unApp + +data Store = Table URI DynamoTable + +instance FromText Store where + parser = uriParser + +instance FromURI Store where + fromURI u = Table u <$> fromURI u + +instance ToText Store where + toText = toText . URI.serializeURI' . \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 + +defaultRegion :: Region +defaultRegion = Frankfurt + +defaultStore :: Region -> Store +defaultStore r = Table u defaultTable + where + u = URI s (Just a) ("/" <> toBS defaultTable) mempty Nothing + s = Scheme "dynamo" + a = Authority Nothing h (Just p) + h = Host (_endpointHost e) + p = Port (_endpointPort e) + e = defaultEndpoint dynamoDB r + +setStore :: HasEnv a => Options -> a -> a +setStore c = configure f + where + f = case store c of + Table u _ -> g u dynamoDB + + g u | Just h <- host u = setEndpoint (secure u) h (port u) + | otherwise = id + +(%) :: ToLog a => Builder -> a -> Builder +b % x = b <> build x + +unsafeEnum :: forall a. (Ord a, Data a, ToText a) => [a] +unsafeEnum = sort . map fromConstr . dataTypeConstrs $ dataTypeOf val + where + val :: a + val = undefined + +string :: ToText a => a -> String +string = Text.unpack . toText + +data Pair = Pair Text Text + +instance FromText Pair where + parser = Pair <$> key <*> val + where + 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 diff --git a/src/Credentials/CLI/Types/Protocol.hs b/src/Credentials/CLI/Types/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Credentials/CLI/Types/Protocol.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Credentials.CLI.Types.Protocol +-- Copyright : (c) 2015-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Credentials.CLI.Types.Protocol where + +import Control.Lens (preview, _Just) + +import Credentials (DynamoTable (..)) + +import Data.Attoparsec.Text (Parser) +import Data.ByteString (ByteString) +import Data.Maybe +import Data.Text (Text) + +import Network.AWS.Data (FromText, fromText, toBS, toText) + +import URI.ByteString + +import qualified Data.Attoparsec.Text as A +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Text as Text + +uriParser :: FromURI a => Parser a +uriParser = uri >>= either fail pure . fromURI + where + uri = A.takeText >>= either (fail . show) pure . f . toBS + f = parseURI strictURIParserOptions + +class FromURI a where + fromURI :: URI -> Either String a + +-- dynamo:/table-name +instance FromURI DynamoTable where + fromURI u = do + scheme "dynamo" u + ensure "Table name cannot be empty." (path u) + +ensure :: FromText a => String -> Text -> Either String a +ensure m x + | Text.null x = Left m + | otherwise = fromText x + +scheme :: ByteString -> URI -> Either String () +scheme e u + | a == e = Right () + | otherwise = Left $ "Protocol '" ++ BS8.unpack a ++ "' unrecognized." + where + a = schemeBS (uriScheme u) + +path :: URI -> Text +path = toText . BS8.dropWhile (== '/') . uriPath + +host :: URI -> Maybe ByteString +host = preview (uriAuthorityL . _Just . authorityHostL . hostBSL) + +secure :: URI -> Bool +secure = (== 443) . port + +port :: URI -> Int +port = fromMaybe 443 . preview + (uriAuthorityL . _Just . authorityPortL . _Just . portNumberL) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- | +-- Module : Main +-- Copyright : (c) 2015-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Main (main) where + +import Prelude hiding (truncate) + +import Control.Exception.Lens +import Control.Lens ((.~), (<&>)) +import Control.Monad.Catch +import Control.Monad.Reader +import Control.Monad.Trans.Resource + +import Credentials hiding (context) +import Credentials.CLI.Format +import Credentials.CLI.IO +import Credentials.CLI.Options +import Credentials.CLI.Types + +import Data.ByteString.Builder (Builder) +import Data.Conduit +import Data.Conduit.Lazy +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) + +import Network.AWS + +import Options.Applicative hiding (optional) +import Options.Applicative.Help.Pretty + +import System.IO + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL + +default (Builder, Text) + +main :: IO () +main = do + (opt, mode) <- customExecParser (prefs (showHelpOnError <> columns 90)) options + + lgr <- newLogger (level opt) stderr + env <- newEnv (region opt) Discover <&> (envLogger .~ lgr) . setStore opt + + catches (runApp env opt (program opt mode)) + [ handler _CredentialError (quit 1 . show) + ] + +program :: Options -> Mode -> App () +program Options{store = store@(Table _ table), ..} = \case + List -> do + says ("Listing contents of " % store % " in " % region % "...") + runLazy (revisions table) >>= + emit . ListR + + Insert key ctx name input -> do + says ("Writing new revision of " % + name % " to " % store % " in " % region % "...") + rev <- case input of + Value val -> insert key ctx name val table + Path path -> do + sz <- getFileSize path + if sz > 190 * 1024 + then throwM $ StorageFailure + "Secret file is larger than allowable storage size." + else do + cs <- liftIO . runResourceT $ + CB.sourceFile path $$ CL.consume + let val = LBS.toStrict (LBS.fromChunks cs) + insert key ctx name val table + emit (InsertR name rev) + + Select ctx name rev -> do + say "Retrieving" + case rev of + Nothing -> pure () + Just r -> say (" revision " % r % " of") + says (" " % name % " from " % store % " in " % region % "...") + (val, rev') <- select ctx name rev table + emit (SelectR name rev' val) + + Delete name rev force -> do + says ("This will delete revision " % + rev % " of " % name % " from " % store % " in " % region % "!") + prompt force $ do + delete name rev table + emit (DeleteR name rev) + + Truncate name force -> do + says ("This will delete all but the latest revision of " % + name % " from " % store % " in " % region % "!") + prompt force $ do + truncate name table + emit (TruncateR name) + + Setup -> do + says ("Setting up " % store % " in " % region % ".") + says "Running ..." + setup table >>= emit . SetupR + + Teardown force -> do + says ("This will delete " % store % " from " % region % "!") + prompt force $ do + teardown table + emit TeardownR + +options :: ParserInfo (Options, Mode) +options = info (helper <*> modes) (fullDesc <> headerDoc (Just desc)) + where + desc = bold "credentials" + <+> "- Administration tool for managing secure, shared credentials." + + modes = hsubparser $ mconcat + [ mode "list" + (pure List) + "List credential names and their respective revisions." + "This does not perform decryption of any credentials, and can be used \ + \to obtain an overview of the credential names and revisions that \ + \are stored." + + , mode "select" + (Select <$> context <*> name <*> optional revision) + "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) + "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) + "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 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_ \ + \revision for the given credential name." + + , mode "setup" + (pure Setup) + "Setup a new credential store." + "This will run the necessary actions to create a new credential store. \ + \This action is idempotent and if the store already exists, \ + \the operation will succeed with exit status 0." + + , mode "teardown" + (Teardown <$> force) + "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) + +common :: Parser Options +common = Options + <$> 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 + ) + + <*> 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", "") + ] + (defaultStore defaultRegion) + (Just "If no host is specified for AWS services (ie. dynamo:/table-name), \ + \the default AWS endpoints will be used.") + ) + + <*> textOption + ( short 'o' + <> long "output" + <> metavar "FORMAT" + <> completes "Output format for displaying retrieved credentials." + "The following formats are supported:" + [ (Pretty, "Pretty printed JSON.") + , (JSON, "Single-line JSON output.") + , (Echo, "Untitled textual output with no trailing newline.") + , (Print, "Print multi-line user output.") + ] + Print Nothing + ) + + <*> textOption + ( short 'l' + <> long "level" + <> metavar "LEVEL" + <> completes "Log level of AWS messages to emit." + "The following log levels are supported:" + [ (Error, "Service errors and exceptions.") + , (Debug, "Requests and responses.") + , (Trace, "Sensitive signing metadata.") + , (Info, "No logging of library routines.") + ] + Info Nothing + ) + +key :: Parser KeyId +key = textOption + ( short 'k' + <> long "key" + <> metavar "ARN" + <> defaults "The KMS Master Key Id to use." + "Examples of KMS aliases or ARNs are:" + [ ("arn:aws:kms:us-east-1:1234:key/12345678-1234", "") + , ("arn:aws:kms:us-east-1:1234:alias/MyAliasName", "") + , ("12345678-1234-1234-12345", "") + , ("alias/MyAliasName", "") + ] + defaultKeyId + (Just "It's recommended to setup a new key using the default alias.") + ) + +context :: Parser Context +context = ctx $ textOption + ( short 'c' + <> long "context" + <> metavar "KEY=VALUE" + <> describe "A key/value pair to add to the encryption context. \ + \The same context must be provided during encryption and decryption." + (Just $ "You can enter multiple key/value pairs. For example:" + indent 2 "-c foo=bar -c something=\"containing spaces\" ..." + ) Optional + ) + +name :: Parser Name +name = textOption + ( short 'n' + <> long "name" + <> metavar "STRING" + <> describe "The unique name of the credential." Nothing Required + ) + +revision :: Fact -> Parser Revision +revision r = textOption + ( short 'v' + <> long "revision" + <> metavar "STRING" + <> describe "The revision of the credential." Nothing r + ) + +force :: Parser Force +force = flag Prompt NoPrompt + ( short 'f' + <> long "force" + <> help "Always overwrite or remove, without an interactive prompt." + ) + +input :: Parser Input +input = textual <|> filepath + where + textual = Value + <$> textOption + ( short 's' + <> long "secret" + <> metavar "STRING" + <> help "The unencrypted secret value of the credential." + ) + + filepath = Path + <$> option str + ( short 'p' + <> long "path" + <> metavar "PATH" + <> help "A file to read as the contents of the unencrypted credential." + <> action "file" + )