75 lines
2.2 KiB
Haskell
75 lines
2.2 KiB
Haskell
|
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.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
|