From 3add3f5b6c8a2ec3052336f12584326de4fce5a4 Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Thu, 8 Oct 2015 23:40:21 -0400 Subject: [PATCH] First draft of big auth simplification --- src/PostgREST/App.hs | 43 +++---------------------- src/PostgREST/Auth.hs | 63 ++++++++++--------------------------- src/PostgREST/Main.hs | 2 +- src/PostgREST/Middleware.hs | 53 +++++++++++-------------------- test/SpecHelper.hs | 2 +- 5 files changed, 42 insertions(+), 121 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 40c86babd..680fe62a3 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -57,12 +57,12 @@ import PostgREST.Types import Prelude -app :: DbStructure -> AppConfig -> DbRole -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response -app dbstructure conf authenticator reqBody dbrole req = +app :: DbStructure -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response +app dbstructure conf reqBody req = case (path, verb) of ([], _) -> do - let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs + let body = encode $ filter ((cs schema==).tableSchema) allTabs return $ responseLBS status200 [jsonH] $ cs body ([table], "OPTIONS") -> do @@ -130,41 +130,6 @@ app dbstructure conf authenticator reqBody dbrole req = countQuery = requestToCountQuery schema <$> apiRequest queries = (,) <$> query <*> countQuery - - (["postgrest", "users"], "POST") -> do - let user = decode reqBody :: Maybe AuthUser - - case user of - Nothing -> return $ responseLBS status400 [jsonH] $ - encode . object $ [("message", String "Failed to parse user.")] - Just u -> do - _ <- addUser (cs $ userId u) - (cs $ userPass u) (cs <$> userRole u) - return $ responseLBS status201 - [ jsonH - , (hLocation, "/postgrest/users?id=eq." <> cs (userId u)) - ] "" - - (["postgrest", "tokens"], "POST") -> - case jwtSecret of - "secret" -> return $ responseLBS status500 [jsonH] $ - encode . object $ [("message", String "JWT Secret is set as \"secret\" which is an unsafe default.")] - _ -> do - let user = decode reqBody :: Maybe AuthUser - - case user of - Nothing -> return $ responseLBS status400 [jsonH] $ - encode . object $ [("message", String "Failed to parse user.")] - Just u -> do - setRole authenticator - login <- signInRole (cs $ userId u) (cs $ userPass u) - case login of - LoginSuccess role uid -> - return $ responseLBS status201 [ jsonH ] $ - encode . object $ [("token", String $ tokenJWT jwtSecret uid role)] - _ -> return $ responseLBS status401 [jsonH] $ - encode . object $ [("message", String "Failed authentication.")] - ([table], "POST") -> do let qt = qualify table echoRequested = hasPrefer "return=representation" @@ -295,7 +260,7 @@ app dbstructure conf authenticator reqBody dbrole req = hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs accept = lookupHeader hAccept schema = cs $ configSchema conf - jwtSecret = cs $ configJwtSecret conf + jwtSecret = (cs $ configJwtSecret conf) :: Text range = rangeRequested hdrs allOrigins = ("Access-Control-Allow-Origin", "*") :: Header contentType = fromMaybe "application/json" $ contentTypeForAccept accept diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index edcf86cf9..4ced51892 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -1,23 +1,24 @@ +{-# LANGUAGE FlexibleContexts #-} module PostgREST.Auth where import Control.Applicative import Control.Monad (mzero) -import Crypto.BCrypt + import Data.Aeson -import Data.Map +import Data.Map (lookup, fromList, toList) import Data.Monoid import Data.String.Conversions (cs) -import Data.Text import Data.Maybe (isNothing) +import Data.Text (Text) import qualified Data.Vector as V import qualified Hasql as H import qualified Hasql.Backend as B import qualified Hasql.Postgres as P import PostgREST.PgQuery (pgFmtLit) -import Prelude +import Prelude import qualified Web.JWT as JWT -import System.IO.Unsafe + data AuthUser = AuthUser { userId :: String @@ -48,51 +49,21 @@ data LoginAttempt = | LoginSuccess DbRole UserId deriving (Eq, Show) -checkPass :: Text -> Text -> Bool -checkPass = (. cs) . validatePassword . cs +setJWTEnv :: Text -> Text -> Maybe [Text] +setJWTEnv secret input = setDBEnv $ jwtClaims secret input -setRole :: Text -> H.Tx P.Postgres s () -setRole role = H.unitEx $ B.Stmt ("set local role " <> cs (pgFmtLit role)) V.empty True +setDBEnv :: Maybe JWT.ClaimsMap -> Maybe [Text] +setDBEnv maybeClaims = + (map setVar . toList) <$> maybeClaims + where + setVar ("role", String val) = setRole val + setVar (key, String val) = "set local postgrest." <> key <> " = " <> cs (pgFmtLit val) <> ";" -setUserId :: Text -> H.Tx P.Postgres s () -setUserId uid = - if uid /= "" - then H.unitEx $ B.Stmt ("set local user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True - else resetUserId +setRole role = "set local role " <> cs (pgFmtLit role) <> ";" -resetUserId :: H.Tx P.Postgres s () -resetUserId = H.unitEx [H.stmt|reset user_vars.user_id|] - -addUser :: Text -> Text -> Maybe Text -> H.Tx P.Postgres s () -addUser identity pass role = - H.unitEx $ - if isNothing role - then [H.stmt|insert into postgrest.auth (id, pass) values (?, ?)|] - identity hashedText - else [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|] - identity hashedText role - where Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) - hashedText = cs hashed :: Text - -signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt -signInRole user pass = do - u <- H.maybeEx $ [H.stmt|select id, pass, rolname from postgrest.auth where id = ?|] user - return $ maybe LoginFailed (\r -> - let (uid, hashed, role) = r in - if checkPass hashed pass - then LoginSuccess role uid - else LoginFailed - ) u - -signInWithJWT :: Text -> Text -> LoginAttempt -signInWithJWT secret input = case maybeRole of - Just (Just (String role)) -> case maybeUserId of - Just (Just (String uid)) -> LoginSuccess (cs role) (cs uid) - _ -> LoginFailed - _ -> LoginFailed +jwtClaims :: Text -> Text -> Maybe JWT.ClaimsMap +jwtClaims secret input = claims where - maybeRole = (Data.Map.lookup "role" <$> claims) ::Maybe (Maybe Value) - maybeUserId = (Data.Map.lookup "id" <$> claims) ::Maybe (Maybe Value) claims = JWT.unregisteredClaims <$> JWT.claims <$> decoded decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 86e710424..fd6bf26a5 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -98,5 +98,5 @@ main = do runSettings appSettings $ middle $ \ req respond -> do body <- strictRequestBody req resOrError <- liftIO $ H.session pool $ H.tx txSettings $ - authenticated conf authenticator (app dbstructure conf authenticator body) req + runWithClaims conf (app dbstructure conf body) req either (respond . errResponse) respond resOrError diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 9dd3a5c48..0f6e379bf 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -27,46 +27,31 @@ import Network.Wai.Middleware.Static (only, staticPolicy) import Codec.Binary.Base64.String (decode) import PostgREST.App (contentTypeForAccept) import PostgREST.Auth (DbRole, LoginAttempt (..), - setRole, setUserId, signInRole, - signInWithJWT) + setRole, setJWTEnv) import PostgREST.Config (AppConfig (..), corsPolicy) -import Prelude +import Prelude hiding(concat) +import qualified Web.JWT as JWT -authenticated :: forall s. AppConfig -> DbRole -> - (DbRole -> Request -> H.Tx P.Postgres s Response) -> +import qualified Data.Vector as V +import qualified Hasql.Backend as B + +runWithClaims :: forall s. AppConfig -> + (Request -> H.Tx P.Postgres s Response) -> Request -> H.Tx P.Postgres s Response -authenticated conf authenticator app req = do - attempt <- httpRequesterRole (requestHeaders req) - case attempt of - MalformedAuth -> - return $ responseLBS status400 [] "Malformed basic auth header" - LoginFailed -> - return $ responseLBS status401 [] "Invalid username or password" - LoginSuccess role uid -> if role /= authenticator then runInRole role uid else app authenticator req - NoCredentials -> if anon /= authenticator then runInRole anon "" else app authenticator req - +runWithClaims conf app req = do + H.unitEx $ B.Stmt env V.empty True + app req where - jwtSecret = cs $ configJwtSecret conf + hdrs = requestHeaders req + jwtSecret = (cs $ configJwtSecret conf) :: Text + auth = fromMaybe "" $ lookup hAuthorization hdrs anon = cs $ configAnonRole conf - httpRequesterRole :: RequestHeaders -> H.Tx P.Postgres s LoginAttempt - httpRequesterRole hdrs = do - let auth = fromMaybe "" $ lookup hAuthorization hdrs - case split (==' ') (cs auth) of - ("Basic" : b64 : _) -> - case split (==':') (cs . decode . cs $ b64) of - (u:p:_) -> signInRole u p - _ -> return MalformedAuth - ("Bearer" : jwt : _) -> - return $ signInWithJWT jwtSecret jwt - _ -> return NoCredentials - - runInRole :: Text -> Text -> H.Tx P.Postgres s Response - runInRole r uid = do - setUserId uid - setRole r - app r req - + jwtEnv = + case split (==' ') (cs auth) of + ("Bearer" : jwt : _) -> fromMaybe [] (setJWTEnv jwtSecret jwt) + _ -> [] + env = concat $ setRole anon : jwtEnv redirectInsecure :: Application -> Application redirectInsecure app req respond = do diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index c4b8727cc..52e2387f5 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -80,7 +80,7 @@ withApp perform = do perform $ middle $ \req resp -> do body <- strictRequestBody req result <- liftIO $ H.session pool $ H.tx txSettings - $ authenticated cfg authenticator (app dbstructure cfg authenticator body) req + $ runWithClaims cfg (app dbstructure cfg body) req either (resp . errResponse) resp result where middle = defaultMiddle False