WIP: Idempotency token

gen/amazonka-gen.cabal

@@ -95,6 +95,7 @@ library
     Gen.AST.Data.Field
     Gen.AST.Data.Instance
     Gen.AST.Data.Syntax
+    Gen.AST.Data.Syntax.AWSRequest
     Gen.AST.Override
     Gen.AST.Prefix
     Gen.AST.Subst
@@ -124,13 +125,13 @@ library
     Gen.Types.URI
     Gen.Types.Waiter
     Gen.WordFrequency
-    Paths_amazonka_gen
 
 executable gen
   import:         base
   hs-source-dirs: bin
   main-is:        gen.hs
   ghc-options:    -threaded -rtsopts "-with-rtsopts=-A128m -I0 -qg0"
+  other-modules:  Paths_amazonka_gen
   build-depends:
     , amazonka-gen
     , filepath

gen/src/Gen/AST/Data.hs

@@ -8,6 +8,7 @@ module Gen.AST.Data
   )
 where
 
+import Control.Comonad (extract)
 import qualified Control.Lens as Lens
 import qualified Control.Monad.Trans.State as State
 import qualified Data.ByteString.Char8 as ByteString.Char8
@@ -21,8 +22,9 @@ import qualified Data.Text.Lazy as Text.Lazy
 import Gen.AST.Data.Field
 import Gen.AST.Data.Instance
 import Gen.AST.Data.Syntax as Syntax
+import qualified Gen.AST.Data.Syntax.AWSRequest as AWSRequest
 import Gen.Prelude
-import Gen.Types
+import Gen.Types hiding (method)
 import qualified Language.Haskell.Exts as Exts
 import Language.Haskell.Exts.Pretty (Pretty)
 
@@ -41,7 +43,103 @@ operationData cfg m o = do
 
   xis <- addInstances xa xs <$> requestInsts m (_opName o) h xr xs
 
-  cls <- pp Print $ requestD cfg m h (xr, xis) (yr, ys)
+  let requestFunction = method <> format
+        where
+          method = methodToText $ _method h
+          format =
+            case (mapMaybe fromInstance xis, _method h, m ^. protocol) of
+              (f : _, _, _) -> f
+              ([], POST, Query) -> "Query"
+              ([], POST, EC2) -> "Query"
+              _ -> ""
+          fromInstance = \case
+            ToBody {} -> Just "Body"
+            ToJSON {} -> Just "JSON"
+            ToElement {} -> Just "XML"
+            _ -> Nothing
+
+      responseReceiver
+        | null ys = AWSRequest.ReceiveNull
+        | isShared . extract $ yr ^. refAnn,
+          all fieldBody ys = case m ^. protocol of
+            APIGateway -> AWSRequest.ReceiveJsonAll
+            JSON -> AWSRequest.ReceiveJsonAll
+            RestJSON -> AWSRequest.ReceiveJsonAll
+            EC2 -> AWSRequest.ReceiveXmlAll wrapper
+            Query -> AWSRequest.ReceiveXmlAll wrapper
+            RestXML -> AWSRequest.ReceiveXmlAll wrapper
+        -- FIXME: take method into account for responses, such as HEAD
+        -- etc, particuarly when the body might be totally empty.
+        | any fieldStream ys =
+            AWSRequest.ReceiveStreamingBody responseFieldParsers
+        | any fieldLitPayload ys =
+            AWSRequest.ReceiveBytes responseFieldParsers
+        | -- Check if we should parse wrapped XML before considering
+          -- ReceiveEmpty, because fieldBody is false for fields
+          -- parsed from within wrapped XML.
+          isXml && isJust wrapper =
+            AWSRequest.ReceiveXml wrapper responseFieldParsers
+        | -- Then check for responses that don't use the field body,
+          -- to avoid trying to `receiveXml` on API calls where AWS
+          -- might send us an empty body.
+          not $ any fieldBody ys =
+            AWSRequest.ReceiveEmpty responseFieldParsers
+        | -- Finally, check for unwrapped XML, parsed fieldwise.
+          isXml && isNothing wrapper =
+            AWSRequest.ReceiveXml wrapper responseFieldParsers
+        | isJson =
+            AWSRequest.ReceiveJson responseFieldParsers
+        | otherwise =
+            error "Gen.AST.Data.operationData(responseReceiver): don't know how to parse"
+        where
+          wrapper = yr ^. refResultWrapper
+
+          isJson = case m ^. protocol of
+            APIGateway -> True
+            JSON -> True
+            RestJSON -> True
+            EC2 -> False
+            Query -> False
+            RestXML -> False
+
+          isXml = case m ^. protocol of
+            APIGateway -> False
+            JSON -> False
+            RestJSON -> False
+            EC2 -> True
+            Query -> True
+            RestXML -> True
+
+      responseFieldParsers =
+        ys <&> \f ->
+          case fieldLocation f of
+            Just Headers -> AWSRequest.ParseHeader hName hParser
+              where
+                hName = memberName (m ^. protocol) Output f
+                hParser = case typeOf f of
+                  TMap {} -> AWSRequest.HeaderFieldMap
+                  TMaybe {} -> AWSRequest.HeaderFieldOptional
+                  _ -> AWSRequest.HeaderFieldRequired
+            _ -> AWSRequest.FigureTheFieldOut f
+
+  cls <-
+    pp Print $
+      AWSRequest.instanceD
+        AWSRequest.Config
+          { requestType = identifier xr,
+            -- Lookup a specific operationPlugins key before checking
+            -- for the wildcard.
+            requestOperationPlugins =
+              fromMaybe [] $
+                (cfg ^. operationPlugins . Lens.at (identifier xr))
+                  <|> (cfg ^. operationPlugins . Lens.at (mkId "*")),
+            requestFunction,
+            responseType = identifier yr,
+            responseReceiver,
+            serviceConfig = m ^. serviceConfig
+          }
+        (m ^. metadata)
+        ys
   mpage <- pagerFields m o >>= traverse (pp Print . pagerD xn)
 
   yis' <- renderInsts p yn (responseInsts ys)

