refactor: config validation inside readAppConfig

Remove Either from configJwtRoleClaimKey/configServerUnixSocketMode
and remove whenLefts.

main/UnixSocket.hs

@@ -16,12 +16,12 @@ import System.Posix.Types       (FileMode)
 
 import Protolude
 
-createAndBindSocket :: FilePath -> Maybe FileMode -> IO Socket
-createAndBindSocket socketFilePath maybeSocketFileMode = do
+createAndBindSocket :: FilePath -> FileMode -> IO Socket
+createAndBindSocket socketFilePath socketFileMode = do
   deleteSocketFileIfExist socketFilePath
   sock <- socket AF_UNIX Stream defaultProtocol
   bind sock $ SockAddrUnix socketFilePath
-  mapM_ (setFileMode socketFilePath) maybeSocketFileMode
+  setFileMode socketFilePath socketFileMode
   return sock
   where
     deleteSocketFileIfExist path = removeFile path `catch` handleDoesNotExist
@@ -30,9 +30,9 @@ createAndBindSocket socketFilePath maybeSocketFileMode = do
       | otherwise = throwIO e
 
 -- run the postgrest application with user defined socket.
-runAppInSocket :: Settings -> Application -> Either Text FileMode -> FilePath -> IO ()
+runAppInSocket :: Settings -> Application -> FileMode -> FilePath -> IO ()
 runAppInSocket settings app socketFileMode sockPath = do
-  sock <- createAndBindSocket sockPath (rightToMaybe socketFileMode)
+  sock <- createAndBindSocket sockPath socketFileMode
   putStrLn $ ("Listening on unix socket " :: Text) <> show sockPath
   listen sock maxListenQueue
   runSettingsSocket settings sock app

src/PostgREST/App.hs

@@ -80,7 +80,7 @@ postgrest logLev refConf refDbStructure pool getTime connWorker =
             Left err -> return . errorResponseFor $ err
             Right apiRequest -> do
               -- The jwt must be checked before touching the db.
-              attempt <- attemptJwtClaims (configJWKS conf) (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configJwtRoleClaimKey conf)
+              attempt <- attemptJwtClaims (configJWKS conf) (configJwtAudience conf) (toS $ iJWT apiRequest) time (configJwtRoleClaimKey conf)
               case jwtClaims attempt of
                 Left errJwt -> return . errorResponseFor $ errJwt
                 Right claims -> do

src/PostgREST/Auth.hs

@@ -54,7 +54,7 @@ jwtClaims attempt =
   Receives the JWT secret and audience (from config) and a JWT and returns a map
   of JWT claims.
 -}
-attemptJwtClaims :: Maybe JWKSet -> Maybe StringOrURI -> LByteString -> UTCTime -> Maybe JSPath -> IO JWTAttempt
+attemptJwtClaims :: Maybe JWKSet -> Maybe StringOrURI -> LByteString -> UTCTime -> JSPath -> IO JWTAttempt
 attemptJwtClaims _ _ "" _ _ = return $ JWTClaims M.empty
 attemptJwtClaims maybeSecret audience payload time jspath =
   case maybeSecret of
@@ -72,11 +72,11 @@ attemptJwtClaims maybeSecret audience payload time jspath =
   Turn JWT ClaimSet into something easier to work with,
   also here the jspath is applied to put the "role" in the map
 -}
-claims2map :: ClaimsSet -> Maybe JSPath -> M.HashMap Text JSON.Value
+claims2map :: ClaimsSet -> JSPath -> M.HashMap Text JSON.Value
 claims2map claims jspath = (\case
     val@(JSON.Object o) ->
       let role = maybe M.empty (M.singleton "role") $
-                 walkJSPath (Just val) =<< jspath in
+                 walkJSPath (Just val) jspath in
       M.delete "role" o `M.union` role -- mutating the map
     _ -> M.empty
   ) $ JSON.toJSON claims

src/PostgREST/Config.hs

@@ -44,7 +44,6 @@ import Control.Lens            (preview)
 import Control.Monad           (fail)
 import Crypto.JWT              (JWKSet, StringOrURI, stringOrUri)
 import Data.Aeson              (encode, toJSON)
