Make object recovery settlement-safe

This commit is contained in:
ms2k 2026-07-18 22:49:19 +09:00
commit cd83841520

View file

@ -1,6 +1,6 @@
module Main (main) where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent (threadDelay)
import Control.Exception (SomeException, try)
import Data.String (fromString)
import Database.PostgreSQL.Simple (Only (..))
@ -14,6 +14,7 @@ import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
import Nuthatch
import Nuthatch.Db (migrate, query_, withDb)
import Nuthatch.Redis (withRedis)
import Nuthatch.Recovery (withLinkedWorker)
import Nuthatch.S3 (newS3)
import System.Directory (doesDirectoryExist)
import System.FilePath ((</>))
@ -30,19 +31,19 @@ main = do
withRedis cfg $ \redis -> do
s3 <- newS3 cfg
let env = newEnv cfg db redis s3
_ <- forkIO (runRecovery env)
let settings =
setPort (cfgListenPort cfg) $
setHost (readHost (cfgListenHost cfg)) defaultSettings
putStrLn $
"nuthatch listening on "
<> cfgListenHost cfg
<> ":"
<> show (cfgListenPort cfg)
runTLS
(tlsSettings (cfgTlsCertPath cfg) (cfgTlsKeyPath cfg))
settings
(application env)
withLinkedWorker (runRecovery env) $ do
let settings =
setPort (cfgListenPort cfg) $
setHost (readHost (cfgListenHost cfg)) defaultSettings
putStrLn $
"nuthatch listening on "
<> cfgListenHost cfg
<> ":"
<> show (cfgListenPort cfg)
runTLS
(tlsSettings (cfgTlsCertPath cfg) (cfgTlsKeyPath cfg))
settings
(application env)
waitForPostgres :: Config -> IO ()
waitForPostgres cfg = go (60 :: Int)