From 1879de8ee9cd31ee038cc0ad8770a411d4e6b4ac Mon Sep 17 00:00:00 2001 From: Alexander Granin Date: Wed, 5 Feb 2020 00:44:05 +0700 Subject: [PATCH] Client app WIP --- app/astro/Astro/API.hs | 7 +++++ app/astro/Astro/API/Asteroid.hs | 3 -- app/astro/Astro/Client.hs | 56 ++++++++++++++++----------------- app/astro/Astro/Common.hs | 1 + app/astro/Astro/Domain/Types.hs | 26 +++++++++------ app/astro/Astro/Server.hs | 14 +-------- 6 files changed, 53 insertions(+), 54 deletions(-) create mode 100644 app/astro/Astro/API.hs diff --git a/app/astro/Astro/API.hs b/app/astro/Astro/API.hs new file mode 100644 index 0000000..ad4b1cf --- /dev/null +++ b/app/astro/Astro/API.hs @@ -0,0 +1,7 @@ +module Astro.API + ( module X + ) where + + +import Astro.API.Asteroid as X +import Astro.API.Meteor as X diff --git a/app/astro/Astro/API/Asteroid.hs b/app/astro/Astro/API/Asteroid.hs index fecd16e..4764738 100644 --- a/app/astro/Astro/API/Asteroid.hs +++ b/app/astro/Astro/API/Asteroid.hs @@ -13,6 +13,3 @@ data AsteroidTemplate = AsteroidTemplate , physical :: Physical } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) - - -type Asteroids = [Asteroid] diff --git a/app/astro/Astro/Client.hs b/app/astro/Astro/Client.hs index fa0853d..81ecd3d 100644 --- a/app/astro/Astro/Client.hs +++ b/app/astro/Astro/Client.hs @@ -10,62 +10,62 @@ module Astro.Client import Hydra.Prelude import qualified Data.ByteString.Lazy as BSL import Data.Aeson (decode) +import Data.Either (rights) 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.API.Meteor -import Astro.API.Asteroid import Astro.Types +import qualified Astro.API as API -reportAsteroid :: API.AsteroidTemplate -> Flow () +reportAsteroid :: API.AsteroidTemplate -> L.AppL () reportAsteroid asteroid = undefined -reportMeteor :: API.MeteorTemplate -> Flow () +reportMeteor :: API.MeteorTemplate -> L.AppL () reportMeteor meteor = undefined -tryParseCmd :: BSL.BytetString -> Either BSL.BytetString obj +tryParseCmd + :: FromJSON obj + => BSL.ByteString + -> Either BSL.ByteString obj tryParseCmd str = case decode str of Nothing -> Left "Decoding failed." Just obj -> Right obj +asteroidReporter = undefined +meteorReporter = undefined - -reportObject :: (obj -> Flow ()) -> obj -> Flow (Either BS.ByteString ()) +reportObject + :: FromJSON obj + => (obj -> L.AppL ()) + -> (Either BSL.ByteString obj) + -> L.AppL (Either BSL.ByteString ()) reportObject reporter obj = undefined -consoleFlow :: Flow () -consoleFlow = do - line <- L.runIO $ BSL.putStr "> " >> BSL.getLine +consoleApp :: L.AppL () +consoleApp = do + line <- L.evalIO $ BSL.putStr "> " >> BSL.getContents let runners = - [ reportObject asteroidReporter $ tryParseCmd @AsteroidTemplate line - , reportObject meteorReporter $ tryParseCmd @MeteorTemplate line + [ reportObject asteroidReporter $ tryParseCmd @(API.AsteroidTemplate) line + , reportObject meteorReporter $ tryParseCmd @(API.MeteorTemplate) line ] eResult <- sequence runners - case eResult of - Left err -> L.runIO $ BSL.putStrLn $ "Command failed: " <> err - Right _ -> pure () + case rights eResult of + [] -> L.evalIO $ BSL.putStrLn "Command is not recognized." + [()] -> pure () + (_) -> L.evalIO $ BSL.putStrLn "Multiple commands evaluated unexpectedly" - consoleFlow - - case parseCmd line of - Nothing -> do - L.runIO $ BSL.putStrLn "Command not recognized." - consoleFlow - Just asteroid@(API.AsteroidTemplate {}) -> reportAsteroid asteroid - Just meteor@(API.MeteorTemplate {}) -> reportMeteor meteor + consoleApp runAstroClient :: IO () -runAstroClient = do - - R.withAppRuntime (Just loggerCfg) $ \rt -> do - appSt <- R.runAppL rt $ initState AppConfig - run 8080 $ astroBackendApp $ Env rt appSt +runAstroClient = R.withAppRuntime (Just loggerCfg) + $ \rt -> R.runAppL rt consoleApp diff --git a/app/astro/Astro/Common.hs b/app/astro/Astro/Common.hs index e08df79..aa4b6cf 100644 --- a/app/astro/Astro/Common.hs +++ b/app/astro/Astro/Common.hs @@ -7,6 +7,7 @@ module Astro.Common where import Hydra.Prelude import qualified Hydra.Domain as D +import qualified Database.Beam.Sqlite as BS -- TODO: configs from the command line dbConfig :: D.DBConfig BS.SqliteM diff --git a/app/astro/Astro/Domain/Types.hs b/app/astro/Astro/Domain/Types.hs index 7deaf8e..aadd1a0 100644 --- a/app/astro/Astro/Domain/Types.hs +++ b/app/astro/Astro/Domain/Types.hs @@ -20,23 +20,29 @@ data Coords = Coords type AstronomicalUnit = Double data Orbital = Orbital - { epoch :: UTCTime - , apoapsis :: AstronomicalUnit + { apoapsis :: AstronomicalUnit , periapsis :: AstronomicalUnit - , semiMajorAxis :: AstronomicalUnit - , Eccentrity :: Double - , Inclination :: Double - , Longitude :: Double - , ArgumentOfPeriapsis :: Double - , OrbitalPeriod :: Double - , AvgOrbitalSpeed :: Double + + -- Enough fields for demo. + + -- , epoch :: UTCTime + -- , semiMajorAxis :: AstronomicalUnit + -- , eccentrity :: Double + -- , inclination :: Double + -- , longitude :: Double + -- , argumentOfPeriapsis :: Double + -- , orbitalPeriod :: Double + -- , avgOrbitalSpeed :: Double } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) data Physical = Physical { meanDiameter :: Double , rotationPeriod :: Double - , albedo :: Double + + + -- Enough fields for demo. + -- , albedo :: Double } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) diff --git a/app/astro/Astro/Server.hs b/app/astro/Astro/Server.hs index e6844cd..3118a9b 100644 --- a/app/astro/Astro/Server.hs +++ b/app/astro/Astro/Server.hs @@ -26,6 +26,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.API.Meteor import Astro.Domain.Meteor import Astro.Catalogue @@ -79,10 +80,6 @@ astroServer' = meteors :<|> meteor --- TODO: configs from the command line -dbConfig :: D.DBConfig BS.SqliteM -dbConfig = D.mkSQLiteConfig "/tmp/astro.db" - meteors :: Maybe Int -> Maybe Int -> AppHandler Meteors meteors mbMass mbSize = runApp $ withDB dbConfig @@ -93,15 +90,6 @@ meteor m = runApp $ withDB dbConfig $ createMeteor m -loggerCfg :: D.LoggerConfig -loggerCfg = D.LoggerConfig - { D._format = "$prio $loggername: $msg" - , D._level = D.Debug - , D._logFilePath = "" - , D._logToConsole = True - , D._logToFile = False - } - prepareSQLiteDB :: IO () prepareSQLiteDB = do putStrLn @String "Copying astro_template.db to /tmp/astro.db..."