diff --git a/app/astro/Astro/Client.hs b/app/astro/Astro/Client.hs deleted file mode 100644 index 28a5b44..0000000 --- a/app/astro/Astro/Client.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveAnyClass #-} - -module Astro.Client - ( ReportChannel (..) - , runAstroClient - ) where - -import Hydra.Prelude -import qualified Data.ByteString.Lazy as BSL -import Data.Aeson (decode) -import Data.Either (rights) -import Servant -import Servant.Client (ClientM, ClientError, BaseUrl(..), Scheme(..), client) - -import qualified Hydra.Domain as D -import qualified Hydra.Runtime as R -import qualified Hydra.Interpreters as R -import qualified Hydra.Language as L - -import Astro.Common (loggerCfg) -import Astro.Domain.Meteor -import Astro.Domain.Asteroid -import Astro.Types -import qualified Astro.Server as Server -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 - -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 - -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 - -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 $ Right 0 - -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 $ Right 0 - - -tryParseCmd - :: FromJSON obj - => BSL.ByteString - -> Either BSL.ByteString obj -tryParseCmd str = case decode str of - Nothing -> Left "Decoding failed." - Just obj -> Right obj - -reportWith - :: FromJSON obj - => (obj -> L.AppL (Either BSL.ByteString res)) - -> (Either BSL.ByteString obj) - -> L.AppL (Either BSL.ByteString ()) -reportWith reporter (Left err) = pure $ Left err -reportWith reporter (Right obj) = reporter obj >> pure (Right ()) - -consoleApp :: AstroServerHandle -> L.AppL () -consoleApp handle@(AstroServerHandle{..}) = do - line <- L.evalIO $ BSL.putStr "> " >> BSL.getContents - - let runners = - [ reportWith meteorReporter $ tryParseCmd @(API.MeteorTemplate) line - , reportWith asteroidReporter $ tryParseCmd @(API.AsteroidTemplate) line - ] - - 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 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 :: ReportChannel -> IO () -runAstroClient ch = - R.withAppRuntime (Just loggerCfg) - $ \rt -> R.runAppL rt $ consoleApp $ makeReporters ch diff --git a/app/astro/Astro/Client/Common.hs b/app/astro/Astro/Client/Common.hs new file mode 100644 index 0000000..7530365 --- /dev/null +++ b/app/astro/Astro/Client/Common.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Astro.Client.Common where + +import Hydra.Prelude +import qualified Data.ByteString.Lazy as BSL +import Data.Aeson (decode) +import Data.Either (rights) +import Servant +import Servant.Client (ClientM, BaseUrl(..), Scheme(..), client) + +import qualified Hydra.Language as L + +import Astro.Domain.Meteor (MeteorId, Meteors) +import Astro.Domain.Asteroid (AsteroidId) +import qualified Astro.Server as Server +import qualified Astro.API as API + + +data TcpConn = DummyTcpConn + +data ReportChannel = TcpChannel | HttpChannel + deriving (Show, Read) + +data Approach + = SH -- ^ ServiceHandle + | RT -- ^ ReaderT + | FM -- ^ Free Monad + | CEFM -- ^ Church Encoded Free Monad + | BIO -- ^ Bare IO + deriving (Show, Read) + +meteors :: Maybe Int -> Maybe Int -> ClientM Meteors +meteor :: API.MeteorTemplate -> ClientM MeteorId +asteroid :: API.AsteroidTemplate -> ClientM AsteroidId +(meteors :<|> meteor :<|> asteroid) = client Server.astroAPI + +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 + +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 + +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 $ Right 0 + +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 $ Right 0 + +tryParseCmd + :: FromJSON obj + => BSL.ByteString + -> Either BSL.ByteString obj +tryParseCmd str = case decode str of + Nothing -> Left "Decoding failed." + Just obj -> Right obj + +localhostAstro :: BaseUrl +localhostAstro = BaseUrl Http "localhost" 8081 "" + +printResults :: [Either BSL.ByteString ()] -> L.AppL () +printResults eResults = printResults' (rights eResults) + where + printResults' [] = L.evalIO $ BSL.putStrLn "Command is not recognized." + printResults' [()] = pure () + printResults' _ = L.evalIO $ BSL.putStrLn "Multiple commands evaluated unexpectedly" diff --git a/app/astro/Astro/Client/ReaderT.hs b/app/astro/Astro/Client/ReaderT.hs new file mode 100644 index 0000000..351f6e4 --- /dev/null +++ b/app/astro/Astro/Client/ReaderT.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Astro.Client.ReaderT + ( AppRT + , AppEnv (..) + , consoleApp + , makeAppEnv + ) where + +import Hydra.Prelude +import qualified Data.ByteString.Lazy as BSL +import Servant.Client (BaseUrl(..), Scheme(..)) + +import qualified Hydra.Domain as D +import qualified Hydra.Language as L + +import qualified Astro.API as API +import Astro.Domain.Meteor (MeteorId, Meteors) +import Astro.Domain.Asteroid (AsteroidId) +import Astro.Client.Common (TcpConn(..), ReportChannel(..), + tryParseCmd, reportMeteorTcp, reportAsteroidTcp, reportMeteorHttp, + reportAsteroidHttp, localhostAstro, printResults) + +data AppEnv = AppEnv + { meteorReporter :: API.MeteorTemplate -> L.AppL (Either BSL.ByteString MeteorId) + , asteroidReporter :: API.AsteroidTemplate -> L.AppL (Either BSL.ByteString AsteroidId) + } + +type AppRT a = ReaderT AppEnv L.AppL a + +reportWith + :: FromJSON obj + => (obj -> L.AppL (Either BSL.ByteString res)) + -> (Either BSL.ByteString obj) + -> AppRT (Either BSL.ByteString ()) +reportWith _ (Left err) = pure $ Left err +reportWith reporter (Right obj) = lift (reporter obj) >> pure (Right ()) + +makeAppEnv :: ReportChannel -> AppEnv +makeAppEnv TcpChannel = AppEnv + (reportMeteorTcp DummyTcpConn) + (reportAsteroidTcp DummyTcpConn) +makeAppEnv HttpChannel = AppEnv + (reportMeteorHttp localhostAstro) + (reportAsteroidHttp localhostAstro) + +consoleApp :: AppRT () +consoleApp = do + AppEnv {..} <- ask + line <- lift $ L.evalIO $ BSL.putStr "> " >> BSL.getContents + + let runners = + [ reportWith meteorReporter $ tryParseCmd @(API.MeteorTemplate) line + , reportWith asteroidReporter $ tryParseCmd @(API.AsteroidTemplate) line + ] + + eResults <- sequence runners + lift $ printResults eResults + + consoleApp diff --git a/app/astro/Astro/Client/ServiceHandle.hs b/app/astro/Astro/Client/ServiceHandle.hs new file mode 100644 index 0000000..456b194 --- /dev/null +++ b/app/astro/Astro/Client/ServiceHandle.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Astro.Client.ServiceHandle + ( AstroServiceHandle (..) + , consoleApp + , makeServiceHandle + ) where + +import Hydra.Prelude +import qualified Data.ByteString.Lazy as BSL + +import qualified Hydra.Domain as D +import qualified Hydra.Language as L + +import qualified Astro.API as API +import Astro.Domain.Meteor (MeteorId, Meteors) +import Astro.Domain.Asteroid (AsteroidId) +import Astro.Client.Common (TcpConn(..), ReportChannel(..), + tryParseCmd, reportMeteorTcp, reportAsteroidTcp, reportMeteorHttp, + reportAsteroidHttp, localhostAstro, printResults) + +data AstroServiceHandle = AstroServiceHandle + { meteorReporter :: API.MeteorTemplate -> L.AppL (Either BSL.ByteString MeteorId) + , asteroidReporter :: API.AsteroidTemplate -> L.AppL (Either BSL.ByteString AsteroidId) + } + + +reportWith + :: FromJSON obj + => (obj -> L.AppL (Either BSL.ByteString res)) + -> (Either BSL.ByteString obj) + -> L.AppL (Either BSL.ByteString ()) +reportWith _ (Left err) = pure $ Left err +reportWith reporter (Right obj) = reporter obj >> pure (Right ()) + +makeServiceHandle :: ReportChannel -> AstroServiceHandle +makeServiceHandle TcpChannel = AstroServiceHandle + (reportMeteorTcp DummyTcpConn) + (reportAsteroidTcp DummyTcpConn) +makeServiceHandle HttpChannel = AstroServiceHandle + (reportMeteorHttp localhostAstro) + (reportAsteroidHttp localhostAstro) + +consoleApp :: AstroServiceHandle -> L.AppL () +consoleApp handle@(AstroServiceHandle{..}) = do + line <- L.evalIO $ BSL.putStr "> " >> BSL.getContents + + let runners = + [ reportWith meteorReporter $ tryParseCmd @(API.MeteorTemplate) line + , reportWith asteroidReporter $ tryParseCmd @(API.AsteroidTemplate) line + ] + + eResults <- sequence runners + printResults eResults + + consoleApp handle diff --git a/app/astro/Astro/Common.hs b/app/astro/Astro/Config.hs similarity index 95% rename from app/astro/Astro/Common.hs rename to app/astro/Astro/Config.hs index aa4b6cf..a986779 100644 --- a/app/astro/Astro/Common.hs +++ b/app/astro/Astro/Config.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveAnyClass #-} -module Astro.Common where +module Astro.Config where import Hydra.Prelude import qualified Hydra.Domain as D diff --git a/app/astro/Astro/Server.hs b/app/astro/Astro/Server.hs index 6989bde..f15c3db 100644 --- a/app/astro/Astro/Server.hs +++ b/app/astro/Astro/Server.hs @@ -27,7 +27,7 @@ import qualified Hydra.Runtime as R import qualified Hydra.Interpreters as R import qualified Hydra.Language as L -import Astro.Common (loggerCfg, dbConfig) +import Astro.Config (loggerCfg, dbConfig) import qualified Astro.API as API import Astro.Domain.Meteor import Astro.Domain.Asteroid diff --git a/app/astro/Main.hs b/app/astro/Main.hs index c26b916..75e7f82 100644 --- a/app/astro/Main.hs +++ b/app/astro/Main.hs @@ -1,20 +1,46 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveAnyClass #-} module Main where import Hydra.Prelude -import System.Environment (getArgs) +import System.Environment (getArgs) -import Astro.Server (runAstroServer) -import Astro.Client (ReportChannel(..), runAstroClient) +import qualified Hydra.Runtime as R +import qualified Hydra.Interpreters as R + +import Astro.Config (loggerCfg) +import Astro.Server (runAstroServer) +import Astro.Client.Common (ReportChannel(..), Approach(..)) +import qualified Astro.Client.ServiceHandle as SH +import qualified Astro.Client.ReaderT as RT + + +runAstroClient :: Approach -> ReportChannel -> IO () +runAstroClient appr ch = R.withAppRuntime (Just loggerCfg) (\rt -> R.runAppL rt app') + where + app' = app'' appr + + app'' SH = SH.consoleApp $ SH.makeServiceHandle ch + app'' RT = runReaderT RT.consoleApp (RT.makeAppEnv ch) + app'' _ = error $ "Approach not yet implemented: " <> show appr + +getChannel :: String -> ReportChannel +getChannel "http" = HttpChannel +getChannel "tcp" = TcpChannel +getChannel ch = error $ show $ "Channel not supported: " <> ch <> " Supported: http tcp" + +getApproach :: String -> Approach +getApproach apprStr = case readMaybe apprStr of + Just appr -> appr + Nothing -> error $ show $ "Approach not supported: " <> apprStr <> " Supported: SH RT" main :: IO () main = do args <- getArgs case args of - ("http_client":_) -> runAstroClient HttpChannel - ("tcp_client":_) -> runAstroClient TcpChannel - _ -> runAstroServer + (chan : appr : _) -> runAstroClient (getApproach appr) (getChannel chan) + ("client" : _) -> runAstroClient SH HttpChannel + ("server" : _) -> runAstroServer + _ -> putStrLn @String "Args not recognized."