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

{-|

This starts up the Warp server.

__Example:__

@
import Purview.Server

view url = p [ text "hello world" ]

main = serve defaultConfiguration view
@

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