diff --git a/README.md b/README.md index bb97bdac..0d209de3 100644 --- a/README.md +++ b/README.md @@ -65,7 +65,7 @@ Create a Makefile with the following content: ```Makefile all: - @seito | sed 's/\x1B\[[0-9;]*[JKmsu]//g' + @seito ``` @@ -75,7 +75,7 @@ Add the following to your Vim configuration (e.g. `~/.vim/after/ftplugin/haskell.vim`): ```vim -:set makeprg=seito\ \\\|\ sed\ 's/\\x1B\\[[0-9;]*[JKmsu]//g' +:set makeprg=seito ``` ### Emacs integration diff --git a/driver/seito.hs b/driver/seito.hs index b372ffb5..7c1f7603 100644 --- a/driver/seito.hs +++ b/driver/seito.hs @@ -1,6 +1,7 @@ module Main (main) where import System.Exit +import System.Environment import Control.Monad import qualified Data.ByteString.Lazy as L @@ -8,6 +9,6 @@ import Client main :: IO () main = do - (success, output) <- client "" + (success, output) <- getArgs >>= client "" L.putStr output unless success exitFailure diff --git a/src/Client.hs b/src/Client.hs index a8f33abc..b3dc7218 100644 --- a/src/Client.hs +++ b/src/Client.hs @@ -2,6 +2,7 @@ module Client (client) where import Imports +import System.IO import Network.Socket import Network.HTTP.Types import Network.HTTP.Client @@ -10,12 +11,23 @@ import qualified Data.ByteString.Lazy as L import HTTP (newSocket, socketName) -client :: FilePath -> IO (Bool, L.ByteString) -client dir = handleSocketFileDoesNotExist name $ do - manager <- newManager defaultManagerSettings {managerRawConnection = return newConnection} - Response{..} <- httpLbs "http://localhost/" manager - return (statusIsSuccessful responseStatus, responseBody) +client :: FilePath -> [String] -> IO (Bool, L.ByteString) +client dir args = case args of + [] -> hIsTerminalDevice stdout >>= run + ["--no-color"] -> run False + ["--color"] -> run True + _ -> do + hPutStrLn stderr $ "Usage: seito [ --color | --no-color ]" + return (False, "") where + run color = handleSocketFileDoesNotExist name $ do + manager <- newManager defaultManagerSettings {managerRawConnection = return newConnection} + let + url :: Request + url = fromString $ "http://localhost/?color=" <> map toLower (show color) + Response{..} <- httpLbs url manager + return (statusIsSuccessful responseStatus, responseBody) + name :: FilePath name = socketName dir diff --git a/src/HTTP.hs b/src/HTTP.hs index c07767da..e172af8e 100644 --- a/src/HTTP.hs +++ b/src/HTTP.hs @@ -7,12 +7,14 @@ module HTTP ( #ifdef TEST , app +, stripAnsi #endif ) where import Imports import System.Directory +import qualified Data.ByteString.Lazy as L import Data.Text.Lazy.Encoding (encodeUtf8) import Network.Wai import Network.HTTP.Types @@ -58,11 +60,46 @@ withThread asyncAction action = do return r app :: IO (Trigger.Result, String) -> Application -app trigger _ respond = trigger >>= textPlain +app trigger request respond = trigger >>= textPlain where - textPlain (result, xs) = respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ xs) - where - status = case result of - Trigger.HookFailed -> internalServerError500 - Trigger.Failure -> internalServerError500 - Trigger.Success -> ok200 + color :: Either ByteString Bool + color = case join $ lookup "color" $ queryString request of + Nothing -> Right True + Just "false" -> Right False + Just "true" -> Right True + Just value -> Left $ "invalid value for color: " <> urlEncode True value + + textPlain :: (Trigger.Result, FilePath) -> IO ResponseReceived + textPlain (result, xs) = case color of + Left err -> respond $ responseLBS status400 [(hContentType, "text/plain")] (L.fromStrict err) + Right c -> respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ strip xs) + where + strip :: String -> String + strip + | c = id + | otherwise = stripAnsi + + status = case result of + Trigger.HookFailed -> status500 + Trigger.Failure -> status500 + Trigger.Success -> status200 + +-- | +-- Remove terminal sequences. +stripAnsi :: String -> String +stripAnsi = go + where + go input = case input of + '\ESC' : '[' : (dropNumericParameters -> c : xs) | isCommand c -> go xs + '\ESC' : '[' : '?' : (dropNumericParameters -> c : xs) | isCommand c -> go xs + x : xs -> x : go xs + [] -> [] + + dropNumericParameters :: FilePath -> FilePath + dropNumericParameters = dropWhile (`elem` ("0123456789;" :: [Char])) + + isCommand :: Char -> Bool + isCommand = (`elem` commands) + + commands :: FilePath + commands = ['A'..'Z'] <> ['a'..'z'] diff --git a/test/ClientSpec.hs b/test/ClientSpec.hs index 1fadb93c..38ab772b 100644 --- a/test/ClientSpec.hs +++ b/test/ClientSpec.hs @@ -2,24 +2,39 @@ module ClientSpec (spec) where import Helper -import HTTP +import HTTP (socketName) +import qualified HTTP import Client import qualified Trigger +withSuccess :: (FilePath -> IO a) -> IO a +withSuccess = withServer Trigger.Success (withColor Green "hello") + +withFailure :: (FilePath -> IO a) -> IO a +withFailure = withServer Trigger.Failure (withColor Red "hello") + +withServer :: Trigger.Result -> String -> (FilePath -> IO a) -> IO a +withServer result text action = do + withTempDirectory $ \ dir -> do + HTTP.withServer dir (return (result, text)) $ do + action dir + spec :: Spec spec = do describe "client" $ do - it "does a HTTP request via a Unix domain socket" $ do - withTempDirectory $ \ dir -> do - withServer dir (return (Trigger.Success, "hello")) $ do - client dir `shouldReturn` (True, "hello") + it "accepts --color" $ do + withSuccess $ \ dir -> do + client dir ["--color"] `shouldReturn` (True, fromString $ withColor Green "hello") + + it "accepts --no-color" $ do + withSuccess $ \ dir -> do + client dir ["--no-color"] `shouldReturn` (True, "hello") it "indicates failure" $ do - withTempDirectory $ \ dir -> do - withServer dir (return (Trigger.Failure, "hello")) $ do - client dir `shouldReturn` (False, "hello") + withFailure $ \ dir -> do + client dir [] `shouldReturn` (False, "hello") context "when server socket is missing" $ do it "reports error" $ do withTempDirectory $ \ dir -> do - client dir `shouldReturn` (False, "could not connect to " <> fromString (socketName dir) <> "\n") + client dir [] `shouldReturn` (False, "could not connect to " <> fromString (socketName dir) <> "\n") diff --git a/test/HTTPSpec.hs b/test/HTTPSpec.hs index f2b7a4bb..2c922c82 100644 --- a/test/HTTPSpec.hs +++ b/test/HTTPSpec.hs @@ -3,6 +3,7 @@ module HTTPSpec (spec) where import Helper import Test.Hspec.Wai +import qualified System.Console.ANSI as Ansi import HTTP import qualified Trigger @@ -10,10 +11,33 @@ import qualified Trigger spec :: Spec spec = do describe "app" $ do - with (return $ app $ return (Trigger.Success, "hello")) $ do + with (return $ app $ return (Trigger.Success, withColor Green "hello")) $ do it "returns 200 on success" $ do - get "/" `shouldRespondWith` 200 + get "/" `shouldRespondWith` fromString (withColor Green "hello") + + context "with ?color" $ do + it "keeps terminal sequences" $ do + get "/?color" `shouldRespondWith` fromString (withColor Green "hello") + + context "with ?color=true" $ do + it "keeps terminal sequences" $ do + get "/?color=true" `shouldRespondWith` fromString (withColor Green "hello") + + context "with ?color=false" $ do + it "removes terminal sequences" $ do + get "/?color=false" `shouldRespondWith` "hello" + + context "with an in invalid value for ?color" $ do + it "returns status 400" $ do + get "/?color=some%20value" `shouldRespondWith` 400 { matchBody = "invalid value for color: some%20value" } with (return $ app $ return (Trigger.Failure, "hello")) $ do it "return 500 on failure" $ do get "/" `shouldRespondWith` 500 + + describe "stripAnsi" $ do + it "removes ANSI color sequences" $ do + stripAnsi ("some " <> withColor Green "colorized" <> " text") `shouldBe` "some colorized text" + + it "removes DEC private mode sequences" $ do + stripAnsi (Ansi.hideCursorCode <> "some text" <> Ansi.showCursorCode) `shouldBe` "some text"