{-# LANGUAGE GADTs #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE PatternGuards #-}

{-# LANGUAGE TemplateHaskell #-}

import Data.FileEmbed (embedStringFile)

import Data.String (IsString(..))

import Data.Text (Text, unpack)

import Data.Traversable (for)

import Control.Applicative (many, (<|>))

import Control.Concurrent (forkIO)

import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar,

tryPutMVar)

import Control.Concurrent.STM (TVar, atomically, newTVarIO, writeTVar,

readTVarIO,

TChan, newBroadcastTChanIO, dupTChan,

readTChan, writeTChan)

import Control.Exception (fromException)

import qualified Language.PureScript.Bundle as Bundle

import Network.HTTP.Types.Header (hContentType, hCacheControl,

hPragma, hExpires)

import Network.HTTP.Types.Status (status200, status404, status503)

import qualified Network.Wai as Wai

import qualified Network.Wai.Handler.Warp as Warp

import qualified Network.Wai.Handler.WebSockets as WS

import qualified Network.WebSockets as WS

import System.IO.UTF8 (readUTF8File)

import System.FilePath ((</>))

import System.Process (readProcessWithExitCode)

, psciBackend :: Backend

port :: Opts.Parser Int

port = Opts.option Opts.auto $

Opts.long "port"

<> Opts.short 'p'

<> Opts.help "The web server port"

backend :: Opts.Parser Backend

backend =

(browserBackend <$> port)

<|> (nodeBackend <$> nodeFlagsFlag)

<*> backend

-- | Make a JavaScript bundle for the browser.

bundle :: IO (Either Bundle.ErrorMessage String)

bundle = runExceptT $ do

inputFiles <- liftIO (glob (".psci_modules" </> "node_modules" </> "*" </> "*.js"))

input <- for inputFiles $ \filename -> do

js <- liftIO (readUTF8File filename)

mid <- Bundle.guessModuleIdentifier filename

length js `seq` return (mid, js)

Bundle.bundle input [] Nothing "PSCI"

indexJS :: IsString string => string

indexJS = $(embedStringFile "psci/static/index.js")

indexPage :: IsString string => string

indexPage = $(embedStringFile "psci/static/index.html")

-- | All of the functions required to implement a PSCi backend

data Backend = forall state. Backend

{ _backendSetup :: IO state

-- ^ Initialize, and call the continuation when the backend is ready

, _backendEval :: state -> String -> IO ()

-- ^ Evaluate JavaScript code

, _backendReload :: state -> IO ()

-- ^ Reload the compiled code

, _backendShutdown :: state -> IO ()

-- ^ Shut down the backend

}

-- | Commands which can be sent to the browser

data BrowserCommand

= Eval (MVar String)

-- ^ Evaluate the latest JS

| Reload

-- ^ Reload the page

-- | State for the browser backend

data BrowserState = BrowserState

{ browserCommands :: TChan BrowserCommand

-- ^ A channel which receives data when the compiled JS has

-- been updated

, browserShutdownNotice :: MVar ()

-- ^ An MVar which becomes full when the server should shut down

, browserIndexJS :: TVar (Maybe String)

-- ^ A TVar holding the latest compiled JS

, browserBundleJS :: TVar (Maybe String)

-- ^ A TVar holding the latest bundled JS

}

browserBackend :: Int -> Backend

browserBackend serverPort = Backend setup evaluate reload shutdown

where

setup :: IO BrowserState

setup = do

shutdownVar <- newEmptyMVar

cmdChan <- newBroadcastTChanIO

indexJs <- newTVarIO Nothing

bundleJs <- newTVarIO Nothing

let

handleWebsocket :: WS.PendingConnection -> IO ()

handleWebsocket pending = do

conn <- WS.acceptRequest pending

-- Fork a thread to keep the connection alive

WS.forkPingThread conn 10

-- Clone the command channel

cmdChanCopy <- atomically $ dupTChan cmdChan

-- Listen for commands

forever $ do

cmd <- atomically $ readTChan cmdChanCopy

case cmd of

Eval resultVar -> void $ do

WS.sendTextData conn ("eval" :: Text)

result <- WS.receiveData conn

-- With many connected clients, all but one of

-- these attempts will fail.

tryPutMVar resultVar (unpack result)

Reload -> do

WS.sendTextData conn ("reload" :: Text)

shutdownHandler :: IO () -> IO ()

shutdownHandler stopServer = void . forkIO $ do

() <- takeMVar shutdownVar

stopServer

onException :: Maybe Wai.Request -> SomeException -> IO ()

onException req ex

| Just (_ :: WS.ConnectionException) <- fromException ex

= return () -- ignore websocket disconnects

| otherwise = Warp.defaultOnException req ex

staticServer :: Wai.Application

staticServer req respond =

case Wai.pathInfo req of

[] ->

respond $ Wai.responseLBS status200

[(hContentType, "text/html")]

indexPage

["js", "index.js"] ->

respond $ Wai.responseLBS status200

[(hContentType, "application/javascript")]

indexJS

["js", "latest.js"] -> do

may <- readTVarIO indexJs

case may of

Nothing ->

respond $ Wai.responseLBS status503 [] "Service not available"

Just js ->

respond $ Wai.responseLBS status200

[ (hContentType, "application/javascript")

, (hCacheControl, "no-cache, no-store, must-revalidate")

, (hPragma, "no-cache")

, (hExpires, "0")

]

(fromString js)

["js", "bundle.js"] -> do

may <- readTVarIO bundleJs

case may of

Nothing ->

respond $ Wai.responseLBS status503 [] "Service not available"

Just js ->

respond $ Wai.responseLBS status200

[ (hContentType, "application/javascript")]

(fromString js)

_ -> respond $ Wai.responseLBS status404 [] "Not found"

let browserState = BrowserState cmdChan shutdownVar indexJs bundleJs

createBundle browserState

putStrLn $ "Serving http://localhost:" <> show serverPort <> "/. Waiting for connections..."

_ <- forkIO $ Warp.runSettings ( Warp.setInstallShutdownHandler shutdownHandler

. Warp.setPort serverPort

. Warp.setOnException onException

$ Warp.defaultSettings

) $

WS.websocketsOr WS.defaultConnectionOptions

handleWebsocket

staticServer

return browserState

createBundle :: BrowserState -> IO ()

createBundle state = do

putStrLn "Bundling Javascript..."

ejs <- bundle

case ejs of

Left err -> do

putStrLn (unlines (Bundle.printErrorMessage err))

exitFailure

Right js -> do

atomically $ writeTVar (browserBundleJS state) (Just js)

reload :: BrowserState -> IO ()

reload state = do

createBundle state

atomically $ writeTChan (browserCommands state) Reload

shutdown :: BrowserState -> IO ()

shutdown state = putMVar (browserShutdownNotice state) ()

evaluate :: BrowserState -> String -> IO ()

evaluate state js = liftIO $ do

resultVar <- newEmptyMVar

atomically $ do

writeTVar (browserIndexJS state) (Just js)

writeTChan (browserCommands state) (Eval resultVar)

result <- takeMVar resultVar

putStrLn result

nodeBackend :: [String] -> Backend

nodeBackend nodeArgs = Backend setup eval reload shutdown

where

setup :: IO ()

setup = return ()

eval :: () -> String -> IO ()

eval _ _ = do

writeFile indexFile "require('$PSCI')['$main']();"

process <- findNodeProcess

result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process

case result of

Just (ExitSuccess, out, _) -> putStrLn out

Just (ExitFailure _, _, err) -> putStrLn err

Nothing -> putStrLn "Couldn't find node.js"

reload :: () -> IO ()

reload _ = return ()

shutdown :: () -> IO ()

shutdown _ = return ()

case psciBackend of

Backend setup eval reload (shutdown :: state -> IO ()) -> do

case e of

Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure

Right (modules, externs, env) -> do

historyFilename <- getHistoryFilename

let settings = defaultSettings { historyFile = Just historyFilename }

initialState = PSCiState [] [] (zip (map snd modules) externs)

config = PSCiConfig inputFiles env

runner = flip runReaderT config

. flip evalStateT initialState

. runInputT (setComplete completion settings)

go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()

go state = do

c <- getCommand (not psciMultiLineMode)

case c of

Left err -> outputStrLn err >> go state

Right Nothing -> go state

Right (Just QuitPSCi) -> do

outputStrLn quitMessage

liftIO $ shutdown state

Right (Just c') -> do

handleInterrupt (outputStrLn "Interrupted.")

(withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) c')))

go state

putStrLn prologueMessage

setup >>= runner . go

<title>PureScript Interactive</title>

<script src='js/bundle.js'></script>

<script src='js/index.js'></script>