postgrest-ws 0.1.0.3 → 0.2.0.0
raw patch · 9 files changed
+272/−73 lines, 9 filesdep +ansi-wl-pprintdep +configuratordep +heredocdep −postgrestdep ~bytestringdep ~http-typesdep ~jwtPVP ok
version bump matches the API change (PVP)
Dependencies added: ansi-wl-pprint, configurator, heredoc, lens, lens-aeson, optparse-applicative, wai-app-static
Dependencies removed: postgrest
Dependency ranges changed: bytestring, http-types, jwt, wai
API changes (from Hackage documentation)
Files
- app/Config.hs +140/−0
- app/Main.hs +15/−52
- postgrest-ws.cabal +16/−6
- src/PostgRESTWS.hs +12/−5
- src/PostgRESTWS/Broadcast.hs +1/−1
- src/PostgRESTWS/Claims.hs +45/−3
- src/PostgRESTWS/Database.hs +15/−1
- src/PostgRESTWS/HasqlBroadcast.hs +28/−0
- src/PostgRESTWS/Types.hs +0/−5
+ app/Config.hs view
@@ -0,0 +1,140 @@+{-|+Module : Config+Description : Manages PostgRESTWS configuration options.++This module provides a helper function to read the command line+arguments using the optparse-applicative and the AppConfig type to store+them. It also can be used to define other middleware configuration that+may be delegated to some sort of external configuration.++It currently includes a hardcoded CORS policy but this could easly be+turned in configurable behaviour if needed.++Other hardcoded options such as the minimum version number also belong here.+-}+module Config ( prettyVersion+ , readOptions+ , minimumPgVersion+ , PgVersion (..)+ , AppConfig (..)+ )+ where++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)+import Text.Heredoc+import Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>))+import qualified Text.PrettyPrint.ANSI.Leijen as L+import Protolude hiding (intercalate, (<>))++-- | Config file settings for the server+data AppConfig = AppConfig {+ configDatabase :: Text+ , configPath :: Text+ , configHost :: Text+ , configPort :: Int++ , configJwtSecret :: Maybe B.ByteString+ , configJwtSecretIsBase64 :: Bool++ , configPool :: Int+ }++-- | User friendly version number+prettyVersion :: Text+prettyVersion = intercalate "." $ map show $ versionBranch version++-- | Function to read and parse options from the command line+readOptions :: IO AppConfig+readOptions = do+ -- First read the config file path from command line+ cfgPath <- customExecParser parserPrefs opts+ -- Now read the actual config file+ conf <- catch+ (C.load [C.Required cfgPath])+ configNotfoundHint++ handle missingKeyHint $ do+ -- db ----------------+ cDbUri <- C.require conf "db-uri"+ cPool <- C.lookupDefault 10 conf "db-pool"+ -- server ------------+ cPath <- C.require conf "server-root"+ cHost <- C.lookupDefault "*4" conf "server-host"+ cPort <- C.lookupDefault 3000 conf "server-port"+ -- jwt ---------------+ cJwtSec <- C.lookup conf "jwt-secret"+ cJwtB64 <- C.lookupDefault False conf "secret-is-base64"++ return $ AppConfig cDbUri cPath cHost cPort (encodeUtf8 <$> cJwtSec) cJwtB64 cPool++ where+ opts = info (helper <*> pathParser) $+ fullDesc+ <> progDesc (+ "PostgREST "+ <> toS prettyVersion+ <> " / create a REST API to an existing Postgres database"+ )+ <> footerDoc (Just $+ text "Example Config File:"+ L.<> nest 2 (hardline L.<> exampleCfg)+ )++ parserPrefs = prefs showHelpOnError++ configNotfoundHint :: IOError -> IO a+ configNotfoundHint e = do+ hPutStrLn stderr $+ "Cannot open config file:\n\t" <> show e+ exitFailure++ missingKeyHint :: C.KeyError -> IO a+ missingKeyHint (C.KeyError n) = do+ hPutStrLn stderr $+ "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 $+ [str|db-uri = "postgres://user:pass@localhost:5432/dbname"+ |db-pool = 10+ |+ |server-root = "./client-example"+ |server-host = "*4"+ |server-port = 3000+ |+ |## choose a secret to enable JWT auth+ |## (use "@filename" to load from separate file)+ |# jwt-secret = "foo"+ |# secret-is-base64 = false+ |]+++pathParser :: Parser FilePath+pathParser =+ strArgument $+ metavar "FILENAME" <>+ help "Path to configuration file"++data PgVersion = PgVersion {+ pgvNum :: Int32+, pgvName :: Text+}++-- | Tells the minimum PostgreSQL version required by this version of PostgRESTWS+minimumPgVersion :: PgVersion+minimumPgVersion = PgVersion 90300 "9.3"
app/Main.hs view
@@ -1,41 +1,35 @@-{-# LANGUAGE CPP #-}- module Main where import Protolude-import PostgREST.Config (AppConfig (..),+import PostgRESTWS+import PostgRESTWS.Broadcast+import PostgRESTWS.HasqlBroadcast+import Config (AppConfig (..), PgVersion (..), minimumPgVersion, prettyVersion, readOptions)-import PostgREST.Error (encodeError)-import PostgREST.OpenAPI (isMalformedProxyUri)-import PostgREST.DbStructure-import PostgREST.App (postgrest)-import PostgRESTWS-import PostgRESTWS.HasqlBroadcast -import Control.AutoUpdate+import Data.Function (id) import Data.ByteString.Base64 (decode) import Data.String (IsString (..)) import Data.Text (stripPrefix, pack, replace)-import Data.Text.IO (hPutStrLn, readFile)-import Data.Function (id)+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Data.Text.IO (readFile) import Data.Time.Clock.POSIX (getPOSIXTime)+import qualified Hasql.Connection as H import qualified Hasql.Query as H import qualified Hasql.Session as H-import qualified Hasql.Connection as H import qualified Hasql.Decoders as HD import qualified Hasql.Encoders as HE import qualified Hasql.Pool as P+import Network.Wai.Application.Static+ import Network.Wai.Handler.Warp+import Network.Wai.Middleware.RequestLogger (logStdout) import System.IO (BufferMode (..), hSetBuffering)--import Data.IORef-#ifndef mingw32_HOST_OS-import System.Posix.Signals-#endif+import Control.AutoUpdate isServerVersionSupported :: H.Session Bool isServerVersionSupported = do@@ -55,60 +49,29 @@ conf <- loadSecretFile =<< readOptions let host = configHost conf port = configPort conf- proxy = configProxyUri conf pgSettings = toS (configDatabase conf) appSettings = setHost ((fromString . toS) host) . setPort port . setServerName (toS $ "postgrest/" <> prettyVersion)+ . setTimeout 3600 $ defaultSettings - when (isMalformedProxyUri $ toS <$> proxy) $ panic- "Malformed proxy uri, a correct example: https://example.com:8443/basePath"- putStrLn $ ("Listening on port " :: Text) <> show (configPort conf) pool <- P.acquire (configPool conf, 10, pgSettings)- conOrError <- H.acquire pgSettings let con = either (panic . show) id conOrError :: H.Connection - result <- P.use pool $ do- supported <- isServerVersionSupported- unless supported $ panic (- "Cannot run in this PostgreSQL version, PostgREST needs at least "- <> pgvName minimumPgVersion)- getDbStructure (toS $ configSchema conf)-- forM_ (lefts [result]) $ \e -> do- hPutStrLn stderr (toS $ encodeError e)- exitFailure-- refDbStructure <- newIORef $ either (panic . show) id result--#ifndef mingw32_HOST_OS- tid <- myThreadId- forM_ [sigINT, sigTERM] $ \sig ->- void $ installHandler sig (Catch $ do- P.release pool- throwTo tid UserInterrupt- ) Nothing-- void $ installHandler sigHUP (- Catch . void . P.use pool $ do- s <- getDbStructure (toS $ configSchema conf)- liftIO $ atomicWriteIORef refDbStructure s- ) Nothing-#endif- -- ask for the OS time at most once per second getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getPOSIXTime } multi <- newHasqlBroadcaster con void $ relayMessagesForever multi+ runSettings appSettings $ postgrestWsMiddleware (configJwtSecret conf) getTime pool multi $- postgrest conf refDbStructure pool getTime+ logStdout $ staticApp $ defaultFileServerSettings $ toS $ configPath conf loadSecretFile :: AppConfig -> IO AppConfig loadSecretFile conf = extractAndTransform mSecret
postgrest-ws.cabal view
@@ -1,5 +1,5 @@ name: postgrest-ws-version: 0.1.0.3+version: 0.2.0.0 synopsis: PostgREST extension to map LISTEN/NOTIFY messages to Websockets description: Please see README.md homepage: https://github.com/diogob/postgrest-ws#readme@@ -22,18 +22,19 @@ , PostgRESTWS.HasqlBroadcast other-modules: PostgRESTWS.Claims- , PostgRESTWS.Types build-depends: base >= 4.7 && < 5 , hasql-pool >= 0.4 && < 0.5 , text >= 1.2 && < 2 , wai >= 3.2 && < 4 , websockets >= 0.9 && < 0.11 , wai-websockets >= 3.0 && < 4- , postgrest >= 0.3 && < 0.5 , http-types >= 0.9 , bytestring >= 0.10 , postgresql-libpq , time+ , lens+ , lens-aeson+ , jwt , unordered-containers >= 0.2 , postgresql-libpq >= 0.9 && < 1.0 , aeson >= 0.11@@ -49,6 +50,7 @@ executable postgrest-ws hs-source-dirs: app main-is: Main.hs+ other-modules: Config ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base >= 4.7 && < 5 , transformers >= 0.4 && < 0.6@@ -57,16 +59,24 @@ , warp >= 3.2 && < 4 , unix >= 2.7 && < 3 , jwt >= 0.7 && < 1- , postgrest >= 0.4.1.0 , postgrest-ws , postgresql-libpq >= 0.9 && < 1.0 , protolude >= 0.1.6 && < 0.2- , auto-update , base64-bytestring+ , bytestring+ , configurator+ , optparse-applicative , text , time+ , wai+ , wai-extra+ , wai-app-static+ , heredoc+ , auto-update+ , ansi-wl-pprint+ , http-types default-language: Haskell2010- default-extensions: OverloadedStrings, NoImplicitPrelude+ default-extensions: OverloadedStrings, NoImplicitPrelude, QuasiQuotes test-suite postgrest-ws-test type: exitcode-stdio-1.0
src/PostgRESTWS.hs view
@@ -1,3 +1,9 @@+{-|+Module : PostgRESTWS+Description : PostgRESTWS Middleware, composing this allows postgrest to create+websockets connections that will communicate with the database through LISTEN/NOTIFY channels.++-} {-# LANGUAGE DeriveGeneric #-} module PostgRESTWS@@ -29,15 +35,18 @@ instance A.ToJSON Message +-- | Given a Maybe Secret, a function to fetch the system time, a Hasql Pool and a Multiplexer this will give you a WAI middleware. postgrestWsMiddleware :: Maybe ByteString -> IO POSIXTime -> H.Pool -> Multiplexer -> Wai.Application -> Wai.Application-postgrestWsMiddleware = WS.websocketsOr WS.defaultConnectionOptions `compose` wsApp+postgrestWsMiddleware =+ WS.websocketsOr WS.defaultConnectionOptions `compose` wsApp where compose = (.) . (.) . (.) . (.) -- when the websocket is closed a ConnectionClosed Exception is triggered -- this kills all children and frees resources for us wsApp :: Maybe ByteString -> IO POSIXTime -> H.Pool -> Multiplexer -> WS.ServerApp-wsApp mSecret getTime pqCon multi pendingConn = getTime >>= forkSessionsWhenTokenIsValid . validateClaims mSecret jwtToken+wsApp mSecret getTime pqCon multi pendingConn =+ getTime >>= forkSessionsWhenTokenIsValid . validateClaims mSecret jwtToken where forkSessionsWhenTokenIsValid = either rejectRequest forkSessions hasRead m = m == ("r" :: ByteString) || m == ("rw" :: ByteString)@@ -51,13 +60,11 @@ conn <- WS.acceptRequest pendingConn -- Fork a pinging thread to ensure browser connections stay alive WS.forkPingThread conn 30- -- each websocket needs its own listen connection to avoid- -- handling of multiple waiting threads in the same connection when (hasRead mode) $ onMessage multi channel (\ch -> forever $ atomically (readTChan ch) >>= WS.sendTextData conn . B.payload)- -- all websockets share a single connection to NOTIFY+ notifySessionFinished <- if hasWrite mode then forkAndWait $ forever $ notifySession channel validClaims pqCon conn else newMVar ()
src/PostgRESTWS/Broadcast.hs view
@@ -1,5 +1,5 @@ {-|-Module : PostgRESTWS.Auth+Module : PostgRESTWS.Broadcast Description : PostgRESTWS functions to broadcast messages to several listening clients This module provides a type called Multiplexer.
src/PostgRESTWS/Claims.hs view
@@ -4,18 +4,23 @@ import Protolude import qualified Data.HashMap.Strict as M-import PostgREST.Auth as PGR import Web.JWT (binarySecret)-import Data.Aeson (Value (..))+import Data.Aeson (Value (..), toJSON) import Data.Time.Clock.POSIX (POSIXTime)+import Control.Lens+import Data.Aeson.Lens+import Data.Maybe (fromJust)+import Data.Time.Clock (NominalDiffTime)+import qualified Web.JWT as JWT + type Claims = M.HashMap Text Value type ConnectionInfo = (ByteString, ByteString, Claims) validateClaims :: Maybe ByteString -> Text -> POSIXTime -> Either Text ConnectionInfo validateClaims secret jwtToken time = do cl <- case jwtClaims jwtSecret jwtToken time of- PGR.JWTClaims c -> Right c+ JWTClaims c -> Right c _ -> Left "Error" jChannel <- claimAsJSON "channel" cl jMode <- claimAsJSON "mode" cl@@ -31,3 +36,40 @@ claimAsJSON name cl = case M.lookup name cl of Just el -> Right el Nothing -> Left (name <> " not in claims")+++{- Private functions and types copied from postgrest++ This code duplication will be short lived since postgrest will migrate towards jose+ Then this library will use jose's verifyClaims and error types.+-}+{-|+ Possible situations encountered with client JWTs+-}+data JWTAttempt = JWTExpired+ | JWTInvalid+ | JWTMissingSecret+ | JWTClaims (M.HashMap Text Value)+ deriving Eq++{-|+ Receives the JWT secret (from config) and a JWT and returns a map+ of JWT claims.+-}+jwtClaims :: Maybe JWT.Secret -> Text -> NominalDiffTime -> JWTAttempt+jwtClaims _ "" _ = JWTClaims M.empty+jwtClaims secret jwt time =+ case secret of+ Nothing -> JWTMissingSecret+ Just s ->+ let mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature s jwt in+ case isExpired <$> mClaims of+ Just True -> JWTExpired+ Nothing -> JWTInvalid+ Just False -> JWTClaims $ value2map $ fromJust mClaims+ where+ isExpired claims =+ let mExp = claims ^? key "exp" . _Integer+ in fromMaybe False $ (<= time) . fromInteger <$> mExp+ value2map (Object o) = o+ value2map _ = M.empty
src/PostgRESTWS/Database.hs view
@@ -1,3 +1,8 @@+{-|+Module : PostgRESTWS.Database+Description : This module encapsulates knowledge about the SQL commands and the Hasql interface.++-} module PostgRESTWS.Database ( notifyPool , notify@@ -14,8 +19,9 @@ import qualified Database.PostgreSQL.LibPQ as PQ import Data.Either.Combinators -import PostgRESTWS.Types+newtype Error = NotifyError Text +-- | Given a Hasql Pool, a channel and a message sends a notify command to the database notifyPool :: Pool -> ByteString -> ByteString -> IO (Either Error ()) notifyPool pool channel mesg = mapError <$> use pool (sql ("NOTIFY " <> channel <> ", '" <> mesg <> "'"))@@ -23,6 +29,7 @@ mapError :: Either UsageError () -> Either Error () mapError = mapLeft (NotifyError . show) +-- | Given a Hasql Connection, a channel and a message sends a notify command to the database notify :: Connection -> ByteString -> ByteString -> IO (Either Error ()) notify con channel mesg = mapError <$> run (sql ("NOTIFY " <> channel <> ", '" <> mesg <> "'")) con@@ -30,18 +37,25 @@ mapError :: Either S.Error () -> Either Error () mapError = mapLeft (NotifyError . show) +-- | Given a Hasql Connection and a channel sends a listen command to the database listen :: Connection -> ByteString -> IO () listen con channel = void $ withLibPQConnection con execListen where execListen pqCon = void $ PQ.exec pqCon $ "LISTEN " <> channel +-- | Given a Hasql Connection and a channel sends a unlisten command to the database unlisten :: Connection -> ByteString -> IO () unlisten con channel = void $ withLibPQConnection con execListen where execListen pqCon = void $ PQ.exec pqCon $ "UNLISTEN " <> channel ++{- | Given a function that handles notifications and a Hasql connection forks a thread that listens on the database connection and calls the handler everytime a message arrives.++ The message handler passed as first argument needs two parameters channel and payload.+-} waitForNotifications :: (ByteString -> ByteString -> IO()) -> Connection -> IO () waitForNotifications sendNotification con =
src/PostgRESTWS/HasqlBroadcast.hs view
@@ -1,3 +1,11 @@+{-|+Module : PostgRESTWS.HasqlBroadcast+Description : Uses Broadcast module adding database as a source producer.++This module provides a function to produce a 'Multiplexer' from a Hasql 'Connection'.+The producer issues a LISTEN command upon Open commands and UNLISTEN upon Close.++-} module PostgRESTWS.HasqlBroadcast ( newHasqlBroadcaster -- re-export@@ -13,6 +21,26 @@ import PostgRESTWS.Database import PostgRESTWS.Broadcast +{- | Returns a multiplexer from a connection, listen for different database notification channels using that connection.++ To listen on channels *chat*++ @+ import Protolude+ import PostgRESTWS.HasqlBroadcast+ import PostgRESTWS.Broadcast+ import Hasql.Connection++ main = do+ conOrError <- H.acquire "postgres://localhost/test_database"+ let con = either (panic . show) id conOrError :: Connection+ multi <- newHasqlBroadcaster con++ onMessage multi "chat" (\ch ->+ forever $ fmap print (atomically $ readTChan ch)+ @++-} newHasqlBroadcaster :: Connection -> IO Multiplexer newHasqlBroadcaster con = newMultiplexer (\cmds msgs-> do waitForNotifications
− src/PostgRESTWS/Types.hs
@@ -1,5 +0,0 @@-module PostgRESTWS.Types where--import Protolude--newtype Error = NotifyError Text