|
| 1 | +{-# LANGUAGE AllowAmbiguousTypes #-} |
| 2 | +{-# LANGUAGE BlockArguments #-} |
| 3 | +{-# LANGUAGE DataKinds #-} |
| 4 | +{-# LANGUAGE DeriveAnyClass #-} |
| 5 | +{-# LANGUAGE DeriveGeneric #-} |
| 6 | +{-# LANGUAGE DuplicateRecordFields #-} |
| 7 | +{-# LANGUAGE FlexibleContexts #-} |
| 8 | +{-# LANGUAGE FlexibleInstances #-} |
| 9 | +{-# LANGUAGE MonoLocalBinds #-} |
| 10 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 11 | +{-# LANGUAGE OverloadedRecordDot #-} |
| 12 | +{-# LANGUAGE OverloadedStrings #-} |
| 13 | +{-# LANGUAGE RankNTypes #-} |
| 14 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 15 | +{-# LANGUAGE TypeApplications #-} |
| 16 | +{-# LANGUAGE TypeOperators #-} |
| 17 | +{-# OPTIONS_GHC -Wno-name-shadowing #-} |
| 18 | +{-# OPTIONS_GHC -Wno-orphans #-} |
| 19 | + |
| 20 | +module Api.Spec where |
| 21 | + |
| 22 | +import Cardano.Api |
| 23 | +import Cardano.Kuber.Api |
| 24 | +import Cardano.Kuber.Data.Models |
| 25 | +import qualified Data.Aeson as A |
| 26 | +import Data.ByteString (toStrict) |
| 27 | +import qualified Data.ByteString.Char8 as BS |
| 28 | +import qualified Data.ByteString.Lazy as BSL |
| 29 | +import Data.Maybe |
| 30 | +import Data.String |
| 31 | +import qualified Data.Text as T hiding (map) |
| 32 | +import GHC.Generics |
| 33 | +import Network.HTTP.Types (status201, status400) |
| 34 | +import Network.Wai |
| 35 | +import Network.Wai.Middleware.Cors |
| 36 | +import Network.Wai.Middleware.Rewrite |
| 37 | +import Network.Wai.Middleware.Static |
| 38 | +import Servant |
| 39 | +import Servant.Exception |
| 40 | +import Websocket.Aeson |
| 41 | +import Websocket.Commands |
| 42 | +import Websocket.Middleware |
| 43 | +import Websocket.TxBuilder (hydraProtocolParams, queryUTxO, toValidHydraTxBuilder) |
| 44 | +import Websocket.Utils |
| 45 | + |
| 46 | +-- Define CORS policy |
| 47 | +corsMiddlewarePolicy :: CorsResourcePolicy |
| 48 | +corsMiddlewarePolicy = |
| 49 | + CorsResourcePolicy |
| 50 | + { corsOrigins = Nothing, |
| 51 | + corsMethods = [BS.pack "GET", BS.pack "POST", BS.pack "OPTIONS"], |
| 52 | + corsRequestHeaders = [fromString "content-type", fromString "api-key"], |
| 53 | + corsExposedHeaders = Nothing, |
| 54 | + corsMaxAge = Just 3600, |
| 55 | + corsVaryOrigin = True, |
| 56 | + corsRequireOrigin = False, |
| 57 | + corsIgnoreFailures = True |
| 58 | + } |
| 59 | + |
| 60 | +newtype ResponseMessage = ResponseMessage |
| 61 | + { result :: String |
| 62 | + } |
| 63 | + deriving (Show, Generic) |
| 64 | + |
| 65 | +instance ToJSON ResponseMessage |
| 66 | + |
| 67 | +data CommitUTxOs = CommitUTxOs |
| 68 | + { utxos :: [TxIn], |
| 69 | + signKey :: Maybe A.Value |
| 70 | + } |
| 71 | + deriving (Show, Generic, FromJSON, ToJSON) |
| 72 | + |
| 73 | +instance ToServantErr FrameworkError where |
| 74 | + status (FrameworkError _ _) = status400 |
| 75 | + status (FrameworkErrors _) = status400 |
| 76 | + |
| 77 | +instance MimeRender PlainText FrameworkError where |
| 78 | + mimeRender ct = mimeRender ct . show |
| 79 | + |
| 80 | +type GetResp = UVerb 'GET '[JSON] UVerbResponseTypes |
| 81 | + |
| 82 | +type PostResp = UVerb 'POST '[JSON] UVerbResponseTypes |
| 83 | + |
| 84 | +type WithWait sub = QueryParam "wait" Bool :> sub |
| 85 | + |
| 86 | +type WithSubmit sub = QueryParam "submit" Bool :> sub |
| 87 | + |
| 88 | +type API = |
| 89 | + "hydra" :> HydraCommandAPI |
| 90 | + :<|> "hydra" :> "query" :> HydraQueryAPI |
| 91 | + |
| 92 | +type HydraCommandAPI = |
| 93 | + "init" :> WithWait PostResp |
| 94 | + :<|> "abort" :> WithWait PostResp |
| 95 | + :<|> "commit" :> WithSubmit (ReqBody '[JSON] CommitUTxOs :> PostResp) |
| 96 | + :<|> "decommit" :> WithSubmit (WithWait (ReqBody '[JSON] CommitUTxOs :> PostResp)) |
| 97 | + :<|> "close" :> WithWait PostResp |
| 98 | + :<|> "contest" :> WithWait PostResp |
| 99 | + :<|> "fanout" :> WithWait PostResp |
| 100 | + :<|> "tx" :> WithSubmit (ReqBody '[JSON] TxBuilder :> Post '[JSON] TxModal) |
| 101 | + :<|> "submit" :> ReqBody '[JSON] TxModal :> PostResp |
| 102 | + |
| 103 | +type HydraQueryAPI = |
| 104 | + "utxo" :> QueryParams "address" T.Text :> QueryParams "txin" T.Text :> GetResp |
| 105 | + :<|> "protocol-parameters" :> GetResp |
| 106 | + :<|> "state" :> GetResp |
| 107 | + |
| 108 | +frameworkErrorHandler valueOrFe = case valueOrFe of |
| 109 | + Left fe -> throwError $ err500 {errBody = BSL.fromStrict $ prettyPrintJSON fe} |
| 110 | + Right val -> respond $ WithStatus @200 val |
| 111 | + |
| 112 | +toServerError :: FrameworkError -> Handler a |
| 113 | +toServerError err = |
| 114 | + throwError $ |
| 115 | + err500 {errBody = BSL.fromStrict $ prettyPrintJSON err} |
| 116 | + |
| 117 | +hydraErrorHandler (msg, status) = do |
| 118 | + let jsonResponseOrError = textToJSON msg |
| 119 | + case jsonResponseOrError of |
| 120 | + Left fe -> toServerError fe |
| 121 | + Right jsonResponse -> |
| 122 | + case status of |
| 123 | + 200 -> respond $ WithStatus @200 jsonResponse |
| 124 | + 201 -> respond $ WithStatus @201 jsonResponse |
| 125 | + _ -> |
| 126 | + throwError $ |
| 127 | + (errorMiddleware status) |
| 128 | + { errHTTPCode = status, |
| 129 | + errReasonPhrase = "", |
| 130 | + errBody = A.encode jsonResponse, |
| 131 | + errHeaders = [("Content-Type", "application/json")] |
| 132 | + } |
| 133 | + |
| 134 | +-- Define Handlers |
| 135 | +server appConfig = |
| 136 | + commandServer appConfig |
| 137 | + :<|> queryServer appConfig |
| 138 | + where |
| 139 | + -- Commands: POSTs and state-changing GETs |
| 140 | + commandServer :: AppConfig -> Server HydraCommandAPI |
| 141 | + commandServer appConfig = |
| 142 | + initHandler appConfig |
| 143 | + :<|> abortHandler appConfig |
| 144 | + :<|> commitHandler appConfig |
| 145 | + :<|> decommitHandler appConfig |
| 146 | + :<|> closeHandler appConfig |
| 147 | + :<|> contestHandler appConfig |
| 148 | + :<|> fanoutHandler appConfig |
| 149 | + :<|> txHandler appConfig |
| 150 | + :<|> submitHandler appConfig |
| 151 | + -- Queries: GET-only, read-only endpoints |
| 152 | + queryServer :: AppConfig -> Server HydraQueryAPI |
| 153 | + queryServer appConfig = |
| 154 | + queryUtxoHandler appConfig |
| 155 | + :<|> queryProtocolParameterHandler appConfig |
| 156 | + :<|> queryStateHandler appConfig |
| 157 | + |
| 158 | +initHandler :: AppConfig -> Maybe Bool -> Handler (Union UVerbResponseTypes) |
| 159 | +initHandler appConfig wait = do |
| 160 | + initResponse <- liftIO $ initialize appConfig (fromMaybe False wait) |
| 161 | + hydraErrorHandler initResponse |
| 162 | + |
| 163 | +abortHandler :: AppConfig -> Maybe Bool -> Handler (Union UVerbResponseTypes) |
| 164 | +abortHandler appConfig wait = do |
| 165 | + abortResponse <- liftIO $ abort appConfig (fromMaybe False wait) |
| 166 | + hydraErrorHandler abortResponse |
| 167 | + |
| 168 | +queryUtxoHandler :: AppConfig -> [T.Text] -> [T.Text] -> Handler (Union UVerbResponseTypes) |
| 169 | +queryUtxoHandler appConfig address txin = do |
| 170 | + parsedTxIns <- liftIO $ listOfTextToTxIn txin |
| 171 | + parsedAddresses <- liftIO $ listOfTextToAddressInEra address |
| 172 | + eitherErrorOrUTxOs <- case parsedTxIns of |
| 173 | + Left fe -> pure $ Left fe |
| 174 | + Right txins -> case parsedAddresses of |
| 175 | + Left fe -> pure $ Left fe |
| 176 | + Right address' -> do |
| 177 | + queryUtxoResponse <- liftIO $ queryUTxO appConfig address' txins |
| 178 | + case queryUtxoResponse of |
| 179 | + Left fe -> pure $ Left fe |
| 180 | + Right utxos -> case bytestringToJSON $ BSL.fromStrict $ serialiseToJSON utxos of |
| 181 | + Left fe' -> pure $ Left fe' |
| 182 | + Right json -> pure $ Right json |
| 183 | + frameworkErrorHandler eitherErrorOrUTxOs |
| 184 | + |
| 185 | +commitHandler :: AppConfig -> Maybe Bool -> CommitUTxOs -> Handler (Union UVerbResponseTypes) |
| 186 | +commitHandler appConfig submit commits = do |
| 187 | + commitResult <- liftIO $ commitUTxO appConfig commits.utxos (signKey commits) (fromMaybe False submit) |
| 188 | + commitResultToJSON <- case commitResult of |
| 189 | + Left fe -> pure $ Left fe |
| 190 | + Right res -> |
| 191 | + case bytestringToJSON $ A.encode res of |
| 192 | + Left fe -> pure $ Left fe |
| 193 | + Right val -> pure $ Right val |
| 194 | + frameworkErrorHandler commitResultToJSON |
| 195 | + |
| 196 | +decommitHandler :: AppConfig -> Maybe Bool -> Maybe Bool -> CommitUTxOs -> Handler (Union UVerbResponseTypes) |
| 197 | +decommitHandler appConfig submit wait decommits = do |
| 198 | + decommitResult <- liftIO $ decommitUTxO appConfig decommits.utxos (signKey decommits) (fromMaybe False wait) (fromMaybe False submit) |
| 199 | + frameworkErrorHandler decommitResult |
| 200 | + |
| 201 | +closeHandler :: AppConfig -> Maybe Bool -> Handler (Union UVerbResponseTypes) |
| 202 | +closeHandler appConfig wait = do |
| 203 | + closeResponse <- liftIO $ close appConfig (fromMaybe False wait) |
| 204 | + hydraErrorHandler closeResponse |
| 205 | + |
| 206 | +contestHandler :: AppConfig -> Maybe Bool -> Handler (Union UVerbResponseTypes) |
| 207 | +contestHandler appConfig wait = do |
| 208 | + closeResponse <- liftIO $ contest appConfig (fromMaybe False wait) |
| 209 | + hydraErrorHandler closeResponse |
| 210 | + |
| 211 | +fanoutHandler :: AppConfig -> Maybe Bool -> Handler (Union UVerbResponseTypes) |
| 212 | +fanoutHandler appConfig wait = do |
| 213 | + fanoutResponse <- liftIO $ fanout appConfig (fromMaybe False wait) |
| 214 | + hydraErrorHandler fanoutResponse |
| 215 | + |
| 216 | +queryProtocolParameterHandler :: AppConfig -> Handler (Union UVerbResponseTypes) |
| 217 | +queryProtocolParameterHandler appConfig = do |
| 218 | + pParamResponse <- liftIO (hydraProtocolParams appConfig :: IO (Either FrameworkError HydraProtocolParameters)) |
| 219 | + pParamsToJSON <- case pParamResponse of |
| 220 | + Left fe -> pure $ Left fe |
| 221 | + Right pparams -> case bytestringToJSON $ A.encode pparams of |
| 222 | + Left fe -> pure $ Left fe |
| 223 | + Right val -> pure $ Right val |
| 224 | + frameworkErrorHandler pParamsToJSON |
| 225 | + |
| 226 | +queryStateHandler :: AppConfig -> Handler (Union UVerbResponseTypes) |
| 227 | +queryStateHandler appConfig = do |
| 228 | + stateResponse <- liftIO $ getHydraState appConfig |
| 229 | + stateResponseJSON <- case stateResponse of |
| 230 | + Left fe -> pure $ Left fe |
| 231 | + Right stateInfo -> case bytestringToJSON $ A.encode stateInfo of |
| 232 | + Left fe -> pure $ Left fe |
| 233 | + Right val -> pure $ Right val |
| 234 | + frameworkErrorHandler stateResponseJSON |
| 235 | + |
| 236 | +txHandler :: AppConfig -> Maybe Bool -> TxBuilder_ ConwayEra -> Handler TxModal |
| 237 | +txHandler appConfig submit txb = do |
| 238 | + hydraTxModal <- liftIO $ toValidHydraTxBuilder appConfig txb (fromMaybe False submit) |
| 239 | + case hydraTxModal of |
| 240 | + Left fe -> toServerError fe |
| 241 | + Right txm -> pure txm |
| 242 | + |
| 243 | +submitHandler :: AppConfig -> TxModal -> Handler (Union UVerbResponseTypes) |
| 244 | +submitHandler appConfig txm = do |
| 245 | + submitResponse <- liftIO $ submit appConfig txm |
| 246 | + hydraErrorHandler submitResponse |
| 247 | + |
| 248 | +-- Create API Proxy |
| 249 | +deployAPI :: Proxy API |
| 250 | +deployAPI = Proxy |
| 251 | + |
| 252 | +-- Define Hydra application |
| 253 | +hydraApp :: AppConfig -> Application |
| 254 | +hydraApp appConfig = rewriteRoot (T.pack "index.html") $ static $ cors (const $ Just corsMiddlewarePolicy) $ serve deployAPI (server appConfig) |
0 commit comments