{-# LANGUAGE OverloadedStrings #-} module Blunt where import Control.Exception (SomeException, evaluate, handle) import Data.Aeson (ToJSON, (.=), encode, object, toJSON) import Data.ByteString.Char8 (unpack) import Data.ByteString.Lazy.Char8 (pack) import Lambdabot.Pointful (pointful) import Network.HTTP.Types (notFound404, ok200) import Network.Wai (Application, Request, Response, queryString, pathInfo, requestMethod, responseLBS) import Network.Wai.Handler.Warp (runEnv) import Pointfree (pointfree) main :: IO () 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", ["convert"]) -> convertAction _ -> notFoundAction indexAction :: Action indexAction _request = do let headers = [("Content-Type", "text/html")] body = pack html return (responseLBS ok200 headers body) data Result = Result { resultInput :: String , resultPointfree :: [String] , resultPointful :: String } deriving (Read, Show) instance ToJSON Result where toJSON result = object [ "input" .= resultInput result , "pointfree" .= resultPointfree result , "pointful" .= resultPointful result ] convertAction :: Action convertAction request = do let input = case lookup "input" (queryString request) of Just (Just param) -> unpack param _ -> "" pf <- safePointfree input let pl = pointful input result = Result { resultInput = input , resultPointfree = pf , resultPointful = pl } let headers = [("Content-Type", "application/json")] body = encode result return (responseLBS ok200 headers body) notFoundAction :: Action notFoundAction _request = return (responseLBS notFound404 [] "") safePointfree :: String -> IO [String] safePointfree = handle handler . evaluate . pointfree where handler :: SomeException -> IO [String] handler _ = return [] html :: String html = unlines [ "" , "" , "" , " " , " " , " " , "" , " Blunt" , "" , " " , " " , "" , " " , "

Blunt

" , "" , "
" , "
Input
" , "
" , " " , "
" , "" , "
Pointfree
" , "
" , "
" , "
" , "" , "
Pointful
" , "
" , "
" , "
" , "
" , "" , "

" , " " , " https://github.com/tfausak/blunt" , " " , "

" , "" , " " , " " , "" ] css :: String css = unlines [ "html, body {" , " background: #f5f5f5;" , " color: #151515;" , " font: 100%/1.5em sans-serif;" , " margin: 0;" , " padding: 0;" , "}" , "" , "body {" , " box-sizing: border-box;" , " margin: 0 auto;" , " max-width: 40em;" , " padding: 0 1.5em;" , "}" , "" , "h1 {" , " color: #90a959;" , " font-size: 2em;" , " font-weight: bold;" , " line-height: 3em;" , " margin: 0;" , " text-align: center;" , "}" , "" , "dl {" , " margin: 0;" , "}" , "" , "dt {" , " margin-top: 1.5em;" , "}" , "" , "dd {" , " margin: 0;" , "}" , "" , "input, div {" , " border: thin solid #e0e0e0;" , " box-sizing: border-box;" , " font-family: monospace;" , " font-size: 1em;" , " width: 100%;" , "}" , "" , "input {" , " height: 3em;" , " line-height: 3em;" , " padding: 0 0.75em;" , "}" , "" , "div {" , " padding: 0.75em;" , " white-space: pre-wrap;" , "}" , "" , "p {" , " margin: 1.5em 0 0 0;" , " text-align: center;" , "}" ] js :: String js = unlines [ "'use strict';" , "" , "(function () {" , " var input = document.getElementById('input');" , " var pointfree = document.getElementById('pointfree');" , " var pointful = document.getElementById('pointful');" , "" , " var updateHash = function () {" , " window.location.replace('#input=' + input.value);" , " };" , "" , " var updateOutput = function () {" , " var request = new XMLHttpRequest();" , "" , " request.onreadystatechange = function () {" , " if (request.readyState === 4 && request.status === 200) {" , " var response = JSON.parse(request.response);" , "" , " pointfree.textContent = response.pointfree.join('\\n');" , " pointful.textContent = response.pointful;" , " }" , " };" , " request.open('GET', '/convert?input=' + encodeURIComponent(input.value));" , " request.send();" , " };" , "" , " input.oninput = function (_event) {" , " updateHash();" , " updateOutput();" , " };" , "" , " if (window.location.hash.indexOf('#input=') === 0) {" , " input.value = window.location.hash.substring(7);" , " input.oninput();" , " }" , "}());" ]