nuthatch/app/Main.hs

module Main (main) where

import           Control.Concurrent (forkIO, 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.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
      _ <- 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)

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