From 0e4246b21e028729a81b64794906f1947feeb13f Mon Sep 17 00:00:00 2001 From: Daniel Harvey Date: Mon, 17 Feb 2020 02:55:24 +0000 Subject: [PATCH] MVP --- .gitignore | 3 ++ ChangeLog.md | 3 ++ LICENSE | 30 ++++++++++++ README.md | 25 ++++++++++ Setup.hs | 2 + app/Main.hs | 11 +++++ package.yaml | 56 +++++++++++++++++++++ src/Lib.hs | 95 ++++++++++++++++++++++++++++++++++++ src/TmuxMate/Commands.hs | 58 ++++++++++++++++++++++ src/TmuxMate/Running.hs | 56 +++++++++++++++++++++ src/TmuxMate/Types.hs | 55 +++++++++++++++++++++ stack.yaml | 66 +++++++++++++++++++++++++ stack.yaml.lock | 12 +++++ test/Spec.hs | 37 ++++++++++++++ test/Tests/TmuxMate/Types.hs | 42 ++++++++++++++++ test/samples/Sample1.dhall | 9 ++++ test/samples/Sample2.dhall | 12 +++++ 17 files changed, 572 insertions(+) create mode 100644 .gitignore create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 app/Main.hs create mode 100644 package.yaml create mode 100644 src/Lib.hs create mode 100644 src/TmuxMate/Commands.hs create mode 100644 src/TmuxMate/Running.hs create mode 100644 src/TmuxMate/Types.hs create mode 100644 stack.yaml create mode 100644 stack.yaml.lock create mode 100644 test/Spec.hs create mode 100644 test/Tests/TmuxMate/Types.hs create mode 100644 test/samples/Sample1.dhall create mode 100644 test/samples/Sample2.dhall diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..16341cb --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +tmux-mate.cabal +*~ \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..cf5d5bd --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for tmux-mate + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..e637cde --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..ab56b52 --- /dev/null +++ b/README.md @@ -0,0 +1,25 @@ +# tmux-mate + +Manage your tmux sessions with the delicious power of Dhall. + +### Trying it + +To use: + +`git clone https://github.com/danieljharvey/tmux-mate` + +`cd tmux-mate` + +`stack install` + +`export TMUX_MATE_PATH='./test/samples/Sample1.dhall && tmux-mate` + +You should now see some garbage and your session. + +### Making your own dhall files + +Look in `test/samples` for ideas. + +### Requirements + +You will need a recent version of `tmux` installed. I tested on version 3, but I'm pretty sure the commands I am using are pretty basic so should work backwards too. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..5c019d7 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Lib +import System.Environment + +main :: IO () +main = do + path <- lookupEnv "TMUX_MATE_PATH" + case path of + Just dhallPath -> loadTestSession dhallPath + Nothing -> putStrLn "Pass a valid path to TMUX_MATE_PATH pls" diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..d841597 --- /dev/null +++ b/package.yaml @@ -0,0 +1,56 @@ +name: tmux-mate +version: 0.1.0.0 +github: "githubuser/tmux-mate" +license: BSD3 +author: "Author name here" +maintainer: "example@example.com" +copyright: "2020 Author name here" + +extra-source-files: + - README.md + - ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: + - base >= 4.7 && < 5 + +library: + source-dirs: src + dependencies: + - process + - text + - dhall + +executables: + tmux-mate-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - tmux-mate + +tests: + tmux-mate-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - tmux-mate + - QuickCheck + - generic-arbitrary + - dhall + - hspec diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 index 0000000..473a23e --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Lib + ( loadTestSession, + ) +where + +import Control.Exception +import qualified Dhall as Dhall +import System.Process +import TmuxMate.Commands +import TmuxMate.Running +import TmuxMate.Types + +getCommands :: Session -> [Running] -> [Command] +getCommands sesh running = + startSession isNewSession (title sesh) + <> concatMap (addPane (title sesh)) filteredPanes + <> concatMap (removePane (title sesh)) filteredRunning + <> attach isNewSession (title sesh) + where + filteredPanes = + filterPanes (title sesh) running (panes sesh) + filteredRunning = + filterRunning (title sesh) (panes sesh) running + isNewSession = + if length running > 0 + then OldSession + else NewSession + +runCommands :: [Command] -> IO () +runCommands = + mapM_ + ( \(a) -> case a of + Required a -> callCommand a + Optional a -> do + res <- (system a) + pure () + ) + +testSession :: Session +testSession = + Session + { title = SessionName "foo", + panes = + [ Pane (PaneCommand "yes 'Pane 1'") (PaneTitle "One"), + Pane (PaneCommand "yes 'Pane 2'") (PaneTitle "Two"), + Pane (PaneCommand "yes 'Pane 3'") (PaneTitle "Three"), + Pane (PaneCommand "yes 'Pane 4'") (PaneTitle "Four") + ] + } + +filterPanes :: SessionName -> [Running] -> [Pane] -> [Pane] +filterPanes (SessionName seshName) running panes = + filter (\pane -> not $ matchCommand (removeQuotes (getPaneCommand $ paneCommand pane))) panes + where + matchCommand str = + length + ( filter + ( \(Running seshName' run _) -> + removeQuotes run == str + && seshName == seshName' + ) + running + ) + > 0 + +filterRunning :: SessionName -> [Pane] -> [Running] -> [Running] +filterRunning (SessionName seshName) panes running = + filter + ( \(Running seshName' run _) -> + not $ (matchCommand (removeQuotes run) && seshName == seshName') + ) + running + where + matchCommand str = + length + ( filter + ( \pane -> + removeQuotes (getPaneCommand $ paneCommand pane) == str + ) + panes + ) + > 0 + +loadTestSession :: FilePath -> IO () +loadTestSession path = do + let (decoder :: Dhall.Decoder Session) = Dhall.auto + config <- Dhall.inputFile decoder path + running <- askRunning (title config) + print running + let commands = (getCommands config running) + print commands + runCommands commands diff --git a/src/TmuxMate/Commands.hs b/src/TmuxMate/Commands.hs new file mode 100644 index 0000000..53e6069 --- /dev/null +++ b/src/TmuxMate/Commands.hs @@ -0,0 +1,58 @@ +module TmuxMate.Commands (startSession, addPane, attach, removePane) where + +import TmuxMate.Types + +-- trash session in case it's already there +startSession :: IsNewSession -> SessionName -> [Command] +startSession isNew seshTitle = + case isNew of + NewSession -> [newSession seshTitle] + OldSession -> [createAdminWindow seshTitle] + +addPane :: SessionName -> Pane -> [Command] +addPane name (Pane command title) = + [ sendKeys name ("tmux split-window -h -d " <> (getPaneCommand command)) + ] + +removePane :: SessionName -> Running -> [Command] +removePane name (Running _ _ index) = + [ sendKeys name ("tmux kill-pane -t " <> show index) + ] + +attach :: IsNewSession -> SessionName -> [Command] +attach isNew seshTitle = + case isNew of + NewSession -> + [ killAdminWindow seshTitle, + attachToSession seshTitle + ] + OldSession -> [killAdminWindow seshTitle] + +sendKeys :: SessionName -> String -> Command +sendKeys (SessionName name) str = + Required $ + "tmux send-keys -t " <> name <> " \"" + <> str + <> "\" ENTER" + +-- + +attachToSession :: SessionName -> Command +attachToSession (SessionName name) = + Required $ "tmux attach-session -t " <> name + +killSession :: SessionName -> Command +killSession (SessionName name) = + Optional $ "tmux kill-session -t " <> name + +newSession :: SessionName -> Command +newSession (SessionName name) = + Required $ "tmux new-session -d -s " <> name + +createAdminWindow :: SessionName -> Command +createAdminWindow (SessionName name) = + Required $ "tmux split-window -v -t " <> name + +killAdminWindow :: SessionName -> Command +killAdminWindow name = + sendKeys name "exit" diff --git a/src/TmuxMate/Running.hs b/src/TmuxMate/Running.hs new file mode 100644 index 0000000..7c0b97f --- /dev/null +++ b/src/TmuxMate/Running.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module TmuxMate.Running where + +import Control.Exception +import Data.List (intercalate, isPrefixOf) +import Data.Maybe (catMaybes, listToMaybe) +import System.Process +import Text.Read +import TmuxMate.Types + +-- "foo:yes Pane 2\nfoo:yes Pane 1\n" + +askRunning :: SessionName -> IO [Running] +askRunning seshName = do + str <- catch readTmuxProcess (\(e :: IOError) -> pure "") + pure $ parseRunning seshName str + +-- ask Tmux what's cooking +readTmuxProcess :: IO String +readTmuxProcess = + readCreateProcess + (shell "tmux list-pane -as -F '#{session_name}:#{pane_index}:#{pane_start_command}'") + "" + +-- stop unrequired + +removeQuotes :: String -> String +removeQuotes = (filter ((/=) '\'')) + +wordsWhen :: (Char -> Bool) -> String -> [String] +wordsWhen p s = case dropWhile p s of + "" -> [] + s' -> w : wordsWhen p s'' + where + (w, s'') = break p s' + +myLookup :: Int -> [a] -> Maybe a +myLookup _ [] = Nothing +myLookup 0 (x : _) = Just x +myLookup i (_ : xs) = myLookup (i - 1) xs + +parseSingle :: String -> Maybe Running +parseSingle str = + Running <$> seshName <*> cmd <*> index + where + seshName = myLookup 0 subStrs + index = myLookup 1 subStrs >>= readMaybe + cmd = case intercalate ":" (drop 2 subStrs) of + "" -> Nothing + a -> Just a + subStrs = wordsWhen (== ':') str + +parseRunning :: SessionName -> String -> [Running] +parseRunning (SessionName seshName) as = + catMaybes (parseSingle <$> (lines as)) diff --git a/src/TmuxMate/Types.hs b/src/TmuxMate/Types.hs new file mode 100644 index 0000000..5eb5446 --- /dev/null +++ b/src/TmuxMate/Types.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module TmuxMate.Types where + +import Dhall (Decoder, FromDhall, ToDhall, autoWith) +import GHC.Generics + +data IsNewSession + = NewSession + | OldSession + +data Session + = Session + { title :: SessionName, + panes :: [Pane] + } + deriving (Eq, Ord, Show, Generic, FromDhall, ToDhall) + +newtype PaneCommand + = PaneCommand {getPaneCommand :: String} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (ToDhall, FromDhall) + +newtype PaneTitle + = PaneTitle {getPaneTitle :: String} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (ToDhall, FromDhall) + +data Pane + = Pane + { paneCommand :: PaneCommand, + paneTitle :: PaneTitle + } + deriving (Eq, Ord, Show, Generic, FromDhall, ToDhall) + +newtype SessionName + = SessionName {getSessionName :: String} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (FromDhall, ToDhall) + +data Command + = Required String + | Optional String + deriving (Eq, Ord, Show, Generic, FromDhall, ToDhall) + +data Running + = Running + { sessionName :: String, + cmd :: String, + index :: Int + } + deriving (Eq, Ord, Show) diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..8144528 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: nightly-2020-02-15 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: + - . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..455ae6f --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 488352 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/2/15.yaml + sha256: 3c4888f2d80a59256a11e4192fa2ed8f60ee9c23723d46cb5a2d83e40550fc63 + original: nightly-2020-02-15 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..ec08435 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +import Dhall +import Dhall.Core (pretty) +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Tests.TmuxMate.Types (Session) +import TmuxMate.Running +import TmuxMate.Types (Running (..), SessionName (..)) + +--quickCheck dhallSessionRoundtrip + +main :: IO () +main = hspec $ do + describe "ParseRunning" $ do + it "Rejects nonsense" $ do + parseSingle "sdfdsf" `shouldBe` Nothing + it "Accepts goodness" $ do + parseSingle "foo:1:yes Pane 1" `shouldBe` Just (Running "foo" "yes Pane 1" 1) + it "Accepts goodness with double colons inside" $ do + parseSingle "foo:1:yes Pane 1:2" `shouldBe` Just (Running "foo" "yes Pane 1:2" 1) + it "returns the original number when given a positive input" $ + parseRunning (SessionName "foo") "0:0:\nfoo:0:yes Pane 2\nfoo:1:yes Pane 1\n" + `shouldBe` [Running "foo" "yes Pane 2" 0, Running "foo" "yes Pane 1" 1] + describe "Dhall" $ do + it "Round trips Dhall encoding" $ do + property dhallSessionRoundtrip + +dhallSessionRoundtrip :: Property +dhallSessionRoundtrip = + monadicIO $ do + (sesh :: Session) <- pick arbitrary + let dhallVal = pretty (embed inject sesh) + let (decoder :: Decoder Session) = auto + decoded <- run $ input decoder dhallVal + assert $ decoded == sesh diff --git a/test/Tests/TmuxMate/Types.hs b/test/Tests/TmuxMate/Types.hs new file mode 100644 index 0000000..9a0a319 --- /dev/null +++ b/test/Tests/TmuxMate/Types.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Tests.TmuxMate.Types + ( Session, + ) +where + +-- add arbitary types + +import GHC.Generics +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +import TmuxMate.Types + +-- helper + +newtype GenericArb a + = GenericArb {getGenericArb :: a} + deriving (Generic) + +instance (Generic a, Arbitrary a) => Arbitrary (GenericArb a) where + arbitrary = genericArbitrary + +-- helper + +instance Arbitrary Session where + arbitrary = genericArbitrary + +instance Arbitrary SessionName where + arbitrary = genericArbitrary + +instance Arbitrary Pane where + arbitrary = genericArbitrary + +instance Arbitrary PaneTitle where + arbitrary = oneof [pure (PaneTitle "title")] + +instance Arbitrary PaneCommand where + arbitrary = oneof [pure (PaneCommand "command")] diff --git a/test/samples/Sample1.dhall b/test/samples/Sample1.dhall new file mode 100644 index 0000000..f349473 --- /dev/null +++ b/test/samples/Sample1.dhall @@ -0,0 +1,9 @@ +{ title = "foo", + panes = [ { + paneCommand = "yes 'Pane 1'", paneTitle = "One" + }, + { + paneCommand = "yes 'Pane 2'", paneTitle = "Two" + } + ] +} \ No newline at end of file diff --git a/test/samples/Sample2.dhall b/test/samples/Sample2.dhall new file mode 100644 index 0000000..2865294 --- /dev/null +++ b/test/samples/Sample2.dhall @@ -0,0 +1,12 @@ +{ title = "foo", + panes = [ { + paneCommand = "yes 'Pane 1'", paneTitle = "One" + }, + { + paneCommand = "yes 'Pane 2'", paneTitle = "Two" + }, + { + paneCommand = "yes 'Pane 3'", paneTitle = "Three" + } + ] +} \ No newline at end of file