Fixes & Astro app added.

app/astro/Astro/Domain/Meteor.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 
 module Astro.Domain.Meteor where
 
@@ -11,21 +12,28 @@ import           Data.Time.Clock (UTCTime)
 type DateTime = UTCTime
 
 data Coords = Coords
-  { _azimuth  :: Int
-  , _altitude :: Int
+  { azimuth  :: Int
+  , altitude :: Int
   }
   deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
 
-data Meteor' k = Meteor'
-  { _id          :: k
-  , _size        :: Int
-  , _mass        :: Int
-  , _coords      :: Coords
-  , _timestamp   :: DateTime
+type MeteorID  = Int
+
+data Meteor = Meteor
+  { meteorId    :: MeteorID
+  , size        :: Int
+  , mass        :: Int
+  , coords      :: Coords
   }
   deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
 
-type RawMeteor = Meteor' ()
-type Meteor    = Meteor' Int
+data MeteorTemplate = MeteorTemplate
+  { size        :: Int
+  , mass        :: Int
+  , azimuth     :: Int
+  , altitude    :: Int
+  }
+  deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
 
--- type Meteors = D.StateVar (Set.Set Meteor)
+newtype Meteors = Meteors [Meteor]
+  deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)

app/astro/Astro/KVDB/Entities/Meteor.hs

@@ -40,7 +40,7 @@ instance D.AsKeyEntity MeteorEntity Int where
   toKeyEntity = MeteorKey
 
 instance D.AsKeyEntity MeteorEntity D.Meteor where
-  toKeyEntity = MeteorKey . D._id
+  toKeyEntity = MeteorKey . D.meteorId
 
 instance D.AsValueEntity MeteorEntity D.Meteor where
   toValueEntity = MeteorValue

app/astro/Astro/SqlDB/AstroDB.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Astro.SqlDB.AstroDB where
+
+import Hydra.Prelude
+
+import           Database.Beam
+import           Data.Time.Clock (UTCTime)
+import qualified Database.Beam as B
+import           Database.Beam ((==.), (&&.), (<-.), (/=.), (==?.))
+
+data MeteorT f = Meteor
+    { _meteorId   :: B.C f Int
+    , _meteorSize :: B.C f Int
+    , _meteorMass :: B.C f Int
+    , _meteorAzimuth    :: B.C f Int
+    , _meteorAltitude   :: B.C f Int
+    } deriving (Generic, B.Beamable)
+
+instance B.Table MeteorT where
+  data PrimaryKey MeteorT f =
+    MeteorId (B.C f Int) deriving (Generic, B.Beamable)
+  primaryKey = MeteorId . _meteorId
+
+type Meteor = MeteorT Identity
+type MeteorId = B.PrimaryKey MeteorT Identity
+
+deriving instance Show Meteor
+deriving instance Eq Meteor
+deriving instance ToJSON Meteor
+deriving instance FromJSON Meteor
+
+data AstroDb f = AstroDb
+    { _meteors :: f (B.TableEntity MeteorT)
+    } deriving (Generic, B.Database be)
+
+astroDb :: B.DatabaseSettings be AstroDb
+astroDb = B.defaultDbSettings

app/astro/Astro/SqlDB/CatalogueDB.hs

@@ -1,38 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-
-module Astro.SqlDB.CatalogueDB where
-
-import Hydra.Prelude
-
-import Database.Beam
-import           Data.Time.Clock (UTCTime)
-
-
-data DBMeteorT f = DBMeteor
-  { _id          :: Columnar f Int
-  , _size        :: Columnar f Int
-  , _mass        :: Columnar f Int
-  , _azimuth     :: Columnar f Int
-  , _altitude    :: Columnar f Int
-  , _timestamp   :: Columnar f UTCTime
-  }
-  deriving (Generic, Beamable)
-
-type DBMeteor = DBMeteorT Identity
-type DBMeteorId = PrimaryKey DBMeteorT Identity
-
-
-instance Table DBMeteorT where
-  data PrimaryKey DBMeteorT f = DBMeteorId (Columnar f Int)
-    deriving (Generic, Beamable)
-  primaryKey = DBMeteorId . _id
-
-
-data CatalogueDB f
-  = CatalogueDB
-  { _meteors :: f (TableEntity DBMeteorT)
-  }
-  deriving (Generic, Database be)
-
-catalogueDB :: DatabaseSettings be CatalogueDB
-catalogueDB = defaultDbSettings

app/astro/Main.hs

@@ -1,22 +1,169 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
 module Main where
 
 import           Control.Monad
-import qualified Data.Map      as Map
-import qualified Data.Set      as Set
 import           Hydra.Prelude
-
 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.Types
-import           Astro.Catalogue
+import           Network.Wai.Handler.Warp (run)
+import           Servant
+import           Data.Time
+import qualified Data.Map      as Map
+import qualified Data.Set      as Set
+import           Data.Time.Clock (UTCTime)
+import qualified Database.Beam as B
+import qualified Database.Beam.Sqlite as BS
+import qualified Database.Beam.Backend.SQL as B
+import           Database.Beam ((==.), (&&.), (<-.), (/=.), (==?.))
 
-mkLoggerCfg :: D.LoggerConfig
-mkLoggerCfg = D.LoggerConfig
+import           Astro.Domain.Meteor
+import qualified Astro.SqlDB.AstroDB as MDB
+
+
+type AstroAPI
+  = (  "meteors"
+    :> QueryParam "mass" Int
+    :> QueryParam "size" Int
+    :> Get '[JSON] Meteors
+    )
+  :<|>
+    (  "meteor"
+    :> ReqBody '[JSON] MeteorTemplate
+    :> Post '[JSON] MeteorID
+    )
+  :<|> EmptyAPI
+
+astroAPI :: Proxy AstroAPI
+astroAPI = Proxy
+
+data Env = Env R.AppRuntime
+type AppHandler = ReaderT Env (ExceptT ServerError IO)
+type AppServer = ServerT AstroAPI (ReaderT Env (ExceptT ServerError IO))
+
+astroServer' :: AppServer
+astroServer' = meteors :<|> meteor :<|> emptyServer
+
+astroServer :: Env -> Server AstroAPI
+astroServer env = hoistServer astroAPI (f env) astroServer'
+  where
+    f :: Env -> ReaderT Env (ExceptT ServerError IO) a -> Handler a
+    f env r = do
+      eResult <- liftIO $ (runExceptT $ runReaderT r env )
+      case eResult of
+        Left err  -> throwError err
+        Right res -> pure res
+
+astroBackendApp :: Env -> Application
+astroBackendApp = serve astroAPI . astroServer
+
+runApp :: L.AppL a -> AppHandler a
+runApp flow = do
+  Env rt <- ask
+  lift $ lift $ R.runAppL rt flow
+
+
+data AppException
+  = ConnectionFailedException Text
+  | OperationFailedException Text
+  deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON, Exception)
+
+doOrFail' :: Show e => (Text -> AppException) -> L.AppL (Either e a) -> L.AppL a
+doOrFail' excF act = act >>= \case
+  Left e  -> error $ show e
+  Right a -> pure a
+
+doOrFail :: Show e => L.AppL (Either e a) -> L.AppL a
+doOrFail = doOrFail' OperationFailedException
+
+connectOrFail :: D.DBConfig BS.SqliteM -> L.AppL (D.SqlConn BS.SqliteM)
+connectOrFail cfg = doOrFail' ConnectionFailedException $ L.initSqlDB cfg
+
+fromDBMeteor :: MDB.Meteor -> Meteor
+fromDBMeteor MDB.Meteor {..} = Meteor
+    _meteorId
+    _meteorSize
+    _meteorMass
+    (Coords _meteorAzimuth _meteorAltitude)
+
+getMeteors :: Maybe Int -> Maybe Int -> D.SqlConn BS.SqliteM -> L.AppL Meteors
+getMeteors mbMass mbSize conn = do
+
+  let predicate meteorDB = case (mbMass, mbSize) of
+        (Just m, Just s)  -> (MDB._meteorSize meteorDB ==. B.val_ s)
+            &&. (MDB._meteorMass meteorDB ==. B.val_ m)
+        (Just m, Nothing) -> (MDB._meteorMass meteorDB ==. B.val_ m)
+        (Nothing, Just s) -> (MDB._meteorSize meteorDB ==. B.val_ s)
+        _                 -> B.val_ True
+
+  eRows <- L.scenario
+    $ L.runDB conn
+    $ L.findRows
+    $ B.select
+    $ B.filter_ predicate
+    $ B.all_ (MDB._meteors MDB.astroDb)
+  case eRows of
+    Right ms -> pure $ Meteors $ map fromDBMeteor ms
+    Left err -> pure $ Meteors []
+
+createMeteor :: MeteorTemplate -> D.SqlConn BS.SqliteM -> L.AppL MeteorID
+createMeteor MeteorTemplate {..} conn = do
+  doOrFail
+    $ L.scenario
+    $ L.runDB conn
+    $ L.insertRows
+    $ B.insert (MDB._meteors MDB.astroDb)
+    $ B.insertExpressions
+          [ MDB.Meteor B.default_
+            (B.val_ size)
+            (B.val_ mass)
+            (B.val_ azimuth)
+            (B.val_ altitude)
+          ]
+
+  let predicate meteorDB
+          = (MDB._meteorSize meteorDB     ==. B.val_ size)
+        &&. (MDB._meteorMass meteorDB     ==. B.val_ mass)
+        &&. (MDB._meteorAzimuth meteorDB  ==. B.val_ azimuth)
+        &&. (MDB._meteorAltitude meteorDB ==. B.val_ altitude)
+
+  m <- doOrFail
+    $ L.scenario
+    $ L.runDB conn
+    $ L.findRow
+    $ B.select
+    $ B.limit_ 1
+    $ B.filter_ predicate
+    $ B.all_ (MDB._meteors MDB.astroDb)
+  pure $ MDB._meteorId $ fromJust m
+
+dbConfig :: D.DBConfig BS.SqliteM
+dbConfig = D.mkSQLiteConfig "/tmp/astro.db"
+
+withDB
+  :: D.DBConfig BS.SqliteM
+  -> (D.SqlConn BS.SqliteM -> L.AppL a)
+  -> L.AppL a
+withDB cfg act = connectOrFail cfg >>= act
+
+meteors :: Maybe Int -> Maybe Int -> AppHandler Meteors
+meteors mbMass mbSize = runApp
+  $ withDB dbConfig
+  $ getMeteors mbMass mbSize
+
+meteor :: MeteorTemplate -> AppHandler MeteorID
+meteor meteor = runApp
+  $ withDB dbConfig
+  $ createMeteor meteor
+
+loggerCfg :: D.LoggerConfig
+loggerCfg = D.LoggerConfig
   { D._format       = "$prio $loggername: $msg"
   , D._level        = D.Debug
   , D._logFilePath  = ""
@@ -25,8 +172,5 @@ mkLoggerCfg = D.LoggerConfig
   }
 
 main :: IO ()
