Astro Client WIP

app/astro/Astro/Catalogue.hs

@@ -102,7 +102,7 @@ getMeteors mbMass mbSize conn = do
       L.logError $ "Error occured on searching meteors: " <> show err
       pure $ Meteors []
 
-createMeteor :: MeteorTemplate -> D.SqlConn BS.SqliteM -> L.AppL MeteorID
+createMeteor :: MeteorTemplate -> D.SqlConn BS.SqliteM -> L.AppL MeteorId
 createMeteor mtp@(MeteorTemplate {..}) conn = do
   L.logInfo $ "Inserting meteor into SQL DB: " <> show mtp
 

app/astro/Astro/Client.hs

@@ -11,6 +11,7 @@ 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 qualified Hydra.Domain  as D
 import qualified Hydra.Runtime as R
@@ -21,8 +22,46 @@ 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
+
+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
+  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
+  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
+  L.evalIO $ pure ()    -- send via tcp here
+  L.logInfo "Meteor sent via TCP (dummy)."
+  pure 0
+
+asteroidTcpReporter :: TcpConn -> API.AsteroidTemplate -> L.AppL (Either String AsteroidId)
+asteroidTcpReporter _ a = do
+  L.evalIO $ pure ()    -- send via tcp here
+  L.logInfo "Asteroid sent via TCP (dummy)."
+  pure 0
+
+
+
+
 
 reportAsteroid :: API.AsteroidTemplate -> L.AppL ()
 reportAsteroid asteroid = undefined
@@ -38,9 +77,6 @@ tryParseCmd str = case decode str of
   Nothing -> Left "Decoding failed."
   Just obj -> Right obj
 
-asteroidReporter = undefined
-meteorReporter = undefined
-
 reportObject
   :: FromJSON obj
   => (obj -> L.AppL ())
@@ -67,5 +103,6 @@ consoleApp = do
 
 
 runAstroClient :: IO ()
-runAstroClient = R.withAppRuntime (Just loggerCfg)
+runAstroClient =
+  R.withAppRuntime (Just loggerCfg)
     $ \rt -> R.runAppL rt consoleApp

app/astro/Astro/Domain/Asteroid.hs

@@ -11,10 +11,10 @@ import           Data.Time.Clock (UTCTime)
 
 import           Astro.Domain.Types
 
-type AsteroidID  = Int
+type AsteroidId  = Int
 
 data Asteroid = Asteroid
-  { asteroidId  :: AsteroidID
+  { asteroidId  :: AsteroidId
   , name        :: Maybe Text
   , orbital     :: Orbital
   , physical    :: Physical

app/astro/Astro/Domain/Meteor.hs

@@ -17,10 +17,10 @@ data Coords = Coords
   }
   deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
 
-type MeteorID  = Int
+type MeteorId  = Int
 
 data Meteor = Meteor
-  { meteorId    :: MeteorID
+  { meteorId    :: MeteorId
   , size        :: Int
   , mass        :: Int
   , coords      :: Coords

app/astro/Astro/KVDB/AstroDB.hs

@@ -30,7 +30,7 @@ instance D.DB AstroDB where
 data MeteorEntity
 
 instance D.DBEntity AstroDB MeteorEntity where
-  data KeyEntity MeteorEntity = MeteorKey D.MeteorID
+  data KeyEntity MeteorEntity = MeteorKey D.MeteorId
     deriving (Show, Eq, Ord)
   data ValueEntity MeteorEntity = KVDBMeteor
           { size  :: Int
@@ -40,11 +40,11 @@ instance D.DBEntity AstroDB MeteorEntity where
           , time  :: D.DateTime
           }
           deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
-  toDBKey (MeteorKey idx) = show $ formatMeteorID idx
+  toDBKey (MeteorKey idx) = show $ formatMeteorId idx
   toDBValue   = D.toDBValueJSON
   fromDBValue = D.fromDBValueJSON
 
-instance D.AsKeyEntity MeteorEntity D.MeteorID where
+instance D.AsKeyEntity MeteorEntity D.MeteorId where
   toKeyEntity = MeteorKey
 
 instance D.AsKeyEntity MeteorEntity D.Meteor where
@@ -54,16 +54,16 @@ instance D.AsValueEntity MeteorEntity D.Meteor where
   toValueEntity = toKVDBMeteor
   fromValueEntity (MeteorKey idx) = fromKVDBMeteor idx
 
-mkMeteorKey :: D.MeteorID -> D.KeyEntity MeteorEntity
+mkMeteorKey :: D.MeteorId -> D.KeyEntity MeteorEntity
 mkMeteorKey = D.toKeyEntity
 
-formatMeteorID :: D.MeteorID -> String
-formatMeteorID = ("0|" <>) . toIdxBase
+formatMeteorId :: D.MeteorId -> String
+formatMeteorId = ("0|" <>) . toIdxBase
 
 toKVDBMeteor :: D.Meteor -> D.ValueEntity MeteorEntity
 toKVDBMeteor (D.Meteor _ size mass (D.Coords azmt alt) time) = KVDBMeteor {..}
 
-fromKVDBMeteor :: D.MeteorID -> D.ValueEntity MeteorEntity -> D.Meteor
+fromKVDBMeteor :: D.MeteorId -> D.ValueEntity MeteorEntity -> D.Meteor
 fromKVDBMeteor meteorId KVDBMeteor {..} = D.Meteor
   { D.meteorId  = meteorId
   , D.size      = size

app/astro/Astro/Server.hs

@@ -27,7 +27,7 @@ import qualified Hydra.Interpreters as R
 import qualified Hydra.Language     as L
 
 import           Astro.Common (loggerCfg, dbConfig)
-import           Astro.API.Meteor
+import qualified Astro.API as API
 import           Astro.Domain.Meteor
 import           Astro.Catalogue
 import           Astro.Types
@@ -40,8 +40,13 @@ type AstroAPI
     )
   :<|>
     (  "meteor"
-    :> ReqBody '[JSON] MeteorTemplate
-    :> Post '[JSON] MeteorID
+    :> ReqBody '[JSON] API.MeteorTemplate
+    :> Post '[JSON] MeteorId
+    )
+  :<|>
+    (  "asteroid"
+    :> ReqBody '[JSON] API.AsteroidTemplate
+    :> Post '[JSON] AsteroidId
     )
 
 astroAPI :: Proxy AstroAPI
@@ -85,11 +90,14 @@ meteors mbMass mbSize = runApp
   $ withDB dbConfig
   $ getMeteors mbMass mbSize
 
-meteor :: MeteorTemplate -> AppHandler MeteorID
+meteor :: API.MeteorTemplate -> AppHandler MeteorId
 meteor m = runApp
   $ withDB dbConfig
   $ createMeteor m
 
+asteroid :: API.AsteroidTemplate -> AppHandler AsteroidId
+asteroid a = error "Not implemented yet."
+
 prepareSQLiteDB :: IO ()
 prepareSQLiteDB = do
   putStrLn @String "Copying astro_template.db to /tmp/astro.db..."