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.cabal b/credentials.cabal new file mode 100644 --- /dev/null +++ b/credentials.cabal @@ -0,0 +1,82 @@ +name: credentials +version: 0.0.1 +synopsis: Secure Credentials Storage and Distribution +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 +build-type: Simple +cabal-version: >= 1.10 + +description: + This library provides a unified interface for managing secure, shared credentials. + It uses Amazon Key Management Service (KMS) for master key management, locally + encrypts and decrypts secrets, which are then stored in any of the supported + storage backends. (Currently DynamoDB.) + . + The use-case is to avoid storing sensitive information such as passwords and + connection strings in plaintext in places such as source control or on + developers' machines. Instead you can securely administer and distribute + secrets, leveraging Amazon's IAM policies for access control and permissions to + ensure limited read-only permissions from production/deployed hosts. + You can embed this library into projects such as web applications to securely + retrieve sensitive information such as database passwords or private keys on startup. + . + A complementary CLI for management of credentials can be installed via + . + . + You can read more about other use-cases and prerequisites . + +source-repository head + type: git + location: git://github.com/brendanhay/credentials.git + +library + default-language: Haskell2010 + hs-source-dirs: src + + ghc-options: -Wall + + exposed-modules: + Credentials + , Credentials.KMS + , Credentials.DynamoDB + , Credentials.DynamoDB.Item + , Credentials.Types + + build-depends: + aeson >= 0.8 + , amazonka >= 1.3.7 + , amazonka-core >= 1.3.7 + , amazonka-dynamodb >= 1.3.7 + , amazonka-kms >= 1.3.7 + , base >= 4.7 && < 5 + , bytestring >= 0.10 + , conduit >= 1.2 + , cryptonite >= 0.10 + , exceptions >= 0.6 + , lens >= 4.4 + , memory >= 0.11 + , retry >= 0.7.0.1 + , semigroups >= 0.6 + , text >= 0.11 + , time >= 1.4 + , transformers >= 0.3 + , unordered-containers >= 0.2.5 + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + + ghc-options: -Wall -threaded + + other-modules: + + build-depends: + base + , credentials diff --git a/src/Credentials.hs b/src/Credentials.hs new file mode 100644 --- /dev/null +++ b/src/Credentials.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Credentials +-- Copyright : (c) 2015-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- This module provides a common interface for operating on your shared +-- credentials. +module Credentials + ( + -- * Usage + -- $usage + + -- * Operations + insert + , select + , delete + , truncate + , revisions + , setup + , teardown + + -- * KMS + , KeyId (..) + , defaultKeyId + + -- * DynamoDB + , DynamoTable (..) + , defaultTable + + -- * Errors + , CredentialError (..) + , AsCredentialError (..) + + -- * Types + , Name (..) + , Revision (..) + , Context (..) + , Setup (..) + ) where + +import Credentials.DynamoDB +import Credentials.Types + +-- $usage +-- To use the library, make sure you have met the following prerequisites: +-- +-- * You have a master key in KMS. You can create this under Identity and Access +-- Management > Encryption Keys, in the AWS developer console. +-- +-- * Your AWS access credentials are available where +-- can find them. This +-- will be automatic if you are running on an EC2 host, otherwise +-- the file, as @AWS_ACCESS_KEY_ID@ and +-- @AWS_SECRET_ACCESS_KEY@ environment variables need to be configured. +-- +-- Since all of the credentials operations are constrained by a 'MonadAWS' context, +-- running them is identical to that of [amazonka](https://hackage.haskell.org/package/amazonka), +-- which you will also need to add to your @build-depends@ section of your project's cabal file. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Credentials +-- > import Control.Lens +-- > import Data.ByteString (ByteString) +-- > import Network.AWS +-- > import System.IO +-- > +-- > example :: IO (ByteString, Revision) +-- > example = do +-- > -- A new 'Logger' to replace the default noop logger is created, +-- > -- which will print AWS debug information and errors to stdout. +-- > lgr <- newLogger Debug stdout +-- > +-- > -- A new amazonka 'Env' is created, which auto-discovers the +-- > -- underlying host credentials. +-- > env <- newEnv Frankfurt Discover +-- > +-- > let table = "dynamo-table-name" +-- > key = "kms-key-alias" +-- > name = "credential-name" +-- > +-- > -- We now run the 'AWS' computation with the overriden logger, +-- > -- performing the sequence of credentials operations. +-- > runResourceT . runAWS (env & envLogger .~ lgr) $ do +-- > -- Firstly, we create the DynamoDB table. +-- > -- This is an idempotent operation but since it makes remote API calls, +-- > -- it's recommended you only run this once via the CLI. +-- > Credentials.setup table +-- > +-- > -- Then we insert a credential\'s value, for a given name. +-- > -- Encryption is handled transparently and the resulting revision +-- > -- is returned. +-- > _ <- Credentials.insert key mempty name "a-super-secret-value" table +-- > +-- > -- Selecting the credential by name, and specifying 'Nothing' for the +-- > -- revision results in the latest credential revision being returned. +-- > Credentials.select mempty name Nothing table diff --git a/src/Credentials/DynamoDB.hs b/src/Credentials/DynamoDB.hs new file mode 100644 --- /dev/null +++ b/src/Credentials/DynamoDB.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Credentials.DynamoDB +-- Copyright : (c) 2015-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Provides the implementation for storage and retrieval of encrypted credentials +-- in DynamoDB. The encryption and decryption is handled by "Credentials.KMS". +-- +-- See the "Credentials" module for usage information. +module Credentials.DynamoDB + ( + -- * Table + DynamoTable (..) + , defaultTable + + -- * Operations + , insert + , select + , delete + , truncate + , revisions + , setup + , teardown + ) where + +import Prelude hiding (truncate) + +import Control.Exception.Lens +import Control.Lens hiding (Context) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Retry + +import Credentials.DynamoDB.Item +import Credentials.KMS as KMS +import Credentials.Types + +import Crypto.Hash (Digest, SHA1) + +import Data.ByteArray.Encoding +import Data.ByteString (ByteString) +import Data.Conduit hiding (await) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Ord +import Data.Text (Text) +import Data.Time.Clock.POSIX +import Data.Typeable + +import Network.AWS +import Network.AWS.Data +import Network.AWS.DynamoDB + +import qualified Crypto.Hash as Crypto +import qualified Data.ByteString as BS +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import qualified Data.HashMap.Strict as Map +import qualified Data.List.NonEmpty as NE + +-- | A DynamoDB table reference. +newtype DynamoTable = DynamoTable { tableName :: Text } + deriving (Eq, Ord, Show, FromText, ToText, ToByteString, ToLog) + +-- | The default DynamoDB table used to store credentials. +-- +-- /Value:/ @credentials@ +defaultTable :: DynamoTable +defaultTable = DynamoTable "credentials" + +-- | Encrypt and insert a new credential revision with the specified name. +-- +-- The newly inserted revision is returned. +insert :: (MonadMask m, MonadAWS m, Typeable m) + => KeyId -- ^ The KMS master key ARN or alias. + -> Context -- ^ The KMS encryption context. + -> Name -- ^ The credential name. + -> ByteString -- ^ The unencrypted plaintext. + -> DynamoTable -- ^ The DynamoDB table. + -> m Revision +insert key ctx name plaintext table = do + ciphertext <- encrypt key ctx name plaintext + catchResourceNotFound table (insertEncrypted name ciphertext table) + +-- | Select an existing credential, optionally specifying the revision. +-- +-- The decrypted plaintext and selected revision are returned. +select :: MonadAWS m + => Context -- ^ The KMS encryption context that was used during insertion. + -> Name -- ^ The credential name. + -> Maybe Revision -- ^ A revision. If 'Nothing', the latest will be selected. + -> DynamoTable -- ^ The DynamoDB table. + -> m (ByteString, Revision) +select ctx name rev table = do + (_, (ciphertext, rev')) <- + catchResourceNotFound table (selectEncrypted name rev table) + (,rev') <$> decrypt ctx name ciphertext + +-- | Delete the specific credential revision. +delete :: MonadAWS m + => Name -- ^ The credential name. + -> Revision -- ^ The revision to delete. + -> DynamoTable -- ^ The DynamoDB table. + -> m () +delete name rev table@DynamoTable{..} = + catchResourceNotFound table $ do + (ver, _) <- selectEncrypted name (Just rev) table + void . send $ + deleteItem tableName + & diKey .~ toItem name <> toItem ver + +-- | Truncate all of a credential's revisions, so that only +-- the latest revision remains. +truncate :: MonadAWS m + => Name -- ^ The credential name. + -> DynamoTable -- ^ The DynamoDB table. + -> m () +truncate name table@DynamoTable{..} = catchResourceNotFound table $ + queryAll $$ CL.mapM_ (deleteMany . view qrsItems) + where + queryAll = + paginate $ + queryByName name table + & qAttributesToGet ?~ nameField :| [versionField] + & qScanIndexForward ?~ True + & qLimit ?~ batchSize + + deleteMany [] = pure () + deleteMany (x:xs) = void . send $ + batchWriteItem + & bwiRequestItems .~ + [ (tableName, deleteItem x :| map deleteItem (batchInit xs)) + ] + + deleteItem k = + writeRequest + & wrDeleteRequest ?~ (deleteRequest & drKey .~ k) + + batchInit xs + | i < n = take (i - 1) xs + | otherwise = xs + where + n = fromIntegral (batchSize - 1) + i = length xs + + batchSize = 50 + +-- | Scan the entire credential database, grouping pages of results into +-- unique credential names and their corresponding revisions. +revisions :: MonadAWS m + => DynamoTable -- ^ The DynamoDB table. + -> Source m (Name, NonEmpty Revision) +revisions table = catchResourceNotFound table $ + paginate (scanTable table) + =$= CL.concatMapM (traverse fromItem . view srsItems) + =$= CL.groupOn1 fst + =$= CL.map group + where + group ((name, rev), revs) = (name, desc (rev :| map snd revs)) + + desc :: NonEmpty (Version, Revision) -> NonEmpty Revision + desc = NE.map snd . NE.sortWith (Down . fst) + +-- | Create the credentials database table. +-- +-- The returned idempotency flag can be used to notify configuration +-- management tools such as ansible whether about system state. +setup :: MonadAWS m + => DynamoTable -- ^ The DynamoDB table. + -> m Setup +setup table@DynamoTable{..} = do + p <- exists table + unless p $ do + let iops = provisionedThroughput 1 1 + keys = keySchemaElement nameField Hash + :| [keySchemaElement versionField Range] + attr = ctAttributeDefinitions .~ + [ attributeDefinition nameField S + , attributeDefinition versionField S + , attributeDefinition revisionField B + ] + secn = ctLocalSecondaryIndexes .~ + [ localSecondaryIndex revisionField + (keySchemaElement nameField Hash + :| [keySchemaElement revisionField Range]) + (projection & pProjectionType ?~ All) + ] + void $ send (createTable tableName keys iops & attr & secn) + void $ await tableExists (describeTable tableName) + pure $ + if p + then Exists + else Created + +-- | Delete the credentials database table and all data. +-- +-- /Note:/ Unless you have DynamoDB backups running, this is a completely +-- irrevocable action. +teardown :: MonadAWS m => DynamoTable -> m () +teardown table@DynamoTable{..} = do + p <- exists table + when p $ do + void $ send (deleteTable tableName) + void $ await tableNotExists (describeTable tableName) + +insertEncrypted :: (MonadMask m, MonadAWS m, Typeable m) + => Name + -> Encrypted + -> DynamoTable + -> m Revision +insertEncrypted name encrypted table@DynamoTable{..} = + recovering policy [const cond] write + where + write = const $ do + ver <- maybe 1 (+1) <$> latest name table + rev <- genRevision ver + void . send $ putItem tableName + & piExpected .~ Map.map (const expect) (toItem ver <> toItem rev) + & piItem .~ + toItem name + <> toItem ver + <> toItem rev + <> toItem encrypted + pure rev + + cond = handler_ _ConditionalCheckFailedException (pure True) + + expect = expectedAttributeValue & eavExists ?~ False + + policy = constantDelay 1000 <> limitRetries 5 + +selectEncrypted :: (MonadThrow m, MonadAWS m) + => Name + -> Maybe Revision + -> DynamoTable + -> m (Version, (Encrypted, Revision)) +selectEncrypted name rev table@DynamoTable{..} = + send (queryByName name table & revision rev) >>= result + where + result = maybe missing fromItem . listToMaybe . view qrsItems + + missing = throwM $ SecretMissing name rev tableName + + -- If revision is specified, the revision index is used and + -- a consistent read is done. + revision Nothing = id + revision (Just r) = + (qIndexName ?~ revisionField) + . (qKeyConditions <>~ equals r) + . (qConsistentRead ?~ True) + +latest :: (MonadThrow m, MonadAWS m) + => Name + -> DynamoTable + -> m (Maybe Version) +latest name table = do + rs <- send (queryByName name table & qConsistentRead ?~ True) + case listToMaybe (rs ^. qrsItems) of + Nothing -> pure Nothing + Just m -> Just <$> fromItem m + +exists :: MonadAWS m => DynamoTable -> m Bool +exists DynamoTable{..} = paginate listTables + =$= CL.concatMap (view ltrsTableNames) + $$ (isJust <$> findC (== tableName)) + +scanTable :: DynamoTable -> Scan +scanTable DynamoTable{..} = + scan tableName + & sAttributesToGet ?~ nameField :| [versionField, revisionField] + +queryByName :: Name -> DynamoTable -> Query +queryByName name DynamoTable{..} = + query tableName + & qLimit ?~ 1 + & qScanIndexForward ?~ False + & qConsistentRead ?~ False + & qKeyConditions .~ equals name + +genRevision :: MonadIO m => Version -> m Revision +genRevision (Version ver) = do + ts <- liftIO getPOSIXTime + let d = Crypto.hash (toBS (show ts) <> toBS ver) :: Digest SHA1 + r = BS.take 7 (convertToBase Base16 d) + pure $! Revision r + +findC :: Monad m => (a -> Bool) -> Consumer a m (Maybe a) +findC f = loop + where + loop = C.await >>= maybe (pure Nothing) go + + go x | f x = pure (Just x) + | otherwise = loop + +-- FIXME: Over specified due to the coarseness of _ResourceNotFound. +catchResourceNotFound :: MonadCatch m => DynamoTable -> m b -> m b +catchResourceNotFound DynamoTable{..} = + handling_ _ResourceNotFoundException $ + throwM $ StorageMissing ("Table " <> tableName <> " doesn't exist.") diff --git a/src/Credentials/DynamoDB/Item.hs b/src/Credentials/DynamoDB/Item.hs new file mode 100644 --- /dev/null +++ b/src/Credentials/DynamoDB/Item.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Credentials.DynamoDB.Item +-- Copyright : (c) 2013-2015-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- This module contains the schema that is used by "Credentials.DynamoDB" to +-- serialise encryption parameters to DynamoDB items. +module Credentials.DynamoDB.Item where + +import Control.Lens (set, view, (&), (.~)) +import Control.Monad ((>=>)) +import Control.Monad.Catch (MonadThrow (..)) + +import Credentials.Types + +import Crypto.Hash (SHA256, digestFromByteString) +import Crypto.MAC.HMAC (HMAC (..)) + +import Data.Bifunctor (bimap) +import Data.ByteArray (convert) +import Data.ByteArray.Encoding (Base (Base16), convertFromBase, convertToBase) +import Data.ByteString (ByteString) +import Data.HashMap.Strict (HashMap) +import Data.Monoid ((<>)) +import Data.Text (Text) + +import Network.AWS.Data +import Network.AWS.DynamoDB + +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +padding :: Text +padding = Text.replicate 19 "0" + +-- | The DynamoDB field used for optimistic locking. +-- +-- Serialisation of 'Version' handles left-padding to support +-- consistent lexicographic ordering when used as a range in DynamoDB. +newtype Version = Version Integer + deriving (Eq, Ord, Num, FromText, ToText) + +equals :: Item a => a -> HashMap Text Condition +equals = Map.map (\x -> condition EQ' & cAttributeValueList .~ [x]) . toItem + +nameField, revisionField, versionField, wrappedKeyField, + ciphertextField, digestField :: Text +nameField = "name" +revisionField = "revision" +versionField = "version" +wrappedKeyField = "key" +ciphertextField = "contents" +digestField = "hmac" + +class Item a where + -- | Encode an item as a set of attributes including their schema. + toItem :: a -> HashMap Text AttributeValue + + -- | Decode an item from a set of attributes. + parseItem :: HashMap Text AttributeValue -> Either CredentialError a + +-- | Decode an item by throwing a 'CredentialError' exception when an +-- error is encountered. +fromItem :: (MonadThrow m, Item a) => HashMap Text AttributeValue -> m a +fromItem = either throwM pure . parseItem + +instance (Item a, Item b) => Item (a, b) where + toItem (x, y) = toItem x <> toItem y + parseItem m = (,) <$> parseItem m <*> parseItem m + +instance Item Name where + toItem = Map.singleton nameField . toAttr + parseItem = parse nameField + +instance Item Revision where + toItem = Map.singleton revisionField . toAttr + parseItem = parse revisionField + +instance Item Version where + toItem = Map.singleton versionField . toAttr + parseItem = parse versionField + +instance Item Encrypted where + toItem Encrypted{..} = + Map.fromList + [ (wrappedKeyField, toAttr wrappedKey) + , (ciphertextField, toAttr ciphertext) + , (digestField, toAttr digest) + ] + + parseItem m = + Encrypted + <$> parse wrappedKeyField m + <*> parse ciphertextField m + <*> parse digestField m + +parse :: Attribute a + => Text + -> HashMap Text AttributeValue + -> Either CredentialError a +parse k m = + case Map.lookup k m of + Nothing -> Left $ FieldMissing k (Map.keys m) + Just v -> + case parseAttr v of + Nothing -> Left $ FieldInvalid k (show v) + Just x -> Right x + +class Attribute a where + -- | Encode an attribute value. + toAttr :: a -> AttributeValue + + -- | Decode an attribute value. + parseAttr :: AttributeValue -> Maybe a + +instance Attribute Text where + toAttr t = set avS (Just t) attributeValue + parseAttr = view avS + +instance Attribute ByteString where + toAttr bs = set avB (Just bs) attributeValue + parseAttr = view avB + +instance Attribute Name where + toAttr = toAttr . toText + parseAttr = fmap Name . parseAttr + +instance Attribute Revision where + toAttr = toAttr . toBS + parseAttr = fmap Revision . parseAttr + +instance Attribute Integer where + toAttr = toAttr . toText + parseAttr = parseAttr >=> either (const Nothing) Just . fromText + +instance Attribute Version where + toAttr (Version n) = + let x = toText n + y = Text.drop (Text.length x) padding <> x + in toAttr y + parseAttr = fmap Version . parseAttr + +instance Attribute (HMAC SHA256) where + toAttr = toAttr . Text.decodeUtf8 . convertToBase Base16 . hmacGetDigest + parseAttr v = do + t :: Text <- parseAttr v + case convertFromBase Base16 (Text.encodeUtf8 t) of + Left _ -> Nothing + Right bs -> HMAC <$> digestFromByteString (bs :: ByteString) diff --git a/src/Credentials/KMS.hs b/src/Credentials/KMS.hs new file mode 100644 --- /dev/null +++ b/src/Credentials/KMS.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Credentials.KMS +-- Copyright : (c) 2015-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Encryption and decryption of local data, by using a wrapped key mechanism +-- and master keys stored in KMS. +-- +-- See the "Credentials" module for usage information. +module Credentials.KMS + ( encrypt + , decrypt + ) where + +import Control.Exception.Lens (catching_, handler) +import Control.Lens hiding (Context) +import Control.Monad +import Control.Monad.Catch (Exception, MonadThrow (..), catches) + +import Credentials.Types + +import Crypto.Cipher.AES (AES256) +import Crypto.Cipher.Types (nullIV) +import Crypto.Error +import Crypto.MAC.HMAC (HMAC (..), hmac) + +import Data.ByteArray.Encoding (Base (Base16), convertToBase) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Typeable (Typeable) + +import Network.AWS +import Network.AWS.Data +import Network.AWS.Error (hasCode, hasStatus) +import Network.AWS.KMS hiding (decrypt, encrypt) + +import Numeric.Natural (Natural) + +import qualified Crypto.Cipher.Types as Cipher +import qualified Data.ByteString as BS +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as Text +import qualified Network.AWS.KMS as KMS + +-- | Encrypt a plaintext 'ByteString' with the given master key and +-- encryption context. The 'Name' is used to annotate error messages. +-- +-- The wrapped data encryption key, ciphertext, and HMAC SHA256 are returned +-- if no error occurs. +encrypt :: (MonadAWS m, Typeable m) + => KeyId + -> Context + -> Name + -> ByteString + -> m Encrypted +encrypt key ctx name plaintext = do + let rq = generateDataKey (toText key) + & gdkNumberOfBytes ?~ keyLength + & gdkEncryptionContext .~ fromContext ctx + + rs <- catches (send rq) + [ handler (_ServiceError . hasStatus 400 . hasCode "NotFound") $ + throwM . MasterKeyMissing key . fmap toText . _serviceMessage + , handler _NotFoundException $ + throwM . MasterKeyMissing key . fmap toText . _serviceMessage + ] + + let (dataKey, hmacKey) = splitKey (rs ^. gdkrsPlaintext) + failure = EncryptFailure ctx name + + aes :: AES256 <- cryptoError failure (Cipher.cipherInit dataKey) + + let !wrappedKey = rs ^. gdkrsCiphertextBlob + !ciphertext = Cipher.ctrCombine aes nullIV plaintext + !digest = hmac hmacKey ciphertext + + pure $! Encrypted{..} + +-- | Decrypt ciphertext using the given encryption context, and wrapped +-- data encryption key. The HMAC SHA256 is recalculated and compared for +-- message integrity. The 'Name' is used to annotate error messages. +-- +-- The resulting unencrypted plaintext 'ByteString' is returned if no error occurs. +decrypt :: MonadAWS m + => Context + -> Name + -> Encrypted + -> m ByteString +decrypt ctx name Encrypted{..} = do + let rq = KMS.decrypt wrappedKey + & decEncryptionContext .~ fromContext ctx + + rs <- catching_ _InvalidCiphertextException (send rq) $ + throwM . DecryptFailure ctx name $ + if Map.null (fromContext ctx) + then "Could not decrypt stored key using KMS. \ + \The credential may require an ecryption context." + else "Could not decrypt stored key using KMS. \ + \The provided encryption context may not match the one \ + \used when the credential was stored." + + -- Decrypted plaintext data. This value may not be returned if the customer + -- master key is not available or if you didn't have permission to use it. + plaintextKey <- + case rs ^. drsPlaintext of + Nothing -> throwM $ + DecryptFailure ctx name + "Decrypted plaintext data not available from KMS." + Just t -> pure t + + let (dataKey, hmacKey) = splitKey plaintextKey + expect = hmac hmacKey (toBS ciphertext) + failure = DecryptFailure ctx name + + unless (expect == digest) $ + throwM (IntegrityFailure name (encodeHex expect) (encodeHex digest)) + + aes :: AES256 <- cryptoError failure (Cipher.cipherInit dataKey) + + pure $! Cipher.ctrCombine aes nullIV (toBS ciphertext) + +splitKey :: ByteString -> (ByteString, ByteString) +splitKey = BS.splitAt 32 + +keyLength :: Natural +keyLength = 64 + +cryptoError :: (MonadThrow m, Exception e) + => (Text -> e) + -> CryptoFailable a + -> m a +cryptoError f = onCryptoFailure (throwM . f . Text.pack . show) pure + +encodeHex :: HMAC a -> ByteString +encodeHex = convertToBase Base16 diff --git a/src/Credentials/Types.hs b/src/Credentials/Types.hs new file mode 100644 --- /dev/null +++ b/src/Credentials/Types.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Credentials.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.Types where + +import Control.Exception.Lens (exception) +import Control.Lens hiding (Context) +import Control.Monad.Catch (Exception, SomeException) + +import Crypto.Hash (SHA256) +import Crypto.MAC.HMAC (HMAC) + +import Data.ByteString (ByteString) +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import Data.Typeable (Typeable) + +import Network.AWS.Data + +-- | The KMS master key identifier. +newtype KeyId = KeyId Text + deriving (Eq, Ord, Show, FromText, ToText, ToByteString, ToLog) + +-- | The default KMS master key alias. +-- +-- /Value:/ @alias\/credentials@ +defaultKeyId :: KeyId +defaultKeyId = KeyId "alias/credentials" + +-- | A shared/readable name for a secret. +newtype Name = Name Text + deriving (Eq, Ord, Show, FromText, ToText, ToByteString, ToLog) + +-- | An opaque, non-monotonic revision number. +newtype Revision = Revision ByteString + deriving (Eq, Ord, Show, FromText, ToText, ToByteString, ToLog) + +-- | A KMS encryption context. +-- +-- /See:/ KMS +-- documentation for more information. +newtype Context = Context { fromContext :: HashMap Text Text } + deriving (Eq, Show, Monoid) + +-- | The encryption parameters required to perform decryption. +data Encrypted = Encrypted + { wrappedKey :: !ByteString -- ^ The wrapped (encrypted) data encryption key. + , ciphertext :: !ByteString -- ^ The encrypted ciphertext. + , digest :: !(HMAC SHA256) -- ^ HMAC SHA256 digest of the ciphertext. + } + +-- | Denotes idempotency of an action. That is, whether an action resulted +-- in any setup being performed. +data Setup + = Created + | Exists + deriving (Eq, Show) + +instance ToText Setup where + toText = \case + Created -> "created" + Exists -> "exists" + +instance ToLog Setup where + build = build . toText + +data CredentialError + = MasterKeyMissing KeyId (Maybe Text) + -- ^ The specified master key id doesn't exist. + + | IntegrityFailure Name ByteString ByteString + -- ^ The computed HMAC doesn't matched the stored HMAC. + + | EncryptFailure Context Name Text + -- ^ Failure occured during local encryption. + + | DecryptFailure Context Name Text + -- ^ Failure occured during local decryption. + + | StorageMissing Text + -- ^ Storage doesn't exist, or has gone on holiday. + + | StorageFailure Text + -- ^ Some storage pre-condition wasn't met. + -- For example: DynamoDB column size exceeded. + + | FieldMissing Text [Text] + -- ^ Missing field from the storage engine. + + | FieldInvalid Text String + -- ^ Unable to parse field from the storage engine. + + | SecretMissing Name (Maybe Revision) Text + -- ^ Secret with the specified name cannot found. + + | OptimisticLockFailure Name Revision Text + -- ^ Attempting to insert a revision that already exists. + + deriving (Eq, Show, Typeable) + +instance Exception CredentialError + +makeClassyPrisms ''CredentialError + +instance AsCredentialError SomeException where + _CredentialError = exception diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,12 @@ +-- | +-- 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 + +main :: IO () +main = putStrLn "Test suite not yet implemented"