Merge pull request #194 from framp/jwt

JWT support

postgrest.cabal

@@ -19,8 +19,8 @@ executable postgrest
   default-language:    Haskell2010
   default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
   build-depends:       base >=4.6 && <5
-                     , hasql == 0.7.3, hasql-backend == 0.4.1
+                     , hasql == 0.7.3.1, hasql-backend == 0.4.1
-                     , hasql-postgres == 0.10.3
+                     , hasql-postgres == 0.10.3.1
                      , warp >= 3.0.2, wai >= 3.0.1
                      , wai-extra, wai-cors
                      , wai-middleware-static >= 0.6.0
@@ -43,6 +43,7 @@ executable postgrest
                      , vector
                      , mtl
                      , cassava
+                     , jwt
   Other-Modules:       App
                      , Auth
                      , Config
@@ -74,8 +75,8 @@ Test-Suite spec
                      , SpecHelper
   Build-Depends:       base, hspec >= 2.1.2, QuickCheck
                      , hspec-wai >= 0.5.0, hspec-wai-json
-                     , hasql == 0.7.3, hasql-backend == 0.4.1
+                     , hasql == 0.7.3.1, hasql-backend == 0.4.1
-                     , hasql-postgres == 0.10.3
+                     , hasql-postgres == 0.10.3.1
                      , warp, wai
                      , packdeps, hlint
                      , HTTP, convertible
@@ -102,3 +103,4 @@ Test-Suite spec
                      , cassava
                      , process
                      , heredoc
+                     , jwt

src/App.hs

@@ -34,13 +34,16 @@ import qualified Hasql as H
 import qualified Hasql.Backend as B
 import qualified Hasql.Postgres as P
 
+import Config (AppConfig(..))
 import Auth
 import PgQuery
 import RangeQuery
 import PgStructure
 
-app :: Text -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
+import Prelude
-app v1schema reqBody req =
+
+app :: AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
+app conf reqBody req =
   case (path, verb) of
     ([], _) -> do
       body <- encode <$> tables (cs schema)
@@ -102,6 +105,27 @@ app v1schema reqBody req =
             , (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 -> 
+                  return $ responseLBS status201 [ jsonH ] $
+                    encode . object $ [("token", String $ tokenJWT jwtSecret (cs $ userId u) role)]
+                _  -> return $ responseLBS status401 [jsonH] $
+                  encode . object $ [("message", String "Failed authentication.")]
+
     ([table], "POST") -> do
       let qt = QualifiedTable schema (cs table)
           echoRequested = lookup "Prefer" hdrs == Just "return=representation"
@@ -201,7 +225,9 @@ app v1schema reqBody req =
     verb   = requestMethod req
     qq     = queryString req
     hdrs   = requestHeaders req
-    schema = requestedSchema v1schema hdrs
+    schema = requestedSchema (cs $ configV1Schema conf) hdrs
+    authenticator = cs $ configDbUser conf
+    jwtSecret = cs $ configJwtSecret conf
     range  = rangeRequested hdrs
     allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
 

src/Auth.hs

@@ -3,17 +3,21 @@ module Auth where
 
 import Data.Aeson
 import Control.Monad (mzero)
-import Control.Applicative ( (<*>), (<$>) )
+import Control.Applicative
 import Crypto.BCrypt
 import Data.Text
 import Data.Monoid
+import Data.Map
 import qualified Data.Vector as V
 import qualified Hasql as H
 import qualified Hasql.Backend as B
 import qualified Hasql.Postgres as P
+import qualified Web.JWT as JWT
 import Data.String.Conversions (cs)
 import PgQuery (pgFmtLit)
 
+import Prelude
+
 import System.IO.Unsafe
 
 data AuthUser = AuthUser {
@@ -26,7 +30,7 @@ instance FromJSON AuthUser where
   parseJSON (Object v) = AuthUser <$>
                          v .: "id" <*>
                          v .: "pass" <*>
-                         v .: "role"
+                         v .:? "role" .!= ""
   parseJSON _ = mzero
 
 instance ToJSON AuthUser where
@@ -69,3 +73,19 @@ signInRole user pass = do
          then LoginSuccess role
          else LoginFailed
     ) u
+
+signInWithJWT :: Text -> Text -> LoginAttempt
+signInWithJWT secret input = case maybeRole of
+    Just (Just (String role)) -> LoginSuccess $ cs role
+    _   -> LoginFailed
+  where 
+    maybeRole = (Data.Map.lookup "role" <$> 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)]
+    }

src/Config.hs

@@ -8,6 +8,7 @@ import qualified Data.ByteString.Char8 as BS
 import Data.String.Conversions (cs)
 import Options.Applicative hiding (columns)
 import Network.Wai.Middleware.Cors (CorsResourcePolicy(..))
