summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorfozworth <>2015-03-29 14:43:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-03-29 14:43:00 (GMT)
commit5820d580eab2d2e009a0253dd0d6530d9f1f9c67 (patch)
tree28da7d4974350605876de40e6aae4501a66ed224
parent6c4f149168eebf4cd40637881152650e6a60bf98 (diff)
version 0.0.40.0.4
-rw-r--r--CHANGELOG.md5
-rw-r--r--blunt.cabal9
-rw-r--r--data/index.html53
-rw-r--r--library/Blunt.hs122
4 files changed, 102 insertions, 87 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index f8bde36..8a890d5 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,10 @@
# Change log
+## v0.0.4 (2015-03-19)
+
+- Allow setting the port with the `PORT` environment variable.
+- Took HTML out of its separate file.
+
## v0.0.3 (2015-03-19)
- Prevent `pointfree'` from throwing errors during a request.
diff --git a/blunt.cabal b/blunt.cabal
index 4b24e1e..b6d5946 100644
--- a/blunt.cabal
+++ b/blunt.cabal
@@ -1,5 +1,5 @@
name: blunt
-version: 0.0.3
+version: 0.0.4
cabal-version: >=1.10
build-type: Simple
license: MIT
@@ -7,11 +7,8 @@ license-file: LICENSE.md
maintainer: Taylor Fausak <taylor@fausak.me>
synopsis: Point-free Haskell as a service.
description:
- TODO
+ https://bitbucket.org/taylorfausak/blunt
category: Web
-data-files:
- index.html
-data-dir: data
extra-source-files:
CHANGELOG.md
README.md
@@ -31,8 +28,6 @@ library
warp ==3.*
default-language: Haskell2010
hs-source-dirs: library
- other-modules:
- Paths_blunt
ghc-options: -Wall
-- pointfree
diff --git a/data/index.html b/data/index.html
deleted file mode 100644
index 333ee84..0000000
--- a/data/index.html
+++ /dev/null
@@ -1,53 +0,0 @@
-<!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>
- '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();
- };
- }());
- </script>
- </body>
-</html>
diff --git a/library/Blunt.hs b/library/Blunt.hs
index 58c42cc..032065e 100644
--- a/library/Blunt.hs
+++ b/library/Blunt.hs
@@ -2,43 +2,111 @@
module Blunt where
-import Paths_blunt (getDataFileName)
-
import Control.Exception (SomeException, evaluate, handle)
import Data.ByteString.Char8 (unpack)
import Data.ByteString.Lazy (fromStrict)
import Data.ByteString.Lazy.Char8 (pack)
import Network.HTTP.Types (notFound404, ok200)
-import Network.Wai (queryString, pathInfo, requestMethod, responseFile,
- responseLBS)
-import Network.Wai.Handler.Warp (run)
+import Network.Wai (Application, Request, Response, queryString, pathInfo,
+ requestMethod, responseLBS)
+import Network.Wai.Handler.Warp (runEnv)
import Pointfree (pointfree')
main :: IO ()
-main = run 8080 $ \ request respond -> do
- index <- getDataFileName "index.html"
- let method = requestMethod request
- path = pathInfo request
- response <- case (method, path) of
- ("GET", []) -> return $ responseFile
- ok200
- [("Content-Type", "text/html; charset=utf-8")]
- index
- Nothing
- ("GET", ["pointfree"]) -> do
- let params = queryString request
- input = case lookup "input" params of
- Just (Just param) -> param
- _ -> ""
- maybeOutput <- safePointfree (unpack input)
- let body = case maybeOutput of
- Just output -> pack output
- Nothing -> fromStrict input
- return $ responseLBS ok200 [("Content-Type", "text/plain; charset=utf-8")] body
- _ -> return $ responseLBS notFound404 [] ""
- respond response
+main = runEnv 8080 application
+
+application :: Application
+application request respondWith = do
+ let action = route request
+ response <- action request
+ respondWith response
+
+type Action = Request -> IO Response
+
+route :: Request -> Action
+route request = case (requestMethod request, pathInfo request) of
+ ("GET", []) -> indexAction
+ ("GET", ["pointfree"]) -> pointfreeAction
+ _ -> notFoundAction
+
+indexAction :: Action
+indexAction _request = do
+ let headers = [("Content-Type", "text/html; charset=utf-8")]
+ body = pack html
+ return (responseLBS ok200 headers body)
+
+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)
+
+notFoundAction :: Action
+notFoundAction _request = return (responseLBS notFound404 [] "")
safePointfree :: String -> IO (Maybe String)
safePointfree = handle handler . evaluate . pointfree' where
handler :: SomeException -> IO (Maybe String)
handler _ = return Nothing
+
+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>"
+ ]
+
+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();"
+ , " };"
+ , "}());"
+ ]