ghc/misc/examples/hsh/Hsh.hs

   1 module Main (main) where
   2
   3 import IO
   4 import Posix
   5
   6 import Directory (setCurrentDirectory)
   7 import System    ( getEnv, exitWith, ExitCode(..) )
   8 import Char      (isSpace)
   9
  10 main :: IO ()
  11 main =
  12    do
  13     initialize
  14     commandLoop
  15
  16 {-
  17    Standard shell practice: move std descriptors out of the way so
  18    it's more convenient to set them up for children.  Also set up an
  19    interrupt handler which will put us back in the main loop.
  20 -}
  21
  22 initialize :: IO ()
  23 initialize =
  24     dupTo stdInput  myStdin                     >>
  25     dupTo stdOutput myStdout                    >>
  26     dupTo stdError  myStderr                    >>
  27     fdClose stdInput                            >>
  28     fdClose stdOutput                           >>
  29 --  fdClose stdError                            >>
  30     installHandler sigINT (Catch intr) Nothing  >>
  31     return ()
  32
  33 -- some random fd numbers...
  34 myStdin  = intToFd 16
  35 myStdout = intToFd 17
  36 myStderr = intToFd 18
  37
  38 -- For user interrupts
  39
  40 intr :: IO ()
  41 intr =
  42     fdWrite myStdout "\n"       >>
  43     commandLoop
  44
  45 {-
  46    Simple command loop: print a prompt, read a command, process the command.
  47    Repeat as necessary.
  48 -}
  49
  50 commandLoop :: IO ()
  51 commandLoop =
  52     fdWrite myStdout "$ "  >>
  53     try (readCommand myStdin)  >>=
  54     either
  55       (\ err ->
  56          if isEOFError err then
  57             return ()
  58          else
  59             dieHorribly)
  60       (\ cmd ->
  61         try (processCommand cmd) >>= either (\ err -> commandLoop) (\ succ -> commandLoop))
  62   where
  63     dieHorribly :: IO ()
  64     dieHorribly =
  65         do
  66          errMsg "read failed"
  67          exitWith (ExitFailure 1)
  68
  69 {-
  70    Read a command a character at a time (to allow for fancy processing later).
  71    On newline, you're done, unless the newline was escaped by a backslash.
  72 -}
  73
  74 readCommand :: Fd -> IO String
  75 readCommand fd =
  76     accumString ""                              >>= \ cmd ->
  77     return cmd
  78   where
  79     accumString :: String -> IO String
  80     accumString s =
  81         myGetChar fd                            >>= \ c ->
  82         case c of
  83           '\\' ->
  84             myGetChar fd                        >>= \ c' ->
  85             accumString (c':c:s)
  86           '\n' -> return (reverse s)
  87           ch  -> accumString (ch:s)
  88
  89 myGetChar :: Fd -> IO Char
  90 myGetChar chan =
  91    do
  92     (s,len) <- fdRead chan 1
  93     case len of
  94       0 -> myGetChar chan
  95       1 -> return (head s)
  96
  97 {-
  98    To process a command, first parse it into words, then do the necessary
  99    redirections, and finally perform the desired command.  Built-ins are
 100    checked first, and if none match, we execute an external command.
 101 -}
 102
 103 processCommand :: String -> IO ()
 104 processCommand "" = return ()
 105 processCommand s =
 106   do
 107    words <- parseCommand s
 108    (inFile, outFile, words) <- parseRedirection words
 109    performRedirections inFile outFile
 110    let
 111     cmd = head words
 112     args = tail words
 113    case builtin cmd of
 114      Just f ->
 115         do
 116          f args
 117          fdClose stdInput
 118          fdClose stdOutput
 119      Nothing -> exec cmd args
 120
 121 {-
 122    Redirections are a bit of a pain, really.  If none are specified, we
 123    dup our own file descriptors.  Otherwise, we try to open the files
 124    as requested.
 125 -}
 126
 127 performRedirections :: Maybe String -> Maybe String -> IO ()
 128 performRedirections inFile outFile =
 129     (case inFile of
 130         Nothing -> dupTo myStdin stdInput
 131         Just x  ->
 132             try (openFd x ReadOnly Nothing defaultFileFlags)
 133                                                 >>=
 134             either
 135               (\ err ->
 136                 errMsg ("Can't redirect input from " ++ x) >>
 137                 fail (userError "redirect"))
 138               (\ succ -> return ()))            >>
 139     (case outFile of
 140         Nothing ->
 141             dupTo myStdout stdOutput
 142         Just x ->
 143             try (createFile x stdFileMode) >>=
 144             either
 145               (\ err ->
 146                 do
 147                  errMsg ("Can't redirect output to " ++ x)
 148                  fdClose stdInput
 149                  fail (userError "redirect"))
 150               (\ succ -> return ()))
 151
 152 {-
 153    We parse a command line into words according to the following rules:
 154     1) Anything inside pairs of "" or '' is parsed literally.
 155     2) Anything (outside of quotes) escaped by \ is taken literally.
 156     3) '<' and '>' are words all by themselves, unless escaped or quoted.
 157     4) Whitespace separates words
 158 -}
 159
 160 parseCommand :: String -> IO [String]
 161 parseCommand = getTokens []
 162   where
 163     getTokens :: [String] -> String -> IO [String]
 164     getTokens ts "" = return (reverse ts)
 165     getTokens ts (c:cs) | isSpace c = getTokens ts cs
 166     getTokens ts s =
 167         getToken s                              >>= \ (t, s') ->
 168         getTokens (t:ts) s'
 169
 170     getToken :: String -> IO (String, String)
 171     getToken (c:cs)
 172       | c == '<' || c == '>' = return ([c], cs)
 173       | c == '"' || c == '\'' = accumQuote c "" cs
 174       | otherwise = accumToken [c] cs
 175
 176     accumToken :: [Char] -> String -> IO (String, String)
 177     accumToken cs "" = return (reverse cs, "")
 178     accumToken cs ('\\':c:s) = accumToken (c:cs) s
 179     accumToken cs x@(c:s)
 180       | isSpace c || c == '<' || c == '>' = return (reverse cs, x)
 181       | c == '"' || c == '\'' = accumQuote c cs s
 182       | otherwise = accumToken (c:cs) s
 183
 184     accumQuote :: Char -> [Char] -> String -> IO (String, String)
 185     accumQuote q cs "" =
 186         errMsg ("Unmatched " ++ [q])            >>
 187         fail (userError "unmatched quote")
 188     accumQuote q cs (c:s)
 189       | c == q = accumToken cs s
 190       | otherwise = accumQuote q (c:cs) s
 191
 192 {-
 193   Here we look for "<" and ">".  When we find one, we remove it and the
 194   following word from the word list.  The arguments following the redirection
 195   symbols and the remaining words are returned to our caller.  However, it's
 196   an error to end a word list with a redirection or for the same redirection
 197   to appear twice.
 198 -}
 199
 200 parseRedirection :: [String] -> IO (Maybe String, Maybe String, [String])
 201 parseRedirection = redirect Nothing Nothing []
 202   where
 203     redirect inFile outFile args [] =
 204         return (inFile, outFile, reverse args)
 205     redirect inFile outFile args [arg]
 206       | arg == "<" || arg == ">" =
 207         errMsg "Missing name for redirect"      >>
 208         fail (userError "parse redirect")
 209       | otherwise =
 210         return (inFile, outFile, reverse (arg:args))
 211     redirect inFile outFile args ("<":name:more)
 212       | inFile == Nothing =
 213         redirect (Just name) outFile args more
 214       | otherwise =
 215         errMsg "Ambiguous input redirect"       >>
 216         fail (userError "parse redirect")
 217     redirect inFile outFile args (">":name:more)
 218       | outFile == Nothing =
 219         redirect inFile (Just name) args more
 220       | otherwise =
 221         errMsg "Ambiguous output redirect"      >>
 222         fail (userError "parse redirect")
 223     redirect inFile outFile args (arg:more) =
 224         redirect inFile outFile (arg:args) more
 225
 226 {-
 227   Executing an external command is pretty simple, but what if it fails?
 228   Fortunately, we don't have any way to redirect stdError just yet,
 229   so we let it complain and then exit.
 230 -}
 231
 232 exec :: String -> [String] -> IO ()
 233 exec cmd args =
 234     forkProcess                                 >>= \ maybe_pid ->
 235     case maybe_pid of
 236       Nothing ->
 237        do
 238         dupTo myStderr stdError
 239         fdClose myStdin
 240         fdClose myStdout
 241         fdClose myStderr
 242         executeFile cmd True args Nothing
 243             `catch`
 244              (\ err ->
 245                fdWrite stdError ("command not found: " ++ cmd ++ ".\n") >>
 246                exitImmediately (ExitFailure 1))
 247       Just pid ->
 248        do
 249         fdClose stdInput
 250         fdClose stdOutput
 251 --      fdClose stdError
 252         getProcessStatus True False pid
 253         return ()
 254
 255 {-
 256     Builtins:
 257         cd [arg] -> change directory (default to HOME)
 258         exit ... -> exit successfully
 259
 260     Builtins must provide their own error messages, since the main command
 261     loop ignores any errors.
 262 -}
 263
 264 builtin :: String -> Maybe ([String] -> IO ())
 265 builtin "cd"   = Just chdir
 266 builtin "exit" = Just exit
 267 builtin _      = Nothing
 268
 269 chdir :: [String] -> IO ()
 270 chdir [] =
 271    do
 272     home <- getEnv "HOME"
 273     setCurrentDirectory home `catch` \ err -> errMsg "cd: can't go home"
 274
 275 chdir [dir] =
 276    do
 277     setCurrentDirectory dir `catch`  \ err -> errMsg ("cd: can't chdir to " ++ dir)
 278 chdir _ =  errMsg "cd: too many arguments"
 279
 280 exit :: [String] -> IO ()
 281 exit _ = exitWith ExitSuccess
 282
 283 -- Print an error message to my std error.
 284
 285 errMsg :: String -> IO ()
 286 errMsg msg =
 287     fdWrite myStderr ("hsh: " ++ msg ++ ".\n")  >>
 288     return ()