First version of code

.gitignore

@@ -0,0 +1,3 @@
+.stack-work/
+build-docker/
+*.swp

LICENSE

@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2016 FP Complete
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

README.md

@@ -0,0 +1,37 @@
+## pid1
+
+Do signal handling and orphan reaping for Unix PID1 init processes.
+
+This provides a Haskell library, and an executable based on that library, for
+initializing signal handlers, spawning and child process, and reaping orphan
+processes. These are the responsibilities that must be fulfilled by the initial
+process in a Unix system, and in particular comes up when running Docker
+containers.
+
+This library/executable will automatically detect if it is run as some process
+besides PID1 and, if so, use a straightforward `exec` system call instead.
+
+__NOTE__ This package is decidedly _not_ portable, and will not work on
+Windows. If you have a use case where you think it makes sense to run on
+Windows, I'd be interested in hearing about it.
+
+Blog post on some of the finer points here expected in the future.
+
+### Usage
+
+The recommended use case for this executable is to embed it in a Docker image.
+Assuming you've placed it at `/sbin/pid1`, the two commonly recommended usages
+are:
+
+1. Override the entrypoint, either via `ENTRYPOINT` in your Dockerfile or
+   `--entrypoint` on the command line.
+
+   ```
+   docker run --rm --entrypoint /sbin/pid1 fpco/pid1 ps
+   ```
+
+2. Add `/sbin/pid1` to the beginning of your command.
+
+   ```
+   docker run --rm --entrypoint /usr/bin/env fpco/pid1 /sbin/pid1 ps
+   ```

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,16 @@
+module Main where
+
+import System.Process.PID1
+import System.Environment
+
+main :: IO ()
+main = do
+    -- Figure out the actual thing to run and spawn it off.
+    args0 <- getArgs
+
+    (cmd, args) <-
+        case args0 of
+            [] -> error "No arguments provided"
+            cmd:args -> return (cmd, args)
+
+    run cmd args Nothing

build-docker.sh

@@ -0,0 +1,25 @@
+#!/usr/bin/env bash
+
+set -eux
+
+rm -rf build-docker
+mkdir -p build-docker
+stack install --local-bin-path build-docker
+
+cat > build-docker/Dockerfile <<EOF
+FROM ubuntu:16.04
+MAINTAINER Michael Snoyman ([email protected])
+RUN apt-get update && apt-get install -y libgmp10
+ADD pid1 /sbin/pid1
+ENTRYPOINT ["/sbin/pid1"]
+EOF
+
+docker build --tag fpco/pid1:16.04 build-docker
+
+# Sanity check
+docker run --rm fpco/pid1:16.04 ps
+
+# Push
+docker tag fpco/pid1:16.04 fpco/pid1:latest
+docker push fpco/pid1:16.04
+docker push fpco/pid1:latest

pid1.cabal

@@ -0,0 +1,35 @@
+name:                pid1
+version:             0.1.0.0
+synopsis:            Do signal handling and orphan reaping for Unix PID1 init processes
+description:         Please see README.md
+homepage:            https://github.com/fpco/pid1#readme
+license:             MIT
+license-file:        LICENSE
+author:              Michael Snoyman
+maintainer:          [email protected]
+copyright:           2016 Michael Snoyman
+category:            System
+build-type:          Simple
+extra-source-files:  README.md ChangeLog.md
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     System.Process.PID1
+  build-depends:       base >= 4 && < 5
+                     , process
+                     , unix
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+
+executable pid1
+  hs-source-dirs:      app
+  main-is:             Main.hs
+  ghc-options:         -Wall -threaded
+  build-depends:       base
+                     , pid1
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/fpco/pid1

src/System/Process/PID1.hs

