From 0d94c4c5e99be0b57ff67e0baf091425b7cd4848 Mon Sep 17 00:00:00 2001 From: Joaquin Florius Date: Thu, 20 Aug 2020 23:31:37 +0000 Subject: [PATCH] WIP Sync --- .vscode/settings.json | 3 +- README.md | 18 +++++++- marble-os.cabal | 6 +++ marble-os.nix | 10 +++-- src/App.hs | 76 +++++++++++++++++++++++++++++++-- src/Args.hs | 98 +++++++++++++++++++++++++++++++++++++++---- src/Configuration.hs | 21 +++++++++- src/Mbl.hs | 18 +++++--- test/MblSpec.hs | 4 +- 9 files changed, 227 insertions(+), 27 deletions(-) diff --git a/.vscode/settings.json b/.vscode/settings.json index 5ed6d8a..a18eaf0 100755 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -10,6 +10,7 @@ "Attoparsec", "Hspec", "delim", - "metavar" + "metavar", + "subparser" ] } \ No newline at end of file diff --git a/README.md b/README.md index f502754..3c52147 100755 --- a/README.md +++ b/README.md @@ -57,4 +57,20 @@ $ make help e.g.: `$ make run ARGS="./sample/calculator.mbl --tick=30"` # Prod -Build with `$ make build` and then run the executable `result/bin/marble` \ No newline at end of file +Build with `$ make build` and then run the executable `result/bin/marble` + +# Missing +### Citations +Extend .mbl to allow citation-like commands. +eg: + +``` +# foo.mbl +---1--2 + +[1]: Say something +``` +This would, in 4 ticks, output `Say something` + +### TUI for the daemon +`brics` tui to see all connected "sync" and .mbl before running. diff --git a/marble-os.cabal b/marble-os.cabal index ae5ccb8..21a86ef 100755 --- a/marble-os.cabal +++ b/marble-os.cabal @@ -30,6 +30,12 @@ library , optparse-applicative , attoparsec , bytestring + , daemons + , cursor + , cereal + , data-default + , pipes + , transformers executable marble import: common-options diff --git a/marble-os.nix b/marble-os.nix index e13fc4e..405442e 100644 --- a/marble-os.nix +++ b/marble-os.nix @@ -1,14 +1,16 @@ -{ mkDerivation, attoparsec, base, bytestring, hspec -, optparse-applicative, stdenv, text, time +{ mkDerivation, attoparsec, base, bytestring, cereal, cursor +, daemons, data-default, hspec, optparse-applicative, pipes, stdenv +, text, time, transformers }: mkDerivation { pname = "marble-os"; - version = "0.1.0.0"; + version = "0.1.1.2"; src = ./.; isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - attoparsec base bytestring optparse-applicative text time + attoparsec base bytestring cereal cursor daemons data-default + optparse-applicative pipes text time transformers ]; executableHaskellDepends = [ base ]; testHaskellDepends = [ base hspec ]; diff --git a/src/App.hs b/src/App.hs index 698a40d..d4c4077 100755 --- a/src/App.hs +++ b/src/App.hs @@ -1,16 +1,84 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + module App where import Args ( args ) import Mbl ( parse , interpret + , MBL ) import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Configuration as C +import qualified Control.Concurrent.MVar as Con +import qualified System.Daemon as D +import qualified Cursor.List as Cursor +import GHC.Generics +import Data.Serialize ( Serialize ) +import Data.Default ( def ) +import qualified Pipes as P +import Pipes ( (<-<) ) +import qualified Control.Pipe.Serialize as P +import qualified Control.Monad as M +import Control.Monad.Trans.Class ( lift ) + +data Command = Hello MBL + | Start + | List + deriving ( Generic, Show ) + + +instance Serialize Command + +type Registry = Cursor.ListCursor MBL + +data Response = Ok + | Listed [MBL] + deriving ( Generic, Show ) + +instance Serialize Response + +handleCommands :: Con.MVar Registry -> Command -> IO Response +handleCommands registryVar command = case command of + Hello mbl -> Con.modifyMVar registryVar + $ \registry -> return $ (Cursor.listCursorAppend mbl registry, Ok) + Start -> error "can't start. Did not program it" + List -> Listed <$> Cursor.rebuildListCursor <$> Con.readMVar registryVar main :: IO () main = do - config <- args - contents <- BS.readFile $ T.unpack $ C.path config - mbl <- either (fail) pure $ parse config contents - interpret config mbl + config <- args + case config of + C.Run config' -> do + contents <- BS.readFile $ T.unpack $ C.path config' + mbl <- either (fail) pure $ parse config' contents + interpret config' mbl + C.Daemon (C.DaemonConfiguration config' remote) -> do + let port = C.port remote + let host = C.host remote + let options = def { D.daemonPort = port, D.printOnDaemonStarted = False } + state <- Con.newMVar Cursor.emptyListCursor + if host == def + then D.ensureDaemonRunning "marble-os" options (handleCommands state) + else pure () + res <- D.runClient (T.unpack $ C.unHost host) port (command) + print (res :: Maybe Response) + where + command :: Command + command = case config' of + C.List -> List + C.Start -> Start + C.Sync (C.SyncConfiguration config' remote) -> do + let port = C.port remote + contents <- BS.readFile $ T.unpack $ C.path config' + mbl <- either (fail) pure $ parse config' contents + D.runClientWithHandler (T.unpack $ C.unHost $ C.host remote) port + $ \reader writer -> P.runEffect $ do + writer <-< P.serializer <-< P.yield (Hello mbl) + (M.forever $ P.await >>= \(res :: Maybe Response) -> + lift (print (Just res)) + ) + <-< P.deserializer + <-< reader + diff --git a/src/Args.hs b/src/Args.hs index 6c54e87..4d5ea60 100644 --- a/src/Args.hs +++ b/src/Args.hs @@ -21,15 +21,64 @@ import Options.Applicative ( Parser , header , (<**>) , auto + , subparser + , command ) import qualified Duration as D import qualified Data.String as S -import Configuration +import qualified Configuration as C +import Data.Default ( def ) -configuration :: Parser Configuration -configuration = - Configuration +remote :: Parser C.Remote +remote = + C.Remote + <$> option + auto + ( long "port" + <> short 'p' + <> help "Port to run the daemon." + <> metavar "PORT" + <> showDefault + <> value 3000 + ) + <*> option + auto + ( long "host" + <> short 'h' + <> help "Host to run the daemon." + <> metavar "HOST" + <> showDefault + <> value def + ) + +daemon :: Parser C.DaemonConfiguration +daemon = C.DaemonConfiguration <$> daemonSubCmd <*> remote + +daemonSubCmd :: Parser C.DaemonSubConfiguration +daemonSubCmd = + subparser + $ command + "list" + ( C.List + <$ (info (pure () <**> helper) + (fullDesc <> progDesc "List all mbls currently waiting.") + ) + ) + <> command + "start" + ( C.Start + <$ (info (pure () <**> helper) + (fullDesc <> progDesc "Start all mbls currently waiting.") + ) + ) + +sync :: Parser C.SyncConfiguration +sync = C.SyncConfiguration <$> run <*> remote + +run :: Parser C.RunConfiguration +run = + C.RunConfiguration <$> strArgument (metavar "CONFIG" <> help "Target marble config file" <> action "file" ) @@ -70,17 +119,48 @@ configuration = defaultDuration = D.seconds 1 parseDuration :: String -> Either String D.Duration parseDuration = D.parseDuration . S.fromString - parseDelimiter :: String -> Either String Delimiter + parseDelimiter :: String -> Either String C.Delimiter parseDelimiter d = case d of x : [] -> Right x _ -> Left $ "Invalid delimiter `" <> d <> "`. Must be 1 character." -args :: IO Configuration +args :: IO C.Configuration args = execParser opts where opts = info - (configuration <**> helper) - (fullDesc <> progDesc "Output things in a controlled manner" <> header - "marble-os - Run things at your own pace" + ( (subparser + ( command + "run" + ( C.Run + <$> (info (run <**> helper) + (fullDesc <> progDesc "Run the marble file") + ) + ) + <> command + "sync" + ( C.Sync + <$> (info + (sync <**> helper) + ( fullDesc + <> progDesc + "Start a daemon and wait to run the marble.\nLook at `marble daemon --help` for more information" + ) + ) + ) + <> command + "daemon" + ( C.Daemon + <$> (info + (daemon <**> helper) + ( fullDesc + <> progDesc + "Control the daemon to launch `sync`'ed marble clients." + ) + ) + ) + ) + ) + <**> helper ) + (fullDesc <> header "marble-os - Run things at your own pace") diff --git a/src/Configuration.hs b/src/Configuration.hs index 1ecf9e8..915ad0d 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -2,12 +2,31 @@ module Configuration where import qualified Data.Text as T import qualified Duration as D +import Data.Default ( Default(..) ) type Delimiter = Char -data Configuration = Configuration +data RunConfiguration = RunConfiguration { path :: T.Text , lane :: Int , repeat :: Bool , tick :: D.Duration , delimiter :: Delimiter } + +data SyncConfiguration = SyncConfiguration RunConfiguration Remote + +data DaemonConfiguration = DaemonConfiguration DaemonSubConfiguration Remote + +data DaemonSubConfiguration = List | Start | Restart + +data Remote = Remote { port :: Port , host :: Host } + + +data Configuration = Run RunConfiguration | Sync SyncConfiguration | Daemon DaemonConfiguration + +newtype Host = Host { unHost :: T.Text } deriving (Show, Eq, Read) + +type Port = Int + +instance Default Host where + def = Host "127.0.0.1" diff --git a/src/Mbl.hs b/src/Mbl.hs index 026ff2a..5e1f7c5 100644 --- a/src/Mbl.hs +++ b/src/Mbl.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} + module Mbl where import Prelude hiding ( takeWhile @@ -18,20 +20,26 @@ import Data.ByteString ( ByteString ) import Control.Applicative ( many , (<|>) ) -import Configuration +import Configuration ( RunConfiguration(..) + , Delimiter + ) import qualified Control.Concurrent as C import qualified Control.Monad as CM import qualified Data.ByteString.Char8 as BS import qualified Duration as D import qualified Data.Bool as B import qualified System.IO as S +import Data.Serialize ( Serialize ) +import GHC.Generics -data Action = Wait | Print ByteString deriving (Show, Eq) +data Action = Wait | Print ByteString deriving (Show, Eq, Generic) type MBL = [Action] +instance Serialize Action + -interpret :: Configuration -> MBL -> IO () +interpret :: RunConfiguration -> MBL -> IO () interpret config mlb = CM.forM_ (repeat' mlb) interpret' where repeat' :: MBL -> MBL @@ -41,7 +49,7 @@ interpret config mlb = CM.forM_ (repeat' mlb) interpret' interpret' (Print str) = BS.putStrLn str >> S.hFlush S.stdout -parse :: Configuration -> ByteString -> Either String MBL +parse :: RunConfiguration -> ByteString -> Either String MBL parse conf content = do let lines = BS.lines content let lane' = lane conf @@ -62,6 +70,6 @@ print delim = "Print" where print' = notChar delim -mbl :: Configuration -> Parser MBL +mbl :: RunConfiguration -> Parser MBL mbl conf = (many $ wait delim <|> print delim) "One Line" where delim = delimiter conf diff --git a/test/MblSpec.hs b/test/MblSpec.hs index 6832718..dd5d532 100755 --- a/test/MblSpec.hs +++ b/test/MblSpec.hs @@ -6,8 +6,8 @@ import Configuration import Duration import Data.Either ( isLeft ) -configuration :: Configuration -configuration = Configuration "/foo/bar" 1 False (seconds 1) '-' +configuration :: RunConfiguration +configuration = RunConfiguration "/foo/bar" 1 False (seconds 1) '-' spec :: Spec spec = do