diff --git a/src/server/FastCGIUtils.hs b/src/server/FastCGIUtils.hs deleted file mode 100644 index 5a61d5282..000000000 --- a/src/server/FastCGIUtils.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE CPP #-} -module FastCGIUtils(initFastCGI,loopFastCGI) where - -import Control.Concurrent(ThreadId,myThreadId) -import Control.Exception(ErrorCall(..),throw,throwTo,catch) -import Control.Monad(when,liftM,liftM2) -import Data.IORef(IORef,newIORef,readIORef,writeIORef) -import Prelude hiding (catch) -import System.Environment(getArgs,getProgName) -import System.Exit(ExitCode(..),exitWith) -import System.IO(hPutStrLn,stderr) -import System.IO.Unsafe(unsafePerformIO) -#ifndef mingw32_HOST_OS -import System.Posix -#endif - -import Network.FastCGI - -import CGIUtils(logError) - - -- There are used in MorphoService.hs, but not in PGFService.hs -initFastCGI :: IO () -initFastCGI = installSignalHandlers - -loopFastCGI :: CGI CGIResult -> IO () -loopFastCGI f = - do (do runOneFastCGI f - exitIfToldTo - restartIfModified) - `catchAborted` logError "Request aborted" - loopFastCGI f - --- Signal handling for FastCGI programs. - -#ifndef mingw32_HOST_OS -installSignalHandlers :: IO () -installSignalHandlers = - do t <- myThreadId - installHandler sigUSR1 (Catch gracefulExit) Nothing - installHandler sigTERM (Catch gracelessExit) Nothing - installHandler sigPIPE (Catch (requestAborted t)) Nothing - return () - -requestAborted :: ThreadId -> IO () -requestAborted t = throwTo t (ErrorCall "**aborted**") - -gracelessExit :: IO () -gracelessExit = do logError "Graceless exit" - exitWith ExitSuccess - -gracefulExit :: IO () -gracefulExit = - do logError "Graceful exit" - writeIORef shouldExit True -#else -installSignalHandlers :: IO () -installSignalHandlers = return () -#endif - -exitIfToldTo :: IO () -exitIfToldTo = - do b <- readIORef shouldExit - when b $ do logError "Exiting..." - exitWith ExitSuccess - -{-# NOINLINE shouldExit #-} -shouldExit :: IORef Bool -shouldExit = unsafePerformIO $ newIORef False - -catchAborted :: IO a -> IO a -> IO a -catchAborted x y = x `catch` \e -> case e of - ErrorCall "**aborted**" -> y - _ -> throw e - --- Restart handling for FastCGI programs. - -#ifndef mingw32_HOST_OS -{-# NOINLINE myModTimeRef #-} -myModTimeRef :: IORef EpochTime -myModTimeRef = unsafePerformIO (getProgModTime >>= newIORef) - --- FIXME: doesn't get directory -myProgPath :: IO FilePath -myProgPath = getProgName - -getProgModTime :: IO EpochTime -getProgModTime = liftM modificationTime (myProgPath >>= getFileStatus) - -needsRestart :: IO Bool -needsRestart = liftM2 (/=) (readIORef myModTimeRef) getProgModTime - -exitIfModified :: IO () -exitIfModified = - do restart <- needsRestart - when restart $ exitWith ExitSuccess - -restartIfModified :: IO () -restartIfModified = - do restart <- needsRestart - when restart $ do prog <- myProgPath - args <- getArgs - hPutStrLn stderr $ prog ++ " has been modified, restarting ..." - -- FIXME: setCurrentDirectory? - executeFile prog False args Nothing - -#else -restartIfModified :: IO () -restartIfModified = return () -#endif - diff --git a/src/server/exec/ContentService.hs b/src/server/exec/ContentService.hs deleted file mode 100644 index 0f2eb6508..000000000 --- a/src/server/exec/ContentService.hs +++ /dev/null @@ -1,357 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, CPP #-} - -import PGF (PGF) -import qualified PGF -import Cache -import FastCGIUtils -import URLEncoding - -import Data.Maybe -import Network.FastCGI -import Text.JSON -import qualified Data.ByteString.Lazy as BS -import qualified Codec.Binary.UTF8.String as UTF8 (encodeString, decodeString) - -import Control.Monad -import Control.Exception -import Control.Concurrent(forkIO) -import System.Environment(getArgs) -import System.Time -import System.Locale -import System.FilePath -import Database.HSQL.MySQL -import Database.HSQL.Types(toSqlValue) - -logFile :: FilePath -logFile = "content-error.log" - - -main :: IO () -main = do - args <- getArgs - case args of - [] -> do stderrToFile logFile - cache <- newCache dbConnect - -#ifndef mingw32_HOST_OS - runFastCGIConcurrent' forkIO 100 (cgiMain cache) -#else - runFastCGI (cgiMain cache) -#endif - [fpath] -> do c <- dbConnect fpath - dbInit c - -getPath = getVarWithDefault "SCRIPT_FILENAME" "" - -cgiMain :: Cache Connection -> CGI CGIResult -cgiMain cache = handleErrors . handleCGIErrors $ - cgiMain' cache =<< getPath - -cgiMain' :: Cache Connection -> FilePath -> CGI CGIResult -cgiMain' cache path = - do c <- liftIO $ readCache cache path - mb_command <- liftM (liftM (urlDecodeUnicode . UTF8.decodeString)) (getInput "command") - case mb_command of - Just "update_grammar" - -> do mb_pgf <- getFile - id <- getGrammarId - name <- getFileName - descr <- getDescription - userId <- getUserId - doUpdateGrammar c mb_pgf id name descr userId - Just "delete_grammar" - -> do id <- getGrammarId - userId <- getUserId - doDeleteGrammar c id userId - Just "grammars" - -> do userId <- getUserId - doGrammars c userId - Just "save" -> doSave c =<< getId - Just "load" -> doLoad c =<< getId - Just "search" -> doSearch c =<< getQuery - Just "delete" -> doDelete c =<< getIds - Just cmd -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show cmd] - Nothing -> do mb_uri <- getIdentity - mb_email <- getEMail - doLogin c mb_uri mb_email - where - getUserId :: CGI (Maybe String) - getUserId = getInput "userId" - - getId :: CGI (Maybe Int) - getId = readInput "id" - - getIds :: CGI [Int] - getIds = fmap (map read) (getMultiInput "id") - - getQuery :: CGI String - getQuery = fmap (fromMaybe "") (getInput "query") - - getGrammarId :: CGI String - getGrammarId = do - mb_url <- getInput "url" - return (maybe "null" (reverse . takeWhile (/='/') . drop 4 . reverse) mb_url) - - getFile :: CGI (Maybe BS.ByteString) - getFile = do - getInputFPS "file" - - getFileName :: CGI String - getFileName = do - mb_name0 <- getInput "name" - let mb_name | mb_name0 == Just "" = Nothing - | otherwise = mb_name0 - mb_file <- getInputFilename "file" - return (fromMaybe "" (mb_name `mplus` mb_file)) - - getDescription :: CGI String - getDescription = fmap (fromMaybe "") (getInput "description") - - getIdentity :: CGI (Maybe String) - getIdentity = getInput "openid.identity" - - getEMail :: CGI (Maybe String) - getEMail = getInput "openid.ext1.value.email" - - -doLogin c mb_uri mb_email = do - path <- scriptName - r <- liftIO $ handleSql (return . Left) $ do - s <- query c ("call getUserId("++toSqlValue mb_uri++","++toSqlValue mb_email++")") - [id] <- collectRows getUserId s - return (Right id) - case r of - Right mb_id -> outputHTML (startupHTML mb_id mb_uri mb_email (Just path)) - Left e -> throwCGIError 400 "Login failed" (lines (show e)) - where - getUserId s = do - id <- getFieldValueMB s "userId" - return (id :: Maybe Int) - -doGrammars c mb_userId = do - path <- scriptName - r <- liftIO $ handleSql (return . Left) $ do - s <- query c ("call getGrammars("++toSqlValue mb_userId++")") - rows <- collectRows (getGrammar path) s - return (Right rows) - case r of - Right rows -> outputJSONP rows - Left e -> throwCGIError 400 "Loading failed" (lines (show e)) - where - getGrammar path s = do - id <- getFieldValue s "id" - name <- getFieldValue s "name" - description <- getFieldValue s "description" - return $ toJSObject [ ("url", showJSON (dropExtension path ++ '/':addExtension (show (id :: Int)) "pgf")) - , ("name", showJSON (name :: String)) - , ("description", showJSON (description :: String)) - ] - -doUpdateGrammar c mb_pgf id name descr mb_userId = do - r <- liftIO $ handleSql (return . Left) $ do - s <- query c ("call updateGrammar("++id++","++toSqlValue name++","++toSqlValue descr++","++toSqlValue mb_userId++")") - [id] <- collectRows (\s -> getFieldValue s "id") s - return (Right id) - nid <- case r of - Right id -> return (id :: Int) - Left e -> throwCGIError 400 "Saving failed" (lines (show e)) - path <- pathTranslated - case mb_pgf of - Just pgf -> if pgf /= BS.empty - then liftIO (BS.writeFile (dropExtension path addExtension (show nid) "pgf") pgf) - else if id == "null" - then throwCGIError 400 "Grammar update failed" [] - else return () - Nothing -> return () - outputHTML "" - -doDeleteGrammar c id mb_userId = do - r <- liftIO $ handleSql (return . Left) $ do - execute c ("call deleteGrammar("++id++","++toSqlValue mb_userId++")") - return (Right "") - case r of - Right x -> outputJSONP ([] :: [(String,String)]) - Left e -> throwCGIError 400 "Saving failed" (lines (show e)) - -doSave c mb_id = do - body <- getBody - r <- liftIO $ handleSql (return . Left) $ do - s <- query c ("call saveDocument("++toSqlValue mb_id++","++toSqlValue body++")") - [id] <- collectRows (\s -> getFieldValue s "id") s - return (Right id) - case r of - Right id -> outputJSONP (toJSObject [("id", id :: Int)]) - Left e -> throwCGIError 400 "Saving failed" (lines (show e)) - -doLoad c Nothing = throwCGIError 400 "Loading failed" ["Missing ID"] -doLoad c (Just id) = do - r <- liftIO $ handleSql (return . Left) $ do - s <- query c ("SELECT id,title,created,modified,content\n"++ - "FROM Documents\n"++ - "WHERE id="++toSqlValue id) - rows <- collectRows getDocument s - return (Right rows) - case r of - Right [row] -> outputJSONP row - Right _ -> throwCGIError 400 "Missing document" ["ID="++show id] - Left e -> throwCGIError 400 "Loading failed" (lines (show e)) - where - getDocument s = do - id <- getFieldValue s "id" - title <- getFieldValue s "title" - created <- getFieldValue s "created" >>= pt - modified <- getFieldValue s "modified" >>= pt - content <- getFieldValue s "content" - return $ toJSObject [ ("id", showJSON (id :: Int)) - , ("title", showJSON (title :: String)) - , ("created", showJSON (created :: String)) - , ("modified", showJSON (modified :: String)) - , ("content", showJSON (content :: String)) - ] - -doSearch c q = do - r <- liftIO $ handleSql (return . Left) $ do - s <- query c ("SELECT id,title,created,modified\n"++ - "FROM Documents"++ - if null q - then "" - else "\nWHERE MATCH(content) AGAINST ("++toSqlValue q++" IN BOOLEAN MODE)") - rows <- collectRows getDocument s - return (Right rows) - case r of - Right rows -> outputJSONP rows - Left e -> throwCGIError 400 "Saving failed" (lines (show e)) - where - getDocument s = do - id <- getFieldValue s "id" - title <- getFieldValue s "title" - created <- getFieldValue s "created" >>= pt - modified <- getFieldValue s "modified" >>= pt - return $ toJSObject [ ("id", showJSON (id :: Int)) - , ("title", showJSON (title :: String)) - , ("created", showJSON (created :: String)) - , ("modified", showJSON (modified :: String)) - ] - -pt ct = liftM (formatCalendarTime defaultTimeLocale "%d %b %Y") (toCalendarTime ct) - -doDelete c ids = do - liftIO $ - inTransaction c $ \c -> - mapM_ (\id -> execute c ("DELETE FROM Documents WHERE id = "++toSqlValue id)) ids - outputJSONP (toJSObject ([] :: [(String,String)])) - -dbConnect fpath = do - [host,db,user,pwd] <- fmap words $ readFile fpath - connect host db user pwd - -startupHTML mb_id mb_uri mb_email mb_path = unlines [ - "", - "", - " ", - " ", - " Editor", - " ", - " ", - " "window.__gfInit.userId = "++show id++"; ") mb_id++ - maybe "" (\uri -> "window.__gfInit.userURI = '"++uri++"'; ") mb_uri++ - maybe "" (\email -> "window.__gfInit.userEMail = '"++email++"'; ") mb_email++ - maybe "" (\path -> "window.__gfInit.contentURL = '"++path++"'; ") mb_path++ - "\">", - " ", - " ", - ""] - -dbInit c = - handleSql (fail . show) $ do - inTransaction c $ \c -> do - execute c "DROP TABLE IF EXISTS GrammarUsers" - execute c "DROP TABLE IF EXISTS Users" - execute c "DROP TABLE IF EXISTS Grammars" - execute c "DROP TABLE IF EXISTS Documents" - execute c ("CREATE TABLE Users"++ - " (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY,\n"++ - " identity VARCHAR(256) NOT NULL,\n"++ - " email VARCHAR(128) NOT NULL,\n"++ - " UNIQUE INDEX (identity))") - execute c ("CREATE TABLE Grammars"++ - " (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY,"++ - " name VARCHAR(64) NOT NULL,\n"++ - " description VARCHAR(512) NOT NULL,\n"++ - " created TIMESTAMP NOT NULL DEFAULT 0,\n"++ - " modified TIMESTAMP NOT NULL DEFAULT 0)") - execute c ("CREATE TABLE Documents"++ - " (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY,"++ - " title VARCHAR(256) NOT NULL,\n"++ - " created TIMESTAMP NOT NULL DEFAULT 0,\n"++ - " modified TIMESTAMP NOT NULL DEFAULT 0,\n"++ - " content TEXT NOT NULL,\n"++ - " FULLTEXT INDEX (content)) TYPE=MyISAM") - execute c ("CREATE TABLE GrammarUsers"++ - " (userId INTEGER NOT NULL,\n"++ - " grammarId INTEGER NOT NULL,\n"++ - " flags INTEGER NOT NULL,\n"++ - " PRIMARY KEY (userId, grammarId),\n"++ - " FOREIGN KEY (userId) REFERENCES Users(id) ON DELETE CASCADE,\n"++ - " FOREIGN KEY (grammarId) REFERENCES Grammars(id) ON DELETE RESTRICT)") - execute c "DROP PROCEDURE IF EXISTS saveDocument" - execute c ("CREATE PROCEDURE saveDocument(IN id INTEGER, content TEXT)\n"++ - "BEGIN\n"++ - " IF id IS NULL THEN\n"++ - " INSERT INTO Documents(title,content,created,modified) VALUES (content,content,NOW(),NOW());\n"++ - " SELECT LAST_INSERT_ID() as id;\n"++ - " ELSE\n"++ - " UPDATE Documents d SET content = content, modified=NOW() WHERE d.id = id;\n"++ - " select id;\n"++ - " END IF;\n"++ - "END") - execute c "DROP PROCEDURE IF EXISTS updateGrammar" - execute c ("CREATE PROCEDURE updateGrammar(IN id INTEGER, name VARCHAR(64), description VARCHAR(512), userId INTEGER)\n"++ - "BEGIN\n"++ - " IF id IS NULL THEN\n"++ - " INSERT INTO Grammars(name,description,created,modified) VALUES (name,description,NOW(),NOW());\n"++ - " SET id = LAST_INSERT_ID();\n"++ - " INSERT INTO GrammarUsers(grammarId,userId,flags) VALUES (id,userId,0);\n"++ - " ELSE\n"++ - " UPDATE Grammars gr SET name = name, description=description, modified=NOW() WHERE gr.id = id;\n"++ - " END IF;\n"++ - " SELECT id;\n"++ - "END") - execute c "DROP PROCEDURE IF EXISTS deleteGrammar" - execute c ("CREATE PROCEDURE deleteGrammar(IN aGrammarId INTEGER, aUserId INTEGER)\n"++ - "BEGIN\n"++ - " DECLARE deleted INTEGER;\n"++ - " DELETE FROM GrammarUsers\n"++ - " WHERE grammarId = aGrammarId AND userId = aUserId;\n"++ - " IF NOT EXISTS(SELECT * FROM GrammarUsers gu WHERE gu.grammarId = aGrammarId) THEN\n"++ - " DELETE FROM Grammars WHERE id = aGrammarId;\n"++ - " SET deleted = 1;\n"++ - " ELSE\n"++ - " SET deleted = 0;\n"++ - " END IF;\n"++ - " SELECT deleted;\n"++ - "END") - execute c "DROP PROCEDURE IF EXISTS getGrammars" - execute c ("CREATE PROCEDURE getGrammars(IN userId INTEGER)\n"++ - "BEGIN\n"++ - " SELECT g.id,g.name,g.description\n"++ - " FROM Grammars g JOIN GrammarUsers gu ON g.id = gu.grammarId\n"++ - " WHERE gu.userId = userId\n"++ - " ORDER BY g.name;\n"++ - "END") - execute c "DROP PROCEDURE IF EXISTS getUserId" - execute c ("CREATE PROCEDURE getUserId(identity VARCHAR(256), email VARCHAR(128))\n"++ - "BEGIN\n"++ - " DECLARE userId INTEGER;\n"++ - " IF identity IS NULL OR email IS NULL THEN\n"++ - " SET userId = NULL;\n"++ - " ELSE\n"++ - " SELECT id INTO userId FROM Users u WHERE u.identity = identity;\n"++ - " IF userId IS NULL THEN\n"++ - " INSERT INTO Users(identity, email) VALUES (identity, email);\n"++ - " SET userId = LAST_INSERT_ID();\n"++ - " END IF;\n"++ - " END IF;\n"++ - " SELECT userId;\n"++ - "END") diff --git a/src/server/exec/MorphoService.hs b/src/server/exec/MorphoService.hs deleted file mode 100644 index 5c173c868..000000000 --- a/src/server/exec/MorphoService.hs +++ /dev/null @@ -1,88 +0,0 @@ -import GF.Compile -import GF.Compile.Rename (renameSourceTerm) -import GF.Compile.Concrete.Compute (computeConcrete) -import GF.Compile.Concrete.TypeCheck (inferLType) -import GF.Data.Operations -import GF.Grammar -import GF.Grammar.Parser -import GF.Infra.Option -import GF.Infra.UseIO -import GF.Infra.Modules (greatestResource) -import GF.Infra.CheckM -import GF.Text.UTF8 - -import Network.FastCGI -import Text.JSON -import Text.PrettyPrint -import qualified Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString) -import Data.ByteString.Char8 as BS - -import Control.Monad -import System.Environment -import System.FilePath - -import Cache -import FastCGIUtils -import URLEncoding - --- FIXME !!!!!! -grammarFile :: FilePath -grammarFile = "/usr/local/share/gf-3.1/lib/alltenses/ParadigmsFin.gfo" - -grammarPath :: FilePath -grammarPath = "/usr/local/share/gf-3.1/lib/prelude" - -main :: IO () -main = do initFastCGI - r <- newCache readGrammar - loopFastCGI (handleErrors (handleCGIErrors (fcgiMain r))) - -fcgiMain :: Cache SourceGrammar -> CGI CGIResult -fcgiMain cache = liftIO (readCache cache grammarFile) >>= cgiMain - -readGrammar :: FilePath -> IO SourceGrammar -readGrammar file = - do let opts = concatOptions [modifyFlags $ \fs -> fs { optVerbosity = Quiet }, - modifyFlags $ \fs -> fs { optLibraryPath = [grammarPath] }] - mgr <- appIOE $ batchCompile opts [file] - err (fail "Grammar loading error") return mgr - -cgiMain :: SourceGrammar -> CGI CGIResult -cgiMain sgr = - do path <- pathInfo - json <- case path of - "/eval" -> do mjson <- return (doEval sgr) `ap` getTerm - err (throwCGIError 400 "Evaluation error" . (:[])) return mjson - _ -> throwCGIError 404 "Not Found" ["Resource not found: " ++ path] - outputJSON json - where - getTerm :: CGI String - getTerm = do mt <- getInput "term" - maybe (throwCGIError 400 "No term given" ["No term given"]) (return . urlDecodeUnicode . UTF8.decodeString) mt - -doEval :: SourceGrammar -> String -> Err JSValue -doEval sgr t = liftM termToJSValue $ eval sgr t - -termToJSValue :: Term -> JSValue -termToJSValue t = - showJSON [toJSObject [("name", render name), ("value",render value)] | (name,value) <- ppTermTabular Unqualified t] - -eval :: SourceGrammar -> String -> Err Term -eval sgr t = - case runP pExp (BS.pack t) of - Right t -> do mo <- maybe (Bad "no source grammar in scope") return $ greatestResource sgr - (t,_) <- runCheck (renameSourceTerm sgr mo t) - ((t,_),_) <- runCheck (inferLType sgr [] t) - computeConcrete sgr t - Left (_,msg) -> fail msg - --- * General CGI and JSON stuff - -outputJSON :: JSON a => a -> CGI CGIResult -outputJSON x = do setHeader "Content-Type" "text/json; charset=utf-8" - outputStrict $ UTF8.encodeString $ encode x - -outputStrict :: String -> CGI CGIResult -outputStrict x | x == x = output x - | otherwise = fail "I am the pope." - diff --git a/src/server/exec/pgf-http.hs b/src/server/exec/pgf-http.hs index 565843047..38ea588ff 100644 --- a/src/server/exec/pgf-http.hs +++ b/src/server/exec/pgf-http.hs @@ -7,7 +7,7 @@ import System.FilePath(takeExtension,takeFileName,takeDirectory,()) import RunHTTP(runHTTP,Options(..)) import ServeStaticFile(serveStaticFile) import PGFService(cgiMain',getPath,stderrToFile,logFile,newPGFCache) -import FastCGIUtils(outputJSONP,handleCGIErrors) +import CGIUtils(outputJSONP,handleCGIErrors) import Paths_gf_server(getDataDir)