File: DynamoDB.hs

package info (click to toggle)
haskell-wreq 0.5.4.3-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 380 kB
  • sloc: haskell: 2,992; makefile: 25
file content (169 lines) | stat: -rw-r--r-- 7,253 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
{-# LANGUAGE OverloadedLists, OverloadedStrings #-}
module AWS.DynamoDB (tests) where

import AWS.Aeson
import Control.Concurrent (threadDelay)
import Control.Lens hiding ((.=))
import Data.Aeson.Lens (key, _String, values, _Double)
import Data.Text as T (pack)
import Network.Wreq
import System.Timeout (timeout)
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (assertBool, assertFailure)

-- FIXME: retry create call in case the table is in DELETING state
-- from a previous test run (error 'Table already exists: ...'). For
-- now 'create' testcase and all others will fails. Rerun when ongoing
-- delete operation is complete.

tests :: String -> String -> Options -> Test
tests prefix region baseopts = testGroup "dynamodb" [
    testCase "createTable" $ createTable prefix region baseopts
  , testCase "listTables" $ listTables prefix region baseopts
  , testCase "awaitTableActive"  $ awaitTableActive prefix region baseopts
  , testCase "putItem" $ putItem prefix region baseopts
  , testCase "getItem" $ getItem prefix region baseopts
  , testCase "deleteItem" $ deleteItem prefix region baseopts
  , testCase "deleteTable" $ deleteTable prefix region baseopts -- call last
  ]

createTable :: String -> String -> Options -> IO ()
createTable prefix region baseopts = do
  let opts = baseopts
             & header "X-Amz-Target" .~ ["DynamoDB_20120810.CreateTable"]
             & header "Content-Type" .~ ["application/x-amz-json-1.0"]
  r <- postWith opts (url region) $
       object [
           "TableName" .= string (prefix ++ tablename),
           "KeySchema" .= [
             object ["AttributeName" .= "name", "KeyType" .= "HASH"],
             object ["AttributeName" .= "age", "KeyType" .= "RANGE"]
           ],
           "AttributeDefinitions" .= [
             object ["AttributeName" .= "name", "AttributeType" .= "S"],
             object ["AttributeName" .= "age", "AttributeType" .= "S"]
           ],
           "ProvisionedThroughput" .= object [
             "ReadCapacityUnits" .= 1,
             "WriteCapacityUnits" .= 1
           ]
       ]
  assertBool "createTables 200" $ r ^. responseStatus . statusCode == 200
  assertBool "createTables OK" $ r ^. responseStatus . statusMessage == "OK"
  assertBool "createTables status CREATING" $
    r ^. responseBody . key "TableDescription" . key "TableStatus" . _String == "CREATING"
  assertBool "createTables no items in new table" $
    r ^? responseBody . key "TableDescription" . key "ItemCount" . _Double == Just 0

listTables :: String -> String -> Options -> IO ()
listTables prefix region baseopts = do
  let opts = baseopts
             & header "X-Amz-Target" .~ ["DynamoDB_20120810.ListTables"]
             & header "Content-Type" .~ ["application/x-amz-json-1.0"]
  -- FIXME avoid limit to keep tests from failing if there are > tables?
  r <- postWith opts (url region) $ object ["Limit" .= 100]
  assertBool "listTables 200" $ r ^. responseStatus . statusCode == 200
  assertBool "listTables OK" $ r ^. responseStatus . statusMessage == "OK"
  assertBool "listTables contains test table" $
    elem (T.pack $ prefix ++ tablename)
         (r ^.. responseBody . key "TableNames" . values . _String)

awaitTableActive :: String -> String -> Options -> IO ()
awaitTableActive prefix region baseopts = do
  let dur = 45 -- typically ACTIVE in 20s or less (us-west-2, Sept 2014)
  res <- timeout (dur*1000*1000) check
  case res of
    Nothing ->
      assertFailure $ "timeout: table not ACTIVE after " ++ show dur ++ "s"
    Just () ->
      return () -- PASS
  where
    check = do
      let opts = baseopts
                 & header "X-Amz-Target" .~ ["DynamoDB_20120810.DescribeTable"]
                 & header "Content-Type" .~ ["application/x-amz-json-1.0"]
      r <- postWith opts (url region) $
           object ["TableName" .= string (prefix ++ tablename)]
      assertBool "awaitTableActive 200" $ r ^. responseStatus . statusCode == 200
      assertBool "awaitTableActive OK" $ r ^. responseStatus . statusMessage == "OK"
      -- Prelude.putStr "."
      case r ^. responseBody . key "Table" . key "TableStatus" . _String of
        "ACTIVE" ->
          return ()
        _ -> do
          threadDelay $ 5*1000*1000 -- 5 sleep
          check

deleteTable :: String -> String -> Options -> IO ()
deleteTable prefix region baseopts = do
  let opts = baseopts
             & header "X-Amz-Target" .~ ["DynamoDB_20120810.DeleteTable"]
             & header "Content-Type" .~ ["application/x-amz-json-1.0"]
  r <- postWith opts (url region) $
       object ["TableName" .= string (prefix ++ tablename)]
  assertBool "deleteTable 200" $ r ^. responseStatus . statusCode == 200
  assertBool "deleteTable OK" $ r ^. responseStatus . statusMessage == "OK"

putItem :: String -> String -> Options -> IO ()
putItem prefix region baseopts = do
  let opts = baseopts
             & header "X-Amz-Target" .~ ["DynamoDB_20120810.PutItem"]
             & header "Content-Type" .~ ["application/x-amz-json-1.0"]
  r <- postWith opts (url region) $
       object [
         "TableName" .= string (prefix ++ tablename),
         "Item" .= object [
                     "name" .= object ["S" .= "someone"],
                     "age" .= object ["S" .= "whatever"],
                     "bar" .= object ["S" .= "baz"]
                    ]
       ]
  assertBool "putItem 200" $ r ^. responseStatus . statusCode == 200
  assertBool "putItem OK" $ r ^. responseStatus . statusMessage == "OK"

getItem :: String -> String -> Options -> IO ()
getItem prefix region baseopts = do
  let opts = baseopts
             & header "X-Amz-Target" .~ ["DynamoDB_20120810.GetItem"]
             & header "Content-Type" .~ ["application/x-amz-json-1.0"]
  r <- postWith opts (url region) $
         object [
           "TableName" .= string (prefix ++ tablename),
           "Key" .= object [
             "name" .= object ["S" .= "someone"],
             "age" .= object ["S" .= "whatever"]
           ],
           "AttributesToGet" .= ["bar"],
           "ConsistentRead" .= true,
           "ReturnConsumedCapacity" .= "TOTAL"
         ]
  assertBool "getItem 200" $ r ^. responseStatus . statusCode == 200
  assertBool "getItem OK" $ r ^. responseStatus . statusMessage == "OK"
  assertBool "getItem baz value is bar" $
    r ^. responseBody . key "Item" . key "bar" . key "S" . _String == "baz"

deleteItem :: String -> String -> Options -> IO ()
deleteItem prefix region baseopts = do
  let opts = baseopts
             & header "X-Amz-Target" .~ ["DynamoDB_20120810.DeleteItem"]
             & header "Content-Type" .~ ["application/x-amz-json-1.0"]
  r <- postWith opts (url region) $
       object [
         "TableName" .= string (prefix ++ tablename),
         "Key" .= object [
           "name" .= object ["S" .= "someone"],
           "age" .= object ["S" .= "whatever"]
         ],
         "ReturnValues" .= "ALL_OLD"
       ]
  assertBool "getItem 200" $ r ^. responseStatus . statusCode == 200
  assertBool "getItem OK" $ r ^. responseStatus . statusMessage == "OK"

url :: String -> String
url region =
  "https://dynamodb." ++ region ++ ".amazonaws.com/"

tablename :: String
tablename =
  "test"