forked from GitHub/gf-core
Rename modules GFI, GFC & GFServer...
... to GF.Interactive, GF.Compiler & GF.Server, respectively.
This commit is contained in:
hallgren
143
src/compiler/GF/Compiler.hs
Normal file
143
src/compiler/GF/Compiler.hs
Normal file
@@ -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
|
||||
511
src/compiler/GF/Interactive.hs
Normal file
511
src/compiler/GF/Interactive.hs
Normal file
@@ -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
|
||||
494
src/compiler/GF/Server.hs
Normal file
494
src/compiler/GF/Server.hs
Normal file
@@ -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 = root</>rpath -- 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)
|
||||
Reference in New Issue
Block a user