hylide-0.1.4.0: app/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}


import Paths_hylide (getDataFileName)
import Control.Concurrent
import Control.Monad
import Data.Aeson
import GHC.Generics
import qualified Data.ByteString.Lazy.Char8 as LBS8

import qualified Data.Text as T
import qualified Network.WebSockets as S
import System.Environment (getArgs)
import System.FilePath
import System.FSNotify
import System.Process
import System.Exit (ExitCode(ExitFailure, ExitSuccess))

import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types (status200, status404)

import qualified Language.Haskell.Interpreter as I
import qualified Control.Exception as E


data Msg = Err String
         | Code String
         deriving (Show, Generic, ToJSON, FromJSON)

main :: IO ()
main = do
  getArgs >>= \case
    [pathToWatch] -> main' pathToWatch
    _ -> error "Error: Name a file to watch!"

main' :: FilePath ->  IO ()
main' pathToWatch = do
  tid1 <- forkIO serveIndex
  tid2 <- forkIO $ serveGLSL pathToWatch
  putStrLn "Press enter to exit."
  void getLine
  killThread tid1
  killThread tid2



serveGLSL :: FilePath -> IO ()
serveGLSL pathToWatch = do
  withManager
    $ S.runServer "127.0.0.1" 8080
    . handleConnection pathToWatch
  return ()

handleConnection :: FilePath -> WatchManager -> S.PendingConnection -> IO ()
handleConnection pathToWatch mgr pending = do
   let (dirToWatch, _) = splitFileName pathToWatch
   connection <- S.acceptRequest pending

   -- let send = sendTextData connection . T.pack
   let send = S.sendTextData connection
   let update = do
         msg <- getCodeOrError pathToWatch
         send . encode $ msg

   let onChange e = do
         case e of
           Modified _ _ -> update
           _ -> return ()
   update
   _ <- watchDir mgr dirToWatch (const True) onChange
   _ <- getLine -- temp hack to keep the socket open
   return ()

interp :: FilePath -> I.InterpreterT IO String
interp fp = do
  I.loadModules [fp]
  I.setImports [takeBaseName fp]
  I.eval "output"

getCodeOrError :: FilePath -> IO Msg
getCodeOrError path = do
  I.runInterpreter (interp path) >>= return . \case
    Left err -> case err of
      I.UnknownError str -> Err str
      I.WontCompile errors -> Err . mconcat $ I.errMsg <$> errors
      I.NotAllowed str -> Err str
      I.GhcException str -> Err str
    Right str -> Code str

-- getCodeOrError' :: FilePath -> IO Msg
-- getCodeOrError' pathToWatch = do
--    -- TODO: more robust paths!:
--    -- c <- readFile pathToWatch
--    let (dirToWatch, _) = splitFileName pathToWatch
--    (ec, stdout, stderr) <- readProcessWithExitCode "runghc" [
--         "-i"++dirToWatch
--       , pathToWatch
--       ] ""
--    case ec of
--      ExitSuccess   -> return (Code stdout)
--      ExitFailure _ -> return (Err stderr)

serveIndex :: IO ()
serveIndex = do
  let port = 5678
  htmlString <- readFile =<< getDataFileName "client/dist-local/index.html"
  jsString <- readFile =<< getDataFileName "client/dist-local/bundle.js"
  run port $ app htmlString jsString


app :: String -> String -> Application
app htmlString jsString req respond = respond $
  case pathInfo req of
    ["bundle.js"] -> serveJS jsString
    []           -> serveHTML htmlString
    _            -> error404

serveHTML :: String -> Network.Wai.Response
serveHTML htmlString = responseLBS status200 [("Content-Type", "text/html")]
  $ LBS8.pack htmlString

serveJS :: String -> Network.Wai.Response
serveJS jsString = responseLBS status200 [("Content-Type", "application/javascript")] 
  $ LBS8.pack jsString

error404 :: Network.Wai.Response
error404 = responseBuilder status404 [("Content-Type", "text/plain")] "404 - Not Found"