+import Prelude
 
 data AppConfig = AppConfig {
     configDbName :: String
@@ -21,6 +22,8 @@ data AppConfig = AppConfig {
   , configSecure :: Bool
   , configPool :: Int
   , configV1Schema :: String
+  
+  , configJwtSecret :: String
   }
 
 argParser :: Parser AppConfig
@@ -36,6 +39,7 @@ argParser = AppConfig
   <*> switch (long "secure" <> short 's' <> help "Redirect all requests to HTTPS")
   <*> option auto (long "db-pool" <> metavar "COUNT" <> value 10 <> help "Max connections in database pool" <> showDefault)
   <*> strOption (long "v1schema" <> metavar "NAME" <> value "1" <> help "Schema to use for nonspecified version (or explicit v1)" <> showDefault)
+  <*> strOption (long "jwt-secret" <> metavar "SECRET" <> value "secret" <> help "Secret used to encrypt and decrypt JWT tokens)" <> showDefault)
 
 defaultCorsPolicy :: CorsResourcePolicy
 defaultCorsPolicy =  CorsResourcePolicy Nothing

src/Main.hs

@@ -38,6 +38,8 @@ main = do
 
   unless (configSecure conf) $
     putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
+  unless ("secret" /= configJwtSecret conf) $
+    putStrLn "WARNING, running in insecure mode, JWT secret is the default value"
   Prelude.putStrLn $ "Listening on port " ++
     (show $ configPort conf :: String)
 
@@ -53,8 +55,6 @@ main = do
         . (if configSecure conf then redirectInsecure else id)
         . gzip def . cors corsPolicy
         . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
-      anonRole = cs $ configAnonRole conf
-      currRole = cs $ configDbUser conf
 
   poolSettings <- maybe (fail "Improper session settings") return $
                 H.poolSettings (fromIntegral $ configPool conf) 30
@@ -64,7 +64,7 @@ main = do
   runSettings appSettings $ middle $ \req respond -> do
     body <- strictRequestBody req
     resOrError <- liftIO $ H.session pool $ H.tx Nothing $
-      authenticated currRole anonRole (app (cs $ configV1Schema conf) body) req
+      authenticated conf (app conf body) req
     either (respond . errResponse) respond resOrError
 
   where

src/Middleware.hs

@@ -4,7 +4,7 @@
 module Middleware where
 
 import Data.Maybe (fromMaybe)
-import Data.Monoid (mconcat)
+import Data.Monoid
 import Data.Text
 -- import Data.Pool(withResource, Pool)
 
@@ -19,13 +19,16 @@ import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
                    rawQueryString, isSecure, Request(..), Response)
 import Network.URI (URI(..), parseURI)
 
-import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
+import Config (AppConfig(..))
+import Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 
-authenticated :: forall s. Text -> Text ->
+import Prelude
+
+authenticated :: forall s. AppConfig ->
                  (Request -> H.Tx P.Postgres s Response) ->
                  Request -> H.Tx P.Postgres s Response
-authenticated currentRole anon app req = do
+authenticated conf app req = do
   attempt <- httpRequesterRole (requestHeaders req)
   case attempt of
     MalformedAuth ->
@@ -36,6 +39,9 @@ authenticated currentRole anon app req = do
     NoCredentials ->     if anon /= currentRole then runInRole anon else app req
 
  where
+   jwtSecret = cs $ configJwtSecret conf
+   currentRole = cs $ configDbUser conf
+   anon = cs $ configAnonRole conf
    httpRequesterRole :: RequestHeaders -> H.Tx P.Postgres s LoginAttempt
    httpRequesterRole hdrs = do
     let auth = fromMaybe "" $ lookup hAuthorization hdrs
@@ -44,6 +50,8 @@ authenticated currentRole anon app req = do
         case split (==':') (cs . decode . cs $ b64) of
           (u:p:_) -> signInRole u p
           _ -> return MalformedAuth
+      ("Bearer" : jwt : _) ->
+        return $ signInWithJWT jwtSecret jwt
       _ -> return NoCredentials
 
    runInRole :: Text -> H.Tx P.Postgres s Response

src/PgQuery.hs

@@ -17,7 +17,7 @@ import qualified Data.ByteString.Char8 as BS
 import Data.Monoid
 import Data.Vector (empty)
 import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Functor ( (<$>) )
+import Data.Functor
 import Control.Monad (join)
 import Data.String.Conversions (cs)
 import qualified Data.Aeson as JSON
@@ -25,6 +25,8 @@ import qualified Data.List as L
 import qualified Data.Vector as V
 import Data.Scientific (isInteger, formatScientific, FPFormat(..))
 
