1{-# LANGUAGE DeriveGeneric              #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE TypeFamilies               #-}
4
5module Aws.DynamoDb.Commands.Table
6    ( -- * Commands
7      CreateTable(..)
8    , createTable
9    , CreateTableResult(..)
10    , DescribeTable(..)
11    , DescribeTableResult(..)
12    , UpdateTable(..)
13    , UpdateTableResult(..)
14    , DeleteTable(..)
15    , DeleteTableResult(..)
16    , ListTables(..)
17    , ListTablesResult(..)
18
19    -- * Data passed in the commands
20    , AttributeType(..)
21    , AttributeDefinition(..)
22    , KeySchema(..)
23    , Projection(..)
24    , LocalSecondaryIndex(..)
25    , LocalSecondaryIndexStatus(..)
26    , ProvisionedThroughput(..)
27    , ProvisionedThroughputStatus(..)
28    , GlobalSecondaryIndex(..)
29    , GlobalSecondaryIndexStatus(..)
30    , GlobalSecondaryIndexUpdate(..)
31    , TableDescription(..)
32    ) where
33
34-------------------------------------------------------------------------------
35import           Control.Applicative
36import           Data.Aeson            ((.!=), (.:), (.:?), (.=))
37import qualified Data.Aeson            as A
38import qualified Data.Aeson.Types      as A
39import           Data.Char             (toUpper)
40import qualified Data.HashMap.Strict   as M
41import           Data.Scientific       (Scientific)
42import qualified Data.Text             as T
43import           Data.Time
44import           Data.Time.Clock.POSIX
45import           Data.Typeable
46import qualified Data.Vector           as V
47import           GHC.Generics          (Generic)
48import           Prelude
49-------------------------------------------------------------------------------
50import           Aws.Core
51import           Aws.DynamoDb.Core
52-------------------------------------------------------------------------------
53
54
55capitalizeOpt :: A.Options
56capitalizeOpt = A.defaultOptions
57    { A.fieldLabelModifier = \x -> case x of
58                                     (c:cs) -> toUpper c : cs
59                                     [] -> []
60    }
61
62
63dropOpt :: Int -> A.Options
64dropOpt d = A.defaultOptions { A.fieldLabelModifier = drop d }
65
66
67convertToUTCTime :: Scientific -> UTCTime
68convertToUTCTime = posixSecondsToUTCTime . fromInteger . round
69
70
71-- | The type of a key attribute that appears in the table key or as a
72-- key in one of the indices.
73data AttributeType = AttrString | AttrNumber | AttrBinary
74    deriving (Show, Read, Ord, Typeable, Eq, Enum, Bounded, Generic)
75
76instance A.ToJSON AttributeType where
77    toJSON AttrString = A.String "S"
78    toJSON AttrNumber = A.String "N"
79    toJSON AttrBinary = A.String "B"
80
81instance A.FromJSON AttributeType where
82    parseJSON (A.String str) =
83        case str of
84            "S" -> return AttrString
85            "N" -> return AttrNumber
86            "B" -> return AttrBinary
87            _   -> fail $ "Invalid attribute type " ++ T.unpack str
88    parseJSON _ = fail "Attribute type must be a string"
89
90-- | A key attribute that appears in the table key or as a key in one of the indices.
91data AttributeDefinition = AttributeDefinition {
92      attributeName :: T.Text
93    , attributeType :: AttributeType
94    } deriving (Eq,Read,Ord,Show,Typeable,Generic)
95
96instance A.ToJSON AttributeDefinition where
97    toJSON = A.genericToJSON capitalizeOpt
98
99instance A.FromJSON AttributeDefinition where
100    parseJSON = A.genericParseJSON capitalizeOpt
101
102-- | The key schema can either be a hash of a single attribute name or a hash attribute name
103-- and a range attribute name.
104data KeySchema = HashOnly T.Text
105               | HashAndRange T.Text T.Text
106    deriving (Eq,Read,Show,Ord,Typeable,Generic)
107
108
109instance A.ToJSON KeySchema where
110    toJSON (HashOnly a)
111        = A.Array $ V.fromList [ A.object [ "AttributeName" .= a
112                                          , "KeyType" .= (A.String "HASH")
113                                          ]
114                               ]
115
116    toJSON (HashAndRange hash range)
117        = A.Array $ V.fromList [ A.object [ "AttributeName" .= hash
118                                          , "KeyType" .= (A.String "HASH")
119                                          ]
120                               , A.object [ "AttributeName" .= range
121                                          , "KeyType" .= (A.String "RANGE")
122                                          ]
123                               ]
124
125instance A.FromJSON KeySchema where
126    parseJSON (A.Array v) =
127        case V.length v of
128            1 -> do obj <- A.parseJSON (v V.! 0)
129                    kt <- obj .: "KeyType"
130                    if kt /= ("HASH" :: T.Text)
131                        then fail "With only one key, the type must be HASH"
132                        else HashOnly <$> obj .: "AttributeName"
133
134            2 -> do hash <- A.parseJSON (v V.! 0)
135                    range <- A.parseJSON (v V.! 1)
136                    hkt <- hash .: "KeyType"
137                    rkt <- range .: "KeyType"
138                    if hkt /= ("HASH" :: T.Text) || rkt /= ("RANGE" :: T.Text)
139                        then fail "With two keys, one must be HASH and the other RANGE"
140                        else HashAndRange <$> hash .: "AttributeName"
141                                          <*> range .: "AttributeName"
142            _ -> fail "Key schema must have one or two entries"
143    parseJSON _ = fail "Key schema must be an array"
144
145-- | This determines which attributes are projected into a secondary index.
146data Projection = ProjectKeysOnly
147                | ProjectAll
148                | ProjectInclude [T.Text]
149    deriving Show
150instance A.ToJSON Projection where
151    toJSON ProjectKeysOnly    = A.object [ "ProjectionType" .= ("KEYS_ONLY" :: T.Text) ]
152    toJSON ProjectAll         = A.object [ "ProjectionType" .= ("ALL" :: T.Text) ]
153    toJSON (ProjectInclude a) = A.object [ "ProjectionType" .= ("INCLUDE" :: T.Text)
154                                         , "NonKeyAttributes" .= a
155                                         ]
156instance A.FromJSON Projection where
157    parseJSON (A.Object o) = do
158        ty <- (o .: "ProjectionType") :: A.Parser T.Text
159        case ty of
160            "KEYS_ONLY" -> return ProjectKeysOnly
161            "ALL" -> return ProjectAll
162            "INCLUDE" -> ProjectInclude <$> o .: "NonKeyAttributes"
163            _ -> fail "Invalid projection type"
164    parseJSON _ = fail "Projection must be an object"
165
166-- | Describes a single local secondary index. The KeySchema MUST
167-- share the same hash key attribute as the parent table, only the
168-- range key can differ.
169data LocalSecondaryIndex
170    = LocalSecondaryIndex {
171        localIndexName  :: T.Text
172      , localKeySchema  :: KeySchema
173      , localProjection :: Projection
174      }
175    deriving (Show, Generic)
176instance A.ToJSON LocalSecondaryIndex where
177    toJSON = A.genericToJSON $ dropOpt 5
178instance A.FromJSON LocalSecondaryIndex where
179    parseJSON = A.genericParseJSON $ dropOpt 5
180
181-- | This is returned by AWS to describe the local secondary index.
182data LocalSecondaryIndexStatus
183    = LocalSecondaryIndexStatus {
184        locStatusIndexName      :: T.Text
185      , locStatusIndexSizeBytes :: Integer
186      , locStatusItemCount      :: Integer
187      , locStatusKeySchema      :: KeySchema
188      , locStatusProjection     :: Projection
189      }
190    deriving (Show, Generic)
191instance A.FromJSON LocalSecondaryIndexStatus where
192    parseJSON = A.genericParseJSON $ dropOpt 9
193
194-- | The target provisioned throughput you are requesting for the table or global secondary index.
195data ProvisionedThroughput
196    = ProvisionedThroughput {
197        readCapacityUnits  :: Int
198      , writeCapacityUnits :: Int
199      }
200    deriving (Show, Generic)
201instance A.ToJSON ProvisionedThroughput where
202    toJSON = A.genericToJSON capitalizeOpt
203instance A.FromJSON ProvisionedThroughput where
204    parseJSON = A.genericParseJSON capitalizeOpt
205
206-- | This is returned by AWS as the status of the throughput for a table or global secondary index.
207data ProvisionedThroughputStatus
208    = ProvisionedThroughputStatus {
209        statusLastDecreaseDateTime   :: UTCTime
210      , statusLastIncreaseDateTime   :: UTCTime
211      , statusNumberOfDecreasesToday :: Int
212      , statusReadCapacityUnits      :: Int
213      , statusWriteCapacityUnits     :: Int
214      }
215    deriving (Show, Generic)
216instance A.FromJSON ProvisionedThroughputStatus where
217    parseJSON = A.withObject "Throughput status must be an object" $ \o ->
218        ProvisionedThroughputStatus
219            <$> (convertToUTCTime <$> o .:? "LastDecreaseDateTime" .!= 0)
220            <*> (convertToUTCTime <$> o .:? "LastIncreaseDateTime" .!= 0)
221            <*> o .:? "NumberOfDecreasesToday" .!= 0
222            <*> o .: "ReadCapacityUnits"
223            <*> o .: "WriteCapacityUnits"
224
225-- | Describes a global secondary index.
226data GlobalSecondaryIndex
227    = GlobalSecondaryIndex {
228        globalIndexName             :: T.Text
229      , globalKeySchema             :: KeySchema
230      , globalProjection            :: Projection
231      , globalProvisionedThroughput :: ProvisionedThroughput
232      }
233    deriving (Show, Generic)
234instance A.ToJSON GlobalSecondaryIndex where
235    toJSON = A.genericToJSON $ dropOpt 6
236instance A.FromJSON GlobalSecondaryIndex where
237    parseJSON = A.genericParseJSON $ dropOpt 6
238
239-- | This is returned by AWS to describe the status of a global secondary index.
240data GlobalSecondaryIndexStatus
241    = GlobalSecondaryIndexStatus {
242        gStatusIndexName             :: T.Text
243      , gStatusIndexSizeBytes        :: Integer
244      , gStatusIndexStatus           :: T.Text
245      , gStatusItemCount             :: Integer
246      , gStatusKeySchema             :: KeySchema
247      , gStatusProjection            :: Projection
248      , gStatusProvisionedThroughput :: ProvisionedThroughputStatus
249      }
250    deriving (Show, Generic)
251instance A.FromJSON GlobalSecondaryIndexStatus where
252    parseJSON = A.genericParseJSON $ dropOpt 7
253
254-- | This is used to request a change in the provisioned throughput of
255-- a global secondary index as part of an 'UpdateTable' operation.
256data GlobalSecondaryIndexUpdate
257    = GlobalSecondaryIndexUpdate {
258        gUpdateIndexName             :: T.Text
259      , gUpdateProvisionedThroughput :: ProvisionedThroughput
260      }
261    deriving (Show, Generic)
262instance A.ToJSON GlobalSecondaryIndexUpdate where
263    toJSON gi = A.object ["Update" .= A.genericToJSON (dropOpt 7) gi]
264
265-- | This describes the table and is the return value from AWS for all
266-- the table-related commands.
267data TableDescription
268    = TableDescription {
269        rTableName              :: T.Text
270      , rTableSizeBytes         :: Integer
271      , rTableStatus            :: T.Text -- ^ one of CREATING, UPDATING, DELETING, ACTIVE
272      , rCreationDateTime       :: Maybe UTCTime
273      , rItemCount              :: Integer
274      , rAttributeDefinitions   :: [AttributeDefinition]
275      , rKeySchema              :: Maybe KeySchema
276      , rProvisionedThroughput  :: ProvisionedThroughputStatus
277      , rLocalSecondaryIndexes  :: [LocalSecondaryIndexStatus]
278      , rGlobalSecondaryIndexes :: [GlobalSecondaryIndexStatus]
279      }
280    deriving (Show, Generic)
281
282instance A.FromJSON TableDescription where
283    parseJSON = A.withObject "Table must be an object" $ \o -> do
284        t <- case (M.lookup "Table" o, M.lookup "TableDescription" o) of
285                (Just (A.Object t), _) -> return t
286                (_, Just (A.Object t)) -> return t
287                _ -> fail "Table description must have key 'Table' or 'TableDescription'"
288        TableDescription <$> t .: "TableName"
289                         <*> t .: "TableSizeBytes"
290                         <*> t .: "TableStatus"
291                         <*> (fmap convertToUTCTime <$> t .:? "CreationDateTime")
292                         <*> t .: "ItemCount"
293                         <*> t .:? "AttributeDefinitions" .!= []
294                         <*> t .:? "KeySchema"
295                         <*> t .: "ProvisionedThroughput"
296                         <*> t .:? "LocalSecondaryIndexes" .!= []
297                         <*> t .:? "GlobalSecondaryIndexes" .!= []
298
299{- Can't derive these instances onto the return values
300instance ResponseConsumer r TableDescription where
301    type ResponseMetadata TableDescription = DyMetadata
302    responseConsumer _ _ _ = ddbResponseConsumer
303instance AsMemoryResponse TableDescription where
304    type MemoryResponse TableDescription = TableDescription
305    loadToMemory = return
306-}
307
308-------------------------------------------------------------------------------
309--- Commands
310-------------------------------------------------------------------------------
311
312data CreateTable = CreateTable {
313      createTableName              :: T.Text
314    , createAttributeDefinitions   :: [AttributeDefinition]
315    -- ^ only attributes appearing in a key must be listed here
316    , createKeySchema              :: KeySchema
317    , createProvisionedThroughput  :: ProvisionedThroughput
318    , createLocalSecondaryIndexes  :: [LocalSecondaryIndex]
319    -- ^ at most 5 local secondary indices are allowed
320    , createGlobalSecondaryIndexes :: [GlobalSecondaryIndex]
321    } deriving (Show, Generic)
322
323createTable :: T.Text -- ^ Table name
324            -> [AttributeDefinition]
325            -> KeySchema
326            -> ProvisionedThroughput
327            -> CreateTable
328createTable tn ad ks p = CreateTable tn ad ks p [] []
329
330instance A.ToJSON CreateTable where
331    toJSON ct = A.object $ m ++ lindex ++ gindex
332        where
333            m = [ "TableName" .= createTableName ct
334                , "AttributeDefinitions" .= createAttributeDefinitions ct
335                , "KeySchema" .= createKeySchema ct
336                , "ProvisionedThroughput" .= createProvisionedThroughput ct
337                ]
338            -- AWS will error with 500 if (LocalSecondaryIndexes : []) is present in the JSON
339            lindex = if null (createLocalSecondaryIndexes ct)
340                        then []
341                        else [ "LocalSecondaryIndexes" .= createLocalSecondaryIndexes ct ]
342            gindex = if null (createGlobalSecondaryIndexes ct)
343                        then []
344                        else [ "GlobalSecondaryIndexes" .= createGlobalSecondaryIndexes ct ]
345
346--instance A.ToJSON CreateTable where
347--    toJSON = A.genericToJSON $ dropOpt 6
348
349
350-- | ServiceConfiguration: 'DdbConfiguration'
351instance SignQuery CreateTable where
352    type ServiceConfiguration CreateTable = DdbConfiguration
353    signQuery = ddbSignQuery "CreateTable"
354
355newtype CreateTableResult = CreateTableResult { ctStatus :: TableDescription }
356    deriving (Show, A.FromJSON)
357-- ResponseConsumer and AsMemoryResponse can't be derived
358instance ResponseConsumer r CreateTableResult where
359    type ResponseMetadata CreateTableResult = DdbResponse
360    responseConsumer _ _ = ddbResponseConsumer
361instance AsMemoryResponse CreateTableResult where
362    type MemoryResponse CreateTableResult = TableDescription
363    loadToMemory = return . ctStatus
364
365instance Transaction CreateTable CreateTableResult
366
367data DescribeTable
368    = DescribeTable {
369        dTableName :: T.Text
370      }
371    deriving (Show, Generic)
372instance A.ToJSON DescribeTable where
373    toJSON = A.genericToJSON $ dropOpt 1
374
375-- | ServiceConfiguration: 'DdbConfiguration'
376instance SignQuery DescribeTable where
377    type ServiceConfiguration DescribeTable = DdbConfiguration
378    signQuery = ddbSignQuery "DescribeTable"
379
380newtype DescribeTableResult = DescribeTableResult { dtStatus :: TableDescription }
381    deriving (Show, A.FromJSON)
382-- ResponseConsumer can't be derived
383instance ResponseConsumer r DescribeTableResult where
384    type ResponseMetadata DescribeTableResult = DdbResponse
385    responseConsumer _ _ = ddbResponseConsumer
386instance AsMemoryResponse DescribeTableResult where
387    type MemoryResponse DescribeTableResult = TableDescription
388    loadToMemory = return . dtStatus
389
390instance Transaction DescribeTable DescribeTableResult
391
392data UpdateTable
393    = UpdateTable {
394        updateTableName                   :: T.Text
395      , updateProvisionedThroughput       :: ProvisionedThroughput
396      , updateGlobalSecondaryIndexUpdates :: [GlobalSecondaryIndexUpdate]
397      }
398    deriving (Show, Generic)
399instance A.ToJSON UpdateTable where
400    toJSON a = A.object
401        $ "TableName" .= updateTableName a
402        : "ProvisionedThroughput" .= updateProvisionedThroughput a
403        : case updateGlobalSecondaryIndexUpdates a of
404            [] -> []
405            l -> [ "GlobalSecondaryIndexUpdates" .= l ]
406
407-- | ServiceConfiguration: 'DdbConfiguration'
408instance SignQuery UpdateTable where
409    type ServiceConfiguration UpdateTable = DdbConfiguration
410    signQuery = ddbSignQuery "UpdateTable"
411
412newtype UpdateTableResult = UpdateTableResult { uStatus :: TableDescription }
413    deriving (Show, A.FromJSON)
414-- ResponseConsumer can't be derived
415instance ResponseConsumer r UpdateTableResult where
416    type ResponseMetadata UpdateTableResult = DdbResponse
417    responseConsumer _ _ = ddbResponseConsumer
418instance AsMemoryResponse UpdateTableResult where
419    type MemoryResponse UpdateTableResult = TableDescription
420    loadToMemory = return . uStatus
421
422instance Transaction UpdateTable UpdateTableResult
423
424data DeleteTable
425    = DeleteTable {
426        deleteTableName :: T.Text
427      }
428    deriving (Show, Generic)
429instance A.ToJSON DeleteTable where
430    toJSON = A.genericToJSON $ dropOpt 6
431
432-- | ServiceConfiguration: 'DdbConfiguration'
433instance SignQuery DeleteTable where
434    type ServiceConfiguration DeleteTable = DdbConfiguration
435    signQuery = ddbSignQuery "DeleteTable"
436
437newtype DeleteTableResult = DeleteTableResult { dStatus :: TableDescription }
438    deriving (Show, A.FromJSON)
439-- ResponseConsumer can't be derived
440instance ResponseConsumer r DeleteTableResult where
441    type ResponseMetadata DeleteTableResult = DdbResponse
442    responseConsumer _ _ = ddbResponseConsumer
443instance AsMemoryResponse DeleteTableResult where
444    type MemoryResponse DeleteTableResult = TableDescription
445    loadToMemory = return . dStatus
446
447instance Transaction DeleteTable DeleteTableResult
448
449-- | TODO: currently this does not support restarting a cutoff query because of size.
450data ListTables = ListTables
451    deriving (Show)
452instance A.ToJSON ListTables where
453    toJSON _ = A.object []
454-- | ServiceConfiguration: 'DdbConfiguration'
455instance SignQuery ListTables where
456    type ServiceConfiguration ListTables = DdbConfiguration
457    signQuery = ddbSignQuery "ListTables"
458
459newtype ListTablesResult
460    = ListTablesResult {
461        tableNames :: [T.Text]
462      }
463    deriving (Show, Generic)
464instance A.FromJSON ListTablesResult where
465    parseJSON = A.genericParseJSON capitalizeOpt
466instance ResponseConsumer r ListTablesResult where
467    type ResponseMetadata ListTablesResult = DdbResponse
468    responseConsumer _ _ = ddbResponseConsumer
469instance AsMemoryResponse ListTablesResult where
470    type MemoryResponse ListTablesResult = [T.Text]
471    loadToMemory = return . tableNames
472
473instance Transaction ListTables ListTablesResult
474