diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 20a7d0285..8ddfa1dea 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -1,3 +1,15 @@ +{-| +Module : PostgREST.Auth +Description : PostgREST authorization functions. + +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. +-} {-# LANGUAGE FlexibleContexts #-} module PostgREST.Auth ( setRole @@ -5,40 +17,45 @@ module PostgREST.Auth ( , tokenJWT ) where -import Control.Applicative -import Data.Aeson -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.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 (Text) +import Data.Text (Text) import PostgREST.PgQuery (pgFmtLit, pgFmtIdent, unquoted) -import Prelude import qualified Web.JWT as JWT import qualified Data.HashMap.Lazy as H +{-| + Receives the JWT secret (from config) and a JWT 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. +-} setJWTEnv :: Text -> Text -> Maybe [Text] -setJWTEnv secret input = setDBEnv $ jwtClaims secret input - -setDBEnv :: Maybe JWT.ClaimsMap -> Maybe [Text] -setDBEnv maybeClaims = - (map setVar . toList) <$> maybeClaims +setJWTEnv secret input = setDBEnv jwtClaims where + setDBEnv maybeClaims = (map setVar . toList) <$> maybeClaims setVar ("role", String val) = setRole val setVar (k, val) = "set local postgrest.claims." <> pgFmtIdent k <> - " = " <> valueToVariable val <> ";" + " = " <> valueToVariable val <> ";" valueToVariable = pgFmtLit . unquoted + jwtClaims = JWT.unregisteredClaims <$> JWT.claims <$> decoded + decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input +-- | Receives the name of a role and returns a SET ROLE statement setRole :: Text -> Text setRole role = "set local role " <> cs (pgFmtLit role) <> ";" -jwtClaims :: Text -> Text -> Maybe JWT.ClaimsMap -jwtClaims secret input = claims - where - claims = JWT.unregisteredClaims <$> JWT.claims <$> decoded - decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input +{-| + 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 } @@ -47,4 +64,3 @@ tokenJWT secret (Array a) = JWT.encodeSigned JWT.HS256 (JWT.secret secret) fromHashMap :: Object -> JWT.ClaimsMap fromHashMap = M.fromList . H.toList tokenJWT secret _ = tokenJWT secret emptyArray - diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 52e2387f5..bf7042c11 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -20,7 +20,6 @@ import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, import Codec.Binary.Base64.String (encode) import Data.CaseInsensitive (CI(..)) import Data.Maybe (fromMaybe) -import Data.Functor.Identity import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import System.Process (readProcess) @@ -55,10 +54,6 @@ withApp perform = do pool :: H.Pool P.Postgres <- H.acquirePool pgSettings testPoolOpts - Right authenticator <- H.session pool $ do - Identity (role :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SELECT SESSION_USER|] - return role - let txSettings = Just (H.ReadCommitted, Just True) metadata <- H.session pool $ H.tx txSettings $ do tabs <- allTables