{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Purview.Server
( serve
, Configuration (..)
, defaultConfiguration
, renderFullPage
, startWebSocketLoop
)
where
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai as Wai
import qualified Network.WebSockets as WebSocket
import qualified Network.Wai.Handler.WebSockets as WaiWebSocket
import Network.HTTP.Types ( status200 )
import qualified Data.ByteString.Char8 as ByteString
import Data.ByteString.Builder.Internal
import qualified Data.Text as Text
import Data.Typeable
import Control.Concurrent.STM.TChan
import Control.Monad.STM
import Control.Concurrent
import Data.Aeson
import Blaze.ByteString.Builder.Char.Utf8
import Component
import EventLoop
import Events
import PrepareTree
import Rendering
import Wrapper
import CollectInitials
import CleanTree
import Configuration
defaultConfiguration :: Configuration IO
defaultConfiguration :: Configuration IO
defaultConfiguration = Configuration
{ interpreter :: IO [Event] -> IO [Event]
interpreter = forall a. a -> a
id
, logger :: String -> IO ()
logger = String -> IO ()
putStrLn
, eventsToListenTo :: [String]
eventsToListenTo = [ String
"click", String
"focusout", String
"focusin", String
"change", String
"submit" ]
, htmlHead :: String
htmlHead = String
""
, devMode :: Bool
devMode = Bool
False
, javascript :: String
javascript = String
""
, port :: Int
port = Int
8001
, secure :: Bool
secure = Bool
False
}
serve :: Monad m => Configuration m -> (String -> Purview () m) -> IO ()
serve :: forall (m :: * -> *).
Monad m =>
Configuration m -> (String -> Purview () m) -> IO ()
serve config :: Configuration m
config@Configuration{ Int
port :: Int
port :: forall (m :: * -> *). Configuration m -> Int
port, String -> IO ()
logger :: String -> IO ()
logger :: forall (m :: * -> *). Configuration m -> String -> IO ()
logger } String -> Purview () m
component =
let
settings :: Settings
settings = Int -> Settings -> Settings
Warp.setPort Int
port Settings
Warp.defaultSettings
in do
String -> IO ()
logger forall a b. (a -> b) -> a -> b
$ String
"Starting on port " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
port
Settings -> Application -> IO ()
Warp.runSettings Settings
settings
forall a b. (a -> b) -> a -> b
$ ConnectionOptions -> ServerApp -> Application -> Application
WaiWebSocket.websocketsOr
ConnectionOptions
WebSocket.defaultConnectionOptions
(forall (m :: * -> *).
Monad m =>
Configuration m -> (String -> Purview () m) -> ServerApp
webSocketHandler Configuration m
config String -> Purview () m
component)
(forall (m :: * -> *).
Configuration m -> (String -> Purview () m) -> Application
httpHandler Configuration m
config String -> Purview () m
component)
webSocketHandler
:: Monad m
=> Configuration m
-> (String -> Purview () m)
-> WebSocket.PendingConnection -> IO ()
webSocketHandler :: forall (m :: * -> *).
Monad m =>
Configuration m -> (String -> Purview () m) -> ServerApp
webSocketHandler Configuration m
config String -> Purview () m
component PendingConnection
pendingConnection = do
let
path :: String
path = ByteString -> String
ByteString.unpack
forall a b. (a -> b) -> a -> b
$ RequestHead -> ByteString
WebSocket.requestPath (PendingConnection -> RequestHead
WebSocket.pendingRequest PendingConnection
pendingConnection)
render :: Purview () m
render = String -> Purview () m
component String
path
Connection
connection <- PendingConnection -> IO Connection
WebSocket.acceptRequest PendingConnection
pendingConnection
forall (m :: * -> *) action.
(Monad m, Typeable action) =>
Configuration m -> Purview action m -> Connection -> IO ()
startWebSocketLoop Configuration m
config { devMode :: Bool
devMode=Bool
True } Purview () m
render Connection
connection
httpHandler :: Configuration m -> (String -> Purview () m) -> Wai.Application
httpHandler :: forall (m :: * -> *).
Configuration m -> (String -> Purview () m) -> Application
httpHandler Configuration m
config String -> Purview () m
component Request
request Response -> IO ResponseReceived
respond =
let
path :: String
path = Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat forall a b. (a -> b) -> a -> b
$ Request -> [Text]
Wai.pathInfo Request
request
render :: Purview () m
render = String -> Purview () m
component forall a b. (a -> b) -> a -> b
$ String
"/" forall a. Semigroup a => a -> a -> a
<> String
path
in
Response -> IO ResponseReceived
respond
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
Wai.responseBuilder
Status
status200
[(HeaderName
"Content-Type", ByteString
"text/html")]
(forall action (m :: * -> *).
Typeable action =>
Configuration m -> Purview action m -> Builder
renderFullPage Configuration m
config Purview () m
render)
renderFullPage :: Typeable action => Configuration m -> Purview action m -> Builder
renderFullPage :: forall action (m :: * -> *).
Typeable action =>
Configuration m -> Purview action m -> Builder
renderFullPage Configuration { String
htmlHead :: String
htmlHead :: forall (m :: * -> *). Configuration m -> String
htmlHead, [String]
eventsToListenTo :: [String]
eventsToListenTo :: forall (m :: * -> *). Configuration m -> [String]
eventsToListenTo, String
javascript :: String
javascript :: forall (m :: * -> *). Configuration m -> String
javascript, Bool
secure :: Bool
secure :: forall (m :: * -> *). Configuration m -> Bool
secure } Purview action m
component =
let
locatedComponent :: Purview action m
locatedComponent = forall event (m :: * -> *).
Typeable event =>
Purview event m -> Purview event m
prepareTree Purview action m
component
([Event]
initialEvents, [(String, String)]
css) = forall event (m :: * -> *).
Typeable event =>
Purview event m -> ([Event], [(String, String)])
collectInitials Purview action m
locatedComponent
rendered :: String
rendered = forall action (m :: * -> *). Purview action m -> String
render (forall event (m :: * -> *).
Typeable event =>
[(String, String)] -> Purview event m -> Purview event m
cleanTree [(String, String)]
css Purview action m
locatedComponent)
wrap :: String -> String
wrap = [(String, String)]
-> String -> [String] -> String -> Bool -> String -> String
wrapHtml [(String, String)]
css String
htmlHead [String]
eventsToListenTo String
javascript Bool
secure
in
String -> Builder
fromString forall a b. (a -> b) -> a -> b
$ String -> String
wrap String
rendered
startWebSocketLoop
:: (Monad m, Typeable action)
=> Configuration m
-> Purview action m
-> WebSocket.Connection
-> IO ()
startWebSocketLoop :: forall (m :: * -> *) action.
(Monad m, Typeable action) =>
Configuration m -> Purview action m -> Connection -> IO ()
startWebSocketLoop Configuration { Bool
devMode :: Bool
devMode :: forall (m :: * -> *). Configuration m -> Bool
devMode, m [Event] -> IO [Event]
interpreter :: m [Event] -> IO [Event]
interpreter :: forall (m :: * -> *). Configuration m -> m [Event] -> IO [Event]
interpreter, String -> IO ()
logger :: String -> IO ()
logger :: forall (m :: * -> *). Configuration m -> String -> IO ()
logger } Purview action m
component Connection
connection = do
TChan Event
eventBus <- forall a. IO (TChan a)
newTChanIO
forall a. STM a -> IO a
atomically
forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan Event
eventBus
forall a b. (a -> b) -> a -> b
$ FromFrontendEvent { $sel:kind:FromFrontendEvent :: Text
kind = Text
"init", $sel:childLocation:FromFrontendEvent :: Identifier
childLocation = forall a. Maybe a
Nothing, $sel:location:FromFrontendEvent :: Identifier
location = forall a. Maybe a
Nothing, $sel:value:FromFrontendEvent :: Maybe String
value = forall a. Maybe a
Nothing }
forall a. Connection -> Int -> IO () -> IO a -> IO a
WebSocket.withPingThread Connection
connection Int
30 (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$ do
ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ TChan Event -> Connection -> IO ()
webSocketMessageHandler TChan Event
eventBus Connection
connection
forall (m :: * -> *) event.
(Monad m, Typeable event) =>
Bool
-> (m [Event] -> IO [Event])
-> (String -> IO ())
-> TChan Event
-> Connection
-> Purview event m
-> IO ()
eventLoop Bool
devMode m [Event] -> IO [Event]
interpreter String -> IO ()
logger TChan Event
eventBus Connection
connection Purview action m
component
webSocketMessageHandler :: TChan Event -> WebSocket.Connection -> IO ()
webSocketMessageHandler :: TChan Event -> Connection -> IO ()
webSocketMessageHandler TChan Event
eventBus Connection
websocketConnection = do
ByteString
message' <- forall a. WebSocketsData a => Connection -> IO a
WebSocket.receiveData Connection
websocketConnection
case forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
message' of
Just Event
fromEvent -> forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan Event
eventBus Event
fromEvent
Maybe Event
Nothing -> do
forall a. Show a => a -> IO ()
print forall a b. (a -> b) -> a -> b
$ ByteString
"error: failed to decode event: " forall a. Semigroup a => a -> a -> a
<> ByteString
message'
forall a. Show a => a -> IO ()
print String
"this may be an error in Purview so feel free to open an issue"
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
TChan Event -> Connection -> IO ()
webSocketMessageHandler TChan Event
eventBus Connection
websocketConnection