{-# 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 = IO [Event] -> IO [Event]
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 :: forall (m :: * -> *). Configuration m -> Int
port :: Int
port, String -> IO ()
logger :: forall (m :: * -> *). Configuration m -> String -> IO ()
logger :: 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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting on port " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
port
Settings -> Application -> IO ()
Warp.runSettings Settings
settings
(Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ ConnectionOptions -> ServerApp -> Application -> Application
WaiWebSocket.websocketsOr
ConnectionOptions
WebSocket.defaultConnectionOptions
(Configuration m -> (String -> Purview () m) -> ServerApp
forall (m :: * -> *).
Monad m =>
Configuration m -> (String -> Purview () m) -> ServerApp
webSocketHandler Configuration m
config String -> Purview () m
component)
(Configuration m -> (String -> Purview () m) -> Application
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
(ByteString -> String) -> ByteString -> String
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
Configuration m -> Purview () m -> Connection -> IO ()
forall (m :: * -> *) action.
(Monad m, Typeable action) =>
Configuration m -> Purview action m -> Connection -> IO ()
startWebSocketLoop Configuration m
config { devMode=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 (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
Wai.pathInfo Request
request
render :: Purview () m
render = String -> Purview () m
component (String -> Purview () m) -> String -> Purview () m
forall a b. (a -> b) -> a -> b
$ String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path
in
Response -> IO ResponseReceived
respond
(Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
Wai.responseBuilder
Status
status200
[(HeaderName
"Content-Type", ByteString
"text/html")]
(Configuration m -> Purview () m -> Builder
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 :: forall (m :: * -> *). Configuration m -> String
htmlHead :: String
htmlHead, [String]
eventsToListenTo :: forall (m :: * -> *). Configuration m -> [String]
eventsToListenTo :: [String]
eventsToListenTo, String
javascript :: forall (m :: * -> *). Configuration m -> String
javascript :: String
javascript, Bool
secure :: forall (m :: * -> *). Configuration m -> Bool
secure :: Bool
secure } Purview action m
component =
let
locatedComponent :: Purview action m
locatedComponent = Purview action m -> Purview action m
forall event (m :: * -> *).
Typeable event =>
Purview event m -> Purview event m
prepareTree Purview action m
component
([Event]
initialEvents, [(String, String)]
css) = Purview action m -> ([Event], [(String, String)])
forall event (m :: * -> *).
Typeable event =>
Purview event m -> ([Event], [(String, String)])
collectInitials Purview action m
locatedComponent
rendered :: String
rendered = Purview action m -> String
forall action (m :: * -> *). Purview action m -> String
render ([(String, String)] -> Purview action m -> Purview action m
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 (String -> Builder) -> String -> Builder
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 :: forall (m :: * -> *). Configuration m -> Bool
devMode :: Bool
devMode, m [Event] -> IO [Event]
interpreter :: forall (m :: * -> *). Configuration m -> m [Event] -> IO [Event]
interpreter :: m [Event] -> IO [Event]
interpreter, String -> IO ()
logger :: forall (m :: * -> *). Configuration m -> String -> IO ()
logger :: String -> IO ()
logger } Purview action m
component Connection
connection = do
TChan Event
eventBus <- IO (TChan Event)
forall a. IO (TChan a)
newTChanIO
STM () -> IO ()
forall a. STM a -> IO a
atomically
(STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
eventBus
(Event -> STM ()) -> Event -> STM ()
forall a b. (a -> b) -> a -> b
$ FromFrontendEvent { $sel:kind:FromFrontendEvent :: Text
kind = Text
"init", $sel:childLocation:FromFrontendEvent :: Identifier
childLocation = Identifier
forall a. Maybe a
Nothing, $sel:location:FromFrontendEvent :: Identifier
location = Identifier
forall a. Maybe a
Nothing, $sel:value:FromFrontendEvent :: Maybe String
value = Maybe String
forall a. Maybe a
Nothing }
Connection -> Int -> IO () -> IO () -> IO ()
forall a. Connection -> Int -> IO () -> IO a -> IO a
WebSocket.withPingThread Connection
connection Int
30 (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ TChan Event -> Connection -> IO ()
webSocketMessageHandler TChan Event
eventBus Connection
connection
Bool
-> (m [Event] -> IO [Event])
-> (String -> IO ())
-> TChan Event
-> Connection
-> Purview action m
-> IO ()
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' <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
WebSocket.receiveData Connection
websocketConnection
case ByteString -> Maybe Event
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
message' of
Just Event
fromEvent -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
eventBus Event
fromEvent
Maybe Event
Nothing -> do
ByteString -> IO ()
forall a. Show a => a -> IO ()
print (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"error: failed to decode event: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
message'
String -> IO ()
forall a. Show a => a -> IO ()
print String
"this may be an error in Purview so feel free to open an issue"
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
TChan Event -> Connection -> IO ()
webSocketMessageHandler TChan Event
eventBus Connection
websocketConnection