graninas/Hydra
1
1
Fork 0
mirror of https://github.com/graninas/Hydra.git synced 2024-11-28 13:02:50 +03:00
Code Issues Projects Releases Wiki Activity

KV DB Support WIP.

Browse Source
This commit is contained in:
Alexander Granin 2019-08-08 16:12:21 +07:00
parent 005a274a47
commit e404e2466e
17 changed files with 205 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
app/Astro/Astro/Catalogue.hs Normal file
View File

@ -0,0 +1,66 @@
module Astro.Catalogue where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Hydra.Domain as D
import qualified Hydra.Language as L
import Hydra.Prelude
import qualified Hydra.Runtime as R
import Astro.Types
import Astro.KVDB.Model
import Astro.Lens
-- withKBlocksDB
-- ::
-- -- forall s db a
-- -- . Lens.HasKBlocksDB s (D.Storage db)
-- -- =>
-- D.KVDBStorage CatalogueDB
-- -> L.KVDBL db a
-- -> L.LangL a
-- withKBlocksDB kvDBModel = L.withDatabase (kvDBModel ^. Lens.meteorsTable)
loadMeteorsCount :: L.KVDBL CatalogueDB Int
loadMeteorsCount = do
eTest <- L.getValue "test"
pure 10
dynamicsMonitor :: AppState -> L.LangL ()
dynamicsMonitor st = do
meteorsCount <- L.withKVDB (st ^. catalogueDB) loadMeteorsCount
-- L.logInfo $ "Meteors count: " +|| meteorsCount ||+ ""
pure ()
initState :: AppConfig -> L.AppL AppState
initState cfg = do
eCatalogueDB <- L.scenario
$ L.initKVDB
$ D.KVDBConfig @CatalogueDB "catalogue"
$ D.KVDBOptions True False
catalogueDB <- case eCatalogueDB of
Right db -> pure db
Left err -> do
L.logError $ "Failed to init KV DB catalogue: " +|| err ||+ ""
error $ "Failed to init KV DB catalogue: " +|| err ||+ "" -- TODO
totalMeteors <- L.newVarIO 0
pure $ AppState
{ _catalogueDB = catalogueDB
, _totalMeteors = totalMeteors
, _config = cfg
}
astroCatalogue :: AppConfig -> L.AppL ()
astroCatalogue cfg = do
appSt <- initState cfg
L.process $ dynamicsMonitor appSt
L.awaitAppForever

72
app/Astro/Astro/KVDB/Entities/Meteor.hs Normal file
View File

