jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'begriffs/v3' into v3

Browse Source
This commit is contained in:
Ruslan Talpa
2015-10-23 09:15:00 +03:00
parent cea4cc5860 8b28b33da3
commit 21bd921ee7
11 changed files with 220 additions and 272 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/App.hs
+13 -41
View File
@@ -48,13 +48,13 @@ import Network.Wai.Internal (Response (..))
import Network.Wai.Parse (parseHttpAccept)
import Data.Aeson
import Data.Aeson.Types (emptyArray)
import Data.Monoid
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.Auth
import PostgREST.Config (AppConfig (..))
import PostgREST.Parsers
import PostgREST.PgQuery
@@ -62,14 +62,16 @@ import PostgREST.PgStructure
import PostgREST.QueryBuilder
import PostgREST.RangeQuery
import PostgREST.Types
import PostgREST.Auth (tokenJWT)
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
Identity (dbrole :: Text) <- H.singleEx $ [H.stmt|SELECT current_user|]
let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs
return $ responseLBS status200 [jsonH] $ cs body
@@ -137,45 +139,11 @@ app dbstructure conf authenticator reqBody dbrole req =
>>= addJoinConditions schema allCols
query = requestToQuery schema <$> apiRequest
--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 echoRequested = hasPrefer "return=representation" --TODO!! do not request content at all in query if not echoRequested
case insertQuery of
@@ -270,9 +238,13 @@ app dbstructure conf authenticator reqBody dbrole req =
then do
let call = B.Stmt "select " V.empty True <>
asJson (callProc qi $ fromMaybe M.empty (decode reqBody))
body :: Maybe (Identity Text) <- H.maybeEx call
bodyJson :: Maybe (Identity Value) <- H.maybeEx call
returnJWT <- doesProcReturnJWT schema proc
return $ responseLBS status200 [jsonH]
(cs $ fromMaybe "[]" $ runIdentity <$> body)
(let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in
if returnJWT
then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
else cs $ encode body)
else return $ responseLBS status404 [] ""
-- check that proc exists
@@ -358,7 +330,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
+69 -97
View File
@@ -1,104 +1,76 @@
module PostgREST.Auth where
{-# LANGUAGE FlexibleContexts #-}
{-|
Module : PostgREST.Auth
Description : PostgREST authorization functions.
import Control.Applicative
import Control.Monad (mzero)
import Crypto.BCrypt
import Data.Aeson
import Data.Map
import Data.Monoid
This module provides functions to deal with the JWT authorization (http://jwt.io).
It also can be used to define other authorization functions,
in the future Oauth, LDAP and similar integrations can be coded here.
Authentication should always be implemented in an external service.
In the test suite there is an example of simple login function that can be used for a
very simple authentication system inside the PostgreSQL database.
-}
module PostgREST.Auth (
setRole
, claimsToSQL
, jwtClaims
, tokenJWT
) where
--line needed for ghc 7.8
import Data.Functor ((<$>))
import Data.Aeson (Value (..), Object)
import Data.Aeson.Types (emptyObject, emptyArray)
import Data.Vector as V (null, head)
import Data.Map as M (fromList, toList)
import Data.Monoid ((<>))
import Data.String.Conversions (cs)
import Data.Text
import Data.Maybe (isNothing)
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 Data.Text (Text)
import PostgREST.PgQuery (pgFmtLit, pgFmtIdent, unquoted)
import qualified Web.JWT as JWT
import qualified Data.HashMap.Lazy as H
import System.IO.Unsafe
data AuthUser = AuthUser {
userId :: String
, userPass :: String
, userRole :: Maybe String
} deriving (Show)
instance FromJSON AuthUser where
parseJSON (Object v) = AuthUser <$>
v .: "id" <*>
v .: "pass" <*>
v .:? "role"
parseJSON _ = mzero
instance ToJSON AuthUser where
toJSON u = object [
"id" .= userId u
, "pass" .= userPass u
, "role" .= userRole u ]
type DbRole = Text
type UserId = Text
data LoginAttempt =
NoCredentials
| MalformedAuth
| LoginFailed
| LoginSuccess DbRole UserId
deriving (Eq, Show)
checkPass :: Text -> Text -> Bool
checkPass = (. cs) . validatePassword . cs
setRole :: Text -> H.Tx P.Postgres s ()
setRole role = H.unitEx $ B.Stmt ("set local role " <> cs (pgFmtLit role)) V.empty True
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
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
{-|
Receives a map of JWT claims and returns a list
of PostgreSQL statements to set the claims as user defined GUCs.
Except if we have a claim called role,
this one is mapped to a SET ROLE statement.
In case there is any problem decoding the JWT it returns Nothing.
-}
claimsToSQL :: JWT.ClaimsMap -> [Text]
claimsToSQL = map setVar . toList
where
setVar ("role", String val) = setRole val
setVar (k, val) = "set local postgrest.claims." <> pgFmtIdent k <>
" = " <> valueToVariable val <> ";"
valueToVariable = pgFmtLit . unquoted
{-|
Receives the JWT secret (from config) and a JWT and
returns a map of JWT claims
In case there is any problem decoding the JWT it returns Nothing.
-}
jwtClaims :: Text -> Text -> Maybe JWT.ClaimsMap
jwtClaims secret input = JWT.unregisteredClaims <$> JWT.claims <$> decoded
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
tokenJWT :: Text -> Text -> Text -> Text
tokenJWT secret uid role = JWT.encodeSigned JWT.HS256 (JWT.secret secret) claimsSet
where
claimsSet = JWT.def {
JWT.unregisteredClaims = Data.Map.fromList [("id", String uid), ("role", String role)]
}
-- | Receives the name of a role and returns a SET ROLE statement
setRole :: Text -> Text
setRole role = "set local role " <> cs (pgFmtLit role) <> ";"
{-|
Receives the JWT secret (from config) and a JWT and a JSON value
and returns a signed JWT.
-}
tokenJWT :: Text -> Value -> Text
tokenJWT secret (Array a) = JWT.encodeSigned JWT.HS256 (JWT.secret secret)
JWT.def { JWT.unregisteredClaims = fromHashMap o }
where
Object o = if V.null a then emptyObject else V.head a
fromHashMap :: Object -> JWT.ClaimsMap
fromHashMap = M.fromList . H.toList
tokenJWT secret _ = tokenJWT secret emptyArray
src/PostgREST/Main.hs
+1 -1
View File
@@ -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
+28 -39
View File
@@ -3,6 +3,9 @@
module PostgREST.Middleware where
-- needed for ghc 7.8
import Data.Functor ((<$>))
import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid
import Data.Text
@@ -10,11 +13,9 @@ import Data.String.Conversions (cs)
import qualified Hasql as H
import qualified Hasql.Postgres as P
import Network.HTTP.Types (RequestHeaders)
import Network.HTTP.Types.Header (hAccept, hAuthorization,
hLocation)
import Network.HTTP.Types.Status (status301, status400, status401,
status415)
import Network.HTTP.Types.Status (status301, status400, status415)
import Network.URI (URI (..), parseURI)
import Network.Wai (Application, Request (..),
Response, isSecure, rawPathInfo,
@@ -24,49 +25,37 @@ import Network.Wai.Middleware.Cors (cors)
import Network.Wai.Middleware.Gzip (def, gzip)
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)
import PostgREST.Auth (setRole, jwtClaims, claimsToSQL)
import PostgREST.Config (AppConfig (..), corsPolicy)
import Prelude
import Prelude hiding(concat)
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
import qualified Data.Map.Lazy as M
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
mapM_ H.unitEx $ stmt <$> env
app req
where
jwtSecret = cs $ configJwtSecret conf
stmt = (flip $ flip B.Stmt V.empty) True
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
claims =
fromMaybe (M.fromList []) $
case split (==' ') (cs auth) of
("Bearer" : jwt : _) -> jwtClaims jwtSecret jwt
_ -> Nothing
env = if M.member "role" claims
then jwtEnv
else setRole anon : jwtEnv
jwtEnv = claimsToSQL claims
redirectInsecure :: Application -> Application
redirectInsecure app req respond = do
src/PostgREST/PgStructure.hs
+19 -5
View File
@@ -14,25 +14,39 @@ import Data.Monoid
import Data.Text (Text, split)
import qualified Hasql as H
import qualified Hasql.Postgres as P
import qualified Hasql.Backend as B
import PostgREST.PgQuery ()
import PostgREST.Types
import GHC.Exts (groupWith)
import Prelude
doesProc :: forall c s. B.CxValue c Int =>
(Text -> Text -> B.Stmt c) -> Text -> Text -> H.Tx c s Bool
doesProc stmt schema proc = do
row :: Maybe (Identity Int) <- H.maybeEx $ stmt schema proc
return $ isJust row
doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool
doesProcExist schema proc = do
row :: Maybe (Identity Int) <- H.maybeEx $ [H.stmt|
doesProcExist = doesProc [H.stmt|
SELECT 1
FROM pg_catalog.pg_namespace n
JOIN pg_catalog.pg_proc p
ON pronamespace = n.oid
WHERE nspname = ?
AND proname = ?
|] schema proc
return $ isJust row
|]
doesProcReturnJWT :: Text -> Text -> H.Tx P.Postgres s Bool
doesProcReturnJWT = doesProc [H.stmt|
SELECT 1
FROM pg_catalog.pg_namespace n
JOIN pg_catalog.pg_proc p
ON pronamespace = n.oid
WHERE nspname = ?
AND proname = ?
AND pg_catalog.pg_get_function_result(p.oid) = 'jwt_claims'
|]
tableFromRow :: (Text, Text, Bool, Maybe Text) -> Table
tableFromRow (s, n, i, a) = Table s n i (parseAcl a)
@@ -172,7 +186,7 @@ allRelations = do
allColumns :: [Relation] -> H.Tx P.Postgres s [Column]
allColumns rels = do
cols <- H.listEx $ [H.stmt|
SELECT
SELECT DISTINCT
info.table_schema AS schema,
info.table_name AS table_name,
info.column_name AS name,