{-# LANGUAGE UndecidableInstances #-}

module Chiasma.Native.Api where

import Chiasma.Data.TmuxError (TmuxError)
import Conduit (ConduitT, Flush, mapC, (.|))
import Control.Monad.Catch (MonadMask)
import qualified Control.Monad.Catch as Catch (bracket)
import Data.Conduit.Process.Typed (createSource)
import qualified Data.Text as Text (unwords)
import System.Process.Typed (
  Process,
  ProcessConfig,
  getStdin,
  getStdout,
  proc,
  setStdin,
  setStdout,
  startProcess,
  stopProcess,
  )
import Text.ParserCombinators.Parsec ()

import Chiasma.Api.Class (TmuxApi(..))
import Chiasma.Data.Cmd (Cmd(..), CmdArgs(..), CmdName(..))
import Chiasma.Data.Conduit (createSinkFlush)
import Chiasma.Native.Process (nativeTmuxProcess, socketArg)
import Chiasma.Native.StreamParse (parseConduit)

newtype TmuxNative =
  TmuxNative { TmuxNative -> Maybe FilePath
tmuxServerSocket :: Maybe FilePath }
  deriving Int -> TmuxNative -> ShowS
[TmuxNative] -> ShowS
TmuxNative -> FilePath
(Int -> TmuxNative -> ShowS)
-> (TmuxNative -> FilePath)
-> ([TmuxNative] -> ShowS)
-> Show TmuxNative
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TmuxNative] -> ShowS
$cshowList :: [TmuxNative] -> ShowS
show :: TmuxNative -> FilePath
$cshow :: TmuxNative -> FilePath
showsPrec :: Int -> TmuxNative -> ShowS
$cshowsPrec :: Int -> TmuxNative -> ShowS
Show

formatCmd :: Cmd -> ByteString
formatCmd :: Cmd -> ByteString
formatCmd (Cmd (CmdName Text
name) (CmdArgs [Text]
args)) =
  Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> ([Text] -> Text) -> [Text] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unwords ([Text] -> ByteString) -> [Text] -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
args [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Item [Text]
"\n"]

tmuxProcessConfig ::
  MonadIO m =>
  Maybe FilePath ->
  ProcessConfig (ConduitT (Flush ByteString) Void m ()) (ConduitT () ByteString m ()) ()
tmuxProcessConfig :: Maybe FilePath
-> ProcessConfig
     (ConduitT (Flush ByteString) Void m ())
     (ConduitT () ByteString m ())
     ()
tmuxProcessConfig Maybe FilePath
sock =
  [FilePath]
-> ProcessConfig
     (ConduitT (Flush ByteString) Void m ())
     (ConduitT () ByteString m ())
     ()
forall o i.
[FilePath]
-> ProcessConfig
     (ConduitT (Flush ByteString) o m ())
     (ConduitM i ByteString m ())
     ()
cons [FilePath]
args
  where
    cons :: [FilePath]
-> ProcessConfig
     (ConduitT (Flush ByteString) o m ())
     (ConduitM i ByteString m ())
     ()
cons =
      StreamSpec 'STInput (ConduitT (Flush ByteString) o m ())
-> ProcessConfig () (ConduitM i ByteString m ()) ()
-> ProcessConfig
     (ConduitT (Flush ByteString) o m ())
     (ConduitM i ByteString m ())
     ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput (ConduitT (Flush ByteString) o m ())
forall (m :: * -> *) o.
MonadIO m =>
StreamSpec 'STInput (ConduitT (Flush ByteString) o m ())
createSinkFlush (ProcessConfig () (ConduitM i ByteString m ()) ()
 -> ProcessConfig
      (ConduitT (Flush ByteString) o m ())
      (ConduitM i ByteString m ())
      ())
-> ([FilePath] -> ProcessConfig () (ConduitM i ByteString m ()) ())
-> [FilePath]
-> ProcessConfig
     (ConduitT (Flush ByteString) o m ())
     (ConduitM i ByteString m ())
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamSpec 'STOutput (ConduitM i ByteString m ())
-> ProcessConfig () () ()
-> ProcessConfig () (ConduitM i ByteString m ()) ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput (ConduitM i ByteString m ())
forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource (ProcessConfig () () ()
 -> ProcessConfig () (ConduitM i ByteString m ()) ())
-> ([FilePath] -> ProcessConfig () () ())
-> [FilePath]
-> ProcessConfig () (ConduitM i ByteString m ()) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> ProcessConfig () () ()
proc FilePath
"tmux"
    args :: [FilePath]
args =
      Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe FilePath -> [Text]
socketArg Maybe FilePath
sock [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Item [Text]
"-C", Item [Text]
"attach"])

