diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Change log +## v0.0.15 (2015-03-29) + +- Switch to converting expressions over WebSockets. +- Removed the `/convert` endpoint. + ## v0.0.14 (2015-03-27) - Added request logging. diff --git a/blunt.cabal b/blunt.cabal --- a/blunt.cabal +++ b/blunt.cabal @@ -1,5 +1,5 @@ name: blunt -version: 0.0.14 +version: 0.0.15 cabal-version: >=1.10 build-type: Simple license: MIT @@ -22,14 +22,7 @@ library exposed-modules: Blunt - Blunt.Actions - Blunt.Application - Blunt.Main Blunt.Markup - Blunt.Middleware - Blunt.Pointfree - Blunt.Pointful - Blunt.Router Blunt.Script Blunt.Style build-depends: @@ -44,7 +37,9 @@ text ==1.*, wai ==3.*, wai-extra ==3.*, + wai-websockets ==3.*, warp ==3.*, + websockets ==0.9.*, wl-pprint-text ==1.* default-language: Haskell2010 hs-source-dirs: library diff --git a/library/Blunt.hs b/library/Blunt.hs --- a/library/Blunt.hs +++ b/library/Blunt.hs @@ -1,23 +1,82 @@ -module Blunt - ( module Blunt.Actions - , module Blunt.Application - , module Blunt.Main - , module Blunt.Markup - , module Blunt.Middleware - , module Blunt.Pointfree - , module Blunt.Pointful - , module Blunt.Router - , module Blunt.Script - , module Blunt.Style - ) where +{-# LANGUAGE OverloadedStrings #-} -import Blunt.Actions -import Blunt.Application -import Blunt.Main -import Blunt.Markup -import Blunt.Middleware -import Blunt.Pointfree -import Blunt.Pointful -import Blunt.Router -import Blunt.Script -import Blunt.Style +module Blunt where + +import Blunt.Markup (markup) +import Control.Exception (SomeException, evaluate, handle) +import Control.Monad (forever) +import Data.Aeson (ToJSON, encode, object, toJSON, (.=)) +import Data.List (isPrefixOf, isSuffixOf) +import Data.Text.Lazy (Text, unpack) +import Lambdabot.Pointful (pointful) +import Network.HTTP.Types (notFound404, ok200) +import Network.Wai (Application, pathInfo, requestMethod, responseLBS) +import Network.Wai.Handler.Warp (runEnv) +import Network.Wai.Handler.WebSockets (websocketsOr) +import Network.Wai.Middleware.Gzip (def, gzip) +import Network.Wai.Middleware.RequestLogger (logStdout) +import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions, + receiveData, sendTextData) +import Pointfree (pointfree) + +main :: IO () +main = runEnv 8080 application + +application :: Application +application = websocketsOr defaultConnectionOptions ws http + +ws :: ServerApp +ws pending = do + connection <- acceptRequest pending + forever $ do + message <- receiveData connection + result <- convert message + sendTextData connection (encode result) + +http :: Application +http = gzip def . logStdout $ \ request respond -> + respond $ case (requestMethod request, pathInfo request) of + ("GET", []) -> responseLBS status headers body where + status = ok200 + headers = [("Content-Type", "text/html; charset=utf-8")] + body = markup + _ -> responseLBS notFound404 [] "" + +convert :: Text -> IO Conversion +convert message = do + let input = unpack message + pf <- safePointfree input + let pl = safePointful input + return Conversion + { conversionInput = input + , conversionPointfree = pf + , conversionPointful = pl + } + +safePointfree :: String -> IO [String] +safePointfree = handle handler . evaluate . pointfree + +handler :: SomeException -> IO [String] +handler _ = return [] + +safePointful :: String -> Maybe String +safePointful input = + let output = pointful input + in if any (`isPrefixOf` output) ["Error:", ".hs:"] + then Nothing + else if ";" `isSuffixOf` output && not (";" `isSuffixOf` input) + then Just (init output) + else Just output + +data Conversion = Conversion + { conversionInput :: String + , conversionPointfree :: [String] + , conversionPointful :: Maybe String + } deriving (Read, Show) + +instance ToJSON Conversion where + toJSON result = object + [ "input" .= conversionInput result + , "pointfree" .= conversionPointfree result + , "pointful" .= conversionPointful result + ] diff --git a/library/Blunt/Actions.hs b/library/Blunt/Actions.hs deleted file mode 100644 --- a/library/Blunt/Actions.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Blunt.Actions where - -import Blunt.Markup (markup) -import Blunt.Pointfree (safePointfree) -import Blunt.Pointful (safePointful) -import Data.Aeson (ToJSON, encode, object, toJSON, (.=)) -import Data.ByteString.Char8 (unpack) -import Network.HTTP.Types (notFound404, ok200) -import Network.Wai (Request, Response, queryString, responseLBS) - -indexAction :: Request -> IO Response -indexAction _request = do - let headers = [("Content-Type", "text/html")] - body = markup - return (responseLBS ok200 headers body) - -data Result = Result - { resultInput :: String - , resultPointfree :: [String] - , resultPointful :: Maybe String - } deriving (Read, Show) - -instance ToJSON Result where - toJSON result = object - [ "input" .= resultInput result - , "pointfree" .= resultPointfree result - , "pointful" .= resultPointful result - ] - -convertAction :: Request -> IO Response -convertAction request = do - let input = case lookup "input" (queryString request) of - Just (Just param) -> unpack param - _ -> "" - - pf <- safePointfree input - let pl = safePointful input - result = Result - { resultInput = input - , resultPointfree = pf - , resultPointful = pl - } - - let headers = [("Content-Type", "application/json")] - body = encode result - return (responseLBS ok200 headers body) - -notFoundAction :: Request -> IO Response -notFoundAction _request = return (responseLBS notFound404 [] "") diff --git a/library/Blunt/Application.hs b/library/Blunt/Application.hs deleted file mode 100644 --- a/library/Blunt/Application.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Blunt.Application where - -import Blunt.Router (route) -import Network.Wai (Application) - -application :: Application -application request respondWith = do - let action = route request - response <- action request - respondWith response diff --git a/library/Blunt/Main.hs b/library/Blunt/Main.hs deleted file mode 100644 --- a/library/Blunt/Main.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Blunt.Main where - -import Blunt.Application (application) -import Blunt.Middleware (middleware) -import Network.Wai.Handler.Warp (runEnv) - -main :: IO () -main = runEnv 8080 (middleware application) diff --git a/library/Blunt/Markup.hs b/library/Blunt/Markup.hs --- a/library/Blunt/Markup.hs +++ b/library/Blunt/Markup.hs @@ -14,7 +14,6 @@ html :: Html () html = doctypehtml_ $ do head_ $ do - meta_ [charset_ "utf-8"] meta_ [ name_ "viewport" , content_ "initial-scale = 1, maximum-scale = 1, minimum-scale = 1, width = device-width" diff --git a/library/Blunt/Middleware.hs b/library/Blunt/Middleware.hs deleted file mode 100644 --- a/library/Blunt/Middleware.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Blunt.Middleware where - -import Network.Wai (Middleware) -import Network.Wai.Middleware.Gzip (def, gzip) -import Network.Wai.Middleware.RequestLogger (logStdout) - -middleware :: Middleware -middleware = gzip def . logStdout diff --git a/library/Blunt/Pointfree.hs b/library/Blunt/Pointfree.hs deleted file mode 100644 --- a/library/Blunt/Pointfree.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Blunt.Pointfree where - -import Control.Exception (SomeException, evaluate, handle) -import Pointfree (pointfree) - -safePointfree :: String -> IO [String] -safePointfree = handle handler . evaluate . pointfree where - handler :: SomeException -> IO [String] - handler _ = return [] diff --git a/library/Blunt/Pointful.hs b/library/Blunt/Pointful.hs deleted file mode 100644 --- a/library/Blunt/Pointful.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Blunt.Pointful where - -import Data.List (isPrefixOf, isSuffixOf) -import Lambdabot.Pointful (pointful) - -safePointful :: String -> Maybe String -safePointful input = - let output = pointful input - in if any (`isPrefixOf` output) ["Error:", ".hs:"] - then Nothing - else if ";" `isSuffixOf` output && not (";" `isSuffixOf` input) - then Just (init output) - else Just output diff --git a/library/Blunt/Router.hs b/library/Blunt/Router.hs deleted file mode 100644 --- a/library/Blunt/Router.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Blunt.Router where - -import Blunt.Actions (convertAction, indexAction, notFoundAction) -import Network.Wai (Request, Response, pathInfo, requestMethod) - -route :: Request -> (Request -> IO Response) -route request = case (requestMethod request, pathInfo request) of - ("GET", []) -> indexAction - ("GET", ["convert"]) -> convertAction - _ -> notFoundAction diff --git a/library/Blunt/Script.hs b/library/Blunt/Script.hs --- a/library/Blunt/Script.hs +++ b/library/Blunt/Script.hs @@ -16,30 +16,24 @@ var pointfree = document.getElementById("pointfree"); var pointful = document.getElementById("pointful"); - var updateHash = \ { window.location.replace("#input=" + input.value); }; - - var updateOutput = \ { - var request = new XMLHttpRequest; - - request.onreadystatechange = \ { - if (request.readyState !== 4 || request.status !== 200) { return; } + var socket = new WebSocket(window.location.origin.replace('http', 'ws')); - var response = JSON.parse request.response; - pointfree.textContent = response.pointfree.join("\n"); - pointful.textContent = response.pointful; + socket.onopen = \ { + input.oninput = \ { + window.location.replace("#input=" + input.value); + socket.send(input.value); }; - request.open("GET", "/convert?input=" + encodeURIComponent(input.value)); - request.send(); + if (input.value) { input.oninput(); } }; - input.oninput = \ { - updateHash(); - updateOutput(); + socket.onmessage = \ message { + var response = JSON.parse(message.data); + pointfree.textContent = response.pointfree.join("\n"); + pointful.textContent = response.pointful; }; if (window.location.hash.indexOf("#input=") === 0) { input.value = window.location.hash.substring(7); - input.oninput(); } }(); |]