@ -0,0 +1,72 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Astro.KVDB.Entities.Meteor where
import Hydra.Prelude
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as LBS
-- meteors (meteor_idx -> meteor_entity_json)
-- ------------------------------------------------------------
-- 0000000 {}
data MeteorEntity
--
-- instance KVDBModelEntity MeteorsTable MeteorEntity
--
--
-- instance D.DBEntity KBlockPrevHashEntity where
-- data DBKey KBlockPrevHashEntity = KBlockPrevHashKey D.BlockNumber
-- deriving (Show, Eq, Ord)
-- data DBValue KBlockPrevHashEntity = KBlockPrevHashValue D.StringHash
-- deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
--
-- instance D.ToDBKey KBlockPrevHashEntity D.BlockNumber where
-- toDBKey = KBlockPrevHashKey
--
-- instance D.ToDBKey KBlockPrevHashEntity D.KBlock where
-- toDBKey = KBlockPrevHashKey . D._number
--
-- instance D.ToDBValue KBlockPrevHashEntity D.KBlock where
-- toDBValue kBlock = KBlockPrevHashValue $ kBlock ^. Lens.prevHash
--
-- -- TODO: this can be made by default
-- instance D.RawDBEntity KBlocksDB KBlockPrevHashEntity where
-- toRawDBKey (KBlockPrevHashKey kBlockIdx) = encodeUtf8 $ toKBlockPrevHashEntityKeyBase kBlockIdx
-- toRawDBValue = LBS.toStrict . A.encode
-- fromRawDBValue = A.decode . LBS.fromStrict
--
-- -- KBlock entity
--
-- instance D.DBEntity KBlockEntity where
-- data DBKey KBlockEntity = KBlockKey D.BlockNumber
-- deriving (Show, Eq, Ord)
-- data DBValue KBlockEntity = KBlockValue D.BlockTime D.BlockNumber D.Nonce D.Solver
-- deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
--
-- instance D.ToDBKey KBlockEntity D.BlockNumber where
-- toDBKey = KBlockKey
--
-- instance D.ToDBKey KBlockEntity D.KBlock where
-- toDBKey = KBlockKey . D._number
--
-- instance D.ToDBValue KBlockEntity D.KBlock where
-- toDBValue (D.KBlock time _ number nonce solver) = KBlockValue time number nonce solver
--
-- instance D.RawDBEntity KBlocksDB KBlockEntity where
-- toRawDBKey (KBlockKey kBlockIdx) = encodeUtf8 $ toKBlockEntityKeyBase kBlockIdx
-- toRawDBValue = LBS.toStrict . A.encode
-- fromRawDBValue = A.decode . LBS.fromStrict
--
--
-- toKBlockIdxBase :: KBlockIdx -> String
-- toKBlockIdxBase = printf "%07d"
--
-- toKBlockPrevHashEntityKeyBase :: KBlockIdx -> String
-- toKBlockPrevHashEntityKeyBase = (<> "0") . toKBlockIdxBase
--
-- toKBlockEntityKeyBase :: KBlockIdx -> String
-- toKBlockEntityKeyBase = (<> "1") . toKBlockIdxBase

0
app/Astro/KVDB/Model.hs → app/Astro/Astro/KVDB/Model.hs
View File

12
app/Astro/Astro/Lens.hs Normal file
View File

@ -0,0 +1,12 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
module Astro.Lens where
import Control.Lens (makeFieldsNoPrefix)
import Astro.Types (Coords, Meteor, AppState)
makeFieldsNoPrefix ''Coords
makeFieldsNoPrefix ''Meteor
makeFieldsNoPrefix ''AppState

13
app/Astro/Types.hs → app/Astro/Astro/Types.hs
View File

