WIP Sync

.vscode/settings.json

@@ -10,6 +10,7 @@
         "Attoparsec",
         "Hspec",
         "delim",
-        "metavar"
+        "metavar",
+        "subparser"
     ]
 }

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`
+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.

marble-os.cabal

@@ -30,6 +30,12 @@ library
                     , optparse-applicative
                     , attoparsec
                     , bytestring
+                    , daemons
+                    , cursor
+                    , cereal
+                    , data-default
+                    , pipes
+                    , transformers
 
 executable marble
   import:             common-options

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 ];

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
+

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")

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"

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

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