gargoyle (empty) → 0.1

raw patch · 4 files changed

+237/−0 lines, 4 filesdep +basedep +directorydep +filelocksetup-changed

Dependencies added: base, directory, filelock, filepath, network, process

Files

LICENSE +12/−0
Setup.hs +2/−0
gargoyle.cabal +32/−0
src/Gargoyle.hs +191/−0

+ LICENSE view

@@ -0,0 +1,12 @@+Copyright (c) 2017, Obsidian Systems LLC+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

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

+ gargoyle.cabal view

@@ -0,0 +1,32 @@+name: gargoyle+version: 0.1+license: BSD3+license-file: LICENSE+author: Obsidian Systems LLC+maintainer: maintainer@obsidian.systems+copyright: Copyright (C) Obsidian Systems LLC 2017+category: System+build-type: Simple+cabal-version: >=1.10+synopsis: Automatically spin up and spin down local daemons+description:+  Gargoyle is a framework for managing daemons from Haskell. In the current release the only requirement is that the daemon be able to communicate over a Unix domain socket. See <https://hackage.haskell.org/package/gargoyle-postgresql gargoyle-postgresql> for a fully worked out example.+  .+  To use Gargoyle the client must:+  .+  1. Define a value of the 'Gargoyle' type which specifies how to administer the daemon.+  2. Create an executable whose `main` is 'gargoyleMain'. The name of this executable should match the executable name specified in the '_gargoyle_exec' field of the 'Gargoyle'.+  3. The client will run their code with 'withGargoyle' to gain access to the daemon.++library+  exposed-modules: Gargoyle+  ghc-options: -Wall+  ghc-prof-options: -fprof-auto+  build-depends: base >= 4.9 && < 4.11+               , directory == 1.3.*+               , filepath == 1.4.*+               , filelock == 0.1.*+               , network == 2.6.*+               , process == 1.4.*+  hs-source-dirs: src+  default-language: Haskell2010

+ src/Gargoyle.hs view