+import Prelude
+
 type PStmt = H.Stmt P.Postgres
 instance Monoid PStmt where
   mappend (B.Stmt query params prep) (B.Stmt query' params' prep') =

src/PgStructure.hs

@@ -9,13 +9,15 @@ import Data.Aeson
 import Data.Functor.Identity
 import Data.String.Conversions (cs)
 import Data.Maybe (fromMaybe)
-import Control.Applicative ( (<$>) )
+import Control.Applicative
 
 import qualified Data.Map as Map
 
 import qualified Hasql as H
 import qualified Hasql.Postgres as P
 
+import Prelude
+
 foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey)
 foreignKeys table = do
   r <- H.listEx $ [H.stmt|

src/RangeQuery.hs

@@ -20,6 +20,8 @@ import Text.Read (readMaybe)
 
 import Data.Maybe (fromMaybe, listToMaybe)
 
+import Prelude
+
 type NonnegRange = Range Int
 
 rangeParse :: BS.ByteString -> Maybe NonnegRange

test/Feature/AuthSpec.hs

@@ -18,13 +18,37 @@ spec = beforeAll
   it "hides tables that anonymous does not own" $
     get "/authors_only" `shouldRespondWith` 404
 
-  it "indicates login failure" $ do
+  it "indicates login failure (BasicAuth)" $ do
-    let auth = authHeader "postgrest_test_author" "fakefake"
+    let auth = authHeaderBasic "postgrest_test_author" "fakefake"
     request methodGet "/authors_only" [auth] ""
       `shouldRespondWith` 401
 
-  it "allows users with permissions to see their tables" $ do
+  it "allows users with permissions to see their tables (BasicAuth)" $ do
     _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    let auth = authHeader "jdoe" "1234"
+    let auth = authHeaderBasic "jdoe" "1234"
     request methodGet "/authors_only" [auth] ""
       `shouldRespondWith` 200
+      
+  it "allows users to login (JWT)" $ do
+    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
+    post "/postgrest/tokens" [json| { "id":"jdoe", "pass": "1234" } |] 
+      `shouldRespondWith` ResponseMatcher {
+          matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"} |]
+        , matchStatus = 201
+        , matchHeaders = ["Content-Type" <:> "application/json"]
+        }
+      
+  it "indicates login failure (JWT)" $ do
+    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
+    post "/postgrest/tokens" [json| { "id":"jdoe", "pass": "NOPE" } |] 
+      `shouldRespondWith` ResponseMatcher {
+          matchBody = Just [json| {"message":"Failed authentication."} |]
+        , matchStatus = 401
+        , matchHeaders = ["Content-Type" <:> "application/json"]
+        }
+
+  it "allows users with permissions to see their tables (JWT)" $ do
+    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200

test/Feature/StructureSpec.hs

@@ -27,7 +27,7 @@ spec = around withApp $ do
 
     it "lists only views user has permission to see" $ do
       _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-      let auth = authHeader "jdoe" "1234"
+      let auth = authHeaderBasic "jdoe" "1234"
 
       request methodGet "/" [auth] ""
         `shouldRespondWith` [json| [

test/SpecHelper.hs

@@ -36,7 +36,7 @@ isLeft (Left _ ) = True
 isLeft _ = False
 
 cfg :: AppConfig
-cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 "1"
+cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 "1" "safe"
 
 testPoolOpts :: PoolSettings
 testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30
@@ -50,15 +50,13 @@ pgSettings = P.ParamSettings (cs $ configDbHost cfg)
 
 withApp :: ActionWith Application -> IO ()
 withApp perform = do
-  let anonRole = cs $ configAnonRole cfg
-      currRole = cs $ configDbUser cfg
   pool :: H.Pool P.Postgres
     <- H.acquirePool pgSettings testPoolOpts
 
   perform $ middle $ \req resp -> do
     body <- strictRequestBody req
     result <- liftIO $ H.session pool $ H.tx Nothing
-      $ authenticated currRole anonRole (app (cs $ configV1Schema cfg) body) req
+      $ authenticated cfg (app cfg body) req
     either (resp . errResponse) resp result
 
   where middle = cors corsPolicy
@@ -93,9 +91,13 @@ matchHeader :: CI BS.ByteString -> String -> [Header] -> Bool
 matchHeader name valRegex headers =
   maybe False (=~ valRegex) $ lookup name headers
 
-authHeader :: String -> String -> Header
+authHeaderBasic :: String -> String -> Header
-authHeader u p =
+authHeaderBasic u p =
   (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))
+  
+authHeaderJWT :: String -> Header
+authHeaderJWT token =
+  (hAuthorization, cs $ "Bearer " ++ token)
 
 testPool :: IO(H.Pool P.Postgres)
 testPool = H.acquirePool pgSettings testPoolOpts

test/TestTypes.hs

@@ -8,9 +8,11 @@ module TestTypes (
 import qualified Data.Aeson as JSON
 import Data.Aeson ((.:))
 -- import Data.Maybe (fromJust)
-import Control.Applicative ((<$>), (<*>))
+import Control.Applicative
 import Control.Monad (mzero)
 
+import Prelude
+
 data IncPK = IncPK {
   incId :: Int
 , incNullableStr :: Maybe String