tabloid-0.45: ShellCmdInputController.hs

module ShellCmdInputController
    (
     Controller
     , new
     , onUpdate
     , view
     , OnUpdate
     , runText
     ) where

import qualified Graphics.UI.Gtk.ModelView as MV 
import qualified ShellCmdInputView as View
import Graphics.UI.Gtk
import Control.Monad
import Control.Applicative
import Control.Concurrent
import qualified System.Process as P
import System.IO
import WindowedApp
import Component
import qualified Data.ByteString.Lazy.Char8 as L
import SimpleRegex
import Control.Concurrent.MVar
import qualified LoadSaveController as LSC

type Controller = Ref C

view = View.mainWidget . gui

new = do
  buf <- textBufferNew Nothing
  lsc <- LSC.new (Just "sh")
  lscv <- (lsc .> LSC.view)
  v@(View.V _ runB _ _ _ _ _) <- View.new buf lscv
  lock <- newEmptyMVar
  this <- newRef (C v "" Nothing buf lock)
  runB `onClicked` (this .<< runText)
  lsc .< (LSC.onLoad (Just (\cont -> textBufferSetText buf (L.unpack cont))))
  lsc .< (LSC.onSave (Just (Just <$> L.pack <$> getBufferText buf)))       
  onBufferChanged buf (lsc .>> LSC.clearLabel)
  return this

type OnUpdate = L.ByteString -> IO ()

onUpdate :: Maybe OnUpdate -> C -> C
onUpdate cb state = state {executeCB = cb}
-- internal functions 
data C = C 
    { 
      gui :: View.ViewState
    , currentCmd :: String
    , executeCB :: Maybe OnUpdate
    , buffer :: TextBuffer
    , execLock :: MVar Bool
    }

getBufferText buf = do
  s <- textBufferGetStartIter buf
  e <- textBufferGetEndIter buf
  textBufferGetText buf s e True
  
runText :: Maybe s -> C -> IO C
runText additionalInput state = do
  locked <- tryPutMVar (execLock state) True
  if locked then
      case executeCB state of
        Just execCB -> 
            do
              text <- getBufferText (buffer state)
              theshell <- entryGetText (View.shellE (gui state))              
              forkOS $ executeCmd text execCB state (words theshell)
              return $ state
        Nothing -> 
            return state
    else return state

executeCmd text execCB state (theshell:theargs) = do 
  postGUISync $ widgetSetSensitivity (View.cancelB $ gui state) True
  postGUISync $ widgetSetSensitivity (View.executeB $ gui state) False
  postGUISync $ widgetSetSensitivity (View.textView $ gui state) False
  postGUISync $ labelSetText (View.exitCodeL $ gui state) $ "Executing..."

  (hin, hout, _, ph) <- P.runInteractiveProcess theshell theargs Nothing  Nothing
  postGUISync $ (View.cancelB $ gui state) `onClicked` (do
                                                         P.terminateProcess ph
                                                         return ())
  forkOS $ do
    hPutStr hin (text ++ otherStdIn)
    lines <- L.hGetContents hout
    postGUISync $ execCB lines
                
  ec <- P.waitForProcess ph 
  postGUISync $ labelSetText (View.exitCodeL $ gui state) $ "Exit Code: " ++ show ec

  postGUISync $ (View.cancelB $ gui state) `onClicked` (return ())
  postGUISync $ widgetSetSensitivity (View.cancelB $ gui state) False
  postGUISync $ widgetSetSensitivity (View.textView $ gui state) True
  postGUISync $ widgetSetSensitivity (View.executeB $ gui state) True
  takeMVar (execLock state)
  return ()
                     
-- tests
main = windowedApp "ShellCmdInputController test" $ do
         t <- new  :: IO Controller
         t .< onUpdate (Just ((mapM_ putStrLn) 
                              . (take 100)  
                              . lines 
                              . L.unpack))
         t .> view