summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorfozworth <>2015-04-03 14:15:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-04-03 14:15:00 (GMT)
commit5684d4e040b9992e5c2f1ad69f541acf8106862a (patch)
treea21215fe0b66fc95bb77d951ce33c46eef790032
parentcc78614b31814744028ff21b3147754766c3f7b1 (diff)
version 0.0.160.0.16
-rw-r--r--CHANGELOG.md59
-rw-r--r--README.md85
-rw-r--r--blunt.cabal30
-rw-r--r--library/Blunt.hs157
-rw-r--r--library/Blunt/Markup.hs63
-rw-r--r--library/Blunt/Script.hs40
-rw-r--r--library/Blunt/Style.hs65
7 files changed, 396 insertions, 103 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index bdfd3e5..091b906 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,8 +1,63 @@
# Change log
-## v0.0.05 (2015-03-19)
+## v0.0.16 (2015-04-03)
-- Constraint versions of `pointfree` dependencies.
+- Fixed a bug that incorrectly decoded inputs from the URL.
+- Added some explanatory text, ostensibly for SEO.
+- Added a ping to the WebSocket client to keep the connection open.
+
+## 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.
+- Added gzip compression.
+- Removed trailing semicolons from pointful output.
+
+## v0.0.13 (2015-03-25)
+
+- Switched from deploying a binary to using Haskell on Heroku.
+- Converted HTML to Lucid.
+- Converted CSS to Clay.
+- Converted JS to JMacro.
+
+## v0.0.12 (2015-03-25)
+
+- Combined `/pointfree` and `/pointful` endpoints into `/convert`.
+
+## v0.0.11 (2015-03-23)
+
+- Added permalinks by storing the input in the URL hash and reading it on
+ page load.
+- Added dependency on Hackage version of pointful package.
+
+## v0.0.10 (2015-03-23)
+
+- Added a pointful conversion of the expression as well.
+
+## v0.0.9 (2015-03-20)
+
+- Updated to list all intermediate steps instead of only the final result.
+- Optimized text input for mobile devices.
+
+## v0.0.8 (2015-03-20)
+
+- Created a simple stylesheet.
+
+## v0.0.7 (2015-03-19)
+
+- Fixed link in Hackage documentation.
+
+## v0.0.6 (2015-03-19)
+
+- Switch from Bitbucket to GitHub.
+
+## v0.0.5 (2015-03-19)
+
+- Constrained versions of pointfree dependencies.
## v0.0.4 (2015-03-19)
diff --git a/README.md b/README.md
index c93c9c5..f55726c 100644
--- a/README.md
+++ b/README.md
@@ -1,3 +1,84 @@
-# Blunt
+<h1 align="center">
+ <a href="https://github.com/tfausak/blunt">
+ Blunt
+ </a>
+</h1>
-Point-free Haskell as a service.
+<p align="center">
+ Blunt converts between pointfree and pointful Haskell expressions.
+</p>
+
+<p align="center">
+ <a href="https://hackage.haskell.org/package/blunt">
+ <img alt="" src="https://img.shields.io/hackage/v/blunt.svg">
+ </a>
+ <a href="http://packdeps.haskellers.com/feed?needle=blunt">
+ <img alt="" src="https://img.shields.io/hackage-deps/v/blunt.svg">
+ </a>
+</p>
+
+<hr>
+
+Blunt is a web front end to the [pointfree][] and [pointful][] libraries. While
+you can install and run it locally, there's no real reason to prefer it over
+the `pointfree` and `pointful` executables. Instead, use the hosted version:
+<https://blunt.herokuapp.com>.
+
+## Install
+
+``` sh
+$ cabal update
+$ cabal install 'blunt ==0.0.*'
+```
+
+## Use
+
+``` sh
+$ blunt
+# http://localhost:8080
+
+$ env PORT=8888 blunt
+# http://localhost:8888
+```
+
+## Develop
+
+``` sh
+$ git clone https://github.com/tfausak/blunt
+$ cd blunt
+
+$ cabal sandbox init
+$ cabal install happy
+$ cabal install
+```
+
+## Deploy
+
+``` sh
+# Create a new app on Heroku using the Haskell on Heroku buildpack.
+$ heroku apps:create --buildpack https://github.com/mietek/haskell-on-heroku
+
+# Let Halcyon know that we need happy installed.
+$ heroku config:set HALCYON_SANDBOX_EXTRA_APPS='happy'
+
+# Configure AWS S3.
+$ heroku config:set HALCYON_AWS_ACCESS_KEY_ID='...'
+$ heroku config:set HALCYON_AWS_SECRET_ACCESS_KEY='...'
+$ heroku config:set HALCYON_S3_BUCKET='...'
+
+# Push the code up to Heroku. Note that this build is expected to fail.
+$ git push heroku master
+
+# Build the app on a PX dyno.
+$ heroku run --size PX build
+
+# Force Heroku to rebuild the app using the cache built in the last step.
+$ git commit --amend --no-edit
+$ git push --force heroku master
+
+# Scale up a web dyno to serve requests.
+$ heroku ps:scale web=1
+```
+
+[pointfree]: http://hackage.haskell.org/package/pointfree
+[pointful]: http://hackage.haskell.org/package/pointful
diff --git a/blunt.cabal b/blunt.cabal
index 5aa5dd9..dd31f65 100644
--- a/blunt.cabal
+++ b/blunt.cabal
@@ -1,13 +1,15 @@
name: blunt
-version: 0.0.5
+version: 0.0.16
cabal-version: >=1.10
build-type: Simple
license: MIT
license-file: LICENSE.md
maintainer: Taylor Fausak <taylor@fausak.me>
+homepage: https://blunt.herokuapp.com
+bug-reports: https://github.com/tfausak/blunt/issues
synopsis: Point-free Haskell as a service.
description:
- https://bitbucket.org/taylorfausak/blunt
+ <https://github.com/tfausak/blunt>
category: Web
extra-source-files:
CHANGELOG.md
@@ -15,17 +17,31 @@ extra-source-files:
source-repository head
type: git
- location: https://bitbucket.org/taylorfausak/blunt
+ location: https://github.com/tfausak/blunt
library
exposed-modules:
Blunt
+ Blunt.Markup
+ Blunt.Script
+ Blunt.Style
build-depends:
base ==4.*,
- bytestring -any,
- http-types -any,
- wai -any,
- warp ==3.*
+ aeson ==0.8.*,
+ bytestring ==0.10.*,
+ clay ==0.10.*,
+ flow ==1.*,
+ http-types ==0.8.*,
+ jmacro ==0.6.*,
+ lucid ==2.*,
+ pointful >=1.0.6 && <2,
+ 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
ghc-options: -Wall
diff --git a/library/Blunt.hs b/library/Blunt.hs
index 032065e..2095d01 100644
--- a/library/Blunt.hs
+++ b/library/Blunt.hs
@@ -2,111 +2,84 @@
module Blunt where
+import Flow
+
+import Blunt.Markup (markup)
import Control.Exception (SomeException, evaluate, handle)
-import Data.ByteString.Char8 (unpack)
-import Data.ByteString.Lazy (fromStrict)
-import Data.ByteString.Lazy.Char8 (pack)
+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, Request, Response, queryString, pathInfo,
- requestMethod, responseLBS)
+import Network.Wai (Application, pathInfo, requestMethod, responseLBS)
import Network.Wai.Handler.Warp (runEnv)
-import Pointfree (pointfree')
+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,
+ forkPingThread, receiveData, sendTextData)
+import Pointfree (pointfree)
main :: IO ()
main = runEnv 8080 application
application :: Application
-application request respondWith = do
- let action = route request
- response <- action request
- respondWith response
+application = websocketsOr defaultConnectionOptions ws http
-type Action = Request -> IO Response
+ws :: ServerApp
+ws pending = do
+ connection <- acceptRequest pending
+ forkPingThread connection 30
+ forever <| do
+ message <- receiveData connection
+ result <- convert message
+ sendTextData connection (encode result)
-route :: Request -> Action
-route request = case (requestMethod request, pathInfo request) of
- ("GET", []) -> indexAction
- ("GET", ["pointfree"]) -> pointfreeAction
- _ -> notFoundAction
+http :: Application
+http = logStdout .> gzip def <| \ 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 [] ""
-indexAction :: Action
-indexAction _request = do
- let headers = [("Content-Type", "text/html; charset=utf-8")]
- body = pack html
- return (responseLBS ok200 headers body)
+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
+ }
-pointfreeAction :: Action
-pointfreeAction request = do
- let params = queryString request
- input = case lookup "input" params of
- Just (Just param) -> param
- _ -> ""
- maybeOutput <- safePointfree (unpack input)
- let headers = [("Content-Type", "text/plain; charset=utf-8")]
- body = case maybeOutput of
- Just output -> pack output
- Nothing -> fromStrict input
- return (responseLBS ok200 headers body)
+safePointfree :: String -> IO [String]
+safePointfree = pointfree .> evaluate .> handle handler
-notFoundAction :: Action
-notFoundAction _request = return (responseLBS notFound404 [] "")
+handler :: SomeException -> IO [String]
+handler _ = return []
-safePointfree :: String -> IO (Maybe String)
-safePointfree = handle handler . evaluate . pointfree' where
- handler :: SomeException -> IO (Maybe String)
- handler _ = return Nothing
+safePointful :: String -> Maybe String
+safePointful input =
+ let output = pointful input
+ in if any (`isPrefixOf` output) ["Error:", "<unknown>.hs:"]
+ then Nothing
+ else if ";" `isSuffixOf` output && not (";" `isSuffixOf` input)
+ then Just (init output)
+ else Just output
-html :: String
-html = unlines
- [ "<!doctype html>"
- , ""
- , "<html>"
- , " <head>"
- , " <meta name='viewport' content='initial-scale = 1, width = device-width'>"
- , ""
- , " <title>Blunt</title>"
- , " </head>"
- , ""
- , " <body>"
- , " <h1>Blunt</h1>"
- , ""
- , " <dl>"
- , " <dt>Input</dt>"
- , " <dd>"
- , " <input id='input' placeholder='sum xs = foldr (+) 0 xs' autofocus>"
- , " </dd>"
- , ""
- , " <dt>Output</dt>"
- , " <dd>"
- , " <input id='output' placeholder='sum = foldr (+) 0' readonly>"
- , " </dd>"
- , " </dl>"
- , ""
- , " <script>"
- , js
- , " </script>"
- , " </body>"
- , "</html>"
- ]
+data Conversion = Conversion
+ { conversionInput :: String
+ , conversionPointfree :: [String]
+ , conversionPointful :: Maybe String
+ } deriving (Read, Show)
-js :: String
-js = unlines
- [ "'use strict';"
- , ""
- , "(function () {"
- , " var input = document.getElementById('input');"
- , " var output = document.getElementById('output');"
- , ""
- , " input.oninput = function (_event) {"
- , " var request = new XMLHttpRequest();"
- , ""
- , " request.onreadystatechange = function () {"
- , " if (request.readyState === 4 && request.status === 200) {"
- , " output.value = request.response;"
- , " }"
- , " };"
- , " request.open('GET', '/pointfree?input=' + encodeURIComponent(input.value));"
- , " request.send();"
- , " };"
- , "}());"
- ]
+instance ToJSON Conversion where
+ toJSON result = object
+ [ "input" .= conversionInput result
+ , "pointfree" .= conversionPointfree result
+ , "pointful" .= conversionPointful result
+ ]
diff --git a/library/Blunt/Markup.hs b/library/Blunt/Markup.hs
new file mode 100644
index 0000000..e8d082a
--- /dev/null
+++ b/library/Blunt/Markup.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Blunt.Markup where
+
+import Flow
+import Lucid
+
+import Blunt.Script (script)
+import Blunt.Style (style)
+import Data.ByteString.Lazy (ByteString)
+
+markup :: ByteString
+markup = renderBS html
+
+html :: Html ()
+html = doctypehtml_ <| do
+ head_ <| do
+ meta_
+ [ name_ "viewport"
+ , content_ "initial-scale = 1, maximum-scale = 1, minimum-scale = 1, width = device-width"
+ ]
+
+ title_ "Blunt"
+
+ style_ [] style
+
+ body_ <| do
+ h1_ "Blunt"
+
+ dl_ <| do
+ dt_ "Input"
+ dd_ <| do
+ input_
+ [ id_ "input"
+ , placeholder_ "sum xs = foldr (+) 0 xs"
+ , autocomplete_ "off"
+ , autofocus_
+ , spellcheck_ "off"
+ , term "autocapitalize" "none"
+ , term "autocorrect" "off"
+ ]
+
+ dt_ "Pointfree"
+ dd_ (div_ [id_ "pointfree"] "")
+
+ dt_ "Pointful"
+ dd_ (div_ [id_ "pointful"] "")
+
+ p_ <| do
+ "Blunt converts Haskell expressions between the pointfree and "
+ "pointful styles. It is a web front end to the "
+ a_ [href_ "http://hackage.haskell.org/package/pointfree"]
+ "pointfree"
+ " and "
+ a_ [href_ "http://hackage.haskell.org/package/pointful"]
+ "pointful"
+ " libraries."
+
+ p_ <| do
+ a_ [href_ "https://github.com/tfausak/blunt"] <| do
+ "github.com/tfausak/blunt"
+
+ script_ [] script
diff --git a/library/Blunt/Script.hs b/library/Blunt/Script.hs
new file mode 100644
index 0000000..190b2d8
--- /dev/null
+++ b/library/Blunt/Script.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Blunt.Script where
+
+import Language.Javascript.JMacro
+
+import Data.Text.Lazy (Text)
+import Text.PrettyPrint.Leijen.Text (displayT, renderOneLine)
+
+script :: Text
+script = displayT (renderOneLine (renderJs js))
+
+js :: JStat
+js = [jmacro| \ {
+ var input = document.getElementById("input");
+ var pointfree = document.getElementById("pointfree");
+ var pointful = document.getElementById("pointful");
+
+ var socket = new WebSocket(window.location.origin.replace('http', 'ws'));
+
+ socket.onopen = \ {
+ input.oninput = \ {
+ window.location.replace(
+ "#input=" + encodeURIComponent(input.value));
+ socket.send(input.value);
+ };
+
+ if (input.value) { input.oninput(); }
+ };
+
+ 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 = decodeURIComponent(window.location.hash.substring(7));
+ }
+}(); |]
diff --git a/library/Blunt/Style.hs b/library/Blunt/Style.hs
new file mode 100644
index 0000000..02ad0d3
--- /dev/null
+++ b/library/Blunt/Style.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Blunt.Style where
+
+import Clay
+
+import Data.Monoid ((<>))
+import Data.Text.Lazy (Text)
+import Prelude hiding (div)
+
+style :: Text
+style = renderWith compact [] css
+
+css :: Css
+css = do
+ html <> body ? do
+ backgroundColor "#f5f5f5"
+ color "#151515"
+ fontFamily [] [sansSerif]
+ lineHeight (em 1.5)
+ sym margin nil
+ sym padding nil
+
+ body ? do
+ boxSizing borderBox
+ sym2 margin nil auto
+ maxWidth (em 40)
+ sym2 padding nil (em 1.5)
+
+ h1 ? do
+ color "#90a959"
+ fontSize (em 2)
+ fontWeight bold
+ lineHeight (em 3)
+ sym margin nil
+ textAlign (alignSide sideCenter)
+
+ dl ? do
+ sym margin nil
+
+ dt ? do
+ marginTop (em 1.5)
+
+ dd ? do
+ sym margin nil
+
+ input <> div ? do
+ border solid (px 1) "#e0e0e0"
+ boxSizing borderBox
+ fontFamily [] [monospace]
+ fontSize (em 1)
+ width (pct 100)
+
+ input ? do
+ height (em 3)
+ lineHeight (em 3)
+ sym2 padding nil (em 0.75)
+
+ div ? do
+ sym padding (em 0.75)
+ whiteSpace preWrap
+
+ p ? do
+ margin (em 1.5) nil nil nil
+ textAlign (alignSide sideCenter)