Refactoring. ReaderT approach added.

app/astro/Astro/Client.hs

@@ -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

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"

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

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

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

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

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."