diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Change log +## 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. diff --git a/blunt.cabal b/blunt.cabal --- a/blunt.cabal +++ b/blunt.cabal @@ -1,5 +1,5 @@ name: blunt -version: 0.0.13 +version: 0.0.14 cabal-version: >=1.10 build-type: Simple license: MIT @@ -22,7 +22,14 @@ 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: @@ -36,6 +43,7 @@ pointful >=1.0.6 && <2, text ==1.*, wai ==3.*, + wai-extra ==3.*, warp ==3.*, wl-pprint-text ==1.* default-language: Haskell2010 diff --git a/library/Blunt.hs b/library/Blunt.hs --- a/library/Blunt.hs +++ b/library/Blunt.hs @@ -1,77 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Blunt where - -import Blunt.Markup (markup) - -import Control.Exception (SomeException, evaluate, handle) -import Data.Aeson (ToJSON, (.=), encode, object, toJSON) -import Data.ByteString.Char8 (unpack) -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 = markup - 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 [] "") +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 -safePointfree :: String -> IO [String] -safePointfree = handle handler . evaluate . pointfree where - handler :: SomeException -> IO [String] - handler _ = return [] +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 diff --git a/library/Blunt/Actions.hs b/library/Blunt/Actions.hs new file mode 100644 --- /dev/null +++ b/library/Blunt/Actions.hs @@ -0,0 +1,51 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/library/Blunt/Application.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/library/Blunt/Main.hs @@ -0,0 +1,8 @@ +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 @@ -2,11 +2,11 @@ module Blunt.Markup where +import Lucid + import Blunt.Script (script) import Blunt.Style (style) - import Data.ByteString.Lazy (ByteString) -import Lucid markup :: ByteString markup = renderBS html diff --git a/library/Blunt/Middleware.hs b/library/Blunt/Middleware.hs new file mode 100644 --- /dev/null +++ b/library/Blunt/Middleware.hs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/library/Blunt/Pointfree.hs @@ -0,0 +1,9 @@ +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 new file mode 100644 --- /dev/null +++ b/library/Blunt/Pointful.hs @@ -0,0 +1,13 @@ +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 new file mode 100644 --- /dev/null +++ b/library/Blunt/Router.hs @@ -0,0 +1,12 @@ +{-# 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 @@ -2,15 +2,16 @@ module Blunt.Script where -import Data.Text.Lazy (Text) 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| +js = [jmacro| \ { var input = document.getElementById("input"); var pointfree = document.getElementById("pointfree"); var pointful = document.getElementById("pointful"); @@ -36,9 +37,9 @@ updateHash(); updateOutput(); }; - + if (window.location.hash.indexOf("#input=") === 0) { input.value = window.location.hash.substring(7); input.oninput(); } -|] +}(); |] diff --git a/library/Blunt/Style.hs b/library/Blunt/Style.hs --- a/library/Blunt/Style.hs +++ b/library/Blunt/Style.hs @@ -3,6 +3,7 @@ module Blunt.Style where import Clay + import Data.Monoid ((<>)) import Data.Text.Lazy (Text) import Prelude hiding (div)