OpenAPI (#251): actually do HTTP

AshleyYakeley · Apr 28, 2024 · ad73494 · ad73494
1 parent 0b177af
commit ad73494
Show file tree

Hide file tree

Showing 4 changed files with 26 additions and 5 deletions.
diff --git a/Pinafore/pinafore-webapi/lib/Pinafore/WebAPI/OpenAPI.hs b/Pinafore/pinafore-webapi/lib/Pinafore/WebAPI/OpenAPI.hs
@@ -6,9 +6,11 @@ import Data.Aeson as Aeson hiding (Result)
 import qualified Data.Aeson.Key as Aeson
 import qualified Data.Aeson.KeyMap as Aeson
 import qualified Data.HashMap.Strict.InsOrd as InsOrd
-import Data.OpenApi hiding (items, name, schema)
+import Data.OpenApi hiding (items, name, schema, server)
 import qualified Data.Scientific as Scientific
 import Data.Shim
+import qualified Network.HTTP.Simple as HTTP
+import qualified Network.HTTP.Types as HTTP (statusCode)
 import Pinafore.Language
 import Pinafore.Language.API
 import Pinafore.WebAPI.Fetch
@@ -202,6 +204,10 @@ importOpenAPI t = do
         case fromJSON jsonval of
             Error err -> liftInner $ FailureResult $ pack err
             Success val -> return val
+    server <-
+        case _openApiServers root of
+            (s:_) -> return $ _serverUrl s
+            [] -> liftInner $ FailureResult "no servers"
     let
         operations :: [(Operation, Text, Text)]
         operations = do
@@ -214,9 +220,9 @@ importOpenAPI t = do
             let lookupResponse code = InsOrd.lookup code $ _responsesResponses $ _operationResponses op
             responseref <-
                 maybeToM "no default response" $ lookupResponse 200 <|> lookupResponse 201 <|> lookupResponse 204
-            response <- getReferenced _componentsResponses responseref
+            responseT <- getReferenced _componentsResponses responseref
             rjt <-
-                case InsOrd.lookup "application/json" $ _responseContent response of
+                case InsOrd.lookup "application/json" $ _responseContent responseT of
                     Just mto -> do
                         rschemaref <- maybeToM "no response schema" $ _mediaTypeObjectSchema mto
                         rschema <- getReferenced _componentsSchemas rschemaref
@@ -226,7 +232,18 @@ importOpenAPI t = do
             func <- mkFunc (actionShimWit responseType) params
             let
                 call :: Object -> IO Value
-                call _ = return $ String $ opname <> " " <> path
+                call obj = do
+                    plainRequest <- HTTP.parseRequest $ unpack $ server <> path
+                    let
+                        request :: HTTP.Request
+                        request = HTTP.setRequestBodyJSON obj $ HTTP.setRequestMethod (encodeUtf8 opname) plainRequest
+                    response <- HTTP.httpJSON request
+                    case HTTP.statusCode $ HTTP.getResponseStatus response of
+                        200 -> return ()
+                        201 -> return ()
+                        204 -> return ()
+                        i -> fail $ "bad status: " <> show i
+                    return $ HTTP.getResponseBody response
             return $
                 case func of
                     MkFunc qt f ->

diff --git a/Pinafore/pinafore-webapi/package.yaml b/Pinafore/pinafore-webapi/package.yaml
@@ -13,6 +13,8 @@ library:
       - network-uri
       - scientific
       - aeson
+      - http-types
+      - http-conduit
       - openapi3
       - shapes
       - polar-shim

diff --git a/Pinafore/pinafore-webapi/pinafore-webapi.cabal b/Pinafore/pinafore-webapi/pinafore-webapi.cabal
@@ -54,6 +54,8 @@ library
   build-depends:
       aeson
     , base >=4.16
+    , http-conduit
+    , http-types
     , insert-ordered-containers
     , network-uri
     , openapi3

diff --git a/Pinafore/pinafore-webapi/test/Main.hs b/Pinafore/pinafore-webapi/test/Main.hs
@@ -15,7 +15,7 @@ testSchema =
         sctext :: [Text] <-
             testerLiftInterpreter $
             -- https://github.com/OAI/OpenAPI-Specification/blob/main/examples/v3.0/petstore-expanded.json
-            parseValueUnify "import openapi \"file:test/schema/petstore-expanded.json\" in functions.Info."
+            parseValueUnify "import openapi \"file:test/schema/petstore-expanded.json\" in servers.Info."
         liftIO $ assertEqual "" [] sctext
 
 tests :: [TestTree]