First draft of big auth simplification

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