-main = do
-  let loggerCfg = mkLoggerCfg
-  let cfg = AppConfig False 0
-  let appF appRt = void $ R.startApp appRt $ astroCatalogue cfg
-  R.withAppRuntime (Just loggerCfg) appF
+main = R.withAppRuntime (Just loggerCfg)
+  $ \rt -> run 8080 $ astroBackendApp $ Env rt

package.yaml

@@ -35,6 +35,7 @@ default-extensions:
 - TupleSections
 - ViewPatterns
 - MultiWayIf
+- RecordWildCards
 
 dependencies:
 - base >= 4.7 && < 5
@@ -103,6 +104,13 @@ dependencies:
 - beam-migrate
 - sqlite-simple
 - resource-pool
+- servant
+- servant-server
+- servant-client
+- servant-swagger
+- servant-docs
+- wai
+- warp
 
 library:
   source-dirs:

src/Hydra/Core/Domain/SQLDB.hs

@@ -26,14 +26,6 @@ import qualified Database.SQLite.Simple          as SQLite
 
 import           Hydra.Core.Domain.DB
 
-data SQLiteConfig = SQLiteConfig DBName
-  deriving (Show, Read, Ord, Eq, Generic, ToJSON, FromJSON)
-
-mkSQLiteConfig :: DBName -> SQLiteConfig
-mkSQLiteConfig = SQLiteConfig
-
--------------------
-
 class (B.BeamSqlBackend be, B.MonadBeam be beM) => BeamRuntime be beM
   | be -> beM, beM -> be where
   rtSelectReturningList :: B.FromBackendRow be a => B.SqlSelect be a -> beM [a]
