diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright (c) 2010-2012 Hamish Mackenzie, Victor Nazarov, Luite Stegeman + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/jsaddle-warp.cabal b/jsaddle-warp.cabal new file mode 100644 --- /dev/null +++ b/jsaddle-warp.cabal @@ -0,0 +1,67 @@ +name: jsaddle-warp +version: 0.6.0.0 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +maintainer: Hamish Mackenzie +synopsis: Interface for JavaScript that works with GHCJS and GHC +description: + This package provides an EDSL for calling JavaScript that + can be used both from GHCJS and GHC. When using GHC + the application is run using Warp and WebSockets to + drive a small JavaScipt helper. +category: Web, Javascript +author: Hamish Mackenzie + +source-repository head + type: git + location: https://github.com/ghcjs/jsaddle + +library + + if !impl(ghcjs -any) + exposed-modules: + Language.Javascript.JSaddle.WebSockets + build-depends: + aeson >=0.8.0.2 && <1.1, + containers >=0.5.6.2 && <0.6, + http-types >=0.8.6 && <0.10, + jsaddle >=0.6.0.0 && <0.7, + stm >=2.4.4 && <2.5, + text >=1.2.1.3 && <1.3, + time >=1.5.0.1 && <1.7, + transformers >=0.4.2.0 && <0.6, + wai >=3.0.3.0 && <3.3, + wai-websockets >=3.0.0.6 && <3.1, + warp >=3.1.2 && <3.3, + websockets >=0.9.5.0 && <0.10 + exposed-modules: + Language.Javascript.JSaddle.Warp + build-depends: + base <5 + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -ferror-spans -Wall + +test-suite test-tool + + if !impl(ghcjs -any) + build-depends: + QuickCheck -any, + bytestring -any, + doctest >=0.10.1 && <0.12, + filepath >=1.4.0.0 && <1.5, + jsaddle -any, + jsaddle-warp -any, + lens -any, + ref-tf -any, + primitive -any, + process >=1.2.3.0 && <1.5 + type: exitcode-stdio-1.0 + main-is: DocTest.hs + build-depends: + base -any + default-language: Haskell2010 + hs-source-dirs: tests + ghc-options: -ferror-spans -threaded diff --git a/src/Language/Javascript/JSaddle/Warp.hs b/src/Language/Javascript/JSaddle/Warp.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/Warp.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- +-- Module : Language.Javascript.JSaddle.WebSockets +-- Copyright : (c) Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.Javascript.JSaddle.Warp ( + -- * Running JSM over WebSockets + run +#ifndef ghcjs_HOST_OS + , jsaddleOr +#endif +) where + +import Language.Javascript.JSaddle.Types (JSM) +#ifndef ghcjs_HOST_OS +import Network.Wai.Handler.Warp + (defaultSettings, setTimeout, setPort, runSettings) +import Network.WebSockets (defaultConnectionOptions) + +import Language.Javascript.JSaddle.Run (syncPoint) +import Language.Javascript.JSaddle.WebSockets (jsaddleOr, jsaddleApp) +#endif + +-- | Run the given 'JSM' action as the main entry point. Either directly +-- in GHCJS or as a Warp server on the given port on GHC. +run :: Int -> JSM () -> IO () +#ifdef ghcjs_HOST_OS +run _port = id +#else +run port f = + runSettings (setPort port (setTimeout 3600 defaultSettings)) $ + jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp +#endif diff --git a/src/Language/Javascript/JSaddle/WebSockets.hs b/src/Language/Javascript/JSaddle/WebSockets.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/WebSockets.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- +-- Module : Language.Javascript.JSaddle.WebSockets +-- Copyright : (c) Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.Javascript.JSaddle.WebSockets ( + -- * Running JSM over WebSockets + jsaddleOr + , jsaddleApp +) where + +import Control.Monad (forever) +import Control.Concurrent (forkIO) + +import Data.Monoid ((<>)) +import Data.Aeson (encode, decode) + +import Network.Wai (Application) +import Network.WebSockets + (ConnectionOptions(..), sendTextData, receiveDataMessage, + acceptRequest, ServerApp) +import qualified Network.WebSockets as WS (DataMessage(..)) +import Network.Wai.Handler.WebSockets (websocketsOr) + +import Language.Javascript.JSaddle.Types (JSM(..)) +import qualified Network.Wai as W + (responseLBS, requestMethod, Application, pathInfo) +import Data.Text (Text) +import qualified Network.HTTP.Types as H + (status403, status200, status405) +import Language.Javascript.JSaddle.Run (runJavaScript) +import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs) + +jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application +jsaddleOr opts entryPoint = websocketsOr opts wsApp + where + wsApp :: ServerApp + wsApp pending_conn = do + conn <- acceptRequest pending_conn + (processResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint + _ <- forkIO . forever $ + receiveDataMessage conn >>= \case + (WS.Text t) -> + case decode t of + Nothing -> error $ "jsaddle WebSocket decode failed : " <> show t + Just r -> processResult r + _ -> error "jsaddle WebSocket unexpected binary data" + start + +jsaddleApp :: Application +jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req + +jsaddleAppPieces :: [Text] -> W.Application +jsaddleAppPieces _ req sendResponse + | W.requestMethod req `notElem` ["GET", "HEAD"] = sendResponse $ W.responseLBS + H.status405 + [("Content-Type", "text/plain")] + "Only GET or HEAD is supported" +jsaddleAppPieces [] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml +jsaddleAppPieces ["jsaddle.js"] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs +jsaddleAppPieces _rawPieces _req sendResponse = sendResponse $ W.responseLBS H.status403 + [ ("Content-Type", "text/plain") + ] "Forbidden" diff --git a/tests/DocTest.hs b/tests/DocTest.hs new file mode 100644 --- /dev/null +++ b/tests/DocTest.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} +module Main ( + main +) where + +import Test.DocTest +import System.IO (stderr, BufferMode(..), stdout, hSetBuffering) +import System.FilePath (()) +import System.Exit (exitFailure, exitWith, ExitCode(..)) +import System.Process (readProcess, system) +import Control.Concurrent (forkIO) +import Control.Monad (void) +import Data.Monoid ((<>)) +import System.Environment (getArgs) +import Language.Javascript.JSaddle.Run.Files (jsaddleJs) +import qualified Data.ByteString.Lazy.Char8 as BS (unpack) + +main :: IO () +main = do + jsaddlePath <- getArgs >>= \case + [arg] -> return arg + _ -> do + putStrLn "Please give the path to the jsaddle package source" + exitFailure + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + node <- system "nodejs --version" >>= \case + ExitSuccess -> return "nodejs" + _ -> return "node" + system (node <> " --version") >>= \case + ExitSuccess -> putStrLn "Node.js found" + e -> do + putStrLn "Node.js not found" + exitWith e + forkIO . void $ readProcess node ["--harmony"] (BS.unpack jsaddleJs) >>= putStr + doctest [ + "-hide-all-packages", + "-package=base-" ++ VERSION_base, + "-package=lens-" ++ VERSION_lens, + "-package=text-" ++ VERSION_text, + "-package=bytestring-" ++ VERSION_bytestring, + "-package=transformers-" ++ VERSION_transformers, + "-package=websockets-" ++ VERSION_websockets, + "-package=primitive-" ++ VERSION_primitive, + "-package=aeson-" ++ VERSION_aeson, + "-package=websockets-" ++ VERSION_websockets, + "-package=wai-" ++ VERSION_wai, + "-package=wai-websockets-" ++ VERSION_wai_websockets, + "-package=warp-" ++ VERSION_warp, + "-package=http-types-" ++ VERSION_http_types, + "-package=stm-" ++ VERSION_stm, + "-package=time-" ++ VERSION_time, + "-package=containers-" ++ VERSION_containers, + "-package=process-" ++ VERSION_process, + "-package=filepath-" ++ VERSION_filepath, + "-package=ref-tf-" ++ VERSION_ref_tf, + "-i" <> jsaddlePath "jsaddle-warp/src", + jsaddlePath "jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs", + "-i" <> jsaddlePath "jsaddle", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Arguments.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Classes.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Exception.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Monad.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Native.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Object.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Properties.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Run.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/String.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Types.hs", + jsaddlePath "jsaddle/src/Language/Javascript/JSaddle/Value.hs" ]