diff --git a/app/Config.hs b/app/Config.hs --- a/app/Config.hs +++ b/app/Config.hs @@ -22,13 +22,11 @@ import System.IO.Error (IOError) import Control.Applicative -import qualified Data.ByteString as B import qualified Data.Configurator as C import qualified Data.Configurator.Types as C import Data.Monoid import Data.Text (intercalate, lines) import Data.Text.Encoding (encodeUtf8) -import Data.Text.IO (hPutStrLn) import Data.Version (versionBranch) import Options.Applicative hiding (str) import Paths_postgrest_ws (version) @@ -44,10 +42,8 @@ , configHost :: Text , configPort :: Int , configAuditChannel :: Maybe Text - - , configJwtSecret :: B.ByteString + , configJwtSecret :: ByteString , configJwtSecretIsBase64 :: Bool - , configPool :: Int } @@ -96,19 +92,15 @@ parserPrefs = prefs showHelpOnError configNotfoundHint :: IOError -> IO a - configNotfoundHint e = do - hPutStrLn stderr $ - "Cannot open config file:\n\t" <> show e - exitFailure + configNotfoundHint e = die $ "Cannot open config file:\n\t" <> show e missingKeyHint :: C.KeyError -> IO a - missingKeyHint (C.KeyError n) = do - hPutStrLn stderr $ + missingKeyHint (C.KeyError n) = + die $ "Required config parameter \"" <> n <> "\" is missing or of wrong type.\n" <> "Documentation for configuration options available at\n" <> "\thttp://postgrest.com/en/v0.4/admin.html#configuration\n\n" <> "Try the --example-config option to see how to configure PostgREST." - exitFailure exampleCfg :: Doc exampleCfg = vsep . map (text . toS) . lines $ diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,6 @@ module Main where -import Protolude +import Protolude hiding (replace) import PostgRESTWS import Config (AppConfig (..), PgVersion (..), @@ -8,11 +8,11 @@ prettyVersion, readOptions) -import Data.ByteString.Base64 (decode) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 import Data.String (IsString (..)) -import Data.Text (stripPrefix, pack, replace) +import Data.Text (pack, replace, strip, stripPrefix) import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Data.Text.IO (readFile) import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Hasql.Query as H import qualified Hasql.Session as H @@ -25,7 +25,6 @@ import Network.Wai.Middleware.RequestLogger (logStdout) import System.IO (BufferMode (..), hSetBuffering) -import Control.AutoUpdate isServerVersionSupported :: H.Session Bool isServerVersionSupported = do @@ -55,15 +54,10 @@ putStrLn $ ("Listening on port " :: Text) <> show (configPort conf) pool <- P.acquire (configPool conf, 10, pgSettings) - - -- ask for the OS time at most once per second - getTime <- mkAutoUpdate - defaultUpdateSettings { updateAction = getPOSIXTime } - multi <- newHasqlBroadcaster pgSettings runSettings appSettings $ - postgrestWsMiddleware (toS <$> configAuditChannel conf) (configJwtSecret conf) getTime pool multi $ + postgrestWsMiddleware (toS <$> configAuditChannel conf) (configJwtSecret conf) getPOSIXTime pool multi $ logStdout $ staticApp $ defaultFileServerSettings $ toS $ configPath conf loadSecretFile :: AppConfig -> IO AppConfig @@ -76,16 +70,21 @@ extractAndTransform s = fmap setSecret $ transformString isB64 =<< case stripPrefix "@" s of - Nothing -> return s - Just filename -> readFile (toS filename) + Nothing -> return . encodeUtf8 $ s + Just filename -> chomp <$> BS.readFile (toS filename) + where + chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs) - transformString :: Bool -> Text -> IO ByteString - transformString False t = return . encodeUtf8 $ t - transformString True t = - case decode (encodeUtf8 $ replaceUrlChars t) of + -- Turns the Base64url encoded JWT into Base64 + transformString :: Bool -> ByteString -> IO ByteString + transformString False t = return t + transformString True t = + case B64.decode $ encodeUtf8 $ strip $ replaceUrlChars $ decodeUtf8 t of Left errMsg -> panic $ pack errMsg Right bs -> return bs - setSecret bs = conf { configJwtSecret = bs } + setSecret bs = conf {configJwtSecret = bs} - replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "=" + -- replace: Replace every occurrence of one substring with another + replaceUrlChars = + replace "_" "/" . replace "-" "+" . replace "." "=" diff --git a/postgrest-ws.cabal b/postgrest-ws.cabal --- a/postgrest-ws.cabal +++ b/postgrest-ws.cabal @@ -1,5 +1,5 @@ name: postgrest-ws -version: 0.4.0.0 +version: 0.4.1.0 synopsis: PostgREST extension to map LISTEN/NOTIFY messages to Websockets description: Please see README.md homepage: https://github.com/diogob/postgrest-ws#readme @@ -20,8 +20,7 @@ , PostgRESTWS.Broadcast , PostgRESTWS.Database , PostgRESTWS.HasqlBroadcast - - other-modules: PostgRESTWS.Claims + , PostgRESTWS.Claims build-depends: base >= 4.7 && < 5 , hasql-pool >= 0.4 && < 0.5 , text >= 1.2 && < 2 @@ -31,14 +30,13 @@ , http-types >= 0.9 , bytestring >= 0.10 , postgresql-libpq - , time , lens , lens-aeson - , jwt + , jose >= 0.6 , unordered-containers >= 0.2 , postgresql-libpq >= 0.9 && < 1.0 , aeson >= 0.11 - , protolude >= 0.1.6 && < 0.2 + , protolude >= 0.2 , jwt >= 0.7.2 && < 0.8 , hasql >= 0.19 , either @@ -46,6 +44,7 @@ , stm , retry , stringsearch + , time , contravariant default-language: Haskell2010 default-extensions: OverloadedStrings, NoImplicitPrelude @@ -64,7 +63,7 @@ , jwt >= 0.7 && < 1 , postgrest-ws , postgresql-libpq >= 0.9 && < 1.0 - , protolude >= 0.1.6 && < 0.2 + , protolude >= 0.2 , base64-bytestring , bytestring , configurator @@ -86,10 +85,11 @@ hs-source-dirs: test main-is: Spec.hs other-modules: BroadcastSpec + , ClaimsSpec , DatabaseSpec , HasqlBroadcastSpec build-depends: base - , protolude >= 0.1.6 && < 0.2 + , protolude >= 0.2 , postgrest-ws , containers , hspec @@ -99,6 +99,7 @@ , hasql , hasql-pool , http-types + , unordered-containers >= 0.2 , wai-extra , stm ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N diff --git a/src/PostgRESTWS.hs b/src/PostgRESTWS.hs --- a/src/PostgRESTWS.hs +++ b/src/PostgRESTWS.hs @@ -10,28 +10,28 @@ , newHasqlBroadcasterOrError ) where -import Protolude +import qualified Hasql.Pool as H import qualified Network.Wai as Wai import qualified Network.Wai.Handler.WebSockets as WS import qualified Network.WebSockets as WS -import qualified Hasql.Pool as H - -import qualified Data.Text.Encoding.Error as T +import Protolude -import Data.Time.Clock.POSIX (POSIXTime) -import qualified Data.HashMap.Strict as M import qualified Data.Aeson as A import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as M +import qualified Data.Text.Encoding.Error as T +import Data.Time.Clock.POSIX (POSIXTime) -import PostgRESTWS.Claims -import PostgRESTWS.Database -import PostgRESTWS.Broadcast (Multiplexer, onMessage) -import PostgRESTWS.HasqlBroadcast (newHasqlBroadcaster, newHasqlBroadcasterOrError) -import qualified PostgRESTWS.Broadcast as B +import PostgRESTWS.Broadcast (Multiplexer, onMessage) +import qualified PostgRESTWS.Broadcast as B +import PostgRESTWS.Claims +import PostgRESTWS.Database +import PostgRESTWS.HasqlBroadcast (newHasqlBroadcaster, + newHasqlBroadcasterOrError) data Message = Message - { claims :: A.Object + { claims :: A.Object , payload :: Text } deriving (Show, Eq, Generic) @@ -49,15 +49,14 @@ -- when the websocket is closed a ConnectionClosed Exception is triggered -- this kills all children and frees resources for us wsApp :: Maybe ByteString -> ByteString -> IO POSIXTime -> H.Pool -> Multiplexer -> WS.ServerApp -wsApp mAuditChannel secret getTime pool multi pendingConn = - getTime >>= forkSessionsWhenTokenIsValid . validateClaims secret jwtToken +wsApp mAuditChannel secret getTime pool multi pendingConn = do + validateClaims secret (toS jwtToken) >>= either rejectRequest forkSessions where - forkSessionsWhenTokenIsValid = either rejectRequest forkSessions hasRead m = m == ("r" :: ByteString) || m == ("rw" :: ByteString) hasWrite m = m == ("w" :: ByteString) || m == ("rw" :: ByteString) rejectRequest = WS.rejectRequest pendingConn . encodeUtf8 -- the first char in path is '/' the rest is the token - jwtToken = decodeUtf8 $ BS.drop 1 $ WS.requestPath $ WS.pendingRequest pendingConn + jwtToken = BS.drop 1 $ WS.requestPath $ WS.pendingRequest pendingConn notifySessionWithTime = notifySession getTime forkSessions (channel, mode, validClaims) = do -- role claim defaults to anon if not specified in jwt @@ -84,10 +83,10 @@ -- But it allows the function to ignore the claims structure and the source -- of the channel, so all claims decoding can be coded in the caller notifySession :: IO POSIXTime - -> A.Object - -> WS.Connection - -> (ByteString -> IO ()) - -> IO () + -> A.Object + -> WS.Connection + -> (ByteString -> IO ()) + -> IO () notifySession getTime claimsToSend wsCon send = withAsync (forever relayData) wait where @@ -102,4 +101,4 @@ claimsWithTime :: IO (M.HashMap Text A.Value) claimsWithTime = do time <- getTime - return $ M.insert "message_sent_at" (A.Number $ fromRational $ toRational time) claimsToSend + return $ M.insert "message_delivered_at" (A.Number $ fromRational $ toRational time) claimsToSend diff --git a/src/PostgRESTWS/Claims.hs b/src/PostgRESTWS/Claims.hs --- a/src/PostgRESTWS/Claims.hs +++ b/src/PostgRESTWS/Claims.hs @@ -7,15 +7,12 @@ ( validateClaims ) where -import Protolude -import qualified Data.HashMap.Strict as M -import Web.JWT (binarySecret) -import Data.Aeson (Value (..), toJSON) -import Data.Time.Clock.POSIX (POSIXTime) import Control.Lens -import Data.Aeson.Lens -import Data.Time.Clock (NominalDiffTime) -import qualified Web.JWT as JWT +import qualified Crypto.JOSE.Types as JOSE.Types +import Crypto.JWT +import Data.Aeson (Value (..), decode, toJSON) +import qualified Data.HashMap.Strict as M +import Protolude type Claims = M.HashMap Text Value @@ -24,26 +21,23 @@ {-| Given a secret, a token and a timestamp it validates the claims and returns either an error message or a triple containing channel, mode and claims hashmap. -} -validateClaims :: ByteString -> Text -> POSIXTime -> Either Text ConnectionInfo -validateClaims secret jwtToken time = do - cl <- case jwtClaims jwtSecret jwtToken time of - JWTClaims c -> Right c - _ -> Left "Error" - jChannel <- claimAsJSON "channel" cl - jMode <- claimAsJSON "mode" cl - channel <- value2BS jChannel - mode <- value2BS jMode - Right (channel, mode, cl) +validateClaims :: ByteString -> LByteString -> IO (Either Text ConnectionInfo) +validateClaims secret jwtToken = + runExceptT $ do + cl <- liftIO $ jwtClaims (parseJWK secret) jwtToken + cl' <- case cl of + JWTClaims c -> pure c + _ -> throwError "Error" + channel <- claimAsJSON "channel" cl' + mode <- claimAsJSON "mode" cl' + pure (channel, mode, cl') + where - jwtSecret = binarySecret secret - value2BS val = case val of - String s -> Right $ encodeUtf8 s - _ -> Left "claim is not string value" - claimAsJSON :: Text -> Claims -> Either Text Value + claimAsJSON :: Text -> Claims -> ExceptT Text IO ByteString claimAsJSON name cl = case M.lookup name cl of - Just el -> Right el - Nothing -> Left (name <> " not in claims") - + Just (String s) -> pure $ encodeUtf8 s + Just _ -> throwError "claim is not string value" + Nothing -> throwError (name <> " not in claims") {- Private functions and types copied from postgrest @@ -53,8 +47,7 @@ {-| Possible situations encountered with client JWTs -} -data JWTAttempt = JWTExpired - | JWTInvalid +data JWTAttempt = JWTInvalid JWTError | JWTMissingSecret | JWTClaims (M.HashMap Text Value) deriving Eq @@ -63,18 +56,40 @@ Receives the JWT secret (from config) and a JWT and returns a map of JWT claims. -} -jwtClaims :: JWT.Secret -> Text -> NominalDiffTime -> JWTAttempt -jwtClaims _ "" _ = JWTClaims M.empty -jwtClaims secret jwt time = - case mClaims of - Nothing -> JWTInvalid - Just cl -> if isExpired cl - then JWTExpired - else JWTClaims $ value2map cl - where - mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature secret jwt - isExpired claims = - let mExp = claims ^? key "exp" . _Integer - in fromMaybe False $ (<= time) . fromInteger <$> mExp - value2map (Object o) = o - value2map _ = M.empty +jwtClaims :: JWK -> LByteString -> IO JWTAttempt +jwtClaims _ "" = return $ JWTClaims M.empty +jwtClaims secret payload = do + let validation = defaultJWTValidationSettings (const True) + eJwt <- runExceptT $ do + jwt <- decodeCompact payload + verifyClaims validation secret jwt + return $ case eJwt of + Left e -> JWTInvalid e + Right jwt -> JWTClaims . claims2map $ jwt + +{-| + Internal helper used to turn JWT ClaimSet into something + easier to work with +-} +claims2map :: ClaimsSet -> M.HashMap Text Value +claims2map = val2map . toJSON + where + val2map (Object o) = o + val2map _ = M.empty + +{-| + Internal helper to generate HMAC-SHA256. When the jwt key in the + config file is a simple string rather than a JWK object, we'll + apply this function to it. +-} +hs256jwk :: ByteString -> JWK +hs256jwk key = + fromKeyMaterial km + & jwkUse .~ Just Sig + & jwkAlg .~ (Just $ JWSAlg HS256) + where + km = OctKeyMaterial (OctKeyParameters (JOSE.Types.Base64Octets key)) + +parseJWK :: ByteString -> JWK +parseJWK str = + fromMaybe (hs256jwk str) (decode (toS str) :: Maybe JWK) diff --git a/src/PostgRESTWS/Database.hs b/src/PostgRESTWS/Database.hs --- a/src/PostgRESTWS/Database.hs +++ b/src/PostgRESTWS/Database.hs @@ -10,7 +10,7 @@ , toPgIdentifier ) where -import Protolude +import Protolude hiding (replace) import Hasql.Pool (Pool, UsageError, use) import Hasql.Session (sql, run, query) import qualified Hasql.Session as S diff --git a/src/PostgRESTWS/HasqlBroadcast.hs b/src/PostgRESTWS/HasqlBroadcast.hs --- a/src/PostgRESTWS/HasqlBroadcast.hs +++ b/src/PostgRESTWS/HasqlBroadcast.hs @@ -15,7 +15,6 @@ import Hasql.Connection import Data.Either.Combinators (mapBoth) -import System.IO (hPutStrLn) import Data.Function (id) import Control.Retry (RetryStatus, retrying, capDelay, exponentialBackoff) @@ -46,9 +45,9 @@ shouldRetry :: RetryStatus -> Either ConnectionError Connection -> IO Bool shouldRetry _ con = case con of - Left err -> - hPutStrLn stderr ("Error connecting notification listener to database: " <> show err) - >> return True + Left err -> do + putErrLn $ "Error connecting notification listener to database: " <> show err + return True _ -> return False {- | Returns a multiplexer from an IO Connection, listen for different database notification channels using the connection produced. @@ -79,7 +78,7 @@ void $ relayMessagesForever multi return multi where - closeProducer _ = hPutStrLn stderr "Broadcaster is dead" + closeProducer _ = putErrLn "Broadcaster is dead" openProducer cmds msgs = do con <- getCon waitForNotifications @@ -90,3 +89,7 @@ case cmd of Open ch -> listen con $ toPgIdentifier ch Close ch -> unlisten con $ toPgIdentifier ch + + +putErrLn :: Text -> IO () +putErrLn = hPutStrLn stderr diff --git a/test/ClaimsSpec.hs b/test/ClaimsSpec.hs new file mode 100644 --- /dev/null +++ b/test/ClaimsSpec.hs @@ -0,0 +1,17 @@ +module ClaimsSpec (spec) where + +import Protolude + +import qualified Data.HashMap.Strict as M +import Test.Hspec +import Data.Aeson (Value (..) ) + +import PostgRESTWS.Claims + +spec :: Spec +spec = + describe "validate claims" + $ it "should succeed using a matching token" + $ validateClaims "reallyreallyreallyreallyverysafe" + "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJtb2RlIjoiciIsImNoYW5uZWwiOiJ0ZXN0In0.1d4s-at2kWj8OSabHZHTbNh1dENF7NWy_r0ED3Rwf58" + `shouldReturn` Right ("test", "r", M.fromList[("mode",String "r"),("channel",String "test")])