@@ -84,8 +76,8 @@ data DBConfig beM
   | SQLitePoolConf PoolConfig DBName
   deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
 
-mkSQLiteConfig2 :: DBName -> DBConfig BS.SqliteM
-mkSQLiteConfig2 = SQLiteConf
+mkSQLiteConfig :: DBName -> DBConfig BS.SqliteM
+mkSQLiteConfig = SQLiteConf
 
 mkSQLitePoolConfig :: PoolConfig -> DBName -> DBConfig BS.SqliteM
 mkSQLitePoolConfig = SQLitePoolConf

src/Hydra/Core/Lang/Language.hs

@@ -107,3 +107,13 @@ evalSqlDB
   -> L.SqlDBL beM a
   -> LangL (D.DBResult a)
 evalSqlDB conn dbAct = liftFC $ EvalSqlDB conn dbAct id
+
+runDB
+  ::
+    ( D.BeamRunner beM
+    , D.BeamRuntime be beM
+    )
+  => D.SqlConn beM
+  -> L.SqlDBL beM a
+  -> LangL (D.DBResult a)
+runDB = evalSqlDB

test/spec/Hydra/Tests/Integration/SqlDBSpec.hs

@@ -61,7 +61,7 @@ connectOrFail cfg = L.initSqlDB cfg >>= \case
 
 
 sqliteCfg :: D.DBConfig BS.SqliteM
-sqliteCfg = D.mkSQLiteConfig2 "test.db"
+sqliteCfg = D.mkSQLiteConfig "test.db"
 
 dbApp :: L.AppL (Either String (Maybe Meteor))
 dbApp = do
@@ -77,9 +77,9 @@ dbApp = do
 spec :: Spec
 spec = do
 
-  unstableTest $ fastTest $ describe "SQLite DB tests 2" $ do
+  unstableTest $ fastTest $ describe "SQLite DB tests" $ do
 
-    describe "Some SQLite DB & Beam test 2" $ do
+    describe "Some SQLite DB & Beam test" $ do
       it "Simple queries" $ do
         eRes <- evalApp dbApp
         eRes `shouldBe` Right Nothing