diff --git a/CHANGELOG.md b/CHANGELOG.md index f004342..b788172 100755 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,5 @@ # Revision history for marble-os -## 0.1.3.0 -- xxx +## 0.1.3.0 -- 2020-08-30 * Added citation support * Added named lanes support diff --git a/README.md b/README.md index ce8b8e6..dd17406 100755 --- a/README.md +++ b/README.md @@ -116,8 +116,7 @@ Build with `$ make build` and then run the executable `result/bin/marble` # Missing -### TUI for the daemon -`brics` tui to see all connected "sync" and .mbl before running. +* Logs for daemon ### Bugs Starting a `sync` with no demon started fails diff --git a/marble-os.cabal b/marble-os.cabal index 2d52bb5..b115434 100755 --- a/marble-os.cabal +++ b/marble-os.cabal @@ -24,7 +24,7 @@ library , Args , Mbl , Configuration - other-modules: + other-modules: Paths_marble_os build-depends: text , time , optparse-applicative diff --git a/src/App.hs b/src/App.hs index 880dcb2..f0c18b9 100755 --- a/src/App.hs +++ b/src/App.hs @@ -30,11 +30,20 @@ import qualified Control.Concurrent.Chan as Chan import qualified Text.Editor as E import Data.List ( find ) import System.Random as R +import Paths_marble_os ( version ) +import Data.Version ( showVersion ) +import qualified System.Exit as Exit +import Control.Exception ( catch + , IOException + ) +import qualified Control.Monad.Trans.Except as TE data Command = Hello MBL | TriggerStart | List | Update [MBL] + | Version + | Kill deriving ( Generic, Show ) @@ -47,6 +56,8 @@ data Response = Started Int | Start MBL | Listed [MBL] | Ok + | Error String + | Versioned String deriving ( Generic, Show ) {- @@ -54,7 +65,9 @@ data Response = Started Int Hello | await.... Start TriggerStart | Started List | Listed - -> Update mbls | Ok + -> Update mbls | Ok or Error + Version | Versioned + Kill | [dead] -} instance Serialize Response @@ -62,6 +75,12 @@ instance Serialize Response emptyState :: State emptyState = State [] +loop :: (Monad m) => TE.ExceptT e m a -> m e +loop = M.liftM (either id id) . TE.runExceptT . M.forever + +quit :: (Monad m) => e -> TE.ExceptT e m r +quit = TE.throwE + handleCommands :: Con.MVar State -> DP.Handler () handleCommands stateVar reader writer = P.runEffect @@ -71,35 +90,40 @@ handleCommands stateVar reader writer = <-< deserializer <-< reader where - commandExecuter = M.forever $ do - command <- P.await + commandExecuter = loop $ do + command <- lift $ P.await case command of + Version -> do + lift $ P.yield $ Versioned $ showVersion version + Kill -> do + lift $ P.yield $ Ok + quit () List -> do - clients <- lift $ Con.readMVar stateVar + clients <- lift $ lift $ Con.readMVar stateVar let mbls' = mbls <$> unClients clients - P.yield $ Listed mbls' + lift $ P.yield $ Listed mbls' Update newMBLs -> do - lift $ Con.modifyMVar_ stateVar $ \state -> do - clients <- updateMBLs newMBLs (unClients state) - pure $ State clients - P.yield $ Ok + opSuccess <- lift $ lift $ Con.modifyMVar stateVar $ \state -> do + let clients = TE.runExcept $ updateMBLs newMBLs (unClients state) + pure $ (either (const state) State clients, clients) + lift $ P.yield $ either Error (const Ok) opSuccess TriggerStart -> do - clients <- lift $ unClients <$> Con.readMVar stateVar + clients <- lift $ lift $ unClients <$> Con.readMVar stateVar let n = length clients - lift $ M.forM_ clients $ \client -> + lift $ lift $ M.forM_ clients $ \client -> Chan.writeChan (channel client) (mbls client) - P.yield $ Started n - lift $ Con.modifyMVar_ stateVar $ \_ -> pure $ emptyState + lift $ P.yield $ Started n + quit () Hello mbl -> do - newChan <- lift Chan.newChan - clients <- lift $ unClients <$> Con.readMVar stateVar + newChan <- lift $ lift Chan.newChan + clients <- lift $ lift $ unClients <$> Con.readMVar stateVar let otherMbls = mbls <$> clients - mblWithName <- lift $ withName otherMbls mbl + mblWithName <- lift $ lift $ withName otherMbls mbl let newClient = Client mblWithName newChan - lift $ Con.modifyMVar_ stateVar $ \state -> + lift $ lift $ Con.modifyMVar_ stateVar $ \state -> pure $ state { unClients = unClients state <> [newClient] } - newMbl <- lift $ Chan.readChan newChan - P.yield $ Start newMbl + newMbl <- lift $ lift $ Chan.readChan newChan + lift $ P.yield $ Start newMbl withName :: [MBL] -> MBL -> IO MBL withName mbls' mb = case name mb of @@ -148,14 +172,14 @@ possibleNames = ] -updateMBLs :: [MBL] -> [Client] -> IO [Client] +updateMBLs :: [MBL] -> [Client] -> TE.Except String [Client] updateMBLs newMbls cls = M.forM cls update where - update :: Client -> IO Client + update :: Client -> TE.Except String Client update cl = case find (\m -> (name m) == needle) newMbls of Just new -> pure cl { mbls = new } Nothing -> - fail $ "Can't update MBL with name " ++ maybe "-" BS.unpack needle + TE.throwE $ "Can't update MBL with name " ++ maybe "-" BS.unpack needle where needle = (name $ mbls cl) getContent :: C.Source -> IO BS.ByteString @@ -168,56 +192,32 @@ main :: IO () main = do config <- args case config of - C.Inspect (C.InspectConfiguration (C.RunConfiguration source parseConfig)) - -> do + C.Version (C.VersionConfiguration remote) -> do + let port = C.port remote + let host = C.host remote + res <- D.runClient (C.unHost host) port Version + `catch` \(_ :: IOException) -> pure Nothing + putStrLn ("marble (local) " ++ showVersion version) + case res of + Just (Versioned v) -> putStrLn ("marble (daemon) " ++ v) + Nothing -> putStrLn "marble (daemon) not started" + _ -> fail $ "Unexpected response: " ++ show res + C.Configuration c -> case c of + C.Inspect (C.InspectConfiguration (C.RunConfiguration source parseConfig)) + -> do + contents <- getContent source + let parsed = runParser parseConfig contents + either (\e -> fail $ "could not inspect this because " <> e) + (putStrLn . show) + parsed + C.Run (C.RunConfiguration source parseConfig) -> do contents <- getContent source - let parsed = runParser parseConfig contents - either (\e -> fail $ "could not inspect this because " <> e) - (print) - parsed - C.Run (C.RunConfiguration source parseConfig) -> do - contents <- getContent source - mbl <- either (fail) pure $ runParser parseConfig contents - interpret 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 } -- TODO duplicated! - if host == def - then do - state <- Con.newMVar emptyState - D.ensureDaemonWithHandlerRunning "marble-os" - options - (handleCommands state) - else pure () - res <- D.runClient (C.unHost host) port command - case (res :: Maybe Response) of - Just (Listed mbls') -> do - newContents <- E.runUserEditorDWIM (E.mkTemplate "mbl") - (BS.pack $ show mbls') - newMbls <- - either (\e -> fail $ "could not inspect this because " <> e) (pure) - $ parseAll - (C.ParseConfiguration '-' undefined Nothing Nothing Nothing) -- TODO: delimiter is BS. Undefined and general badness - newContents - res2 <- D.runClient (C.unHost host) port (Update newMbls) - case (res2 :: Maybe Response) of - Just Ok -> pure () - _ -> fail $ "Unexpected response: " ++ show res2 - Just (Started count) -> print $ "Started " <> show count - _ -> fail $ "Unexpected response: " ++ show res - - where - command :: Command - command = case config' of - C.List -> List - C.Start -> TriggerStart - C.Sync (C.SyncConfiguration (C.RunConfiguration source parseConfig) remote) - -> do - let port = C.port remote - let host = (C.unHost $ C.host remote) - let options = - def { D.daemonPort = port, D.printOnDaemonStarted = False } -- TODO duplicated! + mbl <- either (fail) pure $ runParser parseConfig contents + interpret mbl + C.Daemon (C.DaemonConfiguration config' remote) -> do + let port = C.port remote + let host = C.host remote + let options = def { D.daemonPort = port } -- TODO duplicated! if host == def then do state <- Con.newMVar emptyState @@ -225,10 +225,58 @@ main = do options (handleCommands state) else pure () - contents <- getContent source - mbl <- either (fail) pure $ runParser parseConfig contents - res <- D.runClient host port (Hello mbl) - case res of - Just (Start newMbl) -> interpret newMbl - _ -> fail $ show res + res <- D.runClient (C.unHost host) port command + case (config', res :: Maybe Response) of + (C.Edit, Just (Listed mbls')) -> do + newContents <- E.runUserEditorDWIM (E.mkTemplate "mbl") + (BS.pack $ show mbls') + newMbls <- + either (\e -> fail $ "could not inspect this because " <> e) + (pure) + $ parseAll + (C.ParseConfiguration '-' undefined Nothing Nothing Nothing) -- TODO: delimiter is BS. Undefined and general badness + newContents + res2 <- D.runClient (C.unHost host) port (Update newMbls) + case (res2 :: Maybe Response) of + Just Ok -> pure () + Just (Error err) -> fail err + _ -> fail $ "Unexpected response: " ++ show res2 + (C.List, Just (Listed mbls')) -> do + putStrLn $ show mbls' + (C.Start, Just (Started count)) -> + putStrLn $ "Started " <> show count + (_, Just Ok) -> putStrLn "ok" + (_, Nothing) -> Exit.exitFailure + _ -> + fail + $ "Unexpected response: " + ++ show res + ++ "for: " + ++ show config' + where + command :: Command + command = case config' of + C.List -> List + C.Edit -> List + C.Start -> TriggerStart + C.Kill -> Kill + C.Sync (C.SyncConfiguration (C.RunConfiguration source parseConfig) remote) + -> do + let port = C.port remote + let host = (C.unHost $ C.host remote) + let options = + def { D.daemonPort = port, D.printOnDaemonStarted = False } -- TODO duplicated! + if host == def + then do + state <- Con.newMVar emptyState + D.ensureDaemonWithHandlerRunning "marble-os" + options + (handleCommands state) + else pure () + contents <- getContent source + mbl <- either (fail) pure $ runParser parseConfig contents + res <- D.runClient host port (Hello mbl) + case res of + Just (Start newMbl) -> interpret newMbl + _ -> fail $ show res diff --git a/src/Args.hs b/src/Args.hs index 142ef7e..96fd08c 100644 --- a/src/Args.hs +++ b/src/Args.hs @@ -27,6 +27,8 @@ import Options.Applicative ( Parser , str , readerAbort , completeWith + , flag' + , briefDesc , ParseError(ErrorMsg) ) import Control.Applicative ( (<|>) @@ -43,16 +45,7 @@ import Data.Char ( toLower ) remote :: Parser C.Remote remote = C.Remote - <$> option - auto - ( long "port" - <> short 'p' - <> help "Port to run the daemon." - <> metavar "PORT" - <> showDefault - <> value 3000 - ) - <*> (C.Host <$> option + <$> (C.Host <$> option str ( long "host" <> short 'h' @@ -62,6 +55,15 @@ remote = <> (value $ C.unHost def) ) ) + <*> option + auto + ( long "port" + <> short 'p' + <> help "Port to run the daemon." + <> metavar "PORT" + <> showDefault + <> value 3000 + ) daemon :: Parser C.DaemonConfiguration daemon = C.DaemonConfiguration <$> daemonSubCmd <*> remote @@ -79,6 +81,18 @@ daemonSubCmd = (fullDesc <> progDesc "List all mbls currently waiting.") ) ) + <> (command "ls" (C.List <$ info (pure ()) briefDesc) <> hidden) + <> command + "edit" + ( C.Edit + <$ (info + (pure () <**> helper) + ( fullDesc + <> progDesc + "Edit the waiting sync'd mbls. Open an $EDITOR to do so. The name is used to update, so feel free to reorder them, but don't change the names" + ) + ) + ) <> command "start" ( C.Start @@ -86,6 +100,13 @@ daemonSubCmd = (fullDesc <> progDesc "Start all mbls currently waiting.") ) ) + <> command + "kill" + ( C.Kill + <$ (info (pure () <**> helper) + (fullDesc <> progDesc "Kill the running daemon.") + ) + ) sync :: Parser C.SyncConfiguration sync = C.SyncConfiguration <$> run <*> remote @@ -119,11 +140,8 @@ parser = <*> lane --Overrides <*> optional - (option - str - (long "name" <> metavar "NAME" <> help - "Name of the lane." - ) + (option str + (long "name" <> metavar "NAME" <> help "Name of the lane.") ) <*> optional (C.TickRate <$> option @@ -194,50 +212,64 @@ run :: Parser C.RunConfiguration run = C.RunConfiguration <$> source <*> parser -args :: IO C.Configuration +version :: Parser C.VersionConfiguration +version = + C.VersionConfiguration + <$> ( flag' + () + (long "version" <> short 'v' <> help "Show local and daemon version" + ) + *> remote + ) + +args :: IO C.Args args = execParser opts where opts = info - ( (subparser - ( command - "run" - ( C.Run - <$> (info (run <**> helper) - (fullDesc <> progDesc "Run the marble file") + ( ( C.Configuration + <$> (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." - ) + <> 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 - "inspect" - ( C.Inspect - <$> (info (inspect <**> helper) - (fullDesc <> progDesc "Inspect a source.") + <> command + "daemon" + ( C.Daemon + <$> (info + (daemon <**> helper) + ( fullDesc + <> progDesc + "Control the daemon to launch `sync`'ed marble clients." + ) + ) ) - ) - <> hidden - ) - ) - <**> helper + <> ( command + "inspect" + ( C.Inspect + <$> (info (inspect <**> helper) + (fullDesc <> progDesc "Inspect a source.") + ) + ) + <> hidden + ) + ) + ) + <**> helper + ) + <|> (C.Version <$> version) ) (fullDesc <> header "marble-os - Run things at your own pace") diff --git a/src/Configuration.hs b/src/Configuration.hs index a31b114..a0d88d5 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -41,14 +41,18 @@ data DaemonConfiguration = DaemonConfiguration DaemonSubConfiguration Remote data InspectConfiguration = InspectConfiguration RunConfiguration -data DaemonSubConfiguration = List | Start +data DaemonSubConfiguration = Edit | List | Start | Kill deriving (Show) + +data VersionConfiguration = VersionConfiguration Remote data Lane = Numbered Int | Named ByteString -data Remote = Remote { port :: Port , host :: Host } +data Remote = Remote { host :: Host, port :: Port } data Configuration = Run RunConfiguration | Sync SyncConfiguration | Daemon DaemonConfiguration | Inspect InspectConfiguration +data Args = Configuration Configuration | Version VersionConfiguration + newtype Host = Host { unHost :: String } deriving (Show, Eq, Read) type Port = Int diff --git a/src/Mbl.hs b/src/Mbl.hs index 5bbb623..56ea634 100644 --- a/src/Mbl.hs +++ b/src/Mbl.hs @@ -118,7 +118,8 @@ isPrint a = case a of escape :: ByteString -> ByteString escape = BS.concatMap escape' - where escape' c = if c == '-' || c == '|' then BS.snoc "\\" c else BS.singleton c + where + escape' c = if c == '-' || c == '|' then BS.snoc "\\" c else BS.singleton c scaleWait :: D.Microseconds -> [Action] -> [Action] scaleWait g as = concatMap scale as