lib/mlton/basic/init-script.sml

   1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 structure InitScript: INIT_SCRIPT =
   9 struct
  10
  11 val messageStr = Trace.Immediate.messageStr
  12 val op / = String./
  13
  14 (* Losely based on /etc/sysconfig/init *)
  15 local
  16    open Console open Foreground CharRendition
  17    fun make (settings, msg) =
  18       let
  19          val color = concat [moveToColumn 60, "[  ", set settings, msg,
  20                             set [Default], "  ]\n"]
  21          val normal = concat [" [ ", msg, " ]\n"]
  22       in fn () =>
  23          print (case Process.getEnv "TERM" of
  24                   SOME "linux" => color
  25                 | SOME "xterm" => color
  26                 | _ => normal)
  27       end
  28 in
  29    val succeed = make ([Bold, Foreground BrightGreen], "OK")
  30    val fail = make ([Bold, Foreground BrightRed], "FAILED")
  31    val warn = make ([Bold, Foreground Yellow], "PASSED")
  32 end
  33
  34 fun wrap (th: unit -> unit): unit =
  35    ((th () handle e => (fail (); raise e))
  36     ; succeed ())
  37
  38 fun startStop {name, action, log, thunk, usage} =
  39    let
  40       val me = Pid.current ()
  41       fun getProc () =
  42          List.peek (Process.ps (), fn {name = n, pid, ...} =>
  43                     n = name andalso not (Pid.equals (me, pid)))
  44       val isRunning = isSome o getProc
  45       fun start () =
  46          if isRunning ()
  47             then print (concat [name, " is already running\n"])
  48          else
  49             wrap
  50             (fn () =>
  51              let
  52                 val _ = print (concat ["Starting ", name, ":"])
  53                 val _ = Out.close Out.error
  54                 val _ = Out.set (Out.error, Out.openAppend log)
  55                 val _ =
  56                    Process.doubleFork
  57                    (fn () =>
  58                     let
  59                        val _ = In.close In.standard
  60                        val _ = Out.close Out.standard
  61                        val _ = Posix.ProcEnv.setpgid {pid = NONE, pgid = NONE}
  62                        val _ =
  63                           Signal.setHandler
  64                           (Posix.Signal.term, Signal.Handler.handler (fn _ =>
  65                            Thread.new
  66                            (fn () =>
  67                             (messageStr "received Signal.term -- exiting"
  68                              ; Process.succeed ()))))
  69                     in
  70                        thunk ()
  71                     end)
  72              in ()
  73              end)
  74       fun status () =
  75          print (concat [name,
  76                         if isRunning ()
  77                            then " is running\n"
  78                         else " is not running\n"])
  79       fun stop () =
  80          case getProc () of
  81             NONE => print (concat [name, " is not running\n"])
  82           | SOME {pgrp, ...} =>
  83                wrap (fn () =>
  84                      (print (concat ["Shutting down ", name, ":"])
  85                       ; Process.signalGroup (pgrp, Posix.Signal.term)))
  86    in case action of
  87       "start" => start ()
  88     | "status" => status ()
  89     | "stop" => stop ()
  90     | _ => usage "must start|status|stop"
  91    end
  92 end