Skip to content

Instantly share code, notes, and snippets.

@hamishmack

hamishmack/Devel.hs

Last active April 14, 2018 06:38
Show Gist options
  • Save hamishmack/9bf616a4f457c88b2a9e59f97a974fc0 to your computer and use it in GitHub Desktop.
Save hamishmack/9bf616a4f457c88b2a9e59f97a974fc0 to your computer and use it in GitHub Desktop.
Download ZIP
Running jsaddle and your applications server on the same port
Raw
Devel.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Devel (
test
, debug
) where
import Data.Monoid ((<>))
import Reflex.Dom.Core
#ifndef ghcjs_HOST_OS
import Data.Bool (bool)
import qualified Data.Text as T (unpack, pack)
import Language.Javascript.JSaddle.Warp (jsaddleOr, debugWrapper, jsaddleJs)
import Network.Wai.Handler.Warp
(defaultSettings, setTimeout, setPort, runSettings)
import Network.Wai.Middleware.RequestLogger
import Network.WebSockets (defaultConnectionOptions)
import Language.Javascript.JSaddle (syncPoint, JSM)
import qualified Network.Wai as W
(responseLBS, pathInfo, requestMethod)
import qualified Network.HTTP.Types as H (status200)
import System.Directory (doesDirectoryExist)
import System.Environment (getEnv)
import Network.Wai.Application.Static
(defaultFileServerSettings, staticApp)
import System.FilePath ((</>), joinPath, addTrailingPathSeparator)
import qualified Data.ByteString.Lazy as LBS (fromStrict, pack, ByteString)
import qualified Data.Text.Encoding as T (encodeUtf8)
#if MIN_VERSION_ghcjs_dom(0,9,4)
import GHCJS.DOM.Debug (addDebugMenu)
#else
addDebugMenu :: JSM ()
addDebugMenu = return ()
#endif
debug :: Int -> JSM () -> IO ()
debug prt f = do
let ghcjsFiles = ["rts.js", "lib.js", "out.js", "runmain.js"]
debugWrapper $ \withRefresh registerContext ->
runSettings (setPort prt (setTimeout 36000 defaultSettings)) =<<
jsaddleOr defaultConnectionOptions (registerContext >> addDebugMenu >> f >> syncPoint) (withRefresh $ \req sendResponse ->
case (W.requestMethod req, W.pathInfo req) of
("GET", ["jsaddle.js"]) -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs True
("GET", []) -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] (indexHtml [“/jsaddle.js”])
("GET", ["ghcjs"]) -> sendResponse . W.responseLBS H.status200 [("Content-Type", "text/html")]
=<< indexHtml (map (LBS.fromStrict . T.encodeUtf8) ghcjsFiles)
("GET", [ghcjsFile]) | ghcjsFile `elem` ghcjsFiles ->
staticApp (defaultFileServerSettings
("../dist-ghcjs/build/x86_64-osx/ghcjs-0.2.1/" <> projectName <> "-0.1.0.0/c/" <> projectName <> "/build/" <> projectName <> "/" <> projectName <> ".jsexe/"))
req sendResponse
_ -> logStdoutDev app req sendResponse)
putStrLn $ "<a href=\"http://localhost:" <> show prt <> "\">run</a>"
#else
import Language.Javascript.JSaddle (JSM)
debug :: Int -> JSM () -> IO ()
debug _ = id
#endif
indexHtml :: [LBS.ByteString] -> IO LBS.ByteString
indexHtml jsFiles = do
body <- LBS.fromStrict . snd <$> renderStatic uiStatic
return . mconcat $
[ "<!DOCTYPE html>"
, "<html lang=\"en\" class=\"has-navbar-fixed-top\">"
, "<head>"
, "<meta charset=\"utf-8\">"
, "<title>Title</title>"
, "</head>"
, "<body id=\"body\">"
, body
] ++ map (\js -> "<script src='" <> js <> "'></script>") jsFiles ++
[ "</body>"
, "</html>"
]
app = undefined -- Some Wai Application (eg. servant)
test :: JSM ()
test = mainWidget ui
ui = undefined -- UI
uiStatic = undefined -- Static version of UI (perhaps some of the UI components that work with renderStatic and a "Loading..." message
projectName = undefined -- The name of your project so it (just needed to find cabal new-build --ghcjs output and server it on /ghcjs)
-- Put this in .ghci to make :reload restart the server
-- :def! reload (const $ return "::reload\nDevel.debug 3777 test")
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment