76 lines
2.3 KiB
Haskell
76 lines
2.3 KiB
Haskell
module Main (main) where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Exception (SomeException, try)
|
|
import Data.String (fromString)
|
|
import Database.PostgreSQL.Simple (Only (..))
|
|
import Network.Wai.Handler.Warp
|
|
( HostPreference
|
|
, defaultSettings
|
|
, setHost
|
|
, setPort
|
|
)
|
|
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 ((</>))
|
|
import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
hSetBuffering stdout LineBuffering
|
|
cfg <- loadConfig
|
|
waitForPostgres cfg
|
|
withDb cfg $ \db -> do
|
|
schemaPath <- findSchema
|
|
migrate db schemaPath cfg
|
|
withRedis cfg $ \redis -> do
|
|
s3 <- newS3 cfg
|
|
let env = newEnv cfg db redis s3
|
|
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)
|
|
where
|
|
go 0 = fail "postgres did not become ready"
|
|
go n = do
|
|
result <- try $ withDb cfg $ \db -> do
|
|
_ <- query_ db "SELECT 1" :: IO [Only Int]
|
|
pure ()
|
|
case result of
|
|
Right () -> pure ()
|
|
Left (e :: SomeException) -> do
|
|
putStrLn $ "waiting for postgres (" <> show n <> "): " <> show e
|
|
threadDelay 1000000
|
|
go (n - 1)
|
|
|
|
findSchema :: IO FilePath
|
|
findSchema = do
|
|
let candidates =
|
|
[ "sql"
|
|
, ".." </> "sql"
|
|
, "/app/sql"
|
|
]
|
|
existing <- mapM (\p -> doesDirectoryExist p >>= \e -> pure (e, p)) candidates
|
|
pure $ case [p | (True, p) <- existing] of
|
|
(p : _) -> p
|
|
[] -> "sql"
|
|
|
|
readHost :: String -> HostPreference
|
|
readHost = fromString
|