77 lines
2.4 KiB
Haskell
77 lines
2.4 KiB
Haskell
module Main (main) where
|
|
|
|
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.Mutation.Recovery (runRecovery)
|
|
import Nuthatch.Redis (withRedis)
|
|
import Nuthatch.Recovery (withLinkedWorker)
|
|
import Nuthatch.Runtime (retryStartup)
|
|
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
|
|
let runtimeCfg = cfgRuntime cfg
|
|
httpCfg = cfgHttp cfg
|
|
postgresCfg = cfgPostgres cfg
|
|
redisCfg = cfgRedis cfg
|
|
s3Cfg = cfgS3 cfg
|
|
productCfg = cfgProduct cfg
|
|
retryStartup
|
|
(cfgStartupAttempts runtimeCfg)
|
|
(cfgStartupDelayMs runtimeCfg)
|
|
"postgresql"
|
|
(withDb postgresCfg $ \db -> do
|
|
_ <- query_ db "SELECT 1" :: IO [Only Int]
|
|
pure ())
|
|
withDb postgresCfg $ \db -> do
|
|
schemaPath <- findSchema
|
|
retryStartup
|
|
(cfgStartupAttempts runtimeCfg)
|
|
(cfgStartupDelayMs runtimeCfg)
|
|
"migration"
|
|
(migrate db schemaPath productCfg)
|
|
withRedis redisCfg $ \redis -> do
|
|
s3 <- newS3 s3Cfg
|
|
let env = newEnv cfg db redis s3
|
|
withLinkedWorker (runRecovery env) $ do
|
|
let settings =
|
|
setPort (cfgListenPort httpCfg) $
|
|
setHost (readHost (cfgListenHost httpCfg)) defaultSettings
|
|
putStrLn $
|
|
"nuthatch listening on "
|
|
<> cfgListenHost httpCfg
|
|
<> ":"
|
|
<> show (cfgListenPort httpCfg)
|
|
runTLS
|
|
(tlsSettings (cfgTlsCertPath httpCfg) (cfgTlsKeyPath httpCfg))
|
|
settings
|
|
(application env)
|
|
|
|
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
|