Merge pull request #61 from diogob/refactor-modules

Refactor modules and export full stand-alone server from library

Author: diogob

.circleci/config.yml

@@ -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:

app/Config.hs

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

app/Main.hs

@@ -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
@@ -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
 
@@ -82,6 +80,7 @@ test-suite postgres-websockets-test
   other-modules:       BroadcastSpec
                      , ClaimsSpec
                      , HasqlBroadcastSpec
+                     , ServerSpec
   build-depends:       base
                      , protolude >= 0.2.3
                      , postgres-websockets
@@ -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