gen/src/Gen/AST/Data/Field.hs

@@ -50,13 +50,7 @@ instance TypeOf Field where
           TList {} -> True
           _ -> False
 
-      isHeader =
-        fieldLocation f
-          `elem` map
-            Just
-            [ Headers,
-              Header
-            ]
+      isHeader = fieldLocation f == Just Headers
 
       ref = f ^. fieldRef
       typ = fmap unBase64 (typeOf ref)
@@ -71,7 +65,7 @@ instance HasInfo Field where
 -- FIXME: Can just add the metadata to field as well since
 -- the protocol/timestamp are passed in everywhere in the .Syntax module.
 mkFields ::
-  HasMetadata a Identity =>
+  (HasMetadata a Identity) =>
   a ->
   Solved ->
   StructF (Shape Solved) ->

gen/src/Gen/AST/Data/Instance.hs

@@ -20,6 +20,7 @@ data Inst
   | ToBody Field
   | IsHashable [Field]
   | IsNFData [Field]
+  deriving (Show)
 
 instance ToJSON Inst where
   toJSON = Aeson.toJSON . instToText
@@ -91,7 +92,7 @@ responseInsts fs
     (not . null -> stream, _) = List.partition fieldStream (notLocated fs)
 
 requestInsts ::
-  HasMetadata a f =>
+  (HasMetadata a f) =>
   a ->
   Id ->
   HTTP ->
@@ -129,7 +130,7 @@ requestInsts m oname h r fs = do
       where
         merged xs =
           let ys =
-                map Right (satisfies [Querystring] fs) <> xs
+                map Right (satisfies [QueryString] fs) <> xs
                   ++ map Left protocolQuery
            in case List.find f is of
                 Just (ToQuery zs) -> ToQuery (ys <> zs)
@@ -142,32 +143,32 @@ requestInsts m oname h r fs = do
     replaceXML is
       | all nonEmptyXML is = pure $! filter anyXML is
       | otherwise =
-        case ( r ^? refXMLNamespace . Lens._Just . xmlUri,
-               r ^. refLocationName,
-               listToMaybe (mapMaybe findElement is)
-             ) of
-          -- 1. If there's an xmlNamespace and/or locationName on the ref,
-          --    it should define separate ToXML + ToElement instances
-          (ns, Just e, _) ->
-            pure $! ToElement (ns <|> m ^. xmlNamespace) (Left e) : is
-          -- 2. Otherwise, a single field should be found in the ToXML instance
-          -- and lifted to a single ToElement instance.
-          (_, _, Just f) ->
-            pure $! ToElement ns (Right f) : filter anyXML is
-            where
-              ns =
-                m ^. xmlNamespace
-                  <|> f ^? fieldRef . refXMLNamespace . Lens._Just . xmlUri
-
-          -- 3. Unknown.
-          (ns, e, _) ->
-            Left $
-              "String determining root ToElement instance: "
-                ++ Text.unpack (memberId n)
-                ++ ", namespace: "
-                ++ show ns
-                ++ ", locationName: "
-                ++ show e
+          case ( r ^? refXMLNamespace . Lens._Just . xmlUri,
+                 r ^. refLocationName,
+                 listToMaybe (mapMaybe findElement is)
+               ) of
+            -- 1. If there's an xmlNamespace and/or locationName on the ref,
+            --    it should define separate ToXML + ToElement instances
+            (ns, Just e, _) ->
+              pure $! ToElement (ns <|> m ^. xmlNamespace) (Left e) : is
+            -- 2. Otherwise, a single field should be found in the ToXML instance
+            -- and lifted to a single ToElement instance.
+            (_, _, Just f) ->
+              pure $! ToElement ns (Right f) : filter anyXML is
+              where
+                ns =
+                  m ^. xmlNamespace
+                    <|> f ^? fieldRef . refXMLNamespace . Lens._Just . xmlUri
+
+            -- 3. Unknown.
+            (ns, e, _) ->
+              Left $
+                "String determining root ToElement instance: "
+                  ++ Text.unpack (memberId n)
+                  ++ ", namespace: "
+                  ++ show ns
+                  ++ ", locationName: "
+                  ++ show e
       where
         nonEmptyXML = notXML True
         anyXML = notXML False
@@ -216,7 +217,7 @@ requestInsts m oname h r fs = do
         v = ("Version", Just version)
 
     headers :: [Field]
-    headers = satisfies [Header, Headers] fs
+    headers = [f | f <- fs, fieldLocation f == Just Headers]
 
     target = (<> ("." <> action)) <$> m ^. targetPrefix