ghc/misc/examples/hsh/Hsh.hs

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