credentials-cli (empty) → 0.0.1
raw patch · 9 files changed
+1144/−0 lines, 9 filesdep +aesondep +aeson-prettydep +amazonkasetup-changed
Dependencies added: aeson, aeson-pretty, amazonka, amazonka-core, amazonka-dynamodb, attoparsec, base, bytestring, conduit, conduit-extra, credentials, cryptonite, exceptions, lens, mmorph, mtl, optparse-applicative, resourcet, text, transformers-base, unordered-containers, uri-bytestring
Files
- LICENSE +202/−0
- Setup.hs +2/−0
- credentials-cli.cabal +60/−0
- src/Credentials/CLI/Format.hs +126/−0
- src/Credentials/CLI/IO.hs +91/−0
- src/Credentials/CLI/Options.hs +100/−0
- src/Credentials/CLI/Types.hs +189/−0
- src/Credentials/CLI/Types/Protocol.hs +70/−0
- src/Main.hs +304/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ credentials-cli.cabal view
@@ -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 <brendan.g.hay@gmail.com>+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 <http://hackage.haskell.org/package/credentials credentials> library of the same name.+ .+ You can read more about use-cases and prerequisites <https://github.com/brendanhay/credentials here>.++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
+ src/Credentials/CLI/Format.hs view
@@ -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 <brendan.g.hay@gmail.com>+-- 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
+ src/Credentials/CLI/IO.hs view
@@ -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 <brendan.g.hay@gmail.com>+-- 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
+ src/Credentials/CLI/Options.hs view
@@ -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 <brendan.g.hay@gmail.com>+-- 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
+ src/Credentials/CLI/Types.hs view
@@ -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 <brendan.g.hay@gmail.com>+-- 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
+ src/Credentials/CLI/Types/Protocol.hs view
@@ -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 <brendan.g.hay@gmail.com>+-- 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)
+ src/Main.hs view
@@ -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 <brendan.g.hay@gmail.com>+-- 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"+ )