postgrest-ws 0.4.0.0 → 0.4.1.0
raw patch · 8 files changed
+135/−109 lines, 8 filesdep +josedep ~jwtdep ~protoludePVP ok
version bump matches the API change (PVP)
Dependencies added: jose
Dependency ranges changed: jwt, protolude
API changes (from Hackage documentation)
+ PostgRESTWS.Claims: instance GHC.Classes.Eq PostgRESTWS.Claims.JWTAttempt
+ PostgRESTWS.Claims: validateClaims :: ByteString -> LByteString -> IO (Either Text ConnectionInfo)
Files
- app/Config.hs +4/−12
- app/Main.hs +18/−19
- postgrest-ws.cabal +9/−8
- src/PostgRESTWS.hs +20/−21
- src/PostgRESTWS/Claims.hs +58/−43
- src/PostgRESTWS/Database.hs +1/−1
- src/PostgRESTWS/HasqlBroadcast.hs +8/−5
- test/ClaimsSpec.hs +17/−0
app/Config.hs view
@@ -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 $
app/Main.hs view
@@ -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 "." "="
postgrest-ws.cabal view
@@ -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
src/PostgRESTWS.hs view
@@ -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
src/PostgRESTWS/Claims.hs view
@@ -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)
src/PostgRESTWS/Database.hs view
@@ -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
src/PostgRESTWS/HasqlBroadcast.hs view
@@ -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
+ test/ClaimsSpec.hs view
@@ -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")])