@ -1,4 +1,4 @@
module Types where
module Astro.Types where
import qualified Data.Map as Map
import qualified Data.Set as Set
@ -28,25 +28,18 @@ data Meteor = Meteor
type Meteors = D.StateVar (Set.Set Meteor)
-- type Catalogue = Map.Map Region Meteors
data AppConfig = AppConfig
{ enableDelays :: Bool
, delaysFactor :: Int
, maxMeteors :: Maybe Int
, storeTracked :: Bool
, logDiscovered :: Bool
, logTracked :: Bool
, logTotal :: Bool
}
deriving (Show, Read, Eq, Ord)
data AppState = AppState
{ _catalogueDB :: D.KVDBConn CatalogueDB
{ _catalogueDB :: D.KVDBStorage CatalogueDB
, _totalMeteors :: D.StateVar Int
, _config :: AppConfig
}
--
-- delaysEnabled :: AppState -> Bool
-- delaysEnabled = enableDelays . _config
--

75
app/Astro/Catalogue.hs
View File

@ -1,75 +0,0 @@
module Astro.Catalogue where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Hydra.Domain as D
import qualified Hydra.Language as L
import Hydra.Prelude
import qualified Hydra.Runtime as R
import Types
import qualified Astro.KVDB.Entries as E
import qualified Astro.Lens as Lens
withKBlocksDB
::
-- forall s db a
-- . Lens.HasKBlocksDB s (D.Storage db)
-- =>
E.KVDBModel
-> L.KVDBL db a
-> L.LangL a
withKBlocksDB kvDBModel = L.withDatabase (kvDBModel ^. Lens.meteorsTable)
loadMeteorsCount :: E.KVDBModel -> L.LangL Int
loadMeteorsCount kvDBModel = do
pure 10
dynamicsMonitor :: AppState -> L.LangL ()
dynamicsMonitor st = do
meteorsCount <- loadMeteorsCount (st ^. kbdbModel)
L.logInfo $ "Meteors count: " +|| meteorsCount
initState :: AppConfig -> L.AppL AppState
initState cfg = do
eCatalogueDB :: D.DBResult CatalogueDB <- L.initKVDB
$ D.KVDBConfig "catalogue"
$ D.KVDBOptions True False
catalogueDB <- case eCatalogue of
Right db -> pure db
Left err -> do
L.logError $ "Failed to init KV DB catalogue: " +|| err
error "Failed to init KV DB catalogue: " +|| err -- TODO
totalMeteors <- L.newStateVar 0
pure $ AppState
{ _catalogueDB = catalogueDB
, _totalMeteors = totalMeteors
, _config = cfg
}
astroCatalogue :: AppConfig -> L.AppL ()
astroCatalogue cfg = do
appSt <- initState cfg
L.process $ dynamicsMonitor appSt
-- L.atomically $ do
-- let maxTotal = fromMaybe 0 $ maxMeteors cfg
-- total <- L.readVar $ _totalMeteors st
-- when (maxTotal == 0 || total < maxTotal) L.retry
scenario :: R.CoreRuntime -> AppConfig -> IO ()
scenario coreRt cfg = void
$ R.startApp coreRt
$ meteorsMonitoring cfg

71
app/Astro/KVDB/Entities/Meteor.hs
View File

@ -1,71 +0,0 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Astro.KVDB.Entities.Meteor where
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as LBS
import Hydra.Prelude
-- meteors (meteor_idx -> meteor_entity_json)
-- ------------------------------------------------------------
-- 0000000 {}
data MeteorEntity
instance KVDBModelEntity MeteorsTable MeteorEntity
instance D.DBEntity KBlockPrevHashEntity where
data DBKey KBlockPrevHashEntity = KBlockPrevHashKey D.BlockNumber
deriving (Show, Eq, Ord)
data DBValue KBlockPrevHashEntity = KBlockPrevHashValue D.StringHash
deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
instance D.ToDBKey KBlockPrevHashEntity D.BlockNumber where
toDBKey = KBlockPrevHashKey
instance D.ToDBKey KBlockPrevHashEntity D.KBlock where
toDBKey = KBlockPrevHashKey . D._number
instance D.ToDBValue KBlockPrevHashEntity D.KBlock where
toDBValue kBlock = KBlockPrevHashValue $ kBlock ^. Lens.prevHash
-- TODO: this can be made by default
instance D.RawDBEntity KBlocksDB KBlockPrevHashEntity where
toRawDBKey (KBlockPrevHashKey kBlockIdx) = encodeUtf8 $ toKBlockPrevHashEntityKeyBase kBlockIdx
toRawDBValue = LBS.toStrict . A.encode
fromRawDBValue = A.decode . LBS.fromStrict
-- KBlock entity
instance D.DBEntity KBlockEntity where
data DBKey KBlockEntity = KBlockKey D.BlockNumber
deriving (Show, Eq, Ord)
data DBValue KBlockEntity = KBlockValue D.BlockTime D.BlockNumber D.Nonce D.Solver
deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
instance D.ToDBKey KBlockEntity D.BlockNumber where
toDBKey = KBlockKey
instance D.ToDBKey KBlockEntity D.KBlock where
toDBKey = KBlockKey . D._number
instance D.ToDBValue KBlockEntity D.KBlock where
toDBValue (D.KBlock time _ number nonce solver) = KBlockValue time number nonce solver
instance D.RawDBEntity KBlocksDB KBlockEntity where
toRawDBKey (KBlockKey kBlockIdx) = encodeUtf8 $ toKBlockEntityKeyBase kBlockIdx
toRawDBValue = LBS.toStrict . A.encode
fromRawDBValue = A.decode . LBS.fromStrict
toKBlockIdxBase :: KBlockIdx -> String
toKBlockIdxBase = printf "%07d"
toKBlockPrevHashEntityKeyBase :: KBlockIdx -> String
toKBlockPrevHashEntityKeyBase = (<> "0") . toKBlockIdxBase
toKBlockEntityKeyBase :: KBlockIdx -> String
toKBlockEntityKeyBase = (<> "1") . toKBlockIdxBase

47
app/Astro/Main.hs
View File

@ -9,53 +9,18 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import Hydra.Prelude
import qualified Free as Free
import Types
import qualified FTL as FTL
import qualified Church as Church
import qualified Hydra.Domain as D
import qualified Hydra.Runtime as R
data Method = FT | FreeM | ChurchM
deriving (Show, Read, Eq, Ord)
data Config = Config
{ useLog :: Bool
, method :: Method
, appConfig :: AppConfig
}
deriving (Show, Read, Eq, Ord)
loggerCfg :: D.LoggerConfig
loggerCfg = D.LoggerConfig
{ D._format = "$prio $loggername: $msg"
, D._level = D.Debug
, D._logFilePath = ""
, D._logToConsole = True
, D._logToFile = False
}
import Astro.Types
import Astro.Catalogue
main :: IO ()
main = do
cfgStr <- readFile "meteor_counter.cfg"
let cfg :: Config = read $ toString cfgStr
loggerRt <- R.createVoidLoggerRuntime
coreRt <- R.createCoreRuntime loggerRt
putStrLn @String $ "Method: " <> show (method cfg)
let cfg = AppConfig False 0
loggerRt <- if useLog cfg
then R.createLoggerRuntime loggerCfg
else R.createVoidLoggerRuntime
coreRt <- R.createCoreRuntime loggerRt
when (method cfg == FT)
$ FTL.scenario coreRt
$ appConfig cfg
when (method cfg == FreeM)
$ Free.scenario coreRt
$ appConfig cfg
when (method cfg == ChurchM)
$ Church.scenario coreRt
$ appConfig cfg
void $ R.startApp coreRt $ astroCatalogue cfg

11
package.yaml
View File

@ -126,6 +126,17 @@ executables:
- -O2
dependencies:
- Hydra
astro-app:
main: Main.hs
source-dirs: app/astro
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -Wall
- -O2
dependencies:
- Hydra
tests:

2
src/Hydra/Core/Domain.hs
View File

@ -5,3 +5,5 @@ module Hydra.Core.Domain
import Hydra.Core.Domain.Logger as X
import Hydra.Core.Domain.Process as X
import Hydra.Core.Domain.State as X
import Hydra.Core.Domain.DB as X
import Hydra.Core.Domain.KVDB as X

4
src/Hydra/Core/Domain/DB.hs
View File

@ -4,7 +4,7 @@
module Hydra.Core.Domain.DB where
import Hydra.Prelude
import Data.Aeson.Extra (noLensPrefix)
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as LBS
@ -19,5 +19,5 @@ data DBError = DBError DBErrorType Text
type DBResult a = Either DBError a
data KVDBConn db = KVDBConn
data KVDBStorage db = KVDBStorage
deriving (Show, Generic)

9
src/Hydra/Core/Domain/KVDB.hs
View File

@ -5,7 +5,8 @@ module Hydra.Core.Domain.KVDB where
import Hydra.Prelude
import Data.Aeson.Extra (noLensPrefix)
--import Data.Aeson.Extra (noLensPrefix)
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as LBS
@ -19,13 +20,13 @@ data KVDBOptions = KVDBOptions
data KVDBConfig db = KVDBConfig
{ _path :: FilePath
, _options :: DBOptions
, _options :: KVDBOptions
}
deriving (Show, Generic)
type DBKey = ByteString
type DBValue = ByteString
type KVDBKey = ByteString
type KVDBValue = ByteString
-- class DB db where
-- getDbName :: FilePath

14
src/Hydra/Core/KVDB/Language.hs
View File

@ -2,22 +2,24 @@
module Hydra.Core.KVDB.Language where
import Data.Typeable (typeOf)
import Hydra.Prelude
import qualified Hydra.Core.Domain.Database as D
-- import Data.Typeable (typeOf)
import qualified Hydra.Core.Domain.DB as D
import qualified Hydra.Core.Domain.KVDB as D
data KVDBF db a where
GetValue :: D.DBKey -> (D.DBResult D.DBValue -> next) -> KVDBF db next
PutValue :: D.DBKey -> D.DBValue -> (D.DBResult () -> next) -> KVDBF db next
GetValue :: D.KVDBKey -> (D.DBResult D.KVDBValue -> next) -> KVDBF db next
PutValue :: D.KVDBKey -> D.KVDBValue -> (D.DBResult () -> next) -> KVDBF db next
deriving (Functor)
type KVDBL db = Free (KVDBF db)
getValue :: D.DBKey -> KVDBL db (D.DBResult D.DBValue)
getValue :: D.KVDBKey -> KVDBL db (D.DBResult D.KVDBValue)
getValue key = liftF $ GetValue key id
putValue :: D.DBKey -> D.DBValue -> KVDBL db (D.DBResult ())
putValue :: D.KVDBKey -> D.KVDBValue -> KVDBL db (D.DBResult ())
putValue key val = liftF $ PutValue key val id
-- putEntity

13
src/Hydra/Core/Lang/Language.hs
View File

@ -14,7 +14,9 @@ import qualified Hydra.Core.Random.Class as L
import qualified Hydra.Core.Random.Language as L
import qualified Hydra.Core.State.Class as L
import qualified Hydra.Core.State.Language as L
import qualified Hydra.Core.KVDB.Language as L
import qualified Hydra.Core.Lang.Class as C
import qualified Hydra.Core.Domain as D
import Language.Haskell.TH.MakeFunctor (makeFunctorInstance)
@ -30,6 +32,11 @@ data LangF next where
EvalControlFlow :: L.ControlFlowL a -> (a -> next) -> LangF next
-- | Impure effect. Avoid using it in production code (it's not testable).
EvalIO :: IO a -> (a -> next) -> LangF next
-- | Init KV DB
InitKVDB :: D.KVDBConfig db -> (D.DBResult (D.KVDBStorage db) -> next) -> LangF next
-- | Eval KV DB action
EvalKVDB :: D.KVDBStorage db -> L.KVDBL db a -> (a -> next) -> LangF next
makeFunctorInstance ''LangF
@ -81,11 +88,11 @@ instance L.ControlFlow LangL where
initKVDB :: D.DBConfig db -> LangL (D.DBResult (D.KVDBConn db))
initKVDB :: D.KVDBConfig db -> LangL (D.DBResult (D.KVDBStorage db))
initKVDB config = liftF $ InitKVDB config id
evalKVDB :: D.KVDBConn db -> L.KVDBL db a -> LangL a
evalKVDB :: D.KVDBStorage db -> L.KVDBL db a -> LangL a
evalKVDB conn script = liftF $ EvalKVDB conn script id
withKVDB :: D.KVDBConn db -> L.KVDBL db a -> LangL a
withKVDB :: D.KVDBStorage db -> L.KVDBL db a -> LangL a
withKVDB = evalKVDB

1
src/Hydra/Core/Language.hs
View File

@ -13,3 +13,4 @@ import Hydra.Core.Random.Class as X
import Hydra.Core.Random.Language as X
import Hydra.Core.State.Class as X
import Hydra.Core.State.Language as X
import Hydra.Core.KVDB.Language as X

2
src/Hydra/Framework/App/Language.hs
View File

@ -22,7 +22,7 @@ data AppF next where
makeFunctorInstance ''AppF
type AppL = Free AppF
--
-- | Eval lang.
evalLang' :: L.LangL a -> AppL a
evalLang' action = liftF $ EvalLang action id

6
src/Hydra/Language/Extra.hs
View File

@ -45,6 +45,12 @@ foreverAppChurch app = do
when (x == 1) CL.retry
awaitAppForever :: L.AppL ()
awaitAppForever = L.atomically $ do
xVar <- L.newVar (1 :: Int)
x <- L.readVar xVar
when (x == 1) L.retry
--
-- instance ForeverApp CL.LangL where
-- foreverApp :: CL.AppL a -> CL.AppL ()