Add Haskell MVP BFF with mutation protocol and local compose stack.

app/Main.hs

@@ -0,0 +1,76 @@
+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
+  , runSettings
+  , setHost
+  , setPort
+  )
+import           Nuthatch
+import           Nuthatch.Config (Config (..))
+import           Nuthatch.Db (migrate, query_, withDb)
+import           Nuthatch.Redis (withRedis)
+import           Nuthatch.S3 (newS3)
+import           System.Directory (doesFileExist)
+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)
+          <> " (auth="
+          <> show (cfgAuthMode cfg)
+          <> ")"
+      runSettings 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" </> "001_schema.sql"
+        , ".." </> "sql" </> "001_schema.sql"
+        , "/app/sql" </> "001_schema.sql"
+        ]
+  existing <- mapM (\p -> doesFileExist p >>= \e -> pure (e, p)) candidates
+  pure $ case [p | (True, p) <- existing] of
+    (p : _) -> p
+    []      -> "sql/001_schema.sql"
+
+readHost :: String -> HostPreference
+readHost = fromString