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.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
  retryStartup
    (cfgStartupAttempts cfg)
    (cfgStartupDelayMs cfg)
    "postgresql"
    (withDb cfg $ \db -> do
      _ <- query_ db "SELECT 1" :: IO [Only Int]
      pure ())
  withDb cfg $ \db -> do
    schemaPath <- findSchema
    retryStartup
      (cfgStartupAttempts cfg)
      (cfgStartupDelayMs cfg)
      "migration"
      (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)

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