diff --git a/app/Config.hs b/app/Config.hs new file mode 100644 --- /dev/null +++ b/app/Config.hs @@ -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" diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 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.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 diff --git a/src/PostgRESTWS.hs b/src/PostgRESTWS.hs --- a/src/PostgRESTWS.hs +++ b/src/PostgRESTWS.hs @@ -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 () diff --git a/src/PostgRESTWS/Broadcast.hs b/src/PostgRESTWS/Broadcast.hs --- a/src/PostgRESTWS/Broadcast.hs +++ b/src/PostgRESTWS/Broadcast.hs @@ -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. diff --git a/src/PostgRESTWS/Claims.hs b/src/PostgRESTWS/Claims.hs --- a/src/PostgRESTWS/Claims.hs +++ b/src/PostgRESTWS/Claims.hs @@ -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 diff --git a/src/PostgRESTWS/Database.hs b/src/PostgRESTWS/Database.hs --- a/src/PostgRESTWS/Database.hs +++ b/src/PostgRESTWS/Database.hs @@ -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 = diff --git a/src/PostgRESTWS/HasqlBroadcast.hs b/src/PostgRESTWS/HasqlBroadcast.hs --- a/src/PostgRESTWS/HasqlBroadcast.hs +++ b/src/PostgRESTWS/HasqlBroadcast.hs @@ -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 diff --git a/src/PostgRESTWS/Types.hs b/src/PostgRESTWS/Types.hs deleted file mode 100644 --- a/src/PostgRESTWS/Types.hs +++ /dev/null @@ -1,5 +0,0 @@ -module PostgRESTWS.Types where - -import Protolude - -newtype Error = NotifyError Text