@@ -0,0 +1,155 @@
+-- This is a valid PID 1 process in Haskell, intended as a Docker
+-- entrypoint. It will handle reaping orphans and handling TERM and
+-- INT signals.
+module System.Process.PID1
+    ( run
+    ) where
+
+import           Control.Concurrent       (forkIO, newEmptyMVar, takeMVar,
+                                           threadDelay, tryPutMVar)
+import           Control.Exception        (assert, catch, throwIO)
+import           Control.Monad            (forever, void)
+import           System.Exit              (ExitCode (ExitFailure), exitWith)
+import           System.IO.Error          (isDoesNotExistError)
+import           System.Posix.Process     (ProcessStatus (..), executeFile,
+                                           exitImmediately, getAnyProcessStatus,
+                                           getProcessID)
+import           System.Posix.Signals     (Handler (Catch), Signal,
+                                           installHandler, sigINT, sigKILL,
+                                           sigTERM, signalProcess)
+import           System.Posix.Types       (CPid)
+import           System.Process           (createProcess, proc, env)
+import           System.Process.Internals (ProcessHandle__ (..),
+                                           modifyProcessHandle)
+
+-- | Run the given command with specified arguments, with optional environment
+-- variable override (default is to use the current process's environment)..
+--
+-- This function will check if the current process has a process ID of 1. If it
+-- does, it will install signal handlers for SIGTERM and SIGINT, set up a loop
+-- to reap all orphans, spawn a child process, and when that child dies, kill
+-- all other processes (first with a SIGTERM and then a SIGKILL) and exit with
+-- the child's exit code.
+--
+-- If this process is not PID1, then it will simply @exec@ the given command.
+--
+-- This function will never exit: it will always terminate your process, unless
+-- some exception is thrown.
+--
+-- @since 0.1.0.0
+run :: FilePath -- ^ command to run
+    -> [String] -- ^ command line arguments
+    -> Maybe [(String, String)]
+    -- ^ optional environment variable override, default is current env
+    -> IO a
+run cmd args env' = do
+    -- check if we should act as pid1 or just exec the process
+    myID <- getProcessID
+    if myID == 1
+        then runAsPID1 cmd args env'
+        else executeFile cmd True args env'
+
+-- | Run as a child with signal handling and orphan reaping.
+runAsPID1 :: FilePath -> [String] -> Maybe [(String, String)] -> IO a
+runAsPID1 cmd args env' = do
+    -- Set up an MVar to indicate we're ready to start killing all
+    -- children processes. Then start a thread waiting for that
+    -- variable to be filled and do the actual killing.
+    killChildrenVar <- newEmptyMVar
+    _ <- forkIO $ do
+        takeMVar killChildrenVar
+        killAllChildren
+
+    -- Helper function to start killing, used below
+    let startKilling = void $ tryPutMVar killChildrenVar ()
+
+    -- Install signal handlers for TERM and INT, which will start
+    -- killing all children
+    void $ installHandler sigTERM (Catch startKilling) Nothing
+    void $ installHandler sigINT  (Catch startKilling) Nothing
+
+    -- Spawn the child process
+    (Nothing, Nothing, Nothing, ph) <- createProcess (proc cmd args)
+        { env = env'
+        }
+
+    -- Determine the child PID. We want to exit once this child
+    -- process is dead.
+    p_ <- modifyProcessHandle ph $ \p_ -> return (p_, p_)
+    child <-
+        case p_ of
+            ClosedHandle e -> assert False (exitWith e)
+            OpenHandle pid -> return pid
+
+    -- Loop on reaping child processes
+    reap startKilling child
+
+reap :: IO () -> CPid -> IO a
+reap startKilling child = do
+    -- Track the ProcessStatus of the child
+    childStatus <- newEmptyMVar
+
+    -- Keep reaping one child. Eventually, when all children are dead,
+    -- we'll get an exception. We catch that exception and, assuming
+    -- it's the DoesNotExistError we're expecting, know that all
+    -- children are dead and exit.
+    forever (reapOne childStatus) `catch` \e ->
+        if isDoesNotExistError e
+            -- no more child processes
+            then do
+                takeMVar childStatus >>= exitImmediately . toExitCode
+                error "This can never be reached"
+            -- some other exception occurred, reraise it
+            else throwIO e
+  where
+    reapOne childStatus = do
+        -- Block until a child process exits
+        mres <- getAnyProcessStatus True False
+        case mres of
+            -- This should never happen, if there are no more child
+            -- processes we'll get an exception instead
+            Nothing -> assert False (return ())
+            -- Got a new dead child. If it's the child we created in
+            -- main, then start killing all other children. Otherwise,
+            -- we're just reaping.
+            Just (pid, status)
+                | pid == child -> do
+                    -- Take the first status of the child. It's possible -
+                    -- however unlikely - that the process ID could end up
+                    -- getting reused and there will be another child exiting
+                    -- with the same PID. Just ignore that.
+                    void $ tryPutMVar childStatus status
+                    startKilling
+                | otherwise -> return ()
+
+killAllChildren :: IO ()
+killAllChildren = do
+    -- Send all children processes the TERM signal
+    signalProcess sigTERM (-1) `catch` \e ->
+        if isDoesNotExistError e
+            then return ()
+            else throwIO e
+
+    -- Wait for five seconds. We don't need to put in any logic about
+    -- whether there are still child processes; if all children have
+    -- exited, then the reap loop will exit and our process will shut
+    -- down.
+    threadDelay $ 5 * 1000 * 1000
+
+    -- OK, some children didn't exit. Now time to get serious!
+    signalProcess sigKILL (-1) `catch` \e ->
+        if isDoesNotExistError e
+            then return ()
+            else throwIO e
+
+-- | Convert a ProcessStatus to an ExitCode. In the case of a signal being the
+-- cause of termination, see 'signalToEC'.
+toExitCode :: ProcessStatus -> ExitCode
+toExitCode (Exited ec) = ec
+toExitCode (Terminated sig _) = signalToEC sig
+toExitCode (Stopped sig) = signalToEC sig
+
+-- | Follow the convention of converting a signal into an exit code by adding
+-- 128.
+signalToEC :: Signal -> ExitCode
+signalToEC sig = ExitFailure (fromIntegral sig + 128)

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+# 
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+# 
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-7.1
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+# 
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+# 
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+# 
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.1"
+# 
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+# 
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+# 
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor