module Main where import Prelude hiding (catch) import Network.CGI import Data.Maybe import Control.Monad import Control.Concurrent import System.Process import System.IO import Text.XHtml.Strict import Data.List import Text.Regex import Control.Applicative import Text.JSON import Language.Lojban.Util import Control.Exception import Control.Concurrent import System.Process import System.IO import System.Exit main :: IO () main = runCGI $ handleErrors $ do loj <- liftM (fromMaybe "") $ getInput "lojban" big <- getInput "big" lolcolors <- getInput "lolcolors" opts <- liftM (intersect jboOpts . map fst) $ getInputs err_out <- formatLojban loj (unwords $ map ('-':) opts) case err_out of Left e -> error "jbofihe error! (sorry, sometimes it crashes...)" Right eo -> showOut eo lolcolors big loj opts showOut (err,out) lolcolors big loj opts = do plain <- (=="plain") . fromMaybe "" <$> getInput "output" if plain then do setHeader "Content-type" "text/plain" output (json err out) else do output $ showHtml $ page lolcolors (theform lolcolors big loj opts) (pre ! [theclass "err"] << err +++ outStyle out opts) json :: String -> String -> String json err out = flip showJSObject "" $ toJSObject $ entry "error" err ++ entry "out" out where entry name val | val /="" = [(name,JSString $ toJSString val)] | otherwise = [] outStyle :: String -> [String] -> Html outStyle out opts | any parse opts = pre << out | any (=="H") opts = let o = clean out in o +++ hr +++ pre << o | otherwise = stringToHtml out where parse n = n=="t" || n=="tf" clean :: String -> Html clean = primHtml . remCrap . lines where remCrap [] = [] remCrap ("":h:t:b:k) = subRegex (mkRegex "") (unlines k) "" page :: Maybe a -> Html -> Html -> Html page lolcolors form output = header << (thetitle << title +++ css) +++ body << (h1 << title +++ form +++ hr +++ output) where title = "jbofihe: Lojban Translator" css = style "jbofihe-style.css" +++ maybe noHtml (const colors) lolcolors colors = style "jbofihe-colors.css" style url = thelink ! [rel "stylesheet", thetype "text/css", href url] << "" theform :: Maybe a -> Maybe a -> String -> [String] -> Html theform lolcolors big loj opts = form << (aCheck lolcolors "lolcolors" "Colors" +++ aCheck big "big" "Big text box" +++ inputBox big loj +++ optChecks opts) aCheck :: Maybe a -> String -> String -> Html aCheck big name' capt = p << (input ! ([thetype "checkbox", name name'] ++ maybeCheck big) +++ capt) inputBox :: Maybe a -> String -> Html inputBox big loj = maybe smallBox bigBox big where smallBox = p << (t +++ input ! [thetype "text", value loj, name "lojban"] +++ submit) bigBox _ = p << t +++ p << textarea ! [rows "20", cols "50", value loj, name "lojban"] << loj +++ p << submit submit = input ! [thetype "submit", value "Translate"] t = label << "Lojbanic text:" optChecks :: [String] -> [Html] optChecks opts = map makeCheck (zip [0..] jboOpts) where makeCheck (i,n) = p << (check +++ jboOptNames !! i) where check = input ! ([thetype "checkbox", name n] ++ maybeCheck (find (==n) opts)) maybeCheck :: Maybe a -> [HtmlAttr] maybeCheck = maybe [] (const [checked]) jboOpts = ["H","ie","re","se","sev","cr","t","tf","x"] jboOptNames = ["Formatted output" ,"Display elided separators and terminators" ,"Require elidable separators and terminators to be present" ,"Show elidable separators/terminators that could be omitted" ,"Ditto, plus verbose detail" ,"Allow cultural rafsi in lujvo (Reference Grammar section 4.16)" ,"Show edited parse tree" ,"Show full parse tree" ,"Produce plain text output"] formatLojban :: String -> String -> CGI (Either String (String,String)) formatLojban text opts = liftIO $ flip run (format text) ("jbofihe " ++ opts) where format = flip (subRegex (mkRegex "[\r\n]+")) " " run :: String -> String -> IO (Either String (String,String)) run cmd input = do pipe <- catch (Right `fmap` runInteractiveCommand ("ulimit -t 1 && " ++ cmd)) (const $ return $ Left "Broken pipe") case pipe of Right (inp,out,err,pid) -> do catch (do hSetBuffering inp NoBuffering hPutStr inp input hClose inp errv <- newEmptyMVar outv <- newEmptyMVar output <- hGetContents out errput <- hGetContents err forkIO $ evaluate (length output) >> putMVar outv () forkIO $ evaluate (length errput) >> putMVar errv () takeMVar errv takeMVar outv e <- catch (waitForProcess pid) (const $ return ExitSuccess) return $ Right (errput,output)) (const $ return $ Left "Broken pipe") _ -> return $ Left "Unable to launch process"