First draft of big auth simplification

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 -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
-app dbstructure conf authenticator reqBody dbrole req =
+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

src/PostgREST/Auth.hs

@@ -1,14 +1,15 @@
+{-# 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
@@ -17,7 +18,7 @@ import           PostgREST.PgQuery       (pgFmtLit)
 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
+setJWTEnv :: Text -> Text -> Maybe [Text]
-checkPass = (. cs) . validatePassword . cs
+setJWTEnv secret input = setDBEnv $ jwtClaims secret input
 
-setRole :: Text -> H.Tx P.Postgres s ()
+setDBEnv :: Maybe JWT.ClaimsMap -> Maybe [Text]
-setRole role = H.unitEx $ B.Stmt ("set local role " <> cs (pgFmtLit role)) V.empty True
+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 ()
+setRole role = "set local role " <> cs (pgFmtLit role) <> ";"
-setUserId uid =
-  if uid /= ""
-    then H.unitEx $ B.Stmt ("set local user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True
-    else resetUserId
 
-resetUserId :: H.Tx P.Postgres s ()
+jwtClaims :: Text -> Text -> Maybe JWT.ClaimsMap
-resetUserId = H.unitEx [H.stmt|reset user_vars.user_id|]
+jwtClaims secret input = claims
-
-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
   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
 

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

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,
+                                                setRole, setJWTEnv)
-                                                signInWithJWT)
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
 
-import           Prelude
+import           Prelude hiding(concat)
+import qualified Web.JWT                 as JWT
 
-authenticated :: forall s. AppConfig -> DbRole ->
+import qualified Data.Vector             as V
-                 (DbRole -> Request -> H.Tx P.Postgres s Response) ->
+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
+runWithClaims conf app req = do
-  attempt <- httpRequesterRole (requestHeaders req)
+    H.unitEx $ B.Stmt env V.empty True
-  case attempt of
+    app req
-    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
-
  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
+   jwtEnv =
-   httpRequesterRole hdrs = do
+     case split (==' ') (cs auth) of
-    let auth = fromMaybe "" $ lookup hAuthorization hdrs
+       ("Bearer" : jwt : _) -> fromMaybe [] (setJWTEnv jwtSecret jwt)
-    case split (==' ') (cs auth) of
+       _ -> []
-      ("Basic" : b64 : _) ->
+   env = concat $ setRole anon : jwtEnv
-        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
-
 
 redirectInsecure :: Application -> Application
 redirectInsecure app req respond = do

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