From 707c546cdac5083ad4139a8babcf906f79b8e1e6 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 12 Sep 2019 23:55:10 -0700 Subject: [PATCH] Implemented lockfile with correct handling of SIGINT (^C) and SIGTERM (send by `kill`). --- pkg/king/app/Main.hs | 115 +++++++++++++++++++++++++++--------------- pkg/king/package.yaml | 4 +- stack.yaml | 1 + 3 files changed, 77 insertions(+), 43 deletions(-) diff --git a/pkg/king/app/Main.hs b/pkg/king/app/Main.hs index c7e802fee6..3e329d9cb1 100644 --- a/pkg/king/app/Main.hs +++ b/pkg/king/app/Main.hs @@ -87,7 +87,7 @@ import UrbitPrelude import Data.RAcquire import Arvo -import Control.Exception hiding (evaluate, throwIO) +import Control.Exception (AsyncException(UserInterrupt)) import Data.Acquire import Data.Conduit import Data.Conduit.List hiding (replicate, take) @@ -96,20 +96,23 @@ import Vere.Pier import Vere.Pier.Types import Vere.Serf -import Control.Concurrent (runInBoundThread) -import Control.Lens ((&)) -import System.Directory (doesFileExist, removeFile) -import System.Directory (getHomeDirectory, createDirectoryIfMissing) -import System.Environment (getProgName) -import Text.Show.Pretty (pPrint) -import Urbit.Time (Wen) +import Control.Concurrent (myThreadId, runInBoundThread) +import Control.Lens ((&)) +import Data.Default (def) +import System.Directory (doesFileExist, removeFile) +import System.Directory (createDirectoryIfMissing, getHomeDirectory) +import System.Environment (getProgName) +import System.Posix.Signals (Handler(Catch), installHandler, sigTERM) +import Text.Show.Pretty (pPrint) +import Urbit.Time (Wen) import qualified CLI -import qualified Data.Set as Set -import qualified Vere.Log as Log -import qualified Vere.Pier as Pier -import qualified Vere.Serf as Serf +import qualified Data.Set as Set import qualified EventBrowser +import qualified System.IO.LockFile.Internal as Lock +import qualified Vere.Log as Log +import qualified Vere.Pier as Pier +import qualified Vere.Serf as Serf -------------------------------------------------------------------------------- @@ -162,29 +165,19 @@ removeFileIfExists pax = do -------------------------------------------------------------------------------- -wipeSnapshot :: HasLogFunc env => FilePath -> RIO env () -wipeSnapshot shipPath = do - logTrace "wipeSnapshot" - logDebug $ display $ pack @Text ("Wiping " <> north) - logDebug $ display $ pack @Text ("Wiping " <> south) - removeFileIfExists north - removeFileIfExists south - where - north = shipPath <> "/.urb/chk/north.bin" - south = shipPath <> "/.urb/chk/south.bin" - --------------------------------------------------------------------------------- - tryBootFromPill :: HasLogFunc e => FilePath -> FilePath -> Ship -> RIO e () tryBootFromPill pillPath shipPath ship = do - wipeSnapshot shipPath - rwith (Pier.booted pillPath shipPath [] ship) $ \(serf, log, ss) -> do + rwith bootedPier $ \(serf, log, ss) -> do logTrace "Booting" logTrace $ displayShow ss io $ threadDelay 500000 ss <- shutdown serf 0 logTrace $ displayShow ss logTrace "Booted!" + where + bootedPier = do + lockFile shipPath + Pier.booted pillPath shipPath [] ship runAcquire :: (MonadUnliftIO m, MonadIO m) => Acquire a -> m a @@ -197,24 +190,55 @@ runRAcquire act = rwith act pure tryPlayShip :: HasLogFunc e => FilePath -> RIO e () tryPlayShip shipPath = do runRAcquire $ do + lockFile shipPath rio $ logTrace "RESUMING SHIP" sls <- Pier.resumed shipPath [] rio $ logTrace "SHIP RESUMED" Pier.pier shipPath Nothing sls +lockFile :: HasLogFunc e => FilePath -> RAcquire e () +lockFile pax = void $ mkRAcquire start stop + where + fil = pax <> "/.vere.lock" + + stop handle = do + logInfo $ display @Text $ ("Releasing lock file: " <> pack fil) + io $ Lock.unlock fil handle + + params = def { Lock.retryToAcquireLock = Lock.No } + + start = do + logInfo $ display @Text $ ("Taking lock file: " <> pack fil) + io (Lock.lock params fil) + tryResume :: HasLogFunc e => FilePath -> RIO e () tryResume shipPath = do - rwith (Pier.resumed shipPath []) $ \(serf, log, ss) -> do + rwith resumedPier $ \(serf, log, ss) -> do logTrace (displayShow ss) threadDelay 500000 ss <- shutdown serf 0 logTrace (displayShow ss) logTrace "Resumed!" + where + resumedPier = do + lockFile shipPath + Pier.resumed shipPath [] tryFullReplay :: HasLogFunc e => FilePath -> RIO e () tryFullReplay shipPath = do - wipeSnapshot shipPath + wipeSnapshot tryResume shipPath + where + wipeSnapshot = do + logTrace "wipeSnapshot" + logDebug $ display $ pack @Text ("Wiping " <> north) + logDebug $ display $ pack @Text ("Wiping " <> south) + removeFileIfExists north + removeFileIfExists south + + north = shipPath <> "/.urb/chk/north.bin" + south = shipPath <> "/.urb/chk/south.bin" + -------------------------------------------------------------------------------- @@ -264,6 +288,7 @@ collectAllFx top = do collectedFX :: RAcquire e () collectedFX = do + lockFile top log <- Log.existing (top <> "/.urb/log") serf <- Serf.run (Serf.Config tmpDir serfFlags) rio $ Serf.collectFX serf log @@ -346,21 +371,27 @@ runShip :: HasLogFunc e => CLI.Run -> CLI.Opts -> RIO e () runShip (CLI.Run pierPath) _ = tryPlayShip pierPath startBrowser :: HasLogFunc e => FilePath -> RIO e () -startBrowser pierPath = - rwith (Log.existing logPath) $ \log -> - EventBrowser.run log - where - logPath = pierPath <> "/.urb/log" +startBrowser pierPath = runRAcquire $ do + lockFile pierPath + log <- Log.existing (pierPath <> "/.urb/log") + rio $ EventBrowser.run log main :: IO () -main = CLI.parseArgs >>= runApp . \case - CLI.CmdRun r o -> runShip r o - CLI.CmdNew n o -> newShip n o - CLI.CmdBug (CLI.CollectAllFX pax) -> collectAllFx pax - CLI.CmdBug (CLI.EventBrowser pax) -> startBrowser pax - CLI.CmdBug (CLI.ValidatePill pax pil seq) -> testPill pax pil seq - CLI.CmdBug (CLI.ValidateEvents pax f l) -> checkEvs pax f l - CLI.CmdBug (CLI.ValidateFX pax f l) -> checkFx pax f l +main = do + mainTid <- myThreadId + + let onTermSig = throwTo mainTid UserInterrupt + + installHandler sigTERM (Catch onTermSig) Nothing + + CLI.parseArgs >>= runApp . \case + CLI.CmdRun r o -> runShip r o + CLI.CmdNew n o -> newShip n o + CLI.CmdBug (CLI.CollectAllFX pax) -> collectAllFx pax + CLI.CmdBug (CLI.EventBrowser pax) -> startBrowser pax + CLI.CmdBug (CLI.ValidatePill pax pil seq) -> testPill pax pil seq + CLI.CmdBug (CLI.ValidateEvents pax f l) -> checkEvs pax f l + CLI.CmdBug (CLI.ValidateFX pax f l) -> checkFx pax f l -------------------------------------------------------------------------------- diff --git a/pkg/king/package.yaml b/pkg/king/package.yaml index e36f815f48..2a2946ab35 100644 --- a/pkg/king/package.yaml +++ b/pkg/king/package.yaml @@ -54,6 +54,7 @@ dependencies: - largeword - lens - lmdb + - lock-file - megaparsec - mtl - multimap @@ -79,8 +80,8 @@ dependencies: - tasty-quickcheck - tasty-th - template-haskell - - terminfo - terminal-progress-bar + - terminfo - text - these - time @@ -95,6 +96,7 @@ dependencies: - warp - warp-tls - websockets + - data-default default-extensions: - ApplicativeDo diff --git a/stack.yaml b/stack.yaml index 858a263985..f84739f59a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,6 +7,7 @@ extra-deps: - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81 - flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38 - base58-bytestring-0.1.0@sha256:a1da72ee89d5450bac1c792d9fcbe95ed7154ab7246f2172b57bd4fd9b5eab79 + - lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00 nix: packages: