mcm-0.6.4.10: commands2html.hs
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>
--
-- Licence:
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-- Reads the list of commands
-- then runs them one at a time
-- and converts the output to an HTML snippet
-- NB. Based on mcm2html.hs
module Main (main)
where
import Paths_mcm (version)
import Control.Monad(when, unless)
import qualified Data.ByteString.Lazy as B
import Data.Char (isDigit)
import Data.List (foldl')
import Data.String (fromString)
import qualified Data.Text.Lazy as T
import Data.Version (showVersion)
import System.Console.GetOpt
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.Environment (getArgs)
import System.Exit (ExitCode(..), exitSuccess, exitFailure)
import System.FilePath (takeDirectory)
import System.Process (readProcessWithExitCode)
import qualified Text.Blaze.Html5 as H5
import Text.Blaze.Html5 (ToMarkup, toHtml)
import Text.Blaze.Html5.Attributes (class_, type_, charset)
import qualified Text.Blaze.Html.Renderer.Utf8 as Render_Utf8
import qualified Text.Blaze.Html.Renderer.String as Render_String
import Text.ParserCombinators.Poly.Plain
usage :: String
usage = unlines ["Usage: commands2html [OPTION..] FILE [OPTION..]"
,"Create .commands.html_snippet from the given .commands"
]
main :: IO ()
main = do
progargs <- getArgs
let (actions, nonOpts, msgs) = getOpt Permute options progargs
unless (null msgs) $ error $ concat msgs ++ usageInfo usage options
opts <- foldl' (>>=) (return defaultOptions) actions
let Options {optOutFilenameExtension = extension
,optOutputWrapper = wrapper
} = opts
infilename <- case nonOpts of
[i] -> return i
xs -> do
putStrLn $ "Error: expected a single .commands filename but received: " ++ show xs
exitFailure
when (extension == "") $ error "Extension can't be empty!"
let outfilename = infilename ++ extension
infiledir = takeDirectory infilename
putStrLn $ "Writing " ++ outfilename
cmds <- commandsLoadAndParse infilename
cdir <- getCurrentDirectory
setCurrentDirectory infiledir
r <- mapM runCommand cmds
setCurrentDirectory cdir
B.writeFile outfilename $ Render_Utf8.renderHtml . wrapper $ do
H5.pre H5.! class_ (fromString "C2H") $ mapM_ toHtml r
newline
isComment :: String -> Bool
isComment "" = False
isComment ('#':_) = True
isComment _ = False
commandsLoadAndParse :: FilePath -> IO [String]
commandsLoadAndParse fp = do
s <- readFile fp
return $ filter (not . isComment) $ lines s
newtype CmdResult = CmdResult (String, ExitCode, String, String)
runCommand :: String -> IO CmdResult
runCommand cmd = do
(exitcode, out, err) <- readProcessWithExitCode "/bin/sh" ["-c", cmd] ""
return $ CmdResult (cmd, exitcode, out, err)
instance ToMarkup CmdResult where
toMarkup (CmdResult (cmd, exitcode, out, err)) = do
colourwith Prompt $ text "> "
text cmd
newline
parseAndToHtml out
parseAndToHtml err
toHtml exitcode
instance ToMarkup ExitCode where
toMarkup ExitSuccess = text ""
toMarkup (ExitFailure f) = colourwith BadExit $ do
text "Exit failure: "
text . show $ f
newline
parseAndToHtml :: String -> H5.Html
parseAndToHtml = c . collapseNested . colourstring2nested . parse
where
c [] = text ""
c (x:xs) = do
toHtml x
c xs
data Options = Options
{optOutFilenameExtension :: String
,optOutputWrapper :: H5.Html -> H5.Html
}
defaultOptions :: Options
defaultOptions = Options
{optOutFilenameExtension = ".html_snippet"
,optOutputWrapper = id
}
options :: [OptDescr (Options -> IO Options)]
options = [Option "V" ["version"] (NoArg displayVersion) "show version and exit"
,Option [] ["head"] (NoArg headOpt) "output (to stdout) the suggested snippet for within <head> and exit"
,Option [] ["css"] (NoArg cssOpt) "output (to stdout) the suggested snippet for within an included CSS file and exit"
,Option [] ["fullpage"] (NoArg fullpageOpt) "write a full .html page (instead of .html_snippet)"
,Option "h" ["help"] (NoArg justHelp) "show this help and exit"
]
displayVersion :: Options -> IO Options
displayVersion _ = do
putStrLn $ "commands2html " ++ showVersion version
exitSuccess
justHelp :: Options -> IO Options
justHelp _ = do
putStrLn $ usageInfo usage options
exitSuccess
headOpt :: Options -> IO Options
headOpt _ = do
putStrLn . Render_String.renderHtml $ suggestedHead
exitSuccess
suggestedHead :: H5.Html
suggestedHead = H5.meta H5.! charset (fromString "utf-8")
cssOpt :: Options -> IO Options
cssOpt _ = do
putStrLn . Render_String.renderHtml $ suggestedCss
exitSuccess
-- NB. Valid colours: http://www.w3.org/TR/CSS21/syndata.html#color-units
suggestedCss :: H5.Html
suggestedCss = text $ unlines
["pre.C2H {white-space: pre-wrap; tab-size: 4;-moz-tab-size: 4}"
,"pre.C2H .BadExit {font-weight: bold;color: red;background-color: white}"
,"pre.C2H .Prompt {font-weight: bold}"
,"pre.C2H .GM1 {font-weight: bold}"
,"pre.C2H .GM30 {color: black}" -- black
,"pre.C2H .GM31 {color: red}" -- red
,"pre.C2H .GM32 {color: green}" -- green4
,"pre.C2H .GM33 {color: yellow}" -- yellow
,"pre.C2H .GM34 {color: blue}" -- blue
,"pre.C2H .GM35 {color: fuchsia}" -- magenta
,"pre.C2H .GM36 {color: aqua}" -- cyan4
,"pre.C2H .GM37 {color: white}" -- white
,"pre.C2H .GM40 {background-color: black}" -- black
,"pre.C2H .GM41 {background-color: red}" -- red
,"pre.C2H .GM42 {background-color: green}" -- green4
,"pre.C2H .GM43 {background-color: yellow}" -- yellow
,"pre.C2H .GM44 {background-color: blue}" -- blue
,"pre.C2H .GM45 {background-color: fuchsia}" -- magenta
,"pre.C2H .GM46 {background-color: aqua}" -- cyan4
,"pre.C2H .GM47 {background-color: white}" -- white
]
fullpageOpt :: Options -> IO Options
fullpageOpt opts = return opts {optOutFilenameExtension = ".html"
,optOutputWrapper = fullPage
}
fullPage :: H5.Html -> H5.Html
fullPage content = H5.docTypeHtml $ do
H5.head $ do
suggestedHead
newline
H5.style H5.! type_ (fromString "text/css") $ suggestedCss
newline
H5.body content
newline
text :: String -> H5.Html
text = H5.toHtml . T.pack
newline :: H5.Html
newline = text "\n"
data ColourType = BadExit | Prompt
deriving Show
colourwith :: ColourType -> H5.Html -> H5.Html
colourwith c h = H5.span H5.! class_ (fromString . show $ c) $ h
type P = Parser Char
data ColourString = Plain String
| GraphicsMode Int
data NestedColourString = NPlain String
| NGraphicsMode [Int] [NestedColourString]
instance ToMarkup NestedColourString where
toMarkup (NPlain s) = text s
toMarkup (NGraphicsMode ns cs) = H5.span H5.! class_ cl $ mapM_ toHtml cs
where
cl = fromString $ unwords $ map (\n -> "GM" ++ show n) ns
manySatisfy :: (Char -> Bool) -> P String
manySatisfy p = many (satisfy p)
many1Satisfy :: (Char -> Bool) -> P String
many1Satisfy p = many1 (satisfy p)
char :: Char -> P ()
char c = do
n <- next
unless (c == n) $ fail $ "Unexpected char: " ++ show n
--
-- Parse (a small subset of) ANSI Escape sequences
-- See http://ascii-table.com/ansi-escape-sequences.php
-- and http://hackage.haskell.org/package/ansi-terminal
-- and http://stackoverflow.com/questions/4842424/list-of-ansi-color-escape-sequences
-- and http://wiki.bash-hackers.org/scripting/terminalcodes
parse :: String -> [ColourString]
parse s = case runParser (many pBit) s of
(Left e, _) -> error e
(Right ps, []) -> concat ps
(_, v) -> error $ "Failed to parse end: " ++ v
pBit :: P [ColourString]
pBit = oneOf
[do
char '\ESC'
char '['
as <- sepBy pNum (char ';')
char 'm'
return $ map GraphicsMode as
,do
c <- next
cs <- pManyUntilEsc
return [Plain (c:cs)]
]
pManyUntilEsc :: P String
pManyUntilEsc = manySatisfy (/= '\ESC')
pNum :: P Int
pNum = do
ds <- many1Satisfy isDigit
return $ read ds
colourstring2nested :: [ColourString] -> [NestedColourString]
colourstring2nested [] = []
colourstring2nested xs =
case colourstring2nested' xs of
(r, []) -> r
(r, xs') -> r ++ colourstring2nested xs'
where
colourstring2nested' :: [ColourString] -> ([NestedColourString], [ColourString])
colourstring2nested' [] = ([], [])
colourstring2nested' (Plain s : cs) = (NPlain s : cs', r)
where
(cs', r) = colourstring2nested' cs
colourstring2nested' (GraphicsMode 0 : cs) = ([], cs)
colourstring2nested' (GraphicsMode n : cs) = ([NGraphicsMode [n] cs'], r)
where
(cs', r) = colourstring2nested' cs
-- Items are commonly bold + fg, so spot these and permit easy conversion to class="bold + fg"
collapseNested :: [NestedColourString] -> [NestedColourString]
collapseNested [] = []
collapseNested (NGraphicsMode a [NGraphicsMode b bs]:ns) = collapseNested (NGraphicsMode (a++b) bs : ns)
collapseNested (n:ns) = n:collapseNested ns