Adding the /version endpoints back into the playground servers.

This were lost in a recent reorganisation for AWS lambda, but they're still useful.
IntersectMBO · Oct 20, 2020 · e43b8d2 · e43b8d2
1 parent 95517ac
commit e43b8d2
Show file tree

Hide file tree

Showing 3 changed files with 19 additions and 8 deletions.
diff --git a/marlowe-playground-server/src/API.hs b/marlowe-playground-server/src/API.hs
@@ -6,11 +6,13 @@ module API where
 
 import qualified Auth
 import           Data.Aeson                                       (FromJSON, ToJSON)
+import           Data.Text                                        (Text)
 import           GHC.Generics                                     (Generic)
 import qualified Language.Marlowe.ACTUS.Definitions.ContractTerms as CT
-import           Servant.API                                      ((:<|>), (:>), Get, Header, JSON, NoContent, Post,
-                                                                   Raw, ReqBody)
+import           Servant.API                                      ((:<|>), (:>), Get, Header, JSON, NoContent,
+                                                                   PlainText, Post, Raw, ReqBody)
 
-type API =
-  "actus" :> "generate" :> ReqBody '[JSON] CT.ContractTerms :> Post '[JSON] String
-    :<|> "actus" :> "generate-static" :> ReqBody '[JSON] CT.ContractTerms :> Post '[JSON] String
+type API
+     = "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
@@ -23,6 +23,7 @@ import           Data.Aeson                                       (ToJSON, eithe
 import           Data.Proxy                                       (Proxy (Proxy))
 import           Data.Text                                        (Text)
 import qualified Data.Text                                        as Text
+import           Git                                              (gitRev)
 import           Language.Marlowe.ACTUS.Definitions.ContractTerms (ContractTerms)
 import           Language.Marlowe.ACTUS.Generator                 (genFsContract, genStaticContract)
 import           Language.Marlowe.Pretty                          (pretty)
@@ -56,8 +57,11 @@ mkHandlers AppConfig {..} = do
   githubEndpoints <- liftIO Auth.mkGithubEndpoints
   pure (mhandlers :<|> liftedAuthServer githubEndpoints authConfig)
 
+version :: Applicative m => m Text
+version = pure gitRev
+
 mhandlers :: Server API
-mhandlers = genActusContract :<|> genActusContractStatic
+mhandlers = version :<|> genActusContract :<|> genActusContractStatic
 
 app :: Server Web -> Application
 app handlers =

diff --git a/plutus-playground-server/src/Playground/Server.hs b/plutus-playground-server/src/Playground/Server.hs
@@ -23,6 +23,7 @@ import           Data.Proxy                   (Proxy (Proxy))
 import           Data.Text                    (Text)
 import qualified Data.Text                    as Text
 import           Data.Time.Units              (Second)
+import           Git                          (gitRev)
 import           Language.Haskell.Interpreter (InterpreterError (CompilationErrors), InterpreterResult, SourceCode)
 import qualified Language.Haskell.Interpreter as Interpreter
 import           Network.HTTP.Client.Conduit  (defaultManagerSettings)
@@ -32,19 +33,23 @@ import qualified Playground.Interpreter       as PI
 import           Playground.Types             (CompilationResult, Evaluation, EvaluationResult, PlaygroundError)
 import           Playground.Usecases          (vesting)
 import           Servant                      (Application, err400, errBody, hoistServer, serve)
-import           Servant.API                  ((:<|>) ((:<|>)), (:>), Get, JSON, Post, ReqBody)
+import           Servant.API                  ((:<|>) ((:<|>)), (:>), Get, JSON, PlainText, Post, ReqBody)
 import           Servant.Client               (ClientEnv, mkClientEnv, parseBaseUrl)
 import           Servant.Server               (Handler (Handler), Server, ServerError)
 import           System.Environment           (lookupEnv)
 import qualified Web.JWT                      as JWT
 
 type API
      = "contract" :> ReqBody '[ JSON] SourceCode :> Post '[ JSON] (Either Interpreter.InterpreterError (InterpreterResult CompilationResult))
+       :<|> "version" :> Get '[PlainText, JSON] Text
        :<|> "evaluate" :> ReqBody '[ JSON] Evaluation :> Post '[ JSON] (Either PlaygroundError EvaluationResult)
        :<|> "health" :> Get '[ JSON] ()
 
 type Web = "api" :> (API :<|> Auth.API)
 
+version :: Applicative m => m Text
+version = pure gitRev
+
 maxInterpretationTime :: Second
 maxInterpretationTime = 80
 
@@ -88,7 +93,7 @@ mkHandlers :: MonadIO m => AppConfig -> m (Server Web)
 mkHandlers AppConfig {..} = do
     liftIO $ putStrLn "Interpreter ready"
     githubEndpoints <- liftIO Auth.mkGithubEndpoints
-    pure $ (compileSourceCode clientEnv :<|> evaluateSimulation clientEnv :<|> checkHealth clientEnv) :<|> liftedAuthServer githubEndpoints authConfig
+    pure $ (compileSourceCode clientEnv :<|> version :<|> evaluateSimulation clientEnv :<|> checkHealth clientEnv) :<|> liftedAuthServer githubEndpoints authConfig
 
 app :: Server Web -> Application
 app handlers =