-import Data.Either.Combinators (fromRight', whenLeft)
 import Data.List               (lookup)
 import Data.List.NonEmpty      (fromList, toList)
 import Data.Maybe              (fromJust)
@@ -108,7 +107,7 @@ data AppConfig = AppConfig {
   , configDbUri                 :: Text
   , configJWKS                  :: Maybe JWKSet
   , configJwtAudience           :: Maybe StringOrURI
-  , configJwtRoleClaimKey       :: Either Text JSPath
+  , configJwtRoleClaimKey       :: JSPath
   , configJwtSecret             :: Maybe B.ByteString
   , configJwtSecretIsBase64     :: Bool
   , configLogLevel              :: LogLevel
@@ -117,7 +116,7 @@ data AppConfig = AppConfig {
   , configServerHost            :: Text
   , configServerPort            :: Int
   , configServerUnixSocket      :: Maybe FilePath
-  , configServerUnixSocketMode  :: Either Text FileMode
+  , configServerUnixSocketMode  :: FileMode
   }
 
 configDbPoolTimeout' :: (Fractional a) => AppConfig -> a
@@ -289,7 +288,7 @@ dumpAppConfig conf =
       ,("db-tx-end",                 q . showTxEnd)
       ,("db-uri",                    q . configDbUri)
       ,("jwt-aud",                       toS . encode . maybe "" toJSON . configJwtAudience)
-      ,("jwt-role-claim-key",        q . intercalate mempty . fmap show . fromRight' . configJwtRoleClaimKey)
+      ,("jwt-role-claim-key",        q . intercalate mempty . fmap show . configJwtRoleClaimKey)
       ,("jwt-secret",                q . toS . showJwtSecret)
       ,("jwt-secret-is-base64",          toLower . show . configJwtSecretIsBase64)
       ,("log-level",                 q . show . configLogLevel)
@@ -317,7 +316,7 @@ dumpAppConfig conf =
       | otherwise                 = toS secret
       where
         secret = fromMaybe mempty $ configJwtSecret c
-    showSocketMode c = showOct (fromRight' $ configServerUnixSocketMode c) ""
+    showSocketMode c = showOct (configServerUnixSocketMode c) mempty
 
 -- This class is needed for the polymorphism of overrideFromDbOrEnvironment
 -- because C.required and C.optional have different signatures
@@ -374,13 +373,12 @@ readAppConfig dbSettings env optPath = do
         <*> reqString "db-uri"
         <*> pure Nothing
         <*> parseJwtAudience "jwt-aud"
-        <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optWithAlias (optValue "jwt-role-claim-key")
-                                                                              (optValue "role-claim-key"))
+        <*> parseRoleClaimKey "jwt-role-claim-key" "role-claim-key"
         <*> (fmap encodeUtf8 <$> optString "jwt-secret")
         <*> (fromMaybe False <$> optWithAlias (optBool "jwt-secret-is-base64")
                                               (optBool "secret-is-base64"))
         <*> parseLogLevel "log-level"
-        <*> optString "openapi-server-proxy-uri"
+        <*> parseOpenAPIServerProxyURI "openapi-server-proxy-uri"
         <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types")
         <*> (fromMaybe "!4" <$> optString "server-host")
         <*> (fromMaybe 3000 <$> optInt "server-port")
@@ -394,18 +392,25 @@ readAppConfig dbSettings env optPath = do
         fromEnv = M.mapKeys fromJust $ M.filterWithKey (\k _ -> isJust k) $ M.mapKeys normalize env
         normalize k = ("app.settings." <>) <$> stripPrefix "PGRST_APP_SETTINGS_" (toS k)
 
-    parseSocketFileMode :: C.Key -> C.Parser C.Config (Either Text FileMode)
+    parseSocketFileMode :: C.Key -> C.Parser C.Config FileMode
     parseSocketFileMode k =
       optString k >>= \case
-        Nothing -> pure $ Right 432 -- return default 660 mode if no value was provided
+        Nothing -> pure $ 432 -- return default 660 mode if no value was provided
         Just fileModeText ->
           case (readOct . unpack) fileModeText of
             []              ->
-              pure $ Left "Invalid server-unix-socket-mode: not an octal"
+              fail "Invalid server-unix-socket-mode: not an octal"
             (fileMode, _):_ ->
               if fileMode < 384 || fileMode > 511
-                then pure $ Left "Invalid server-unix-socket-mode: needs to be between 600 and 777"
-                else pure $ Right fileMode
+                then fail "Invalid server-unix-socket-mode: needs to be between 600 and 777"
+                else pure fileMode
+
+    parseOpenAPIServerProxyURI :: C.Key -> C.Parser C.Config (Maybe Text)
+    parseOpenAPIServerProxyURI k =
+      optString k >>= \case
+        Nothing                            -> pure Nothing
+        Just val | isMalformedProxyUri val -> fail "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
+                 | otherwise               -> pure $ Just val
 
     parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI)
     parseJwtAudience k =
@@ -436,6 +441,12 @@ readAppConfig dbSettings env optPath = do
         Just "rollback-allow-override" -> pure $ f (True,       True)
         Just _                         -> fail "Invalid transaction termination. Check your configuration."
 
+    parseRoleClaimKey :: C.Key -> C.Key -> C.Parser C.Config JSPath
+    parseRoleClaimKey k al =
+      optWithAlias (optString k) (optString al) >>= \case
+        Nothing  -> pure [JSPKey "role"]
+        Just rck -> either (fail . show) pure $ pRoleClaimKey rck
+
     reqWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> [Char] -> C.Parser C.Config a
     reqWithAlias orig alias err =
       orig >>= \case
@@ -503,10 +514,6 @@ readAppConfig dbSettings env optPath = do
         Nothing -> (> 0) <$> (readMaybe $ toS s :: Maybe Integer)
     coerceBool _            = Nothing
 
-    parseRoleClaimKey :: C.Value -> Either Text JSPath
-    parseRoleClaimKey (C.String s) = pRoleClaimKey s
-    parseRoleClaimKey v            = pRoleClaimKey $ show v
-
     splitOnCommas :: C.Value -> [Text]
     splitOnCommas (C.String s) = strip <$> splitOn "," s
     splitOnCommas _            = []
@@ -520,14 +527,6 @@ readAppConfig dbSettings env optPath = do
 readValidateConfig :: [(Text, Text)] -> Environment -> Maybe FilePath -> IO AppConfig
 readValidateConfig dbSettings env path = do
   conf <- loadDbUriFile =<< loadSecretFile =<< readAppConfig dbSettings env path
-  -- Checks that the provided proxy uri is formated correctly
-  when (isMalformedProxyUri $ toS <$> configOpenApiServerProxyUri conf) $
-    panic
-      "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
-  -- Checks that the provided jspath is valid
-  whenLeft (configJwtRoleClaimKey conf) panic
-  -- Check the file mode is valid
-  whenLeft (configServerUnixSocketMode conf) panic
   return $ conf { configJWKS = parseSecret <$> configJwtSecret conf}
 
 type Environment = M.Map [Char] Text

src/PostgREST/OpenAPI.hs

@@ -312,7 +312,7 @@ pickProxy proxy
   -- should never happen
   -- since the request would have been rejected by the middleware if proxy uri
   -- is malformed
-  | isMalformedProxyUri proxy = Nothing
+  | isMalformedProxyUri $ fromMaybe mempty proxy = Nothing
   | otherwise = Just Proxy {
     proxyScheme = scheme
   , proxyHost = host'

src/PostgREST/Private/ProxyUri.hs

@@ -25,9 +25,8 @@ import Protolude.Conv (toS)
   http://postgrest.com/openapi.json
   https://postgrest.com:8080/openapi.json
 -}
-isMalformedProxyUri :: Maybe Text -> Bool
-isMalformedProxyUri Nothing =  False
-isMalformedProxyUri (Just uri)
+isMalformedProxyUri :: Text -> Bool
+isMalformedProxyUri uri
   | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri
   | otherwise = True
 

test/SpecHelper.hs

@@ -82,7 +82,7 @@ _baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in
   , configDbUri                 = mempty
   , configJWKS                  = parseSecret <$> secret
   , configJwtAudience           = Nothing
-  , configJwtRoleClaimKey       = Right [JSPKey "role"]
+  , configJwtRoleClaimKey       = [JSPKey "role"]
   , configJwtSecret             = secret
   , configJwtSecretIsBase64     = False
   , configLogLevel              = LogCrit
@@ -91,7 +91,7 @@ _baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in
   , configServerHost            = "localhost"
   , configServerPort            = 3000
   , configServerUnixSocket      = Nothing
-  , configServerUnixSocketMode  = Right 432
+  , configServerUnixSocketMode  = 432
   , configDbTxAllowOverride     = True
   , configDbTxRollbackAll       = True
   }

test/io-tests/fixtures.yaml

@@ -173,5 +173,4 @@ invalidroleclaimkeys:
   - '.role##'
   - '.my_role;;domain'
   - '.#$$%&$%/'
-  - ''
   - '1234'