nuthatch/app/Main.hs

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