Generate API calls

IntersectMBO · Oct 27, 2020 · 9829271 · 9829271
1 parent 4f160e7
commit 9829271
Show file tree

Hide file tree

Showing 4 changed files with 23 additions and 51 deletions.
diff --git a/marlowe-playground-client/src/Simulation.purs b/marlowe-playground-client/src/Simulation.purs
@@ -1,5 +1,6 @@
 module Simulation where
 
+import API (OracleResponse(..))
 import Data.HTTP.Method as HTTP
 import Foreign.Class as F
 import Control.Alternative (map, void, when, (<|>))
@@ -141,7 +142,6 @@ handleAction settings (LoadScript key) = do
 handleAction settings (SetEditorText contents) = do
   editorSetValue contents
   updateContractInState contents
-  setOraclePrice settings
 
 handleAction settings StartSimulation = do
   assign (_currentMarloweState <<< _executionState) (Just $ emptyExecutionStateWithSlot zero)
@@ -301,56 +301,19 @@ setOraclePrice settings = do
 
 getPrice :: forall m. MonadAff m => SPSettings_ SPParams_ -> String -> String -> HalogenM State Action ChildSlots Void m BigInteger
 getPrice settings exchange pair = do
-  result <- runAjax (getPriceAjax settings exchange pair)
+  result <- runAjax (runReaderT (Server.getApiOracleByExchangeByPair exchange pair) settings)
   a <-
     liftEffect case result of
-      NotAsked -> do
-        log "NotAsked"
-        pure 0.0
-      Loading -> do
-        log "Loading"
-        pure 0.0
+      NotAsked -> pure "0"
+      Loading -> pure "0"
       Failure e -> do
         log $ "Failure" <> errorToString e
-        pure 0.0
-      Success a -> pure a.price
+        pure "0"
+      Success (OracleResponse a) -> pure a.price
   let
-    price = fromMaybe (fromInt 0) (fromString (show (floor a)))
+    price = fromMaybe zero (fromString a)
   pure price
 
-getPriceAjax ::
-  forall m.
-  MonadError AjaxError m =>
-  MonadAff m =>
-  (SPSettings_ SPParams_) -> String -> String -> m { price :: Number }
-getPriceAjax settings exchange pair = do
-  let
-    spParams_ = view (_params <<< _Newtype) settings
-
-    encodeOptions = view _encodeJson settings
-
-    decodeOptions = view _decodeJson settings
-
-    baseURL = spParams_.baseURL
-
-    httpMethod = HTTP.fromString "GET"
-
-    queryString = ""
-
-    reqUrl = baseURL <> "api/oracle/" <> exchange <> "/" <> pair
-
-    reqHeaders = []
-
-    affReq =
-      defaultRequest
-        { method = httpMethod
-        , url = reqUrl
-        , headers = defaultRequest.headers <> reqHeaders
-        , content = Nothing
-        }
-  r <- ajax F.decode affReq
-  pure r.body
-
 getCurrentContract :: forall m. HalogenM State Action ChildSlots Void m String
 getCurrentContract = do
   oldContract <- use _oldContract

diff --git a/marlowe-playground-server/app/PSGenerator.hs b/marlowe-playground-server/app/PSGenerator.hs
@@ -167,6 +167,7 @@ myTypes =
     , mkSumType (Proxy @CT.Assertions)
     , mkSumType (Proxy @CT.AssertionContext)
     , mkSumType (Proxy @Webghc.CompileRequest)
+    , mkSumType (Proxy @API.OracleResponse)
     ]
 
 mySettings :: Settings

diff --git a/marlowe-playground-server/src/API.hs b/marlowe-playground-server/src/API.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveGeneric    #-}
+{-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE TypeOperators      #-}
 
 module API where
@@ -12,8 +14,12 @@ import qualified Language.Marlowe.ACTUS.Definitions.ContractTerms as CT
 import           Servant.API                                      ((:<|>), (:>), Capture, Get, Header, JSON, NoContent,
                                                                    PlainText, Post, Raw, ReqBody)
 
+data OracleResponse = OracleResponse { price :: String }
+  deriving (Generic, FromJSON, ToJSON)
+
+
 type API
-     = "oracle" :> Capture "exchange" String :> Capture "pair" String :> Get '[JSON] Value
+     = "oracle" :> Capture "exchange" String :> Capture "pair" String :> Get '[JSON] OracleResponse
        :<|> "version" :> Get '[ PlainText, JSON] Text
        :<|> "actus" :> ("generate" :> ReqBody '[ JSON] CT.ContractTerms :> Post '[ JSON] String
                         :<|> "generate-static" :> ReqBody '[ JSON] CT.ContractTerms :> Post '[ JSON] String)
diff --git a/marlowe-playground-server/src/Server.hs b/marlowe-playground-server/src/Server.hs
@@ -11,19 +11,20 @@
 
 module Server where
 
-import           API                                              (API)
+import           API
 import qualified Auth
 import           Auth.Types                                       (OAuthClientId (OAuthClientId),
                                                                    OAuthClientSecret (OAuthClientSecret))
 import           Control.Monad.Except                             (ExceptT)
 import           Control.Monad.IO.Class                           (MonadIO, liftIO)
 import           Control.Monad.Logger                             (LoggingT, MonadLogger, logInfoN, runStderrLoggingT)
 import           Control.Monad.Reader                             (ReaderT, runReaderT)
-import           Data.Aeson
-import           Data.Aeson                                       (ToJSON, eitherDecode, encode)
+import           GHC.Generics             (Generic)
+import           Data.Aeson                                       as Aeson
+import           Data.Aeson                                       (FromJSON, ToJSON, eitherDecode, encode)
 import qualified Data.HashMap.Strict                              as HM
 import           Data.Proxy                                       (Proxy (Proxy))
-import           Data.String
+import           Data.String                                      as S
 import           Data.Text                                        (Text)
 import qualified Data.Text                                        as Text
 import           Git                                              (gitRev)
@@ -45,7 +46,7 @@ genActusContractStatic :: ContractTerms -> Handler String
 genActusContractStatic = pure . show . pretty . genStaticContract
 
 
-oracle :: MonadIO m => String -> String -> m Value
+oracle :: MonadIO m => String -> String -> m OracleResponse
 oracle exchange pair = do
     response <- liftIO (httpJSON (fromString $ "GET https://api.cryptowat.ch/markets/" <> exchange <> "/" <> pair <> "/price"))
     let result = getResponseBody response :: Value
@@ -56,7 +57,8 @@ oracle exchange pair = do
                 _          -> zero
             _ -> zero
     let normalized = round (price * 100000000) :: Integer
-    pure (object [ "price" .= (Number $ fromInteger normalized) ])
+    -- pure (object [ "price" .= (String $ fromString (show normalized)) ])
+    pure (OracleResponse (show normalized))
 
 
 liftedAuthServer :: Auth.GithubEndpoints -> Auth.Config -> Server Auth.API