mirror of
https://github.com/graninas/Hydra.git
synced 2024-11-24 12:45:57 +03:00
Refactoring. ReaderT approach added.
This commit is contained in:
Alexander Granin
parent
e247306cb1
commit
b20aa3a001
@ -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
|
||||
83
app/astro/Astro/Client/Common.hs
Normal file
83
app/astro/Astro/Client/Common.hs
Normal file
@ -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"
|
||||
63
app/astro/Astro/Client/ReaderT.hs
Normal file
63
app/astro/Astro/Client/ReaderT.hs
Normal file
@ -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
|
||||
59
app/astro/Astro/Client/ServiceHandle.hs
Normal file
59
app/astro/Astro/Client/ServiceHandle.hs
Normal file
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -1,20 +1,46 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Hydra.Prelude
|
||||
import System.Environment (getArgs)
|
||||
|
||||
import qualified Hydra.Runtime as R
|
||||
import qualified Hydra.Interpreters as R
|
||||
|
||||
import Astro.Config (loggerCfg)
|
||||
import Astro.Server (runAstroServer)
|
||||
import Astro.Client (ReportChannel(..), runAstroClient)
|
||||
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."
|
||||
|
||||
Loading…
Reference in New Issue
Block a user