{- - - Copyright 2005-2008, Robert Dockins. - -} module System.Console.Shell.RunShell ( runShell , defaultExceptionHandler , simpleSubshell ) where import Data.Maybe ( isJust ) import Data.Char ( isSpace ) import Data.List ( isPrefixOf, find ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Control.Monad ( when, MonadPlus(..) ) import Control.Monad.Error () import Control.Concurrent ( ThreadId, threadDelay, killThread, forkIO ) import Control.Concurrent.MVar ( MVar, newEmptyMVar, tryTakeMVar, tryPutMVar, withMVar, takeMVar, putMVar ) import System.Directory ( doesFileExist ) import qualified Control.Exception as Ex import System.Console.Shell.Backend import System.Console.Shell.ShellMonad import System.Console.Shell.Types import System.Console.Shell.Commands import System.Console.Shell.PPrint import System.Console.Shell.Regex (runRegex) import System.Console.Shell.ConsoleHandler ------------------------------------------------------------------- -- A record to hold some of the internal muckety-muck needed -- to make the shell go. This is mostly concurrency variables -- needed to handle keyboard interrupts. data InternalShellState st bst = InternalShellState { evalVar :: MVar (Maybe (st,Maybe (ShellSpecial st))) , evalThreadVar :: MVar ThreadId , cancelHandler :: IO () , backendState :: bst , continuedInput :: MVar String } ------------------------------------------------------------------- -- Main entry point for the shell. Sets up all the internal state -- needed to run shell commands and evaluation in a separate thread and -- initializes the backend. -- | Run a shell. Given a shell description, a shell backend to use -- and an initial state this function runs the shell until it exits, -- and then returns the final state. runShell :: ShellDescription st -> ShellBackend bst -> st -> IO st runShell desc backend init = Ex.bracket setupShell exitShell (\iss -> executeShell desc backend iss init) where setupShell = do evVar <- newEmptyMVar thVar <- newEmptyMVar ci <- newEmptyMVar bst <- initBackend backend return InternalShellState { evalVar = evVar , evalThreadVar = thVar , cancelHandler = handleINT evVar thVar , backendState = bst , continuedInput = ci } exitShell iss = do shutdownBackend backend (backendState iss) executeShell :: ShellDescription st -> ShellBackend bst -> InternalShellState st bst -> st -> IO st executeShell desc backend iss init = do when (historyEnabled desc) (do setMaxHistoryEntries backend (backendState iss) (maxHistoryEntries desc) loadHistory desc backend (backendState iss)) maybe (return ()) (outputString backend (backendState iss) . InfoOutput) (greetingText desc) final <- shellLoop desc backend iss init when (historyEnabled desc) (do saveHistory desc backend (backendState iss) clearHistoryState backend (backendState iss)) flushOutput backend (backendState iss) return final -- helper function that triggers when an INT signal is caught handleINT :: MVar (Maybe (st,Maybe (ShellSpecial st))) -> MVar ThreadId -> IO () handleINT evVar thVar = do x <- tryPutMVar evVar Nothing when x (withMVar thVar killThread) ------------------------------------------------------------------------- -- This function is installed as the attempted completion function. -- It attempts to match the prefix of the input buffer against a -- command. If it matches, it supplies the completions appropriate -- for that point in the command. Otherwise it returns Nothing; in -- that case, the backend will fall back on the default completion function -- set in the shell description. completionFunction :: ShellDescription st -> ShellBackend bst -> bst -> st -> (String,String,String) -> IO (Maybe (String,[String])) completionFunction desc backend bst st line@(before,word,after) = do if all isSpace before then completeCommands desc line else case runRegex (commandsRegex desc) before of [((_,cmdParser,_,_),before')] -> do let completers = [ z | IncompleteParse (Just z) <- cmdParser before' ] strings <- case completers of FilenameCompleter:_ -> completeFilename backend bst word >>= return . Just UsernameCompleter:_ -> completeUsername backend bst word >>= return . Just (OtherCompleter f):_ -> f st word >>= return . Just _ -> return Nothing case strings of Nothing -> return Nothing Just [] -> return Nothing Just xs -> return (Just (maximalPrefix xs,xs)) _ -> return Nothing completeCommands :: ShellDescription st -> (String,String,String) -> IO (Maybe (String,[String])) completeCommands desc (before,word,after) = case matchingNames of [] -> return $ Nothing xs -> return $ Just (maximalPrefix xs,xs) where matchingNames = filter (word `isPrefixOf`) cmdNames cmdNames = map (\ (n,_,_,_) -> (maybePrefix desc)++n) (getShellCommands desc) maximalPrefix :: [String] -> String maximalPrefix [] = [] maximalPrefix (x:xs) = f x xs where f p [] = p f p (x:xs) = f (fst $ unzip $ takeWhile (\x -> fst x == snd x) $ zip p x) xs ----------------------------------------------------------- -- Deal with reading and writing history files. loadHistory :: ShellDescription st -> ShellBackend bst -> bst -> IO () loadHistory desc backend bst = case historyFile desc of Nothing -> return () Just path -> do fexists <- doesFileExist path when fexists $ Ex.handle (\(ex::ShellacException) -> (outputString backend bst) (ErrorOutput $ concat ["could not read history file '",path,"'\n ",show ex])) (readHistory backend bst path) saveHistory :: ShellDescription st -> ShellBackend bst -> bst -> IO () saveHistory desc backend bst = case historyFile desc of Nothing -> return () Just path -> Ex.handle (\(ex::ShellacException) -> (outputString backend bst) (ErrorOutput $ concat ["could not write history file '",path,"'\n ",show ex])) (writeHistory backend bst path) ----------------------------------------------------------- -- The real meat. We setup backend stuff, call the backend -- to get the input string, and then handle the input. shellLoop :: ShellDescription st -> ShellBackend bst -> InternalShellState st bst -> st -> IO st shellLoop desc backend iss = loop where bst = backendState iss loop st = do flushOutput backend bst runSh st (outputString backend bst) (beforePrompt desc) setAttemptedCompletionFunction backend bst (completionFunction desc backend bst st) case defaultCompletions desc of Nothing -> setDefaultCompletionFunction backend bst $ Nothing Just f -> setDefaultCompletionFunction backend bst $ Just (f st) setWordBreakChars backend bst (wordBreakChars desc) ci <- tryTakeMVar (continuedInput iss) pr <- getPrompt (isJust ci) st inp <- doGetInput ci pr case inp of Nothing -> (outputString backend bst) (RegularOutput "\n") >> return st Just inp' -> if not (isJust ci) then handleInput inp' st else evaluateInput inp' st doGetInput :: Maybe String -> String -> IO (Maybe String) doGetInput ci pr = case commandStyle desc of SingleCharCommands -> do c <- getSingleChar backend bst pr return (fmap (:[]) c) _ -> do str <- getInput backend bst pr return (fmap (\x -> maybe x (++ '\n':x) ci) str) getPrompt False st = prompt desc st getPrompt True st = case secondaryPrompt desc of Nothing -> prompt desc st Just f -> f st handleInput inp st = do when (historyEnabled desc && (isJust (find (not . isSpace) inp))) (addHistory backend bst inp) let inp' = inp++" " -- hack, makes commands unambiguous case runRegex (commandsRegex desc) inp' of (x,inp''):_ -> executeCommand x inp'' st [] -> evaluateInput inp st executeCommand (cmdName,cmdParser,_,_) inp st = let parses = cmdParser inp parses' = concatMap (\x -> case x of CompleteParse z -> [z]; _ -> []) parses in case parses' of f:_ -> do r <- handleExceptions desc (\x -> runSh x (outputString backend bst) f) st case r of (st',Just spec) -> handleSpecial st' spec (st',Nothing) -> loop st' _ -> (outputString backend bst) (InfoOutput $ showCmdHelp desc cmdName) >> loop st handleSpecial st ShellExit = return st handleSpecial st ShellNothing = loop st handleSpecial st (ShellHelp Nothing) = (outputString backend bst) (InfoOutput $ showShellHelp desc) >> loop st handleSpecial st (ShellHelp (Just cmd)) = (outputString backend bst) (InfoOutput $ showCmdHelp desc cmd) >> loop st handleSpecial st (ShellContinueLine str) = putMVar (continuedInput iss) str >> loop st handleSpecial st (ExecSubshell subshell) = runSubshell desc subshell backend bst st >>= loop handleExceptions desc f st = Ex.catch (f st) $ \ex -> runSh st (outputString backend bst) (exceptionHandler desc ex) runThread eval inp iss st = do val <- handleExceptions desc (\x -> runSh x (outputString backend bst) (eval inp)) st tryPutMVar (evalVar iss) (Just val) return () evaluateInput inp st = let eVar = evalVar iss tVar = evalThreadVar iss in do tryTakeMVar eVar tryTakeMVar tVar tid <- forkIO (runThread (evaluateFunc desc) inp iss st) putMVar tVar tid result <- withControlCHandler (cancelHandler iss) (takeMVar eVar) case result of Nothing -> onCancel backend bst >> loop st Just (st',Just spec) -> handleSpecial st' spec Just (st',Nothing) -> loop st' ------------------------------------------------------------------------- -- | The default shell exception handler. It simply prints the exception -- and returns the shell state unchanged. (However, it specificaly -- ignores the thread killed exception, because that is used to -- implement execution canceling) #ifdef BASE4 defaultExceptionHandler :: ShellacException -> Sh st () defaultExceptionHandler ex = case Ex.fromException ex of Just Ex.ThreadKilled -> return () _ -> shellPutErrLn $ concat ["The following exception occurred:\n ",show ex] #else defaultExceptionHandler :: ShellacException -> Sh st () defaultExceptionHandler (Ex.AsyncException Ex.ThreadKilled) = return () defaultExceptionHandler ex = do shellPutErrLn $ concat ["The following exception occurred:\n ",show ex] #endif ---------------------------------------------------------------------------- -- | Creates a simple subshell from a state mapping function -- and a shell description. simpleSubshell :: (st -> IO st') -- ^ A function to generate the initial subshell -- state from the outer shell state -> ShellDescription st' -- ^ A shell description for the subshell -> IO (Subshell st st') simpleSubshell toSubSt desc = do ref <- newIORef undefined let toSubSt' st = writeIORef ref st >> toSubSt st let fromSubSt subSt = readIORef ref let mkDesc _ = return desc return (toSubSt',fromSubSt,mkDesc) ---------------------------------------------------------------------------- -- | Execute a subshell, suspending the outer shell until the subshell exits. runSubshell :: ShellDescription desc -- ^ the description of the outer shell -> Subshell st st' -- ^ the subshell to execute -> ShellBackend bst -- ^ the shell backend to use -> bst -- ^ the backendstate -> st -- ^ the current state -> IO st -- ^ the modified state runSubshell desc (toSubSt, fromSubSt, mkSubDesc) backend bst st = do subSt <- toSubSt st subDesc <- mkSubDesc subSt evVar <- newEmptyMVar thVar <- newEmptyMVar ci <- newEmptyMVar let iss = InternalShellState { evalVar = evVar , evalThreadVar = thVar , cancelHandler = handleINT evVar thVar , backendState = bst , continuedInput = ci } subSt' <- executeShell subDesc backend iss subSt st' <- fromSubSt subSt' return st'