Add Haskell MVP BFF with mutation protocol and local compose stack.
This commit is contained in:
parent
5759938f3f
commit
6bc08bd7bf
1 changed files with 3123 additions and 3 deletions
157
src/Nuthatch/Config.hs
Normal file
157
src/Nuthatch/Config.hs
Normal file
|
|
@ -0,0 +1,157 @@
|
|||
module Nuthatch.Config
|
||||
( Config (..)
|
||||
, AuthMode (..)
|
||||
, loadConfig
|
||||
) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import System.Environment (lookupEnv)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
data AuthMode = AuthDev
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data Config = Config
|
||||
{ cfgListenHost :: String
|
||||
, cfgListenPort :: Int
|
||||
, cfgPublicBaseUrl :: Text
|
||||
, cfgJwtSecret :: Text
|
||||
, cfgSessionHours :: Integer
|
||||
, cfgCookieName :: Text
|
||||
, cfgCsrfCookieName :: Text
|
||||
, cfgPgConn :: String
|
||||
, cfgRedisHost :: String
|
||||
, cfgRedisPort :: Int
|
||||
, cfgRedisDb :: Integer
|
||||
, cfgS3Endpoint :: Text
|
||||
, cfgS3Region :: Text
|
||||
, cfgS3Bucket :: Text
|
||||
, cfgS3AccessKey :: Text
|
||||
, cfgS3SecretKey :: Text
|
||||
, cfgS3PathStyle :: Bool
|
||||
, cfgPersonalQuotaBytes :: Integer
|
||||
, cfgSharedQuotaBytes :: Integer
|
||||
, cfgMaxObjectBytes :: Integer
|
||||
, cfgThrottleBytesPerSec :: Integer
|
||||
, cfgThrottleBurstBytes :: Integer
|
||||
, cfgListCacheTtlSec :: Integer
|
||||
, cfgSearchMaxKeys :: Int
|
||||
, cfgRecoveryGraceSec :: Integer
|
||||
, cfgAuthMode :: AuthMode
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
loadConfig :: IO Config
|
||||
loadConfig = do
|
||||
listen <- fromMaybe "127.0.0.1:8080" <$> lookupEnv "NUTHATCH_LISTEN"
|
||||
let (host, portText) = splitHostPort listen
|
||||
port <- requireRead "NUTHATCH_LISTEN port" portText
|
||||
publicBase <- T.pack . fromMaybe ("http://" <> listen) <$> lookupEnv "NUTHATCH_PUBLIC_BASE_URL"
|
||||
jwtSecret <- T.pack . fromMaybe "dev-only-change-me-to-a-long-random-string" <$> lookupEnv "NUTHATCH_JWT_SECRET"
|
||||
when (T.length jwtSecret < 16) $
|
||||
fail "NUTHATCH_JWT_SECRET must be at least 16 characters"
|
||||
sessionHours <- envInteger "NUTHATCH_SESSION_HOURS" 12
|
||||
cookieName <- T.pack . fromMaybe "nuthatch_session" <$> lookupEnv "NUTHATCH_COOKIE_NAME"
|
||||
csrfCookie <- T.pack . fromMaybe "nuthatch_csrf" <$> lookupEnv "NUTHATCH_CSRF_COOKIE_NAME"
|
||||
pgConn <- fromMaybe "host=127.0.0.1 port=5432 user=nuthatch password=nuthatch dbname=nuthatch"
|
||||
<$> lookupEnv "NUTHATCH_PG_CONN"
|
||||
redisUrl <- fromMaybe "redis://127.0.0.1:6379/0" <$> lookupEnv "NUTHATCH_REDIS_URL"
|
||||
(redisHost, redisPort, redisDb) <- parseRedisUrl redisUrl
|
||||
s3Endpoint <- T.pack . fromMaybe "http://127.0.0.1:9000" <$> lookupEnv "NUTHATCH_S3_ENDPOINT"
|
||||
s3Region <- T.pack . fromMaybe "us-east-1" <$> lookupEnv "NUTHATCH_S3_REGION"
|
||||
s3Bucket <- T.pack . fromMaybe "nuthatch" <$> lookupEnv "NUTHATCH_S3_BUCKET"
|
||||
s3Access <- T.pack . fromMaybe "minioadmin" <$> lookupEnv "NUTHATCH_S3_ACCESS_KEY"
|
||||
s3Secret <- T.pack . fromMaybe "minioadmin" <$> lookupEnv "NUTHATCH_S3_SECRET_KEY"
|
||||
pathStyle <- envBool "NUTHATCH_S3_PATH_STYLE" True
|
||||
personalQuota <- envInteger "NUTHATCH_PERSONAL_QUOTA_BYTES" (1024 * 1024 * 1024)
|
||||
sharedQuota <- envInteger "NUTHATCH_SHARED_QUOTA_BYTES" (10 * 1024 * 1024 * 1024)
|
||||
maxObject <- envInteger "NUTHATCH_MAX_OBJECT_BYTES" (100 * 1024 * 1024)
|
||||
throttleRate <- envInteger "NUTHATCH_THROTTLE_BYTES_PER_SEC" (10 * 1024 * 1024)
|
||||
throttleBurst <- envInteger "NUTHATCH_THROTTLE_BURST_BYTES" (20 * 1024 * 1024)
|
||||
listTtl <- envInteger "NUTHATCH_LIST_CACHE_TTL_SEC" 30
|
||||
searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
|
||||
recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
|
||||
authModeText <- fromMaybe "dev" <$> lookupEnv "NUTHATCH_AUTH_MODE"
|
||||
authMode <- case authModeText of
|
||||
"dev" -> pure AuthDev
|
||||
other -> fail $ "unsupported NUTHATCH_AUTH_MODE: " <> other
|
||||
pure Config
|
||||
{ cfgListenHost = host
|
||||
, cfgListenPort = port
|
||||
, cfgPublicBaseUrl = publicBase
|
||||
, cfgJwtSecret = jwtSecret
|
||||
, cfgSessionHours = sessionHours
|
||||
, cfgCookieName = cookieName
|
||||
, cfgCsrfCookieName = csrfCookie
|
||||
, cfgPgConn = pgConn
|
||||
, cfgRedisHost = redisHost
|
||||
, cfgRedisPort = redisPort
|
||||
, cfgRedisDb = redisDb
|
||||
, cfgS3Endpoint = s3Endpoint
|
||||
, cfgS3Region = s3Region
|
||||
, cfgS3Bucket = s3Bucket
|
||||
, cfgS3AccessKey = s3Access
|
||||
, cfgS3SecretKey = s3Secret
|
||||
, cfgS3PathStyle = pathStyle
|
||||
, cfgPersonalQuotaBytes = personalQuota
|
||||
, cfgSharedQuotaBytes = sharedQuota
|
||||
, cfgMaxObjectBytes = maxObject
|
||||
, cfgThrottleBytesPerSec = throttleRate
|
||||
, cfgThrottleBurstBytes = throttleBurst
|
||||
, cfgListCacheTtlSec = listTtl
|
||||
, cfgSearchMaxKeys = searchMax
|
||||
, cfgRecoveryGraceSec = recoveryGrace
|
||||
, cfgAuthMode = authMode
|
||||
}
|
||||
|
||||
splitHostPort :: String -> (String, String)
|
||||
splitHostPort s =
|
||||
case break (== ':') s of
|
||||
(h, ':' : p) -> (h, p)
|
||||
_ -> ("127.0.0.1", "8080")
|
||||
|
||||
envInteger :: String -> Integer -> IO Integer
|
||||
envInteger name def = do
|
||||
m <- lookupEnv name
|
||||
case m of
|
||||
Nothing -> pure def
|
||||
Just v -> requireRead name v
|
||||
|
||||
envBool :: String -> Bool -> IO Bool
|
||||
envBool name def = do
|
||||
m <- lookupEnv name
|
||||
case fmap T.toLower (T.pack <$> m) of
|
||||
Nothing -> pure def
|
||||
Just "1" -> pure True
|
||||
Just "true" -> pure True
|
||||
Just "yes" -> pure True
|
||||
Just "0" -> pure False
|
||||
Just "false" -> pure False
|
||||
Just "no" -> pure False
|
||||
Just other -> fail $ name <> ": invalid boolean " <> T.unpack other
|
||||
|
||||
requireRead :: (Read a) => String -> String -> IO a
|
||||
requireRead name v =
|
||||
case readMaybe v of
|
||||
Just x -> pure x
|
||||
Nothing -> fail $ name <> ": cannot parse " <> v
|
||||
|
||||
parseRedisUrl :: String -> IO (String, Int, Integer)
|
||||
parseRedisUrl url =
|
||||
case T.stripPrefix "redis://" (T.pack url) of
|
||||
Nothing -> fail "NUTHATCH_REDIS_URL must start with redis://"
|
||||
Just rest -> do
|
||||
let (hostPort, dbPart) =
|
||||
case T.breakOn "/" rest of
|
||||
(hp, d) | T.null d -> (hp, "/0")
|
||||
(hp, d) -> (hp, d)
|
||||
(hostText, portText) =
|
||||
case T.breakOn ":" hostPort of
|
||||
(h, p) | T.null p -> (h, "6379")
|
||||
(h, p) -> (h, T.drop 1 p)
|
||||
port <- requireRead "redis port" (T.unpack portText)
|
||||
db <- requireRead "redis db" (T.unpack (T.drop 1 dbPart))
|
||||
pure (T.unpack hostText, port, db)
|
||||
Loading…
Reference in a new issue