add haskell-http-client-generator (#6429)

samples/client/petstore/haskell-http-client/example-app/Main.hs

@@ -0,0 +1,233 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-binds -fno-warn-orphans #-}
+
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy.Char8 as BCL
+import qualified Data.Text as T
+import qualified Data.Time as TI
+import qualified Lens.Micro as L
+import qualified Network.HTTP.Client as NH
+
+import qualified SwaggerPetstore as S
+
+import Data.Monoid ((<>))
+
+-- * MAIN
+
+main :: IO ()
+main = do
+
+  mgr <- NH.newManager NH.defaultManagerSettings
+
+  -- print log messages to sdtout
+  let config =
+        S.withStdoutLogging
+          S.newConfig { S.configHost = "http://0.0.0.0/v2"
+                      -- , S.configLoggingFilter = S.debugLevelFilter
+                      }
+
+  putStrLn "******** CONFIG ********"
+  putStrLn (show config)
+
+  putStrLn "******** Pet operations ********"
+  runPet mgr config
+
+  putStrLn "******** Store operations ********"
+  runStore mgr config
+
+  putStrLn "******** User operations ********"
+  runUser mgr config
+
+  putStrLn "******** END ********"
+
+  return ()
+
+
+-- * PET
+
+runPet :: NH.Manager -> S.SwaggerPetstoreConfig -> IO ()
+runPet mgr config = do
+
+  -- create the request for addPet, encoded with content-type application/json
+  let addPetRequest = S.addPet S.MimeJSON (S.mkPet "name" ["url1", "url2"])
+
+  -- send the rquest with accept header application/json
+  -- dispatchLbs simply returns the raw Network.HTTP.Client.Response ByteString
+  addPetResponse <- S.dispatchLbs mgr config addPetRequest S.MimeJSON
+
+  -- the Consumes & Produces typeclasses control which 'content-type'
+  -- and 'accept' encodings are allowed for each operation
+  -- -- No instance for (S.Produces S.AddPet S.MimePlainText)
+  -- addPetResponse <- S.dispatchLbs mgr config addPetRequest S.MimePlainText
+
+  -- inspect the AddPet type to see typeclasses indicating wihch
+  -- content-type and accept types (mimeTypes) are valid
+
+  -- :i S.AddPet
+    -- data S.AddPet 	-- Defined in ‘SwaggerPetstore.API’
+    -- instance S.Produces S.AddPet S.MimeXML
+    --   -- Defined in ‘SwaggerPetstore.API’
+    -- instance S.Produces S.AddPet S.MimeJSON
+    --   -- Defined in ‘SwaggerPetstore.API’
+    -- instance S.Consumes S.AddPet S.MimeXML
+    --   -- Defined in ‘SwaggerPetstore.API’
+    -- instance S.Consumes S.AddPet S.MimeJSON
+    --   -- Defined in ‘SwaggerPetstore.API’
+    -- instance S.HasBodyParam S.AddPet S.Pet
+    --   -- Defined in ‘SwaggerPetstore.API’
+
+  
+  -- since this swagger definition has no response schema defined for
+  -- the 'addPet' response, we decode the response bytestring manually
+  case A.eitherDecode (NH.responseBody addPetResponse) of
+    Right pet@S.Pet { S.petId = Just pid } -> do
+
+        -- create the request for getPetById
+        let getPetByIdRequest = S.getPetById pid
+
+        -- dispatchMime returns MimeResult, which includes the
+        -- expected decoded model object 'Pet', or a parse failure
+        getPetByIdRequestResult <- S.dispatchMime mgr config getPetByIdRequest S.MimeJSON
+        case S.mimeResult getPetByIdRequestResult of
+          Left (S.MimeError _ _) -> return () -- parse error, already displayed in the log
+          Right r -> putStrLn $ "getPetById: found pet: " <> show r  -- display 'Pet' model object, r 
+
+        -- findPetsByStatus
+        let findPetsByStatusRequest = S.findPetsByStatus ["available","pending","sold"]
+        findPetsByStatusResult <- S.dispatchMime mgr config findPetsByStatusRequest S.MimeJSON
+        mapM_ (\r -> putStrLn $ "findPetsByStatus: found " <> (show . length) r <> " pets") findPetsByStatusResult 
+
+        -- findPetsByTags
+        let findPetsByTagsRequest = S.findPetsByTags ["name","tag1"]
+        findPetsByTagsResult <- S.dispatchMime mgr config findPetsByTagsRequest S.MimeJSON
+        mapM_ (\r -> putStrLn $ "findPetsByTags: found " <> (show . length) r <> " pets") findPetsByTagsResult 
+
+        -- updatePet
+        let updatePetRequest = S.updatePet S.MimeJSON $ pet
+                { S.petStatus   = Just "available"
+                , S.petCategory = Just (S.Category (Just 3) (Just "catname"))
+                }
+        _ <- S.dispatchLbs mgr config updatePetRequest S.MimeXML
+
+        -- requred parameters are included as function arguments, optional parameters are included with applyOptionalParam
+        -- inspect the UpdatePetWithForm type to see typeclasses indicating optional paramteters (:i S.UpdatePetWithForm)
+        -- instance S.HasOptionalParam S.UpdatePetWithForm S.Name
+        --   -- Defined in ‘SwaggerPetstore.API’
+        -- instance S.HasOptionalParam S.UpdatePetWithForm S.Status
+        --   -- Defined in ‘SwaggerPetstore.API’
+        let updatePetWithFormRequest = S.updatePetWithForm S.MimeFormUrlEncoded pid
+                `S.applyOptionalParam` S.Name "petName"
+                `S.applyOptionalParam` S.Status "pending"
+        _ <- S.dispatchLbs mgr config updatePetWithFormRequest S.MimeJSON
+
+        -- multipart/form-data file uploads are just a different content-type
+        let uploadFileRequest = S.uploadFile S.MimeMultipartFormData pid
+                `S.applyOptionalParam` S.File "package.yaml" -- the file contents of the path are read when dispatched
+                `S.applyOptionalParam` S.AdditionalMetadata "a package.yaml file"
+        uploadFileRequestResult <- S.dispatchMime mgr config uploadFileRequest S.MimeJSON
+        mapM_ (\r -> putStrLn $ "uploadFile: " <> show r) uploadFileRequestResult 
+
+        -- deletePet
+        let deletePetRequest = S.deletePet pid
+                `S.applyOptionalParam` S.ApiUnderscorekey "api key"
+        _ <- S.dispatchLbs mgr config deletePetRequest S.MimeJSON
+
+        return ()
+
+    Left e -> putStrLn e
+    _ -> putStrLn "no Pet id returned"
+
+  return ()
+
+
+
+-- * STORE
+  
+-- declare that 'placeOrder' can recieve a JSON content-type request
+instance S.Consumes S.PlaceOrder S.MimeJSON 
+
+runStore :: NH.Manager -> S.SwaggerPetstoreConfig -> IO ()
+runStore mgr config = do
+
+  -- we can set arbitrary headers with setHeader
+  let getInventoryRequest = S.getInventory
+        `S.setHeader` [("api_key","special-key")] 
+  getInventoryRequestRequestResult <- S.dispatchMime mgr config getInventoryRequest S.MimeJSON
+  mapM_ (\r -> putStrLn $ "getInventoryRequest: found " <> (show . length) r <> " results") getInventoryRequestRequestResult
+
+  -- placeOrder
+  now <- TI.getCurrentTime
+  let placeOrderRequest = S.placeOrder S.MimeJSON (S.mkOrder { S.orderId = Just 21, S.orderQuantity = Just 210, S.orderShipDate = Just now})
+  placeOrderResult <- S.dispatchMime mgr config placeOrderRequest S.MimeJSON
+  mapM_ (\r -> putStrLn $ "placeOrderResult: " <> show r) placeOrderResult
+
+  let orderId = maybe 10 id $ either (const Nothing) (S.orderId) (S.mimeResult placeOrderResult)
+
+  -- getOrderByid
+  let getOrderByIdRequest = S.getOrderById orderId
+  getOrderByIdRequestResult <- S.dispatchMime mgr config getOrderByIdRequest S.MimeJSON
+  mapM_ (\r -> putStrLn $ "getOrderById: found order: " <> show r) getOrderByIdRequestResult 
+
+  -- deleteOrder
+  let deleteOrderRequest = S.deleteOrder "21"
+  _ <- S.dispatchLbs mgr config deleteOrderRequest S.MimeJSON
+
+  return ()
+
+
+
+-- * USER
+
+-- this swagger definition doesn't declare what content-type the
+-- server actually expects for these operations, so delcare it here
+instance S.Consumes S.CreateUser S.MimeJSON
+instance S.Consumes S.UpdateUser S.MimeJSON
+instance S.Consumes S.CreateUsersWithArrayInput S.MimeJSON
+instance S.Consumes S.CreateUsersWithListInput S.MimeJSON
+
+-- similarly we declare these operations are allowed to omit the
+-- accept header despite what the swagger definition says
+instance S.Produces S.CreateUsersWithArrayInput S.MimeNoContent
+instance S.Produces S.CreateUsersWithListInput S.MimeNoContent
+
+runUser :: NH.Manager -> S.SwaggerPetstoreConfig -> IO ()
+runUser mgr config = do
+
+  let username = "hsusername"
+  -- createUser
+  let user = S.mkUser { S.userId = Just 21, S.userUsername = Just username } 
+  let createUserRequest = S.createUser S.MimeJSON user
+  _ <- S.dispatchLbs mgr config createUserRequest S.MimeJSON
+
+  -- can use traversals or lenses (model record names are appended with T or L) to view or modify records
+  let users = take 8 $ drop 1 $ iterate (L.over S.userUsernameT (<> "*") . L.over S.userIdT (+1)) user
+  let createUsersWithArrayInputRequest = S.createUsersWithArrayInput S.MimeJSON users
+  _ <- S.dispatchLbs mgr config createUsersWithArrayInputRequest S.MimeNoContent
+
+  -- createUsersWithArrayInput
+  let createUsersWithListInputRequest = S.createUsersWithListInput S.MimeJSON users
+  _ <- S.dispatchLbs mgr config createUsersWithListInputRequest S.MimeNoContent
+
+  -- getUserByName
+  let getUserByNameRequest = S.getUserByName username
+  getUserByNameResult <- S.dispatchMime mgr config getUserByNameRequest S.MimeJSON
+  mapM_ (\r -> putStrLn $ "getUserByName: found user: " <> show r) getUserByNameResult 
+
+  -- loginUser
+  let loginUserRequest = S.loginUser username "password1"
+  loginUserResult <- S.dispatchLbs mgr config loginUserRequest S.MimeJSON
+  BCL.putStrLn $ "loginUser: " <> (NH.responseBody loginUserResult)
+
+  -- updateUser
+  let updateUserRequest = S.updateUser S.MimeJSON username (user { S.userEmail = Just "xyz@example.com" })
+  _ <- S.dispatchLbs mgr config updateUserRequest S.MimeJSON
+
+  -- logoutUser
+  _ <- S.dispatchLbs mgr config S.logoutUser S.MimeJSON
+  
+  -- deleteUser
+  let deleteUserRequest = S.deleteUser username
+  _ <- S.dispatchLbs mgr config deleteUserRequest S.MimeJSON
+
+  return ()