Skip to content

Commit

Permalink
Merge pull request #61 from diogob/refactor-modules
Browse files Browse the repository at this point in the history 
Refactor modules and export full stand-alone server from library
  • Loading branch information
@diogob
diogob authored Aug 11, 2020
2 parents 2d6a835 + 1168c58 commit 39f2515
Show file tree
Hide file tree
Showing 14 changed files with 464 additions and 335 deletions.
2 changes: 1 addition & 1 deletion .circleci/config.yml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@
# - https://circleci.com/docs/2.0/language-haskell/
# - https://circleci.com/blog/publishing-to-github-releases-via-circleci/
#
version: 2
version: 2.1
jobs:
publish:
docker:
Expand Down
65 changes: 0 additions & 65 deletions app/Config.hs
View file

This file was deleted.

108 changes: 5 additions & 103 deletions app/Main.hs
View file
Original file line number Diff line number Diff line change
@@ -1,45 +1,9 @@
module Main where

import Protolude hiding (replace)
import PostgresWebsockets
import Config (AppConfig (..),
PgVersion (..),
minimumPgVersion,
prettyVersion,
readOptions)
import Protolude
import PostgresWebsockets

import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import Data.String (IsString (..))
import Data.Text (pack, replace, strip, stripPrefix)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import qualified Hasql.Statement as H
import qualified Hasql.Session 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 Data.Time.Clock (UTCTime, getCurrentTime)
import Control.AutoUpdate ( defaultUpdateSettings
, mkAutoUpdate
, updateAction
)

import Network.Wai (Application, responseLBS)
import Network.HTTP.Types (status200)
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.RequestLogger (logStdout)
import System.IO (BufferMode (..),
hSetBuffering)

isServerVersionSupported :: H.Session Bool
isServerVersionSupported = do
ver <- H.statement () pgVersion
return $ ver >= pgvNum minimumPgVersion
where
pgVersion =
H.Statement "SELECT current_setting('server_version_num')::integer"
HE.noParams (HD.singleRow $ HD.column $ HD.nonNullable HD.int4) False
import System.IO (BufferMode (..), hSetBuffering)

main :: IO ()
main = do
Expand All @@ -51,67 +15,5 @@ main = do
<> prettyVersion
<> " / Connects websockets to PostgreSQL asynchronous notifications."

conf <- loadSecretFile =<< readOptions
shutdownSignal <- newEmptyMVar
let host = configHost conf
port = configPort conf
listenChannel = toS $ configListenChannel conf
pgSettings = toS (configDatabase conf)
waitForShutdown cl = void $ forkIO (takeMVar shutdownSignal >> cl >> die "Shutting server down...")

appSettings = setHost ((fromString . toS) host)
. setPort port
. setServerName (toS $ "postgres-websockets/" <> prettyVersion)
. setTimeout 3600
. setInstallShutdownHandler waitForShutdown
. setGracefulShutdownTimeout (Just 5)
$ defaultSettings

putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)

let shutdown = putErrLn ("Broadcaster connection is dead" :: Text) >> putMVar shutdownSignal ()
pool <- P.acquire (configPool conf, 10, pgSettings)
multi <- newHasqlBroadcaster shutdown listenChannel pgSettings
getTime <- mkGetTime

runSettings appSettings $
postgresWsMiddleware getTime listenChannel (configJwtSecret conf) pool multi $
logStdout $ maybe dummyApp staticApp' (configPath conf)

where
mkGetTime :: IO (IO UTCTime)
mkGetTime = mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime}
staticApp' :: Text -> Application
staticApp' = staticApp . defaultFileServerSettings . toS
dummyApp :: Application
dummyApp _ respond =
respond $ responseLBS status200 [("Content-Type", "text/plain")] "Hello, Web!"

loadSecretFile :: AppConfig -> IO AppConfig
loadSecretFile conf = extractAndTransform secret
where
secret = decodeUtf8 $ configJwtSecret conf
isB64 = configJwtSecretIsBase64 conf

extractAndTransform :: Text -> IO AppConfig
extractAndTransform s =
fmap setSecret $ transformString isB64 =<<
case stripPrefix "@" s of
Nothing -> return . encodeUtf8 $ s
Just filename -> chomp <$> BS.readFile (toS filename)
where
chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs)

-- 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}

-- replace: Replace every occurrence of one substring with another
replaceUrlChars =
replace "_" "/" . replace "-" "+" . replace "." "="
conf <- loadConfig
void $ serve conf
37 changes: 20 additions & 17 deletions postgres-websockets.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,11 @@ library
, PostgresWebsockets.Broadcast
, PostgresWebsockets.HasqlBroadcast
, PostgresWebsockets.Claims
, PostgresWebsockets.Config

other-modules: Paths_postgres_websockets
, PostgresWebsockets.Server
, PostgresWebsockets.Middleware
build-depends: base >= 4.7 && < 5
, hasql-pool >= 0.5 && < 0.6
, text >= 1.2 && < 1.3
Expand All @@ -46,32 +51,25 @@ library
, contravariant >= 1.5.2 && < 1.6
, alarmclock >= 0.7.0.2 && < 0.8
, async >= 2.2.0 && < 2.3
, envparse >= 0.4.1
, base64-bytestring >= 1.0.0.3 && < 1.1
, bytestring >= 0.10
, warp >= 3.2 && < 4
, wai-extra >= 3.0.29 && < 3.1
, wai-app-static >= 3.1.7.1 && < 3.2
, auto-update >= 0.1.6 && < 0.2

default-language: Haskell2010
default-extensions: OverloadedStrings, NoImplicitPrelude, LambdaCase
default-extensions: OverloadedStrings, NoImplicitPrelude, LambdaCase, RecordWildCards

executable postgres-websockets
hs-source-dirs: app
main-is: Main.hs
other-modules: Config
, Paths_postgres_websockets
other-modules:
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends: base >= 4.7 && < 5
, transformers >= 0.4 && < 0.6
, hasql >= 0.19
, hasql-pool >= 0.4
, warp >= 3.2 && < 4
, postgres-websockets
, protolude >= 0.2.3
, base64-bytestring >= 1.0.0.3 && < 1.1
, bytestring >= 0.10
, text >= 1.2 && < 1.3
, time >= 1.8.0.2 && < 1.9
, wai >= 3.2 && < 4
, wai-extra >= 3.0.29 && < 3.1
, wai-app-static >= 3.1.7.1 && < 3.2
, http-types >= 0.9
, envparse >= 0.4.1
, auto-update >= 0.1.6 && < 0.2
default-language: Haskell2010
default-extensions: OverloadedStrings, NoImplicitPrelude, QuasiQuotes

Expand All @@ -82,6 +80,7 @@ test-suite postgres-websockets-test
other-modules: BroadcastSpec
, ClaimsSpec
, HasqlBroadcastSpec
, ServerSpec
build-depends: base
, protolude >= 0.2.3
, postgres-websockets
Expand All @@ -97,6 +96,10 @@ test-suite postgres-websockets-test
, unordered-containers >= 0.2
, wai-extra >= 3.0.29 && < 3.1
, stm >= 2.5.0.0 && < 2.6
, websockets >= 0.12.7.0 && < 0.13
, network >= 2.8.0.1 && < 2.9
, lens >= 4.17.1 && < 4.18
, lens-aeson
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010
default-extensions: OverloadedStrings, NoImplicitPrelude
Expand Down
Loading

0 comments on commit 39f2515

Please sign in to comment.