@@ -0,0 +1,191 @@+-- | Utilities for running a daemon in a local directory+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Gargoyle+  ( Gargoyle (..)+  , withGargoyle+  , gargoyleMain+  ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Network.Socket+import System.Directory+import System.Exit+import System.FilePath+import System.IO+import System.IO.Error+import System.Environment+import System.FileLock+import System.Process++import Debug.Trace++data Gargoyle pid a = Gargoyle+  { _gargoyle_exec :: FilePath+    -- ^ The path to the executable created with 'gargoyleMain' which will serve as the daemon+    -- monitor process.+  , _gargoyle_init :: FilePath -> IO ()+    -- ^ The action to run in order to populate the daemon's environment for the first run.+  , _gargoyle_start :: FilePath -> IO pid+    -- ^ The action to run in order to spin up the daemon on every run. This happens after+    -- '_gargoyle_init' if it also runs.+  , _gargoyle_stop :: pid -> IO ()+    -- ^ The action to run when the monitor process detects that no clients are connected anymore.+  , _gargoyle_getInfo :: FilePath -> IO a+    -- ^ Run a command which knows about the working directory of the daemon to collect runtime+    -- information to pass to client code in 'withGargoyle'.+  }++gControlDir :: FilePath -> FilePath+gControlDir = (</> "control")++gWorkDir :: FilePath -> FilePath+gWorkDir = (</> "work")++gOldWorkDir :: FilePath -> FilePath+gOldWorkDir = (</> "db")++gLockDir :: FilePath -> FilePath+gLockDir = (</> "lock")++checkThreadedRuntime :: IO ()+checkThreadedRuntime = when (not rtsSupportsBoundThreads) $ do+  hPutStrLn stderr "Gargoyle requires threaded run-time, aborting"+  assert rtsSupportsBoundThreads (return ()) -- throws an AssertionFailed exception++-- | Run an IO action while maintaining a connection to a daemon. The daemon will automatically be+-- stopped when no clients remain. If the daemon has not yet been initialized, it will be.+-- The counterpart of this function is 'gargoyleMain' which should be used to produce an executable+-- that will monitor the daemon's status.+withGargoyle :: Gargoyle pid a -- ^ Description of how to manage the daemon.+             -> FilePath -- ^ The directory where the daemon should be initialized.+             -> (a -> IO b)+                -- ^ Client action which has access to runtime information provided by+                -- the 'Gargoyle'.+             -> IO b+                -- ^ By the time this function returns, the monitor process is aware that the+                -- the client is no longer interested in the daemon.+withGargoyle g daemonDir b = do+  checkThreadedRuntime+  daemonExists <- doesDirectoryExist daemonDir+  if daemonExists+    then do+    let oldWrk = gOldWorkDir daemonDir+        wrk = gWorkDir daemonDir+    oldWorkDirExists <- doesDirectoryExist oldWrk+    workDirExists <- doesDirectoryExist wrk+    when (oldWorkDirExists && not workDirExists) $ renameDirectory oldWrk wrk+    else do+    createDirectory daemonDir+    _gargoyle_init g (gWorkDir daemonDir)+  s <- socket AF_UNIX Stream defaultProtocol+  let acquire = do+        connectResult <- try $ connect s $ SockAddrUnix $ gControlDir daemonDir+        case connectResult of+          Right () -> return ()+          Left e+            | isDoesNotExistError e -> do+              let monProc = (proc (_gargoyle_exec g) [daemonDir])+                    { std_in = CreatePipe+                    , std_out = CreatePipe+                    , std_err = Inherit }+              (Just monIn, Just monOut, Nothing, monHnd) <- createProcess monProc+              void $ forkOS $ void $ waitForProcess monHnd+              hClose monIn+              r <- hGetLine monOut+              case r of+                "retry" -> do+                  threadDelay 500000 -- These are expensive ops so don't try too hard+                  acquire -- Try again+                "ready" -> acquire+                _ -> fail "Unexpected gargoyle message from monitor process"+            | otherwise -> throwIO e+  bracket_ acquire (shutdown s ShutdownBoth >> close s) $+    b =<< _gargoyle_getInfo g (gWorkDir daemonDir)++-- | Run a local daemon over a domain socket; the daemon will be automatically stopped when+-- no clients remain. This function assumes that the daemon has already been initialized+-- in the specified location. This function should be used as the main function of an executable+-- which will then be invoked by calling 'withGargoyle' in the client code to monitor+-- the daemon's status.+gargoyleMain :: Gargoyle pid a+             -- ^ Description of how to initialize, spin up, and spin down a daemon.+             -> IO () -- ^ Returns only when all clients have disconnected.+gargoyleMain g = do+  checkThreadedRuntime+  [daemonDir] <- getArgs >>= \case+    x@[_] -> return x+    _ -> fail "Gargoyle monitor received unexpected number of arguments"+  let lockPath = gLockDir daemonDir+  -- Make sure the lock file is there+  catch (openFile lockPath WriteMode >>= hClose) $ \(e :: IOException) -> if+    | isAlreadyInUseError e -> return ()+    | isDoesNotExistError e -> throwIO e -- this means it's not a file but it exists+    | isPermissionError e -> throwIO e -- the daemon directory is in a bad state+  -- The daemon tries to hold on to the lock file for its lifetime, signaling that it is+  -- accepting connections.+  lock <- tryLockFile lockPath Exclusive >>= \case+    Just x -> return x+    Nothing -> do+      putStrLn "retry"+      hFlush stdout+      exitFailure+  -- Clients must maintain a connection to controlSocket to ensure that+  -- the daemon doesn't get shut down+  controlSocket <- socket AF_UNIX Stream defaultProtocol+  let socketPath = gControlDir daemonDir+      createSocket = do+        result <- try $ bind controlSocket $ SockAddrUnix socketPath+        case result of+          Right () -> return ()+          Left e+            | isAlreadyInUseError e+            -> do+              -- This is safe because all gargoyle monitors try to take a lock before trying+              -- to mess with the control socket. This avoids race conditions provided that+              -- only gargoyle monitors touch the daemon directory.+              removePathForcibly socketPath+              putStrLn "retry"+              hFlush stdout+              exitFailure+            | otherwise -> throwIO e+  bracket createSocket (\_ -> removeFile socketPath) $ \_ -> do+    -- Between bind and listen, the socket will be in a non-accepting state;+    -- this should last a very brief time, so the client should just briefly wait and then retry+    listen controlSocket 128+    -- TODO: There is a failure mode here: if an interloper connects and disconnects before+    -- the initial caller connects, the initial caller will fail to connect; instead, we should+    -- start up with an existing connection (possibly a pipe passed in from the parent process) and+    -- with this var set to 1+    numClientsVar <- newMVar (0 :: Int)+    -- When this var is filled, the server will shut down+    shutdownVar <- newEmptyMVar+    void $ forkOS $ forever $ do+      (s, _) <- accept controlSocket+      --TODO: What happens if we decide we're shutting down here?+      modifyMVar_ numClientsVar $ \n -> do+        return $ succ n+      forkOS $ do+        h <- socketToHandle s ReadMode+        -- Block until we hit EOF; if we successfully read a character that means the client is+        -- in violation of the protocol, so we shut them down too+        catchJust+          (\e -> if isEOFError e then Just () else e `traceShow` Nothing)+          (hGetChar h >> hPutStrLn stderr "Warning: client sent data over the control socket")+          return+        mask_ $ do+          n <- takeMVar numClientsVar+          case pred n of+            0 -> do+              shutdown controlSocket ShutdownBoth+              putMVar shutdownVar ()+            n' -> putMVar numClientsVar n'+    bracket (_gargoyle_start g (gWorkDir daemonDir)) (_gargoyle_stop g) $ \_ -> do+      hSetBuffering stdout LineBuffering+      putStrLn "ready" -- Signal to the invoker that we're ready+      takeMVar shutdownVar+  unlockFile lock