OpenAPI (#251): put HTTP code in separate module

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

Hide file tree

Showing 4 changed files with 25 additions and 17 deletions.
diff --git a/Pinafore/pinafore-webapi/lib/Pinafore/WebAPI/HTTP.hs b/Pinafore/pinafore-webapi/lib/Pinafore/WebAPI/HTTP.hs
@@ -0,0 +1,21 @@
+module Pinafore.WebAPI.HTTP
+    ( callHTTP
+    ) where
+
+import Data.Aeson as Aeson
+import Network.HTTP.Simple
+import Network.HTTP.Types (statusCode)
+import Shapes
+
+callHTTP :: Text -> Text -> Value -> IO Value
+callHTTP op uri obj = do
+    plainRequest <- parseRequest $ unpack uri
+    let
+        request :: Request
+        request = setRequestBodyJSON obj $ setRequestMethod (encodeUtf8 op) plainRequest
+    response <- httpJSON request
+    case statusCode $ getResponseStatus response of
+        200 -> return $ getResponseBody response
+        201 -> return $ getResponseBody response
+        204 -> return Null
+        i -> fail $ "failed with HTTP status " <> show i
diff --git a/Pinafore/pinafore-webapi/lib/Pinafore/WebAPI/OpenAPI.hs b/Pinafore/pinafore-webapi/lib/Pinafore/WebAPI/OpenAPI.hs
@@ -9,11 +9,10 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrd
 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
+import Pinafore.WebAPI.HTTP
 import Pinafore.WebAPI.JSONType
 import Pinafore.WebAPI.OpenAPI.Schema
 import Shapes hiding (Param)
@@ -230,20 +229,6 @@ importOpenAPI t = do
                     Nothing -> return NullJSONType
             MkIOShimWit responseType responseF <- mkResponse rjt
             func <- mkFunc (actionShimWit responseType) params
-            let
-                call :: Object -> IO Value
-                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 ->
@@ -253,7 +238,7 @@ importOpenAPI t = do
                             qt $
                         f $ \paramobj ->
                             liftIO $ do
-                                respvalue <- call $ objectFromList paramobj
+                                respvalue <- callHTTP opname (server <> path) $ Object $ objectFromList paramobj
                                 responseF respvalue
     functions <- runM (_openApiComponents root) $ for operations mkOperationFunction
     return $

diff --git a/Pinafore/pinafore-webapi/package.yaml b/Pinafore/pinafore-webapi/package.yaml
@@ -23,6 +23,7 @@ library:
       - Pinafore.WebAPI
     other-modules:
       - Pinafore.WebAPI.JSONType
+      - Pinafore.WebAPI.HTTP
       - Pinafore.WebAPI.Fetch
       - Pinafore.WebAPI.OpenAPI.Schema
       - Pinafore.WebAPI.OpenAPI

diff --git a/Pinafore/pinafore-webapi/pinafore-webapi.cabal b/Pinafore/pinafore-webapi/pinafore-webapi.cabal
@@ -18,6 +18,7 @@ library
       Pinafore.WebAPI
   other-modules:
       Pinafore.WebAPI.JSONType
+      Pinafore.WebAPI.HTTP
       Pinafore.WebAPI.Fetch
       Pinafore.WebAPI.OpenAPI.Schema
       Pinafore.WebAPI.OpenAPI