seito: Strip terminal sequences when output does not go to a tty

Author: sol

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

driver/seito.hs

@@ -1,13 +1,14 @@
 module Main (main) where
 
 import           System.Exit
+import           System.Environment
 import           Control.Monad
 import qualified Data.ByteString.Lazy as L
 
 import           Client
 
 main :: IO ()
 main = do
-  (success, output) <- client ""
+  (success, output) <- getArgs >>= client ""
   L.putStr output
   unless success exitFailure

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
 

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']

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 "success")
+
+withFailure :: (FilePath -> IO a) -> IO a
+withFailure = withServer Trigger.Failure (withColor Red "failure")
+
+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 "success")
+
+    it "accepts --no-color" $ do
+      withSuccess $ \ dir -> do
+        client dir ["--no-color"] `shouldReturn` (True, "success")
 
     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, "failure")
 
     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")

test/HTTPSpec.hs

@@ -3,17 +3,41 @@ module HTTPSpec (spec) where
 import           Helper
 
 import           Test.Hspec.Wai
+import qualified System.Console.ANSI as Ansi
 
 import           HTTP
 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"