JWT support

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
-app v1schema reqBody req =
+import Prelude
+
+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