module Credentials.DynamoDB
(
DynamoTable (..)
, defaultTable
, 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
newtype DynamoTable = DynamoTable { tableName :: Text }
deriving (Eq, Ord, Show, FromText, ToText, ToByteString, ToLog)
defaultTable :: DynamoTable
defaultTable = DynamoTable "credentials"
insert :: (MonadMask m, MonadAWS m, Typeable m)
=> KeyId
-> Context
-> Name
-> ByteString
-> DynamoTable
-> m Revision
insert key ctx name plaintext table = do
ciphertext <- encrypt key ctx name plaintext
catchResourceNotFound table (insertEncrypted name ciphertext table)
select :: MonadAWS m
=> Context
-> Name
-> Maybe Revision
-> DynamoTable
-> m (ByteString, Revision)
select ctx name rev table = do
(_, (ciphertext, rev')) <-
catchResourceNotFound table (selectEncrypted name rev table)
(,rev') <$> decrypt ctx name ciphertext
delete :: MonadAWS m
=> Name
-> Revision
-> DynamoTable
-> 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 :: MonadAWS m
=> Name
-> DynamoTable
-> 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, deleteKey x :| map deleteKey (batchInit xs))
]
deleteKey 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
revisions :: MonadAWS m
=> DynamoTable
-> 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)
setup :: MonadAWS m
=> DynamoTable
-> 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
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
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
catchResourceNotFound :: MonadCatch m => DynamoTable -> m b -> m b
catchResourceNotFound DynamoTable{..} =
handling_ _ResourceNotFoundException $
throwM $ StorageMissing ("Table " <> tableName <> " doesn't exist.")