From b70dba87bab5dfc8039f0b9f69e0851f92324f8b Mon Sep 17 00:00:00 2001 From: hallgren Date: Wed, 15 Oct 2014 21:04:29 +0000 Subject: Rename modules GFI, GFC & GFServer... ... to GF.Interactive, GF.Compiler & GF.Server, respectively. --- src/compiler/GF.hs | 4 +- src/compiler/GF/Compiler.hs | 143 ++++++++++++ src/compiler/GF/Interactive.hs | 511 +++++++++++++++++++++++++++++++++++++++++ src/compiler/GF/Server.hs | 494 +++++++++++++++++++++++++++++++++++++++ src/compiler/GFC.hs | 144 ------------ src/compiler/GFI.hs | 511 ----------------------------------------- src/compiler/GFServer.hs | 494 --------------------------------------- 7 files changed, 1150 insertions(+), 1151 deletions(-) create mode 100644 src/compiler/GF/Compiler.hs create mode 100644 src/compiler/GF/Interactive.hs create mode 100644 src/compiler/GF/Server.hs delete mode 100644 src/compiler/GFC.hs delete mode 100644 src/compiler/GFI.hs delete mode 100644 src/compiler/GFServer.hs (limited to 'src') diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs index 68e43b6ca..cb63cadbe 100644 --- a/src/compiler/GF.hs +++ b/src/compiler/GF.hs @@ -1,7 +1,7 @@ module Main where -import GFC -import GFI +import GF.Compiler +import GF.Interactive import GF.Data.ErrM import GF.Infra.Option import GF.Infra.UseIO diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs new file mode 100644 index 000000000..3be8c6e14 --- /dev/null +++ b/src/compiler/GF/Compiler.hs @@ -0,0 +1,143 @@ +module GF.Compiler (mainGFC, writePGF) where + +import PGF +import PGF.Internal(concretes,optimizePGF,unionPGF) +import PGF.Internal(putSplitAbs,encodeFile,runPut) +import GF.Compile as S(batchCompile,link,srcAbsName) +import qualified GF.CompileInParallel as P(batchCompile) +import GF.Compile.Export +import GF.Compile.CFGtoPGF +import GF.Compile.GetGrammar +import GF.Grammar.CFG + +import GF.Infra.Ident(showIdent) +import GF.Infra.UseIO +import GF.Infra.Option +import GF.Data.ErrM +import GF.System.Directory + +import Data.Maybe +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.ByteString.Lazy as BSL +import System.FilePath +import Control.Monad(unless,forM_) + +mainGFC :: Options -> [FilePath] -> IO () +mainGFC opts fs = do + r <- appIOE (case () of + _ | null fs -> fail $ "No input files." + _ | all (extensionIs ".cf") fs -> compileCFFiles opts fs + _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs -> compileSourceFiles opts fs + _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs + _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs) + case r of + Ok x -> return x + Bad msg -> die $ if flag optVerbosity opts == Normal + then ('\n':msg) + else msg + where + extensionIs ext = (== ext) . takeExtension + +compileSourceFiles :: Options -> [FilePath] -> IOE () +compileSourceFiles opts fs = + do (t_src,~cnc_grs@(~(cnc,gr):_)) <- batchCompile opts fs + unless (flag optStopAfterPhase opts == Compile) $ + do let abs = showIdent (srcAbsName gr cnc) + pgfFile = outputPath opts (grammarName' opts abs<.>"pgf") + t_pgf <- if outputJustPGF opts + then maybeIO $ getModificationTime pgfFile + else return Nothing + if t_pgf >= Just t_src + then putIfVerb opts $ pgfFile ++ " is up-to-date." + else do pgfs <- mapM (link opts) + [(cnc,t_src,gr)|(cnc,gr)<-cnc_grs] + let pgf = foldl1 unionPGF pgfs + writePGF opts pgf + writeOutputs opts pgf + where + batchCompile = maybe batchCompile' P.batchCompile (flag optJobs opts) + batchCompile' opts fs = do (cnc,t,gr) <- S.batchCompile opts fs + return (t,[(cnc,gr)]) + +compileCFFiles :: Options -> [FilePath] -> IOE () +compileCFFiles opts fs = do + rules <- fmap concat $ mapM (getCFRules opts) fs + startCat <- case rules of + (CFRule cat _ _ : _) -> return cat + _ -> fail "empty CFG" + let pgf = cf2pgf (last fs) (uniqueFuns (mkCFG startCat Set.empty rules)) + let cnc = justModuleName (last fs) + unless (flag optStopAfterPhase opts == Compile) $ + do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) + let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf + writePGF opts pgf' + writeOutputs opts pgf' + +unionPGFFiles :: Options -> [FilePath] -> IOE () +unionPGFFiles opts fs = + if outputJustPGF opts + then maybe doIt checkFirst (flag optName opts) + else doIt + where + checkFirst name = + do let pgfFile = outputPath opts (name <.> "pgf") + sourceTime <- maximum `fmap` mapM getModificationTime fs + targetTime <- maybeIO $ getModificationTime pgfFile + if targetTime >= Just sourceTime + then putIfVerb opts $ pgfFile ++ " is up-to-date." + else doIt + + doIt = + do pgfs <- mapM readPGFVerbose fs + let pgf0 = foldl1 unionPGF pgfs + pgf = if flag optOptimizePGF opts then optimizePGF pgf0 else pgf0 + pgfFile = outputPath opts (grammarName opts pgf <.> "pgf") + if pgfFile `elem` fs + then putStrLnE $ "Refusing to overwrite " ++ pgfFile + else writePGF opts pgf + writeOutputs opts pgf + + readPGFVerbose f = + putPointE Normal opts ("Reading " ++ f ++ "...") $ liftIO $ readPGF f + +writeOutputs :: Options -> PGF -> IOE () +writeOutputs opts pgf = do + sequence_ [writeOutput opts name str + | fmt <- outputFormats opts, + (name,str) <- exportPGF opts fmt pgf] + +writePGF :: Options -> PGF -> IOE () +writePGF opts pgf = + if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF + where + writeNormalPGF = + do let outfile = outputPath opts (grammarName opts pgf <.> "pgf") + writing opts outfile $ encodeFile outfile pgf + + writeSplitPGF = + do let outfile = outputPath opts (grammarName opts pgf <.> "pgf") + writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf)) + --encodeFile_ outfile (putSplitAbs pgf) + forM_ (Map.toList (concretes pgf)) $ \cnc -> do + let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c") + writing opts outfile $ encodeFile outfile cnc + + +writeOutput :: Options -> FilePath-> String -> IOE () +writeOutput opts file str = writing opts path $ writeUTF8File path str + where path = outputPath opts file + +-- * Useful helper functions + +grammarName :: Options -> PGF -> String +grammarName opts pgf = grammarName' opts (showCId (abstractName pgf)) +grammarName' opts abs = fromMaybe abs (flag optName opts) + +outputFormats opts = [fmt | fmt <- flag optOutputFormats opts, fmt/=FmtByteCode] +outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts) + +outputPath opts file = maybe id () (flag optOutputDir opts) file + +writing opts path io = + putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO io diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs new file mode 100644 index 000000000..745f64f84 --- /dev/null +++ b/src/compiler/GF/Interactive.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE ScopedTypeVariables, CPP #-} +-- | GF interactive mode +module GF.Interactive (mainGFI,mainRunGFI,mainServerGFI) where +import Prelude hiding (putStrLn,print) +import qualified Prelude as P(putStrLn) +import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,emptyCommandEnv,interpretCommandLine) +--import GF.Command.Importing(importSource,importGrammar) +import GF.Command.Commands(flags,options) +import GF.Command.Abstract +import GF.Command.Parse(readCommandLine,pCommand) +import GF.Data.Operations (Err(..),chunks,err,raise) +import GF.Grammar hiding (Ident,isPrefixOf) +import GF.Grammar.Analyse +import GF.Grammar.Parser (runP, pExp) +import GF.Grammar.ShowTerm +import GF.Grammar.Lookup (allOpers,allOpersTo) +import GF.Compile.Rename(renameSourceTerm) +--import GF.Compile.Compute.Concrete (computeConcrete,checkPredefError) +import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues) +import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType) +import GF.Infra.Dependencies(depGraph) +import GF.Infra.CheckM +import GF.Infra.UseIO(ioErrorText) +import GF.Infra.SIO +import GF.Infra.Option +import qualified System.Console.Haskeline as Haskeline +--import GF.Text.Coding(decodeUnicode,encodeUnicode) + +--import GF.Compile.Coding(codeTerm) + +import PGF +import PGF.Internal(emptyPGF,abstract,funs,lookStartCat) + +import Data.Char +import Data.List(nub,isPrefixOf,isInfixOf,partition) +import qualified Data.Map as Map +--import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.UTF8 as UTF8(fromString) +import qualified Text.ParserCombinators.ReadP as RP +--import System.IO(utf8) +--import System.CPUTime(getCPUTime) +import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory) +import Control.Exception(SomeException,fromException,evaluate,try) +import Control.Monad +import GF.Text.Pretty (render) +import qualified GF.System.Signal as IO(runInterruptibly) +#ifdef SERVER_MODE +import GF.Server(server) +#endif +import GF.System.Console(changeConsoleEncoding) + +import GF.Infra.BuildInfo(buildInfo) +import Data.Version(showVersion) +import Paths_gf(version) + +mainRunGFI :: Options -> [FilePath] -> IO () +mainRunGFI opts files = shell (beQuiet opts) files + +beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) + +mainGFI :: Options -> [FilePath] -> IO () +mainGFI opts files = do + P.putStrLn welcome + shell opts files + +shell opts files = loop opts =<< runSIO (importInEnv emptyGFEnv opts files) + +#ifdef SERVER_MODE +mainServerGFI opts0 port files = + server port root (execute1 opts) + =<< runSIO (importInEnv emptyGFEnv opts files) + where + root = flag optDocumentRoot opts + opts = beQuiet opts0 +#else +mainServerGFI opts files = + error "GF has not been compiled with server mode support" +#endif + +-- | Read end execute commands until it is time to quit +loop :: Options -> GFEnv -> IO () +loop opts gfenv = maybe (return ()) (loop opts) =<< readAndExecute1 opts gfenv + +-- | Read and execute one command, returning Just an updated environment for +-- | the next command, or Nothing when it is time to quit +readAndExecute1 :: Options -> GFEnv -> IO (Maybe GFEnv) +readAndExecute1 opts gfenv = + runSIO . execute1 opts gfenv =<< readCommand opts gfenv + +-- | Read a command +readCommand :: Options -> GFEnv -> IO String +readCommand opts gfenv0 = + case flag optMode opts of + ModeRun -> tryGetLine + _ -> fetchCommand gfenv0 + +-- | Optionally show how much CPU time was used to run an IO action +optionallyShowCPUTime :: Options -> SIO a -> SIO a +optionallyShowCPUTime opts act + | not (verbAtLeast opts Normal) = act + | otherwise = do t0 <- getCPUTime + r <- act + t1 <- getCPUTime + let dt = t1-t0 + putStrLnFlush $ show (dt `div` 1000000000) ++ " msec" + return r + +{- +loopOptNewCPU opts gfenv' + | not (verbAtLeast opts Normal) = return gfenv' + | otherwise = do + cpu' <- getCPUTime + putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec") + return $ gfenv' {cputime = cpu'} +-} + +-- | Execute a given command, returning Just an updated environment for +-- | the next command, or Nothing when it is time to quit +execute1 :: Options -> GFEnv -> String -> SIO (Maybe GFEnv) +execute1 opts gfenv0 s0 = + interruptible $ optionallyShowCPUTime opts $ + case pwords s0 of + -- special commands, requiring source grammar in env + {-"eh":w:_ -> do + cs <- readFile w >>= return . map words . lines + gfenv' <- foldM (flip (process False benv)) gfenv cs + loopNewCPU gfenv' -} + "q" :_ -> quit + "!" :ws -> system_command ws + "cc":ws -> compute_concrete ws + "sd":ws -> show_deps ws + "so":ws -> show_operations ws + "ss":ws -> show_source ws + "dg":ws -> dependency_graph ws + "eh":ws -> eh ws + "i" :ws -> import_ ws + -- other special commands, working on GFEnv + "e" :_ -> empty + "dc":ws -> define_command ws + "dt":ws -> define_tree ws + "ph":_ -> print_history + "r" :_ -> reload_last + "se":ws -> set_encoding ws + -- ordinary commands, working on CommandEnv + _ -> do interpretCommandLine env s0 + continue gfenv + where +-- loopNewCPU = fmap Just . loopOptNewCPU opts + continue = return . Just + stop = return Nothing + env = commandenv gfenv0 + sgr = sourcegrammar gfenv0 + gfenv = gfenv0 {history = s0 : history gfenv0} + pwords s = case words s of + w:ws -> getCommandOp w :ws + ws -> ws + + interruptible act = + either (\e -> printException e >> return (Just gfenv)) return + =<< runInterruptibly act + + -- Special commands: + + quit = do when (verbAtLeast opts Normal) $ putStrLn "See you." + stop + + system_command ws = do restrictedSystem $ unwords ws ; continue gfenv + + compute_concrete ws = do + let + pOpts style q ("-table" :ws) = pOpts TermPrintTable q ws + pOpts style q ("-all" :ws) = pOpts TermPrintAll q ws + pOpts style q ("-list" :ws) = pOpts TermPrintList q ws + pOpts style q ("-one" :ws) = pOpts TermPrintOne q ws + pOpts style q ("-default":ws) = pOpts TermPrintDefault q ws + pOpts style q ("-unqual" :ws) = pOpts style Unqualified ws + pOpts style q ("-qual" :ws) = pOpts style Qualified ws + pOpts style q ws = (style,q,unwords ws) + + (style,q,s) = pOpts TermPrintDefault Qualified ws + {- + (new,ws') = case ws of + "-new":ws' -> (True,ws') + "-old":ws' -> (False,ws') + _ -> (flag optNewComp opts,ws) + -} + case runP pExp (UTF8.fromString s) of + Left (_,msg) -> putStrLn msg + Right t -> putStrLn . err id (showTerm sgr style q) + . checkComputeTerm sgr + $ {-codeTerm (decodeUnicode utf8 . BS.pack)-} t + continue gfenv + + show_deps ws = do + let (os,xs) = partition (isPrefixOf "-") ws + ops <- case xs of + _:_ -> do + let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs] + err error (return . nub . concat) $ mapM (constantDepsTerm sgr) ts + _ -> error "expected one or more qualified constants as argument" + let prTerm = showTerm sgr TermPrintDefault Qualified + let size = sizeConstant sgr + let printed + | elem "-size" os = + let sz = map size ops in + unlines $ ("total: " ++ show (sum sz)) : + [prTerm f ++ "\t" ++ show s | (f,s) <- zip ops sz] + | otherwise = unwords $ map prTerm ops + putStrLn $ printed + continue gfenv + + show_operations ws = + case greatestResource sgr of + Nothing -> putStrLn "no source grammar in scope; did you import with -retain?" >> continue gfenv + Just mo -> do + let (os,ts) = partition (isPrefixOf "-") ws + let greps = [drop 6 o | o <- os, take 6 o == "-grep="] + let isRaw = elem "-raw" os + ops <- case ts of + _:_ -> do + let Right t = runP pExp (UTF8.fromString (unwords ts)) + ty <- err error return $ checkComputeTerm sgr t + return $ allOpersTo sgr ty + _ -> return $ allOpers sgr + let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops] + let printer = if isRaw + then showTerm sgr TermPrintDefault Qualified + else (render . TC.ppType) + let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs] + mapM_ putStrLn [l | l <- printed, all (flip isInfixOf l) greps] + continue gfenv + + show_source ws = do + let (os,ts) = partition (isPrefixOf "-") ws + let strip = if elem "-strip" os then stripSourceGrammar else id + let mygr = strip $ case ts of + _:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (showIdent i) ts] + [] -> sgr + case 0 of + _ | elem "-detailedsize" os -> putStrLn (printSizesGrammar mygr) + _ | elem "-size" os -> do + let sz = sizesGrammar mygr + putStrLn $ unlines $ + ("total\t" ++ show (fst sz)): + [showIdent j ++ "\t" ++ show (fst k) | (j,k) <- snd sz] + _ | elem "-save" os -> mapM_ + (\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in + restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file)) + (modules mygr) + _ -> putStrLn $ render mygr + continue gfenv + + dependency_graph ws = + do let stop = case ws of + ('-':'o':'n':'l':'y':'=':fs):_ -> Just $ chunks ',' fs + _ -> Nothing + restricted $ writeFile "_gfdepgraph.dot" (depGraph stop sgr) + putStrLn "wrote graph in file _gfdepgraph.dot" + continue gfenv + + eh [w] = -- Ehhh? Reads commands from a file, but does not execute them + do cs <- restricted (readFile w) >>= return . map (interpretCommandLine env) . lines + continue gfenv + eh _ = do putStrLn "eh command not parsed" + continue gfenv + + import_ args = + do gfenv' <- case parseOptions args of + Ok (opts',files) -> do + curr_dir <- getCurrentDirectory + lib_dir <- getLibraryDirectory (addOptions opts opts') + importInEnv gfenv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files + Bad err -> do + putStrLn $ "Command parse error: " ++ err + return gfenv + continue gfenv' + + empty = continue $ gfenv { + commandenv=emptyCommandEnv, sourcegrammar = emptySourceGrammar + } + + define_command (f:ws) = + case readCommandLine (unwords ws) of + Just comm -> continue $ gfenv { + commandenv = env { + commandmacros = Map.insert f comm (commandmacros env) + } + } + _ -> dc_not_parsed + define_command _ = dc_not_parsed + + dc_not_parsed = putStrLn "command definition not parsed" >> continue gfenv + + define_tree (f:ws) = + case readExpr (unwords ws) of + Just exp -> continue $ gfenv { + commandenv = env { + expmacros = Map.insert f exp (expmacros env) + } + } + _ -> dt_not_parsed + define_tree _ = dt_not_parsed + + dt_not_parsed = putStrLn "value definition not parsed" >> continue gfenv + + print_history = mapM_ putStrLn (reverse (history gfenv0))>> continue gfenv + + reload_last = do + let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]] + case imports of + (s,ws):_ -> do + putStrLn $ "repeating latest import: " ++ s + import_ ws + _ -> do + putStrLn $ "no import in history" + continue gfenv + + set_encoding [c] = + do let cod = renameEncoding c + restricted $ changeConsoleEncoding cod + continue gfenv + set_encoding _ = putStrLn "se command not parsed" >> continue gfenv + + +printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e) + +checkComputeTerm sgr t = do + mo <- maybe (raise "no source grammar in scope") return $ greatestResource sgr + ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t + inferLType sgr [] t + t1 <- {-if new + then-} return (CN.normalForm (CN.resourceValues sgr) (L NoLoc identW) t) + {-else computeConcrete sgr t-} + checkPredefError t1 + +fetchCommand :: GFEnv -> IO String +fetchCommand gfenv = do + path <- getAppUserDataDirectory "gf_history" + let settings = + Haskeline.Settings { + Haskeline.complete = wordCompletion gfenv, + Haskeline.historyFile = Just path, + Haskeline.autoAddHistory = True + } + res <- IO.runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt (commandenv gfenv))) + case res of + Left _ -> return "" + Right Nothing -> return "q" + Right (Just s) -> return s + +importInEnv :: GFEnv -> Options -> [FilePath] -> SIO GFEnv +importInEnv gfenv opts files + | flag optRetainResource opts = + do src <- importSource (sourcegrammar gfenv) opts files + return $ gfenv {sourcegrammar = src} + | otherwise = + do let opts' = addOptions (setOptimization OptCSE False) opts + pgf0 = multigrammar (commandenv gfenv) + pgf1 <- importGrammar pgf0 opts' files + if (verbAtLeast opts Normal) + then putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf1) + else return () + return $ gfenv { commandenv = mkCommandEnv pgf1 } + +tryGetLine = do + res <- try getLine + case res of + Left (e :: SomeException) -> return "q" + Right l -> return l + +welcome = unlines [ + " ", + " * * * ", + " * * ", + " * * ", + " * ", + " * ", + " * * * * * * * ", + " * * * ", + " * * * * * * ", + " * * * ", + " * * * ", + " ", + "This is GF version "++showVersion version++". ", + buildInfo, + "License: see help -license. ", + "Bug reports: http://code.google.com/p/grammatical-framework/issues/list" + ] + +prompt env + | abs == wildCId = "> " + | otherwise = showCId abs ++ "> " + where + abs = abstractName (multigrammar env) + +data GFEnv = GFEnv { + sourcegrammar :: SourceGrammar, -- gfo grammar -retain + commandenv :: CommandEnv, + history :: [String] + } + +emptyGFEnv :: GFEnv +emptyGFEnv = + GFEnv emptySourceGrammar (mkCommandEnv emptyPGF) [] {-0-} + +wordCompletion gfenv (left,right) = do + case wc_type (reverse left) of + CmplCmd pref + -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] + CmplStr (Just (Command _ opts _)) s0 + -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optType opts))) + case mb_state0 of + Right state0 -> let (rprefix,rs) = break isSpace (reverse s0) + s = reverse rs + prefix = reverse rprefix + ws = words s + in case loop state0 ws of + Nothing -> ret 0 [] + Just state -> let compls = getCompletions state prefix + in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls)) + Left (_ :: SomeException) -> ret 0 [] + CmplOpt (Just (Command n _ _)) pref + -> case Map.lookup n (commands cmdEnv) of + Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags inf, isPrefixOf pref flg] + opt_compls = [Haskeline.Completion ('-':opt) ('-':opt) True | (opt,_) <- options inf, isPrefixOf pref opt] + ret (length pref+1) + (flg_compls++opt_compls) + Nothing -> ret (length pref) [] + CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i + -> Haskeline.completeFilename (left,right) + CmplIdent _ pref + -> do mb_abs <- try (evaluate (abstract pgf)) + case mb_abs of + Right abs -> ret (length pref) [Haskeline.simpleCompletion name | cid <- Map.keys (funs abs), let name = showCId cid, isPrefixOf pref name] + Left (_ :: SomeException) -> ret (length pref) [] + _ -> ret 0 [] + where + pgf = multigrammar cmdEnv + cmdEnv = commandenv gfenv + optLang opts = valCIdOpts "lang" (head (languages pgf)) opts + optType opts = + let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts + in case readType str of + Just ty -> ty + Nothing -> error ("Can't parse '"++str++"' as type") + + loop ps [] = Just ps + loop ps (t:ts) = case nextState ps (simpleParseInput t) of + Left es -> Nothing + Right ps -> loop ps ts + + ret len xs = return (drop len left,xs) + + +data CompletionType + = CmplCmd Ident + | CmplStr (Maybe Command) String + | CmplOpt (Maybe Command) Ident + | CmplIdent (Maybe Command) Ident + deriving Show + +wc_type :: String -> CompletionType +wc_type = cmd_name + where + cmd_name cs = + let cs1 = dropWhile isSpace cs + in go cs1 cs1 + where + go x [] = CmplCmd x + go x (c:cs) + | isIdent c = go x cs + | otherwise = cmd x cs + + cmd x [] = ret CmplIdent x "" 0 + cmd _ ('|':cs) = cmd_name cs + cmd _ (';':cs) = cmd_name cs + cmd x ('"':cs) = str x cs cs + cmd x ('-':cs) = option x cs cs + cmd x (c :cs) + | isIdent c = ident x (c:cs) cs + | otherwise = cmd x cs + + option x y [] = ret CmplOpt x y 1 + option x y ('=':cs) = optValue x y cs + option x y (c :cs) + | isIdent c = option x y cs + | otherwise = cmd x cs + + optValue x y ('"':cs) = str x y cs + optValue x y cs = cmd x cs + + ident x y [] = ret CmplIdent x y 0 + ident x y (c:cs) + | isIdent c = ident x y cs + | otherwise = cmd x cs + + str x y [] = ret CmplStr x y 1 + str x y ('\"':cs) = cmd x cs + str x y ('\\':c:cs) = str x y cs + str x y (c:cs) = str x y cs + + ret f x y d = f cmd y + where + x1 = take (length x - length y - d) x + x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1 + + cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of + [x] -> Just x + _ -> Nothing + + isIdent c = c == '_' || c == '\'' || isAlphaNum c diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs new file mode 100644 index 000000000..0fc7f0388 --- /dev/null +++ b/src/compiler/GF/Server.hs @@ -0,0 +1,494 @@ +-- | GF server mode +{-# LANGUAGE CPP #-} +module GF.Server(server) where +import Data.List(partition,stripPrefix,isInfixOf) +import qualified Data.Map as M +import Control.Monad(when) +import Control.Monad.State(StateT(..),get,gets,put) +import Control.Monad.Error(ErrorT(..),Error(..)) +import System.Random(randomRIO) +--import System.IO(stderr,hPutStrLn) +import GF.System.Catch(try) +import Control.Exception(bracket_) +import System.IO.Error(isAlreadyExistsError) +import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory, + setCurrentDirectory,getCurrentDirectory, + getDirectoryContents,removeFile,removeDirectory, + getModificationTime) +import Data.Time (getCurrentTime,formatTime) +import System.Locale(defaultTimeLocale,rfc822DateFormat) +import System.FilePath(dropExtension,takeExtension,takeFileName,takeDirectory, + (),makeRelative) +#ifndef mingw32_HOST_OS +import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink, + createSymbolicLink) +#endif +import GF.Infra.Concurrency(newMVar,modifyMVar,newLog) +import Network.URI(URI(..)) +import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache) +--import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi +import Network.CGI(handleErrors,liftIO) +import CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile +import Text.JSON(encode,showJSON,makeObj) +--import System.IO.Silently(hCapture) +import System.Process(readProcessWithExitCode) +import System.Exit(ExitCode(..)) +import Codec.Binary.UTF8.String(decodeString,encodeString) +import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn) +import GF.Infra.SIO(captureSIO) +import qualified PGFService as PS +import qualified ExampleService as ES +import Data.Version(showVersion) +import Paths_gf(getDataDir,version) +import GF.Infra.BuildInfo (buildInfo) +import SimpleEditor.Convert(parseModule) +import RunHTTP(cgiHandler) +import URLEncoding(decodeQuery) + +--logFile :: FilePath +--logFile = "pgf-error.log" + +debug s = logPutStrLn s + +-- | Combined FastCGI and HTTP server +server port optroot execute1 state0 = + do --stderrToFile logFile + state <- newMVar M.empty + cache <- PS.newPGFCache + datadir <- getDataDir + let root = maybe (datadir"www") id optroot +-- debug $ "document root="++root + setDir root +-- FCGI.acceptLoop forkIO (handle_fcgi execute1 state0 state cache) + -- if acceptLoop returns, then GF was not invoked as a FastCGI script + http_server execute1 state0 state cache root + where + -- | HTTP server + http_server execute1 state0 state cache root = + do logLn <- newLog ePutStrLn -- to avoid intertwined log messages + logLn gf_version + logLn $ "Document root = "++root + logLn $ "Starting HTTP server, open http://localhost:" + ++show port++"/ in your web browser." + initServer port (handle logLn root state0 cache execute1 state) + +gf_version = "This is GF version "++showVersion version++".\n"++buildInfo + +{- +-- | FastCGI request handler +handle_fcgi execute1 state0 stateM cache = + do Just method <- FCGI.getRequestMethod + debug $ "request method="++method + Just path <- FCGI.getPathInfo +-- debug $ "path info="++path + query <- maybe (return "") return =<< FCGI.getQueryString +-- debug $ "query string="++query + let uri = URI "" Nothing path query "" + headers <- fmap (mapFst show) FCGI.getAllRequestHeaders + body <- fmap BS.unpack FCGI.fGetContents + let req = Request method uri headers body +-- debug (show req) + (output,resp) <- liftIO $ hCapture [stdout] $ modifyMVar stateM $ handle state0 cache execute1 req + let Response code headers body = resp +-- debug output + debug $ " "++show code++" "++show headers + FCGI.setResponseStatus code + mapM_ (uncurry (FCGI.setResponseHeader . toHeader)) headers + let pbody = BS.pack body + n = BS.length pbody + FCGI.fPut pbody + debug $ "done "++show n +-} + +-- * Request handler +-- | Handler monad +type HM s a = StateT (Q,s) (ErrorT Response IO) a +run :: HM s Response -> (Q,s) -> IO (s,Response) +run m s = either bad ok =<< runErrorT (runStateT m s) + where + bad resp = return (snd s,resp) + ok (resp,(qs,state)) = return (state,resp) + +get_qs :: HM s Q +get_qs = gets fst +get_state :: HM s s +get_state = gets snd +put_qs qs = do state <- get_state; put (qs,state) +put_state state = do qs <- get_qs; put (qs,state) + +err :: Response -> HM s a +err e = StateT $ \ s -> ErrorT $ return $ Left e + +hmbracket_ :: IO () -> IO () -> HM s a -> HM s a +hmbracket_ pre post m = + do s <- get + e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s + case e of + Left resp -> err resp + Right (a,s) -> do put s;return a + +-- | HTTP request handler +handle logLn documentroot state0 cache execute1 stateVar + rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) = + addDate $ + case method of + "POST" -> normal_request (utf8inputs body) + "GET" -> normal_request (utf8inputs q) + _ -> return (resp501 $ "method "++method) + where + logPutStrLn msg = liftIO $ logLn msg + debug msg = logPutStrLn msg + + addDate m = + do t <- getCurrentTime + r <- m + let fmt = formatTime defaultTimeLocale rfc822DateFormat t + return r{resHeaders=("Date",fmt):resHeaders r} + + normal_request qs = + do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs) + let stateful m = modifyMVar stateVar $ \ s -> run m (qs,s) + -- stateful ensures mutual exclusion, so you can use/change the cwd + case upath of + "/new" -> stateful $ new + "/gfshell" -> stateful $ inDir command + "/cloud" -> stateful $ inDir cloud +-- "/stop" -> +-- "/start" -> + "/parse" -> parse (decoded qs) + "/version" -> do (c1,c2) <- PS.listPGFCache cache + let rel = map (makeRelative documentroot) + return $ ok200 (unlines (gf_version:"":rel c1++"":rel c2)) + "/flush" -> do PS.flushPGFCache cache; return (ok200 "flushed") + '/':rpath -> + -- This code runs without mutual exclusion, so it must *not* + -- use/change the cwd. Access files by absolute paths only. + case (takeDirectory path,takeFileName path,takeExtension path) of + (_ ,_ ,".pgf") -> do --debug $ "PGF service: "++path + wrapCGI $ PS.cgiMain' cache path + (dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs) + (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir (fst cache) + _ -> serveStaticFile rpath path + where path = translatePath rpath + _ -> return $ resp400 upath + + root = documentroot + + translatePath rpath = rootrpath -- hmm, check for ".." + + wrapCGI cgi = cgiHandler root (handleErrors . handleCGIErrors $ cgi) rq + + look field = + do qs <- get_qs + case partition ((==field).fst) qs of + ((_,(value,_)):qs1,qs2) -> do put_qs (qs1++qs2) + return value + _ -> err $ resp400 $ "no "++field++" in request" + + inDir ok = cd =<< look "dir" + where + cd ('/':dir@('t':'m':'p':_)) = + do cwd <- getCurrentDirectory + b <- doesDirectoryExist dir + case b of + False -> do b <- liftIO $ try $ readFile dir -- poor man's symbolic links + case b of + Left _ -> err $ resp404 dir + Right dir' -> cd dir' + True -> do --logPutStrLn $ "cd "++dir + hmInDir dir (ok dir) + cd dir = err $ resp400 $ "unacceptable directory "++dir + + -- First ensure that only one thread that depends on the cwd is running! + hmInDir dir = hmbracket_ (setDir dir) (setDir documentroot) + + new = fmap ok200 $ liftIO $ newDirectory + + command dir = + do cmd <- look "command" + state <- get_state + let st = maybe state0 id $ M.lookup dir state + (output,st') <- liftIO $ captureSIO $ execute1 st cmd + let state' = maybe state (flip (M.insert dir) state) st' + put_state state' + return $ ok200 output + + parse qs = return $ json200 (makeObj(map parseModule qs)) + + cloud dir = + do cmd <- look "command" + case cmd of + "make" -> make id dir . raw =<< get_qs + "remake" -> make skip_empty dir . raw =<< get_qs + "upload" -> upload id . raw =<< get_qs + "ls" -> jsonList . maybe ".json" fst . lookup "ext" =<< get_qs + "ls-l" -> jsonListLong . maybe ".json" fst . lookup "ext" =<< get_qs + "rm" -> rm =<< look_file + "download" -> download =<< look_file + "link_directories" -> link_directories dir =<< look "newdir" + _ -> err $ resp400 $ "cloud command "++cmd + + look_file = check =<< look "file" + where + check path = + if ok_access path + then return path + else err $ resp400 $ "unacceptable path "++path + + make skip dir args = + do let (flags,files) = partition ((=="-").take 1.fst) args + _ <- upload skip files + let args = "-s":"-make":map flag flags++map fst files + flag (n,"") = n + flag (n,v) = n++"="++v + cmd = unwords ("gf":args) + logPutStrLn cmd + out@(ecode,_,_) <- liftIO $ readProcessWithExitCode "gf" args "" + logPutStrLn $ show ecode + cwd <- getCurrentDirectory + return $ json200 (jsonresult cwd ('/':dir++"/") cmd out files) + + upload skip files = + if null badpaths + then do liftIO $ mapM_ (uncurry updateFile) (skip okfiles) + return resp204 + else err $ resp404 $ "unacceptable path(s) "++unwords badpaths + where + (okfiles,badpaths) = apSnd (map fst) $ partition (ok_access.fst) files + + skip_empty = filter (not.null.snd) + + jsonList = jsonList' return + jsonListLong = jsonList' (mapM addTime) + jsonList' details ext = fmap (json200) (details =<< ls_ext "." ext) + + addTime path = + do t <- getModificationTime path + return $ makeObj ["path".=path,"time".=format t] + where + format = formatTime defaultTimeLocale rfc822DateFormat + + rm path | takeExtension path `elem` ok_to_delete = + do b <- doesFileExist path + if b + then do removeFile path + return $ ok200 "" + else err $ resp404 path + rm path = err $ resp400 $ "unacceptable extension "++path + + download path = liftIO $ serveStaticFile' path + + link_directories olddir newdir@('/':'t':'m':'p':'/':_) | old/=new = + hmInDir ".." $ liftIO $ + do logPutStrLn =<< getCurrentDirectory + logPutStrLn $ "link_dirs new="++new++", old="++old +#ifdef mingw32_HOST_OS + isDir <- doesDirectoryExist old + if isDir then removeDir old else removeFile old + writeFile old new -- poor man's symbolic links +#else + isLink <- isSymbolicLink `fmap` getSymbolicLinkStatus old + logPutStrLn $ "old is link: "++show isLink + if isLink then removeLink old else removeDir old + createSymbolicLink new old +#endif + return $ ok200 "" + where + old = takeFileName olddir + new = takeFileName newdir + link_directories olddir newdir = + err $ resp400 $ "unacceptable directories "++olddir++" "++newdir + + grammarList dir qs = + do pgfs <- ls_ext dir ".pgf" + return $ jsonp qs pgfs + + ls_ext dir ext = + do paths <- getDirectoryContents dir + return [path | path<-paths, takeExtension path==ext] + +-- * Dynamic content + +jsonresult cwd dir cmd (ecode,stdout,stderr) files = + makeObj [ + "errorcode" .= if ecode==ExitSuccess then "OK" else "Error", + "command" .= cmd, + "output" .= unlines [rel stderr,rel stdout], + "minibar_url" .= "/minibar/minibar.html?"++dir++pgf] + where + pgf = case files of + (abstract,_):_ -> "%20"++dropExtension abstract++".pgf" + _ -> "" + + rel = unlines . map relative . lines + + -- remove absolute file paths from error messages: + relative s = case stripPrefix cwd s of + Just ('/':rest) -> rest + _ -> s + +-- * Static content + +serveStaticFile rpath path = + do --logPutStrLn $ "Serving static file "++path + b <- doesDirectoryExist path + if b + then if rpath `elem` ["","."] || last path=='/' + then serveStaticFile' (path "index.html") + else return (resp301 ('/':rpath++"/")) + else serveStaticFile' path + +serveStaticFile' path = + do let ext = takeExtension path + (t,rdFile) = contentTypeFromExt ext + if ext `elem` [".cgi",".fcgi",".sh",".php"] + then return $ resp400 $ "Unsupported file type: "++ext + else do b <- doesFileExist path + if b then fmap (ok200' (ct t "")) $ rdFile path + else do cwd <- getCurrentDirectory + logPutStrLn $ "Not found: "++path++" cwd="++cwd + return (resp404 path) + +-- * Logging +logPutStrLn s = ePutStrLn s + +-- * JSONP output + +jsonp qs = maybe json200 apply (lookup "jsonp" qs) + where + apply f = jsonp200' $ \ json -> f++"("++json++")" + +-- * Standard HTTP responses +ok200 = Response 200 [plainUTF8,noCache,xo] . encodeString +ok200' t = Response 200 [t,xo] +json200 x = json200' id x +json200' f = ok200' jsonUTF8 . encodeString . f . encode +jsonp200' f = ok200' jsonpUTF8 . encodeString . f . encode +html200 = ok200' htmlUTF8 . encodeString +resp204 = Response 204 [xo] "" -- no content +resp301 url = Response 301 [plain,xo,location url] $ + "Moved permanently to "++url +resp400 msg = Response 400 [plain,xo] $ "Bad request: "++msg++"\n" +resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n" +resp500 msg = Response 500 [plain,xo] $ "Internal error: "++msg++"\n" +resp501 msg = Response 501 [plain,xo] $ "Not implemented: "++msg++"\n" + +instance Error Response where + noMsg = resp500 "no message" + strMsg = resp500 + +-- * Content types +plain = ct "text/plain" "" +plainUTF8 = ct "text/plain" csutf8 +jsonUTF8 = ct "application/json" csutf8 -- http://www.ietf.org/rfc/rfc4627.txt +jsonpUTF8 = ct "application/javascript" csutf8 +htmlUTF8 = ct "text/html" csutf8 + +ct t cs = ("Content-Type",t++cs) +csutf8 = "; charset=UTF-8" +xo = ("Access-Control-Allow-Origin","*") -- Allow cross origin requests + -- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS +location url = ("Location",url) + +contentTypeFromExt ext = + case ext of + ".html" -> text "html" + ".htm" -> text "html" + ".xml" -> text "xml" + ".txt" -> text "plain" + ".css" -> text "css" + ".js" -> text "javascript" + ".png" -> bin "image/png" + ".jpg" -> bin "image/jpg" + _ -> bin "application/octet-stream" + where + text subtype = ("text/"++subtype++"; charset=UTF-8", + fmap encodeString . readFile) + bin t = (t,readBinaryFile) + +-- * IO utilities +updateFile path new = + do old <- try $ readBinaryFile path +-- let new = encodeString new0 + when (Right new/=old) $ do logPutStrLn $ "Updating "++path + seq (either (const 0) length old) $ + writeBinaryFile path new + +-- | Check that a path is not outside the current directory +ok_access path = + case path of + '/':_ -> False + '.':'.':'/':_ -> False + _ -> not ("/../" `isInfixOf` path) + +-- | Only delete files with these extensions +ok_to_delete = [".json",".gfstdoc",".gfo",".gf",".pgf"] + +newDirectory = + do debug "newDirectory" + loop 10 + where + loop 0 = fail "Failed to create a new directory" + loop n = maybe (loop (n-1)) return =<< once + + once = + do k <- randomRIO (1,maxBound::Int) + let path = "tmp/gfse."++show k + b <- try $ createDirectory path + case b of + Left err -> do debug (show err) ; + if isAlreadyExistsError err + then return Nothing + else ioError err + Right _ -> return (Just ('/':path)) + +-- | Remove a directory and the files in it, but not recursively +removeDir dir = + do files <- filter (`notElem` [".",".."]) `fmap` getDirectoryContents dir + mapM (removeFile . (dir)) files + removeDirectory dir + +setDir path = + do --logPutStrLn $ "cd "++show path + setCurrentDirectory path + +{- +-- * direct-fastcgi deficiency workaround + +--toHeader = FCGI.toHeader -- not exported, unfortuntately + +toHeader "Content-Type" = FCGI.HttpContentType -- to avoid duplicate headers +toHeader s = FCGI.HttpExtensionHeader s -- cheating a bit +-} + +-- * misc utils + +--utf8inputs = mapBoth decodeString . inputs +type Q = [(String,(String,String))] +utf8inputs :: String -> Q +utf8inputs q = [(decodeString k,(decodeString v,v))|(k,v)<-inputs q] +decoded = mapSnd fst +raw = mapSnd snd + +inputs ('?':q) = decodeQuery q +inputs q = decodeQuery q + +{- +-- Stay clear of queryToArgument, which uses unEscapeString, which had +-- backward incompatible changes in network-2.4.1.1, see +-- https://github.com/haskell/network/commit/f2168b1f8978b4ad9c504e545755f0795ac869ce +inputs = queryToArguments . fixplus + where + fixplus = concatMap decode + decode '+' = "%20" -- httpd-shed bug workaround + decode c = [c] +-} + +mapFst f xys = [(f x,y)|(x,y)<-xys] +mapSnd f xys = [(x,f y)|(x,y)<-xys] +mapBoth = map . apBoth +apBoth f (x,y) = (f x,f y) +apSnd f (x,y) = (x,f y) + +infix 1 .= +n .= v = (n,showJSON v) diff --git a/src/compiler/GFC.hs b/src/compiler/GFC.hs deleted file mode 100644 index 4b88bd998..000000000 --- a/src/compiler/GFC.hs +++ /dev/null @@ -1,144 +0,0 @@ -module GFC (mainGFC, writePGF) where --- module Main where - -import PGF -import PGF.Internal(concretes,optimizePGF,unionPGF) -import PGF.Internal(putSplitAbs,encodeFile,runPut) -import GF.Compile as S(batchCompile,link,srcAbsName) -import qualified GF.CompileInParallel as P(batchCompile) -import GF.Compile.Export -import GF.Compile.CFGtoPGF -import GF.Compile.GetGrammar -import GF.Grammar.CFG - -import GF.Infra.Ident(showIdent) -import GF.Infra.UseIO -import GF.Infra.Option -import GF.Data.ErrM -import GF.System.Directory - -import Data.Maybe -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.ByteString.Lazy as BSL -import System.FilePath -import Control.Monad(unless,forM_) - -mainGFC :: Options -> [FilePath] -> IO () -mainGFC opts fs = do - r <- appIOE (case () of - _ | null fs -> fail $ "No input files." - _ | all (extensionIs ".cf") fs -> compileCFFiles opts fs - _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs -> compileSourceFiles opts fs - _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs - _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs) - case r of - Ok x -> return x - Bad msg -> die $ if flag optVerbosity opts == Normal - then ('\n':msg) - else msg - where - extensionIs ext = (== ext) . takeExtension - -compileSourceFiles :: Options -> [FilePath] -> IOE () -compileSourceFiles opts fs = - do (t_src,~cnc_grs@(~(cnc,gr):_)) <- batchCompile opts fs - unless (flag optStopAfterPhase opts == Compile) $ - do let abs = showIdent (srcAbsName gr cnc) - pgfFile = outputPath opts (grammarName' opts abs<.>"pgf") - t_pgf <- if outputJustPGF opts - then maybeIO $ getModificationTime pgfFile - else return Nothing - if t_pgf >= Just t_src - then putIfVerb opts $ pgfFile ++ " is up-to-date." - else do pgfs <- mapM (link opts) - [(cnc,t_src,gr)|(cnc,gr)<-cnc_grs] - let pgf = foldl1 unionPGF pgfs - writePGF opts pgf - writeOutputs opts pgf - where - batchCompile = maybe batchCompile' P.batchCompile (flag optJobs opts) - batchCompile' opts fs = do (cnc,t,gr) <- S.batchCompile opts fs - return (t,[(cnc,gr)]) - -compileCFFiles :: Options -> [FilePath] -> IOE () -compileCFFiles opts fs = do - rules <- fmap concat $ mapM (getCFRules opts) fs - startCat <- case rules of - (CFRule cat _ _ : _) -> return cat - _ -> fail "empty CFG" - let pgf = cf2pgf (last fs) (uniqueFuns (mkCFG startCat Set.empty rules)) - let cnc = justModuleName (last fs) - unless (flag optStopAfterPhase opts == Compile) $ - do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) - let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf - writePGF opts pgf' - writeOutputs opts pgf' - -unionPGFFiles :: Options -> [FilePath] -> IOE () -unionPGFFiles opts fs = - if outputJustPGF opts - then maybe doIt checkFirst (flag optName opts) - else doIt - where - checkFirst name = - do let pgfFile = outputPath opts (name <.> "pgf") - sourceTime <- maximum `fmap` mapM getModificationTime fs - targetTime <- maybeIO $ getModificationTime pgfFile - if targetTime >= Just sourceTime - then putIfVerb opts $ pgfFile ++ " is up-to-date." - else doIt - - doIt = - do pgfs <- mapM readPGFVerbose fs - let pgf0 = foldl1 unionPGF pgfs - pgf = if flag optOptimizePGF opts then optimizePGF pgf0 else pgf0 - pgfFile = outputPath opts (grammarName opts pgf <.> "pgf") - if pgfFile `elem` fs - then putStrLnE $ "Refusing to overwrite " ++ pgfFile - else writePGF opts pgf - writeOutputs opts pgf - - readPGFVerbose f = - putPointE Normal opts ("Reading " ++ f ++ "...") $ liftIO $ readPGF f - -writeOutputs :: Options -> PGF -> IOE () -writeOutputs opts pgf = do - sequence_ [writeOutput opts name str - | fmt <- outputFormats opts, - (name,str) <- exportPGF opts fmt pgf] - -writePGF :: Options -> PGF -> IOE () -writePGF opts pgf = - if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF - where - writeNormalPGF = - do let outfile = outputPath opts (grammarName opts pgf <.> "pgf") - writing opts outfile $ encodeFile outfile pgf - - writeSplitPGF = - do let outfile = outputPath opts (grammarName opts pgf <.> "pgf") - writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf)) - --encodeFile_ outfile (putSplitAbs pgf) - forM_ (Map.toList (concretes pgf)) $ \cnc -> do - let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c") - writing opts outfile $ encodeFile outfile cnc - - -writeOutput :: Options -> FilePath-> String -> IOE () -writeOutput opts file str = writing opts path $ writeUTF8File path str - where path = outputPath opts file - --- * Useful helper functions - -grammarName :: Options -> PGF -> String -grammarName opts pgf = grammarName' opts (showCId (abstractName pgf)) -grammarName' opts abs = fromMaybe abs (flag optName opts) - -outputFormats opts = [fmt | fmt <- flag optOutputFormats opts, fmt/=FmtByteCode] -outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts) - -outputPath opts file = maybe id () (flag optOutputDir opts) file - -writing opts path io = - putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO io diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs deleted file mode 100644 index 44f978cb3..000000000 --- a/src/compiler/GFI.hs +++ /dev/null @@ -1,511 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} --- | GF interactive mode -module GFI (mainGFI,mainRunGFI,mainServerGFI) where -import Prelude hiding (putStrLn,print) -import qualified Prelude as P(putStrLn) -import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,emptyCommandEnv,interpretCommandLine) ---import GF.Command.Importing(importSource,importGrammar) -import GF.Command.Commands(flags,options) -import GF.Command.Abstract -import GF.Command.Parse(readCommandLine,pCommand) -import GF.Data.Operations (Err(..),chunks,err,raise) -import GF.Grammar hiding (Ident,isPrefixOf) -import GF.Grammar.Analyse -import GF.Grammar.Parser (runP, pExp) -import GF.Grammar.ShowTerm -import GF.Grammar.Lookup (allOpers,allOpersTo) -import GF.Compile.Rename(renameSourceTerm) ---import GF.Compile.Compute.Concrete (computeConcrete,checkPredefError) -import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues) -import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType) -import GF.Infra.Dependencies(depGraph) -import GF.Infra.CheckM -import GF.Infra.UseIO(ioErrorText) -import GF.Infra.SIO -import GF.Infra.Option -import qualified System.Console.Haskeline as Haskeline ---import GF.Text.Coding(decodeUnicode,encodeUnicode) - ---import GF.Compile.Coding(codeTerm) - -import PGF -import PGF.Internal(emptyPGF,abstract,funs,lookStartCat) - -import Data.Char -import Data.List(nub,isPrefixOf,isInfixOf,partition) -import qualified Data.Map as Map ---import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.UTF8 as UTF8(fromString) -import qualified Text.ParserCombinators.ReadP as RP ---import System.IO(utf8) ---import System.CPUTime(getCPUTime) -import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory) -import Control.Exception(SomeException,fromException,evaluate,try) -import Control.Monad -import GF.Text.Pretty (render) -import qualified GF.System.Signal as IO(runInterruptibly) -#ifdef SERVER_MODE -import GFServer(server) -#endif -import GF.System.Console(changeConsoleEncoding) - -import GF.Infra.BuildInfo(buildInfo) -import Data.Version(showVersion) -import Paths_gf(version) - -mainRunGFI :: Options -> [FilePath] -> IO () -mainRunGFI opts files = shell (beQuiet opts) files - -beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) - -mainGFI :: Options -> [FilePath] -> IO () -mainGFI opts files = do - P.putStrLn welcome - shell opts files - -shell opts files = loop opts =<< runSIO (importInEnv emptyGFEnv opts files) - -#ifdef SERVER_MODE -mainServerGFI opts0 port files = - server port root (execute1 opts) - =<< runSIO (importInEnv emptyGFEnv opts files) - where - root = flag optDocumentRoot opts - opts = beQuiet opts0 -#else -mainServerGFI opts files = - error "GF has not been compiled with server mode support" -#endif - --- | Read end execute commands until it is time to quit -loop :: Options -> GFEnv -> IO () -loop opts gfenv = maybe (return ()) (loop opts) =<< readAndExecute1 opts gfenv - --- | Read and execute one command, returning Just an updated environment for --- | the next command, or Nothing when it is time to quit -readAndExecute1 :: Options -> GFEnv -> IO (Maybe GFEnv) -readAndExecute1 opts gfenv = - runSIO . execute1 opts gfenv =<< readCommand opts gfenv - --- | Read a command -readCommand :: Options -> GFEnv -> IO String -readCommand opts gfenv0 = - case flag optMode opts of - ModeRun -> tryGetLine - _ -> fetchCommand gfenv0 - --- | Optionally show how much CPU time was used to run an IO action -optionallyShowCPUTime :: Options -> SIO a -> SIO a -optionallyShowCPUTime opts act - | not (verbAtLeast opts Normal) = act - | otherwise = do t0 <- getCPUTime - r <- act - t1 <- getCPUTime - let dt = t1-t0 - putStrLnFlush $ show (dt `div` 1000000000) ++ " msec" - return r - -{- -loopOptNewCPU opts gfenv' - | not (verbAtLeast opts Normal) = return gfenv' - | otherwise = do - cpu' <- getCPUTime - putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec") - return $ gfenv' {cputime = cpu'} --} - --- | Execute a given command, returning Just an updated environment for --- | the next command, or Nothing when it is time to quit -execute1 :: Options -> GFEnv -> String -> SIO (Maybe GFEnv) -execute1 opts gfenv0 s0 = - interruptible $ optionallyShowCPUTime opts $ - case pwords s0 of - -- special commands, requiring source grammar in env - {-"eh":w:_ -> do - cs <- readFile w >>= return . map words . lines - gfenv' <- foldM (flip (process False benv)) gfenv cs - loopNewCPU gfenv' -} - "q" :_ -> quit - "!" :ws -> system_command ws - "cc":ws -> compute_concrete ws - "sd":ws -> show_deps ws - "so":ws -> show_operations ws - "ss":ws -> show_source ws - "dg":ws -> dependency_graph ws - "eh":ws -> eh ws - "i" :ws -> import_ ws - -- other special commands, working on GFEnv - "e" :_ -> empty - "dc":ws -> define_command ws - "dt":ws -> define_tree ws - "ph":_ -> print_history - "r" :_ -> reload_last - "se":ws -> set_encoding ws - -- ordinary commands, working on CommandEnv - _ -> do interpretCommandLine env s0 - continue gfenv - where --- loopNewCPU = fmap Just . loopOptNewCPU opts - continue = return . Just - stop = return Nothing - env = commandenv gfenv0 - sgr = sourcegrammar gfenv0 - gfenv = gfenv0 {history = s0 : history gfenv0} - pwords s = case words s of - w:ws -> getCommandOp w :ws - ws -> ws - - interruptible act = - either (\e -> printException e >> return (Just gfenv)) return - =<< runInterruptibly act - - -- Special commands: - - quit = do when (verbAtLeast opts Normal) $ putStrLn "See you." - stop - - system_command ws = do restrictedSystem $ unwords ws ; continue gfenv - - compute_concrete ws = do - let - pOpts style q ("-table" :ws) = pOpts TermPrintTable q ws - pOpts style q ("-all" :ws) = pOpts TermPrintAll q ws - pOpts style q ("-list" :ws) = pOpts TermPrintList q ws - pOpts style q ("-one" :ws) = pOpts TermPrintOne q ws - pOpts style q ("-default":ws) = pOpts TermPrintDefault q ws - pOpts style q ("-unqual" :ws) = pOpts style Unqualified ws - pOpts style q ("-qual" :ws) = pOpts style Qualified ws - pOpts style q ws = (style,q,unwords ws) - - (style,q,s) = pOpts TermPrintDefault Qualified ws - {- - (new,ws') = case ws of - "-new":ws' -> (True,ws') - "-old":ws' -> (False,ws') - _ -> (flag optNewComp opts,ws) - -} - case runP pExp (UTF8.fromString s) of - Left (_,msg) -> putStrLn msg - Right t -> putStrLn . err id (showTerm sgr style q) - . checkComputeTerm sgr - $ {-codeTerm (decodeUnicode utf8 . BS.pack)-} t - continue gfenv - - show_deps ws = do - let (os,xs) = partition (isPrefixOf "-") ws - ops <- case xs of - _:_ -> do - let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs] - err error (return . nub . concat) $ mapM (constantDepsTerm sgr) ts - _ -> error "expected one or more qualified constants as argument" - let prTerm = showTerm sgr TermPrintDefault Qualified - let size = sizeConstant sgr - let printed - | elem "-size" os = - let sz = map size ops in - unlines $ ("total: " ++ show (sum sz)) : - [prTerm f ++ "\t" ++ show s | (f,s) <- zip ops sz] - | otherwise = unwords $ map prTerm ops - putStrLn $ printed - continue gfenv - - show_operations ws = - case greatestResource sgr of - Nothing -> putStrLn "no source grammar in scope; did you import with -retain?" >> continue gfenv - Just mo -> do - let (os,ts) = partition (isPrefixOf "-") ws - let greps = [drop 6 o | o <- os, take 6 o == "-grep="] - let isRaw = elem "-raw" os - ops <- case ts of - _:_ -> do - let Right t = runP pExp (UTF8.fromString (unwords ts)) - ty <- err error return $ checkComputeTerm sgr t - return $ allOpersTo sgr ty - _ -> return $ allOpers sgr - let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops] - let printer = if isRaw - then showTerm sgr TermPrintDefault Qualified - else (render . TC.ppType) - let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs] - mapM_ putStrLn [l | l <- printed, all (flip isInfixOf l) greps] - continue gfenv - - show_source ws = do - let (os,ts) = partition (isPrefixOf "-") ws - let strip = if elem "-strip" os then stripSourceGrammar else id - let mygr = strip $ case ts of - _:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (showIdent i) ts] - [] -> sgr - case 0 of - _ | elem "-detailedsize" os -> putStrLn (printSizesGrammar mygr) - _ | elem "-size" os -> do - let sz = sizesGrammar mygr - putStrLn $ unlines $ - ("total\t" ++ show (fst sz)): - [showIdent j ++ "\t" ++ show (fst k) | (j,k) <- snd sz] - _ | elem "-save" os -> mapM_ - (\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in - restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file)) - (modules mygr) - _ -> putStrLn $ render mygr - continue gfenv - - dependency_graph ws = - do let stop = case ws of - ('-':'o':'n':'l':'y':'=':fs):_ -> Just $ chunks ',' fs - _ -> Nothing - restricted $ writeFile "_gfdepgraph.dot" (depGraph stop sgr) - putStrLn "wrote graph in file _gfdepgraph.dot" - continue gfenv - - eh [w] = -- Ehhh? Reads commands from a file, but does not execute them - do cs <- restricted (readFile w) >>= return . map (interpretCommandLine env) . lines - continue gfenv - eh _ = do putStrLn "eh command not parsed" - continue gfenv - - import_ args = - do gfenv' <- case parseOptions args of - Ok (opts',files) -> do - curr_dir <- getCurrentDirectory - lib_dir <- getLibraryDirectory (addOptions opts opts') - importInEnv gfenv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files - Bad err -> do - putStrLn $ "Command parse error: " ++ err - return gfenv - continue gfenv' - - empty = continue $ gfenv { - commandenv=emptyCommandEnv, sourcegrammar = emptySourceGrammar - } - - define_command (f:ws) = - case readCommandLine (unwords ws) of - Just comm -> continue $ gfenv { - commandenv = env { - commandmacros = Map.insert f comm (commandmacros env) - } - } - _ -> dc_not_parsed - define_command _ = dc_not_parsed - - dc_not_parsed = putStrLn "command definition not parsed" >> continue gfenv - - define_tree (f:ws) = - case readExpr (unwords ws) of - Just exp -> continue $ gfenv { - commandenv = env { - expmacros = Map.insert f exp (expmacros env) - } - } - _ -> dt_not_parsed - define_tree _ = dt_not_parsed - - dt_not_parsed = putStrLn "value definition not parsed" >> continue gfenv - - print_history = mapM_ putStrLn (reverse (history gfenv0))>> continue gfenv - - reload_last = do - let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]] - case imports of - (s,ws):_ -> do - putStrLn $ "repeating latest import: " ++ s - import_ ws - _ -> do - putStrLn $ "no import in history" - continue gfenv - - set_encoding [c] = - do let cod = renameEncoding c - restricted $ changeConsoleEncoding cod - continue gfenv - set_encoding _ = putStrLn "se command not parsed" >> continue gfenv - - -printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e) - -checkComputeTerm sgr t = do - mo <- maybe (raise "no source grammar in scope") return $ greatestResource sgr - ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t - inferLType sgr [] t - t1 <- {-if new - then-} return (CN.normalForm (CN.resourceValues sgr) (L NoLoc identW) t) - {-else computeConcrete sgr t-} - checkPredefError t1 - -fetchCommand :: GFEnv -> IO String -fetchCommand gfenv = do - path <- getAppUserDataDirectory "gf_history" - let settings = - Haskeline.Settings { - Haskeline.complete = wordCompletion gfenv, - Haskeline.historyFile = Just path, - Haskeline.autoAddHistory = True - } - res <- IO.runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt (commandenv gfenv))) - case res of - Left _ -> return "" - Right Nothing -> return "q" - Right (Just s) -> return s - -importInEnv :: GFEnv -> Options -> [FilePath] -> SIO GFEnv -importInEnv gfenv opts files - | flag optRetainResource opts = - do src <- importSource (sourcegrammar gfenv) opts files - return $ gfenv {sourcegrammar = src} - | otherwise = - do let opts' = addOptions (setOptimization OptCSE False) opts - pgf0 = multigrammar (commandenv gfenv) - pgf1 <- importGrammar pgf0 opts' files - if (verbAtLeast opts Normal) - then putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf1) - else return () - return $ gfenv { commandenv = mkCommandEnv pgf1 } - -tryGetLine = do - res <- try getLine - case res of - Left (e :: SomeException) -> return "q" - Right l -> return l - -welcome = unlines [ - " ", - " * * * ", - " * * ", - " * * ", - " * ", - " * ", - " * * * * * * * ", - " * * * ", - " * * * * * * ", - " * * * ", - " * * * ", - " ", - "This is GF version "++showVersion version++". ", - buildInfo, - "License: see help -license. ", - "Bug reports: http://code.google.com/p/grammatical-framework/issues/list" - ] - -prompt env - | abs == wildCId = "> " - | otherwise = showCId abs ++ "> " - where - abs = abstractName (multigrammar env) - -data GFEnv = GFEnv { - sourcegrammar :: SourceGrammar, -- gfo grammar -retain - commandenv :: CommandEnv, - history :: [String] - } - -emptyGFEnv :: GFEnv -emptyGFEnv = - GFEnv emptySourceGrammar (mkCommandEnv emptyPGF) [] {-0-} - -wordCompletion gfenv (left,right) = do - case wc_type (reverse left) of - CmplCmd pref - -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] - CmplStr (Just (Command _ opts _)) s0 - -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optType opts))) - case mb_state0 of - Right state0 -> let (rprefix,rs) = break isSpace (reverse s0) - s = reverse rs - prefix = reverse rprefix - ws = words s - in case loop state0 ws of - Nothing -> ret 0 [] - Just state -> let compls = getCompletions state prefix - in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls)) - Left (_ :: SomeException) -> ret 0 [] - CmplOpt (Just (Command n _ _)) pref - -> case Map.lookup n (commands cmdEnv) of - Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags inf, isPrefixOf pref flg] - opt_compls = [Haskeline.Completion ('-':opt) ('-':opt) True | (opt,_) <- options inf, isPrefixOf pref opt] - ret (length pref+1) - (flg_compls++opt_compls) - Nothing -> ret (length pref) [] - CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i - -> Haskeline.completeFilename (left,right) - CmplIdent _ pref - -> do mb_abs <- try (evaluate (abstract pgf)) - case mb_abs of - Right abs -> ret (length pref) [Haskeline.simpleCompletion name | cid <- Map.keys (funs abs), let name = showCId cid, isPrefixOf pref name] - Left (_ :: SomeException) -> ret (length pref) [] - _ -> ret 0 [] - where - pgf = multigrammar cmdEnv - cmdEnv = commandenv gfenv - optLang opts = valCIdOpts "lang" (head (languages pgf)) opts - optType opts = - let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts - in case readType str of - Just ty -> ty - Nothing -> error ("Can't parse '"++str++"' as type") - - loop ps [] = Just ps - loop ps (t:ts) = case nextState ps (simpleParseInput t) of - Left es -> Nothing - Right ps -> loop ps ts - - ret len xs = return (drop len left,xs) - - -data CompletionType - = CmplCmd Ident - | CmplStr (Maybe Command) String - | CmplOpt (Maybe Command) Ident - | CmplIdent (Maybe Command) Ident - deriving Show - -wc_type :: String -> CompletionType -wc_type = cmd_name - where - cmd_name cs = - let cs1 = dropWhile isSpace cs - in go cs1 cs1 - where - go x [] = CmplCmd x - go x (c:cs) - | isIdent c = go x cs - | otherwise = cmd x cs - - cmd x [] = ret CmplIdent x "" 0 - cmd _ ('|':cs) = cmd_name cs - cmd _ (';':cs) = cmd_name cs - cmd x ('"':cs) = str x cs cs - cmd x ('-':cs) = option x cs cs - cmd x (c :cs) - | isIdent c = ident x (c:cs) cs - | otherwise = cmd x cs - - option x y [] = ret CmplOpt x y 1 - option x y ('=':cs) = optValue x y cs - option x y (c :cs) - | isIdent c = option x y cs - | otherwise = cmd x cs - - optValue x y ('"':cs) = str x y cs - optValue x y cs = cmd x cs - - ident x y [] = ret CmplIdent x y 0 - ident x y (c:cs) - | isIdent c = ident x y cs - | otherwise = cmd x cs - - str x y [] = ret CmplStr x y 1 - str x y ('\"':cs) = cmd x cs - str x y ('\\':c:cs) = str x y cs - str x y (c:cs) = str x y cs - - ret f x y d = f cmd y - where - x1 = take (length x - length y - d) x - x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1 - - cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of - [x] -> Just x - _ -> Nothing - - isIdent c = c == '_' || c == '\'' || isAlphaNum c diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs deleted file mode 100644 index fbcca3d94..000000000 --- a/src/compiler/GFServer.hs +++ /dev/null @@ -1,494 +0,0 @@ --- | GF server mode -{-# LANGUAGE CPP #-} -module GFServer(server) where -import Data.List(partition,stripPrefix,isInfixOf) -import qualified Data.Map as M -import Control.Monad(when) -import Control.Monad.State(StateT(..),get,gets,put) -import Control.Monad.Error(ErrorT(..),Error(..)) -import System.Random(randomRIO) ---import System.IO(stderr,hPutStrLn) -import GF.System.Catch(try) -import Control.Exception(bracket_) -import System.IO.Error(isAlreadyExistsError) -import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory, - setCurrentDirectory,getCurrentDirectory, - getDirectoryContents,removeFile,removeDirectory, - getModificationTime) -import Data.Time (getCurrentTime,formatTime) -import System.Locale(defaultTimeLocale,rfc822DateFormat) -import System.FilePath(dropExtension,takeExtension,takeFileName,takeDirectory, - (),makeRelative) -#ifndef mingw32_HOST_OS -import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink, - createSymbolicLink) -#endif -import GF.Infra.Concurrency(newMVar,modifyMVar,newLog) -import Network.URI(URI(..)) -import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache) ---import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi -import Network.CGI(handleErrors,liftIO) -import CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile -import Text.JSON(encode,showJSON,makeObj) ---import System.IO.Silently(hCapture) -import System.Process(readProcessWithExitCode) -import System.Exit(ExitCode(..)) -import Codec.Binary.UTF8.String(decodeString,encodeString) -import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn) -import GF.Infra.SIO(captureSIO) -import qualified PGFService as PS -import qualified ExampleService as ES -import Data.Version(showVersion) -import Paths_gf(getDataDir,version) -import GF.Infra.BuildInfo (buildInfo) -import SimpleEditor.Convert(parseModule) -import RunHTTP(cgiHandler) -import URLEncoding(decodeQuery) - ---logFile :: FilePath ---logFile = "pgf-error.log" - -debug s = logPutStrLn s - --- | Combined FastCGI and HTTP server -server port optroot execute1 state0 = - do --stderrToFile logFile - state <- newMVar M.empty - cache <- PS.newPGFCache - datadir <- getDataDir - let root = maybe (datadir"www") id optroot --- debug $ "document root="++root - setDir root --- FCGI.acceptLoop forkIO (handle_fcgi execute1 state0 state cache) - -- if acceptLoop returns, then GF was not invoked as a FastCGI script - http_server execute1 state0 state cache root - where - -- | HTTP server - http_server execute1 state0 state cache root = - do logLn <- newLog ePutStrLn -- to avoid intertwined log messages - logLn gf_version - logLn $ "Document root = "++root - logLn $ "Starting HTTP server, open http://localhost:" - ++show port++"/ in your web browser." - initServer port (handle logLn root state0 cache execute1 state) - -gf_version = "This is GF version "++showVersion version++".\n"++buildInfo - -{- --- | FastCGI request handler -handle_fcgi execute1 state0 stateM cache = - do Just method <- FCGI.getRequestMethod - debug $ "request method="++method - Just path <- FCGI.getPathInfo --- debug $ "path info="++path - query <- maybe (return "") return =<< FCGI.getQueryString --- debug $ "query string="++query - let uri = URI "" Nothing path query "" - headers <- fmap (mapFst show) FCGI.getAllRequestHeaders - body <- fmap BS.unpack FCGI.fGetContents - let req = Request method uri headers body --- debug (show req) - (output,resp) <- liftIO $ hCapture [stdout] $ modifyMVar stateM $ handle state0 cache execute1 req - let Response code headers body = resp --- debug output - debug $ " "++show code++" "++show headers - FCGI.setResponseStatus code - mapM_ (uncurry (FCGI.setResponseHeader . toHeader)) headers - let pbody = BS.pack body - n = BS.length pbody - FCGI.fPut pbody - debug $ "done "++show n --} - --- * Request handler --- | Handler monad -type HM s a = StateT (Q,s) (ErrorT Response IO) a -run :: HM s Response -> (Q,s) -> IO (s,Response) -run m s = either bad ok =<< runErrorT (runStateT m s) - where - bad resp = return (snd s,resp) - ok (resp,(qs,state)) = return (state,resp) - -get_qs :: HM s Q -get_qs = gets fst -get_state :: HM s s -get_state = gets snd -put_qs qs = do state <- get_state; put (qs,state) -put_state state = do qs <- get_qs; put (qs,state) - -err :: Response -> HM s a -err e = StateT $ \ s -> ErrorT $ return $ Left e - -hmbracket_ :: IO () -> IO () -> HM s a -> HM s a -hmbracket_ pre post m = - do s <- get - e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s - case e of - Left resp -> err resp - Right (a,s) -> do put s;return a - --- | HTTP request handler -handle logLn documentroot state0 cache execute1 stateVar - rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) = - addDate $ - case method of - "POST" -> normal_request (utf8inputs body) - "GET" -> normal_request (utf8inputs q) - _ -> return (resp501 $ "method "++method) - where - logPutStrLn msg = liftIO $ logLn msg - debug msg = logPutStrLn msg - - addDate m = - do t <- getCurrentTime - r <- m - let fmt = formatTime defaultTimeLocale rfc822DateFormat t - return r{resHeaders=("Date",fmt):resHeaders r} - - normal_request qs = - do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs) - let stateful m = modifyMVar stateVar $ \ s -> run m (qs,s) - -- stateful ensures mutual exclusion, so you can use/change the cwd - case upath of - "/new" -> stateful $ new - "/gfshell" -> stateful $ inDir command - "/cloud" -> stateful $ inDir cloud --- "/stop" -> --- "/start" -> - "/parse" -> parse (decoded qs) - "/version" -> do (c1,c2) <- PS.listPGFCache cache - let rel = map (makeRelative documentroot) - return $ ok200 (unlines (gf_version:"":rel c1++"":rel c2)) - "/flush" -> do PS.flushPGFCache cache; return (ok200 "flushed") - '/':rpath -> - -- This code runs without mutual exclusion, so it must *not* - -- use/change the cwd. Access files by absolute paths only. - case (takeDirectory path,takeFileName path,takeExtension path) of - (_ ,_ ,".pgf") -> do --debug $ "PGF service: "++path - wrapCGI $ PS.cgiMain' cache path - (dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs) - (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir (fst cache) - _ -> serveStaticFile rpath path - where path = translatePath rpath - _ -> return $ resp400 upath - - root = documentroot - - translatePath rpath = rootrpath -- hmm, check for ".." - - wrapCGI cgi = cgiHandler root (handleErrors . handleCGIErrors $ cgi) rq - - look field = - do qs <- get_qs - case partition ((==field).fst) qs of - ((_,(value,_)):qs1,qs2) -> do put_qs (qs1++qs2) - return value - _ -> err $ resp400 $ "no "++field++" in request" - - inDir ok = cd =<< look "dir" - where - cd ('/':dir@('t':'m':'p':_)) = - do cwd <- getCurrentDirectory - b <- doesDirectoryExist dir - case b of - False -> do b <- liftIO $ try $ readFile dir -- poor man's symbolic links - case b of - Left _ -> err $ resp404 dir - Right dir' -> cd dir' - True -> do --logPutStrLn $ "cd "++dir - hmInDir dir (ok dir) - cd dir = err $ resp400 $ "unacceptable directory "++dir - - -- First ensure that only one thread that depends on the cwd is running! - hmInDir dir = hmbracket_ (setDir dir) (setDir documentroot) - - new = fmap ok200 $ liftIO $ newDirectory - - command dir = - do cmd <- look "command" - state <- get_state - let st = maybe state0 id $ M.lookup dir state - (output,st') <- liftIO $ captureSIO $ execute1 st cmd - let state' = maybe state (flip (M.insert dir) state) st' - put_state state' - return $ ok200 output - - parse qs = return $ json200 (makeObj(map parseModule qs)) - - cloud dir = - do cmd <- look "command" - case cmd of - "make" -> make id dir . raw =<< get_qs - "remake" -> make skip_empty dir . raw =<< get_qs - "upload" -> upload id . raw =<< get_qs - "ls" -> jsonList . maybe ".json" fst . lookup "ext" =<< get_qs - "ls-l" -> jsonListLong . maybe ".json" fst . lookup "ext" =<< get_qs - "rm" -> rm =<< look_file - "download" -> download =<< look_file - "link_directories" -> link_directories dir =<< look "newdir" - _ -> err $ resp400 $ "cloud command "++cmd - - look_file = check =<< look "file" - where - check path = - if ok_access path - then return path - else err $ resp400 $ "unacceptable path "++path - - make skip dir args = - do let (flags,files) = partition ((=="-").take 1.fst) args - _ <- upload skip files - let args = "-s":"-make":map flag flags++map fst files - flag (n,"") = n - flag (n,v) = n++"="++v - cmd = unwords ("gf":args) - logPutStrLn cmd - out@(ecode,_,_) <- liftIO $ readProcessWithExitCode "gf" args "" - logPutStrLn $ show ecode - cwd <- getCurrentDirectory - return $ json200 (jsonresult cwd ('/':dir++"/") cmd out files) - - upload skip files = - if null badpaths - then do liftIO $ mapM_ (uncurry updateFile) (skip okfiles) - return resp204 - else err $ resp404 $ "unacceptable path(s) "++unwords badpaths - where - (okfiles,badpaths) = apSnd (map fst) $ partition (ok_access.fst) files - - skip_empty = filter (not.null.snd) - - jsonList = jsonList' return - jsonListLong = jsonList' (mapM addTime) - jsonList' details ext = fmap (json200) (details =<< ls_ext "." ext) - - addTime path = - do t <- getModificationTime path - return $ makeObj ["path".=path,"time".=format t] - where - format = formatTime defaultTimeLocale rfc822DateFormat - - rm path | takeExtension path `elem` ok_to_delete = - do b <- doesFileExist path - if b - then do removeFile path - return $ ok200 "" - else err $ resp404 path - rm path = err $ resp400 $ "unacceptable extension "++path - - download path = liftIO $ serveStaticFile' path - - link_directories olddir newdir@('/':'t':'m':'p':'/':_) | old/=new = - hmInDir ".." $ liftIO $ - do logPutStrLn =<< getCurrentDirectory - logPutStrLn $ "link_dirs new="++new++", old="++old -#ifdef mingw32_HOST_OS - isDir <- doesDirectoryExist old - if isDir then removeDir old else removeFile old - writeFile old new -- poor man's symbolic links -#else - isLink <- isSymbolicLink `fmap` getSymbolicLinkStatus old - logPutStrLn $ "old is link: "++show isLink - if isLink then removeLink old else removeDir old - createSymbolicLink new old -#endif - return $ ok200 "" - where - old = takeFileName olddir - new = takeFileName newdir - link_directories olddir newdir = - err $ resp400 $ "unacceptable directories "++olddir++" "++newdir - - grammarList dir qs = - do pgfs <- ls_ext dir ".pgf" - return $ jsonp qs pgfs - - ls_ext dir ext = - do paths <- getDirectoryContents dir - return [path | path<-paths, takeExtension path==ext] - --- * Dynamic content - -jsonresult cwd dir cmd (ecode,stdout,stderr) files = - makeObj [ - "errorcode" .= if ecode==ExitSuccess then "OK" else "Error", - "command" .= cmd, - "output" .= unlines [rel stderr,rel stdout], - "minibar_url" .= "/minibar/minibar.html?"++dir++pgf] - where - pgf = case files of - (abstract,_):_ -> "%20"++dropExtension abstract++".pgf" - _ -> "" - - rel = unlines . map relative . lines - - -- remove absolute file paths from error messages: - relative s = case stripPrefix cwd s of - Just ('/':rest) -> rest - _ -> s - --- * Static content - -serveStaticFile rpath path = - do --logPutStrLn $ "Serving static file "++path - b <- doesDirectoryExist path - if b - then if rpath `elem` ["","."] || last path=='/' - then serveStaticFile' (path "index.html") - else return (resp301 ('/':rpath++"/")) - else serveStaticFile' path - -serveStaticFile' path = - do let ext = takeExtension path - (t,rdFile) = contentTypeFromExt ext - if ext `elem` [".cgi",".fcgi",".sh",".php"] - then return $ resp400 $ "Unsupported file type: "++ext - else do b <- doesFileExist path - if b then fmap (ok200' (ct t "")) $ rdFile path - else do cwd <- getCurrentDirectory - logPutStrLn $ "Not found: "++path++" cwd="++cwd - return (resp404 path) - --- * Logging -logPutStrLn s = ePutStrLn s - --- * JSONP output - -jsonp qs = maybe json200 apply (lookup "jsonp" qs) - where - apply f = jsonp200' $ \ json -> f++"("++json++")" - --- * Standard HTTP responses -ok200 = Response 200 [plainUTF8,noCache,xo] . encodeString -ok200' t = Response 200 [t,xo] -json200 x = json200' id x -json200' f = ok200' jsonUTF8 . encodeString . f . encode -jsonp200' f = ok200' jsonpUTF8 . encodeString . f . encode -html200 = ok200' htmlUTF8 . encodeString -resp204 = Response 204 [xo] "" -- no content -resp301 url = Response 301 [plain,xo,location url] $ - "Moved permanently to "++url -resp400 msg = Response 400 [plain,xo] $ "Bad request: "++msg++"\n" -resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n" -resp500 msg = Response 500 [plain,xo] $ "Internal error: "++msg++"\n" -resp501 msg = Response 501 [plain,xo] $ "Not implemented: "++msg++"\n" - -instance Error Response where - noMsg = resp500 "no message" - strMsg = resp500 - --- * Content types -plain = ct "text/plain" "" -plainUTF8 = ct "text/plain" csutf8 -jsonUTF8 = ct "application/json" csutf8 -- http://www.ietf.org/rfc/rfc4627.txt -jsonpUTF8 = ct "application/javascript" csutf8 -htmlUTF8 = ct "text/html" csutf8 - -ct t cs = ("Content-Type",t++cs) -csutf8 = "; charset=UTF-8" -xo = ("Access-Control-Allow-Origin","*") -- Allow cross origin requests - -- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS -location url = ("Location",url) - -contentTypeFromExt ext = - case ext of - ".html" -> text "html" - ".htm" -> text "html" - ".xml" -> text "xml" - ".txt" -> text "plain" - ".css" -> text "css" - ".js" -> text "javascript" - ".png" -> bin "image/png" - ".jpg" -> bin "image/jpg" - _ -> bin "application/octet-stream" - where - text subtype = ("text/"++subtype++"; charset=UTF-8", - fmap encodeString . readFile) - bin t = (t,readBinaryFile) - --- * IO utilities -updateFile path new = - do old <- try $ readBinaryFile path --- let new = encodeString new0 - when (Right new/=old) $ do logPutStrLn $ "Updating "++path - seq (either (const 0) length old) $ - writeBinaryFile path new - --- | Check that a path is not outside the current directory -ok_access path = - case path of - '/':_ -> False - '.':'.':'/':_ -> False - _ -> not ("/../" `isInfixOf` path) - --- | Only delete files with these extensions -ok_to_delete = [".json",".gfstdoc",".gfo",".gf",".pgf"] - -newDirectory = - do debug "newDirectory" - loop 10 - where - loop 0 = fail "Failed to create a new directory" - loop n = maybe (loop (n-1)) return =<< once - - once = - do k <- randomRIO (1,maxBound::Int) - let path = "tmp/gfse."++show k - b <- try $ createDirectory path - case b of - Left err -> do debug (show err) ; - if isAlreadyExistsError err - then return Nothing - else ioError err - Right _ -> return (Just ('/':path)) - --- | Remove a directory and the files in it, but not recursively -removeDir dir = - do files <- filter (`notElem` [".",".."]) `fmap` getDirectoryContents dir - mapM (removeFile . (dir)) files - removeDirectory dir - -setDir path = - do --logPutStrLn $ "cd "++show path - setCurrentDirectory path - -{- --- * direct-fastcgi deficiency workaround - ---toHeader = FCGI.toHeader -- not exported, unfortuntately - -toHeader "Content-Type" = FCGI.HttpContentType -- to avoid duplicate headers -toHeader s = FCGI.HttpExtensionHeader s -- cheating a bit --} - --- * misc utils - ---utf8inputs = mapBoth decodeString . inputs -type Q = [(String,(String,String))] -utf8inputs :: String -> Q -utf8inputs q = [(decodeString k,(decodeString v,v))|(k,v)<-inputs q] -decoded = mapSnd fst -raw = mapSnd snd - -inputs ('?':q) = decodeQuery q -inputs q = decodeQuery q - -{- --- Stay clear of queryToArgument, which uses unEscapeString, which had --- backward incompatible changes in network-2.4.1.1, see --- https://github.com/haskell/network/commit/f2168b1f8978b4ad9c504e545755f0795ac869ce -inputs = queryToArguments . fixplus - where - fixplus = concatMap decode - decode '+' = "%20" -- httpd-shed bug workaround - decode c = [c] --} - -mapFst f xys = [(f x,y)|(x,y)<-xys] -mapSnd f xys = [(x,f y)|(x,y)<-xys] -mapBoth = map . apBoth -apBoth f (x,y) = (f x,f y) -apSnd f (x,y) = (x,f y) - -infix 1 .= -n .= v = (n,showJSON v) -- cgit v1.2.3