withProcess :: (MonadIO m, MonadMask m)
            => ProcessConfig stdin stdout stderr
            -> (Process stdin stdout stderr -> m a)
            -> m a
withProcess :: ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcess ProcessConfig stdin stdout stderr
config = m (Process stdin stdout stderr)
-> (Process stdin stdout stderr -> m ())
-> (Process stdin stdout stderr -> m a)
-> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
Catch.bracket (ProcessConfig stdin stdout stderr
-> m (Process stdin stdout stderr)
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr
-> m (Process stdin stdout stderr)
startProcess ProcessConfig stdin stdout stderr
config) Process stdin stdout stderr -> m ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ()
stopProcess

instance (MonadIO m, MonadDeepError e TmuxError m, MonadMask m) => TmuxApi m TmuxNative where
  runCommands :: TmuxNative -> (Text -> Either TmuxDecodeError b) -> Cmds -> m [b]
runCommands (TmuxNative Maybe FilePath
socket) =
    Maybe FilePath
-> (Text -> Either TmuxDecodeError b) -> Cmds -> m [b]
forall (m :: * -> *) e a.
(MonadIO m, MonadDeepError e TmuxError m) =>
Maybe FilePath
-> (Text -> Either TmuxDecodeError a) -> Cmds -> m [a]
nativeTmuxProcess Maybe FilePath
socket

  withTmux :: TmuxNative
-> (ConduitT (Flush Cmd) Void m ()
    -> ConduitT () TmuxOutputBlock m () -> m b)
-> m b
withTmux (TmuxNative Maybe FilePath
socket) ConduitT (Flush Cmd) Void m ()
-> ConduitT () TmuxOutputBlock m () -> m b
f =
    ProcessConfig
  (ConduitT (Flush ByteString) Void m ())
  (ConduitT () ByteString m ())
  ()
-> (Process
      (ConduitT (Flush ByteString) Void m ())
      (ConduitT () ByteString m ())
      ()
    -> m b)
-> m b
forall (m :: * -> *) stdin stdout stderr a.
(MonadIO m, MonadMask m) =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcess (Maybe FilePath
-> ProcessConfig
     (ConduitT (Flush ByteString) Void m ())
     (ConduitT () ByteString m ())
     ()
forall (m :: * -> *).
MonadIO m =>
Maybe FilePath
-> ProcessConfig
     (ConduitT (Flush ByteString) Void m ())
     (ConduitT () ByteString m ())
     ()
tmuxProcessConfig Maybe FilePath
socket) Process
  (ConduitT (Flush ByteString) Void m ())
  (ConduitT () ByteString m ())
  ()
-> m b
handler
    where
      handler :: Process
  (ConduitT (Flush ByteString) Void m ())
  (ConduitT () ByteString m ())
  ()
-> m b
handler Process
  (ConduitT (Flush ByteString) Void m ())
  (ConduitT () ByteString m ())
  ()
prc =
        let
          stdin' :: ConduitT (Flush Cmd) Void m ()
stdin' = (Flush Cmd -> Flush ByteString)
-> ConduitT (Flush Cmd) (Flush ByteString) m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC ((Cmd -> ByteString) -> Flush Cmd -> Flush ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cmd -> ByteString
formatCmd) ConduitT (Flush Cmd) (Flush ByteString) m ()
-> ConduitT (Flush ByteString) Void m ()
-> ConduitT (Flush Cmd) Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Process
  (ConduitT (Flush ByteString) Void m ())
  (ConduitT () ByteString m ())
  ()
-> ConduitT (Flush ByteString) Void m ()
forall stdin stdout stderr. Process stdin stdout stderr -> stdin
getStdin Process
  (ConduitT (Flush ByteString) Void m ())
  (ConduitT () ByteString m ())
  ()
prc
          stdout' :: ConduitT () TmuxOutputBlock m ()
stdout' = Process
  (ConduitT (Flush ByteString) Void m ())
  (ConduitT () ByteString m ())
  ()
-> ConduitT () ByteString m ()
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process
  (ConduitT (Flush ByteString) Void m ())
  (ConduitT () ByteString m ())
  ()
prc ConduitT () ByteString m ()
-> ConduitM ByteString TmuxOutputBlock m ()
-> ConduitT () TmuxOutputBlock m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString TmuxOutputBlock m ()
forall (m :: * -> *).
MonadThrow m =>
ConduitT ByteString TmuxOutputBlock m ()
parseConduit
        in ConduitT (Flush Cmd) Void m ()
-> ConduitT () TmuxOutputBlock m () -> m b
f ConduitT (Flush Cmd) Void m ()
stdin' ConduitT () TmuxOutputBlock m ()
stdout'