From e247306cb1ca18632ae347ae8af15f1946789296 Mon Sep 17 00:00:00 2001 From: Alexander Granin Date: Fri, 7 Feb 2020 20:02:33 +0700 Subject: [PATCH] Client with 2 apis to server implemented. --- app/astro/Astro/Client.hs | 85 ++++++++++++++++++++++----------------- app/astro/Astro/Server.hs | 3 ++ app/astro/Main.hs | 5 ++- 3 files changed, 54 insertions(+), 39 deletions(-) diff --git a/app/astro/Astro/Client.hs b/app/astro/Astro/Client.hs index 0f1afcb..28a5b44 100644 --- a/app/astro/Astro/Client.hs +++ b/app/astro/Astro/Client.hs @@ -4,14 +4,16 @@ {-# LANGUAGE DeriveAnyClass #-} module Astro.Client - ( runAstroClient + ( ReportChannel (..) + , runAstroClient ) where import Hydra.Prelude import qualified Data.ByteString.Lazy as BSL import Data.Aeson (decode) import Data.Either (rights) -import Servant.Client (ClientM, ClientError, BaseUrl) +import Servant +import Servant.Client (ClientM, ClientError, BaseUrl(..), Scheme(..), client) import qualified Hydra.Domain as D import qualified Hydra.Runtime as R @@ -27,48 +29,47 @@ import qualified Astro.API as API data TcpConn = DummyTcpConn + +data ReportChannel = TcpChannel | HttpChannel + +data AstroServerHandle = AstroServerHandle + { meteorReporter :: API.MeteorTemplate -> L.AppL (Either BSL.ByteString MeteorId) + , asteroidReporter :: API.AsteroidTemplate -> L.AppL (Either BSL.ByteString AsteroidId) + } + + meteors :: Maybe Int -> Maybe Int -> ClientM Meteors meteor :: API.MeteorTemplate -> ClientM MeteorId asteroid :: API.AsteroidTemplate -> ClientM AsteroidId (meteors :<|> meteor :<|> asteroid) = client Server.astroAPI -meteorHttpReporter :: BaseUrl -> API.MeteorTemplate -> L.AppL (Either String MeteorId) -meteorHttpReporter url m = do - eMId <- L.callAPI url $ meteor m +reportMeteorHttp :: BaseUrl -> API.MeteorTemplate -> L.AppL (Either BSL.ByteString MeteorId) +reportMeteorHttp url m = do + eMId <- L.scenario $ L.callAPI url $ meteor m pure $ case eMId of Left err -> Left $ show err Right r -> Right r -asteroidHttpReporter :: BaseUrl -> API.AsteroidTemplate -> L.AppL (Either String AsteroidId) -asteroidHttpReporter url a = do - eAId <- L.callAPI url $ asteroid a +reportAsteroidHttp :: BaseUrl -> API.AsteroidTemplate -> L.AppL (Either BSL.ByteString AsteroidId) +reportAsteroidHttp url a = do + eAId <- L.scenario $ L.callAPI url $ asteroid a pure $ case eAId of Left err -> Left $ show err Right r -> Right r - -meteorTcpReporter :: TcpConn -> API.MeteorTemplate -> L.AppL (Either String MeteorId) -meteorTcpReporter _ m = do +reportMeteorTcp :: TcpConn -> API.MeteorTemplate -> L.AppL (Either BSL.ByteString MeteorId) +reportMeteorTcp _ m = do L.evalIO $ pure () -- send via tcp here L.logInfo "Meteor sent via TCP (dummy)." - pure 0 + pure $ Right 0 -asteroidTcpReporter :: TcpConn -> API.AsteroidTemplate -> L.AppL (Either String AsteroidId) -asteroidTcpReporter _ a = do +reportAsteroidTcp :: TcpConn -> API.AsteroidTemplate -> L.AppL (Either BSL.ByteString AsteroidId) +reportAsteroidTcp _ a = do L.evalIO $ pure () -- send via tcp here L.logInfo "Asteroid sent via TCP (dummy)." - pure 0 + pure $ Right 0 - - - -reportAsteroid :: API.AsteroidTemplate -> L.AppL () -reportAsteroid asteroid = undefined - -reportMeteor :: API.MeteorTemplate -> L.AppL () -reportMeteor meteor = undefined - tryParseCmd :: FromJSON obj => BSL.ByteString @@ -77,32 +78,42 @@ tryParseCmd str = case decode str of Nothing -> Left "Decoding failed." Just obj -> Right obj -reportObject +reportWith :: FromJSON obj - => (obj -> L.AppL ()) + => (obj -> L.AppL (Either BSL.ByteString res)) -> (Either BSL.ByteString obj) -> L.AppL (Either BSL.ByteString ()) -reportObject reporter obj = undefined +reportWith reporter (Left err) = pure $ Left err +reportWith reporter (Right obj) = reporter obj >> pure (Right ()) -consoleApp :: L.AppL () -consoleApp = do +consoleApp :: AstroServerHandle -> L.AppL () +consoleApp handle@(AstroServerHandle{..}) = do line <- L.evalIO $ BSL.putStr "> " >> BSL.getContents let runners = - [ reportObject asteroidReporter $ tryParseCmd @(API.AsteroidTemplate) line - , reportObject meteorReporter $ tryParseCmd @(API.MeteorTemplate) line + [ reportWith meteorReporter $ tryParseCmd @(API.MeteorTemplate) line + , reportWith asteroidReporter $ tryParseCmd @(API.AsteroidTemplate) line ] - eResult <- sequence runners - case rights eResult of + eResults <- sequence runners + case rights eResults of [] -> L.evalIO $ BSL.putStrLn "Command is not recognized." [()] -> pure () (_) -> L.evalIO $ BSL.putStrLn "Multiple commands evaluated unexpectedly" - consoleApp + consoleApp handle +makeReporters :: ReportChannel -> AstroServerHandle +makeReporters TcpChannel = AstroServerHandle + (reportMeteorTcp DummyTcpConn) + (reportAsteroidTcp DummyTcpConn) +makeReporters HttpChannel = AstroServerHandle + (reportMeteorHttp localhostAstro) + (reportAsteroidHttp localhostAstro) + where + localhostAstro = BaseUrl Http "localhost" 8081 "" -runAstroClient :: IO () -runAstroClient = +runAstroClient :: ReportChannel -> IO () +runAstroClient ch = R.withAppRuntime (Just loggerCfg) - $ \rt -> R.runAppL rt consoleApp + $ \rt -> R.runAppL rt $ consoleApp $ makeReporters ch diff --git a/app/astro/Astro/Server.hs b/app/astro/Astro/Server.hs index f5eb6db..6989bde 100644 --- a/app/astro/Astro/Server.hs +++ b/app/astro/Astro/Server.hs @@ -5,6 +5,7 @@ module Astro.Server ( runAstroServer + , astroAPI ) where import Control.Monad @@ -29,6 +30,7 @@ import qualified Hydra.Language as L import Astro.Common (loggerCfg, dbConfig) import qualified Astro.API as API import Astro.Domain.Meteor +import Astro.Domain.Asteroid import Astro.Catalogue import Astro.Types @@ -84,6 +86,7 @@ astroServer' :: AppServer astroServer' = meteors :<|> meteor + :<|> asteroid meteors :: Maybe Int -> Maybe Int -> AppHandler Meteors meteors mbMass mbSize = runApp diff --git a/app/astro/Main.hs b/app/astro/Main.hs index 456d395..c26b916 100644 --- a/app/astro/Main.hs +++ b/app/astro/Main.hs @@ -9,11 +9,12 @@ import Hydra.Prelude import System.Environment (getArgs) import Astro.Server (runAstroServer) -import Astro.Client (runAstroClient) +import Astro.Client (ReportChannel(..), runAstroClient) main :: IO () main = do args <- getArgs case args of - ("client":_) -> runAstroClient + ("http_client":_) -> runAstroClient HttpChannel + ("tcp_client":_) -> runAstroClient TcpChannel _ -> runAstroServer