From e9e919e6e3bd92ef6c30181817dd9c6e571011de Mon Sep 17 00:00:00 2001 From: hallgren Date: Tue, 17 Dec 2013 15:55:14 +0000 Subject: src/server/gf-server.cabal: compile it as a common library + executables --- src/server/ContentService.hs | 357 -------------------------------------- src/server/MorphoService.hs | 88 ---------- src/server/exec/ContentService.hs | 357 ++++++++++++++++++++++++++++++++++++++ src/server/exec/MorphoService.hs | 88 ++++++++++ src/server/exec/pgf-fcgi.hs | 16 ++ src/server/exec/pgf-http.hs | 49 ++++++ src/server/gf-server.cabal | 62 +++---- src/server/pgf-fcgi.hs | 16 -- src/server/pgf-http.hs | 49 ------ 9 files changed, 537 insertions(+), 545 deletions(-) delete mode 100644 src/server/ContentService.hs delete mode 100644 src/server/MorphoService.hs create mode 100644 src/server/exec/ContentService.hs create mode 100644 src/server/exec/MorphoService.hs create mode 100644 src/server/exec/pgf-fcgi.hs create mode 100644 src/server/exec/pgf-http.hs delete mode 100644 src/server/pgf-fcgi.hs delete mode 100644 src/server/pgf-http.hs (limited to 'src/server') diff --git a/src/server/ContentService.hs b/src/server/ContentService.hs deleted file mode 100644 index 0f2eb6508..000000000 --- a/src/server/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/MorphoService.hs b/src/server/MorphoService.hs deleted file mode 100644 index 5c173c868..000000000 --- a/src/server/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/ContentService.hs b/src/server/exec/ContentService.hs new file mode 100644 index 000000000..0f2eb6508 --- /dev/null +++ b/src/server/exec/ContentService.hs @@ -0,0 +1,357 @@ +{-# 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 new file mode 100644 index 000000000..5c173c868 --- /dev/null +++ b/src/server/exec/MorphoService.hs @@ -0,0 +1,88 @@ +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-fcgi.hs b/src/server/exec/pgf-fcgi.hs new file mode 100644 index 000000000..3b5b0b3cf --- /dev/null +++ b/src/server/exec/pgf-fcgi.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} +import Control.Concurrent(forkIO) +import Network.FastCGI(runFastCGI,runFastCGIConcurrent') + +import PGFService(cgiMain,newPGFCache,stderrToFile,logFile) +import System.IO +main = do stderrToFile logFile + fcgiMain =<< newPGFCache + + +fcgiMain cache = +#ifndef mingw32_HOST_OS + runFastCGIConcurrent' forkIO 100 (cgiMain cache) +#else + runFastCGI (cgiMain cache) +#endif diff --git a/src/server/exec/pgf-http.hs b/src/server/exec/pgf-http.hs new file mode 100644 index 000000000..565843047 --- /dev/null +++ b/src/server/exec/pgf-http.hs @@ -0,0 +1,49 @@ + +import Network.CGI(requestMethod,getVarWithDefault,logCGI,handleErrors,liftIO) +import System.Environment(getArgs) +import System.Directory(getDirectoryContents) +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 Paths_gf_server(getDataDir) + +main :: IO () +main = do datadir <- getDataDir + let defaults = Options { documentRoot = datadir"www", + port = 41296 } + cache <- newPGFCache + args <- getArgs + options <- case args of + [] -> return defaults + [port] -> do p <- readIO port + return defaults{port=p} + putStrLn $ "Starting HTTP server, open http://localhost:" + ++show (port options)++"/ in your web browser.\n" + print options + putStrLn $ "logFile="++logFile + stderrToFile logFile + httpMain cache options + + +httpMain cache options = runHTTP options (do log ; serve =<< getPath) + where + log = do method <- requestMethod + uri <- getVarWithDefault "REQUEST_URI" "-" + logCGI $ method++" "++uri + + serve path = + handleErrors . handleCGIErrors $ + if takeExtension path==".pgf" + then cgiMain' cache path + else if takeFileName path=="grammars.cgi" + then grammarList (takeDirectory path) + else serveStaticFile path + + grammarList dir = + do paths <- liftIO $ getDirectoryContents dir + let pgfs = [path|path<-paths, takeExtension path==".pgf"] + outputJSONP pgfs diff --git a/src/server/gf-server.cabal b/src/server/gf-server.cabal index 49b2b8f6f..50a778aec 100644 --- a/src/server/gf-server.cabal +++ b/src/server/gf-server.cabal @@ -1,6 +1,6 @@ name: gf-server version: 1.0 -cabal-version: >= 1.2 +cabal-version: >= 1.8 build-type: Custom license: GPL license-file: ../../LICENSE @@ -16,19 +16,13 @@ flag http Description: Build pgf-http (deprecated, replaced by gf -server) Default: False -executable pgf-http - main-is: pgf-http.hs - Hs-source-dirs: . transfer - ghc-options: -threaded - if impl(ghc>=7.0) - ghc-options: -rtsopts +Library + exposed-modules: PGFService FastCGIUtils ServeStaticFile RunHTTP + other-modules: Cache URLEncoding Fold + hs-source-dirs: . transfer - if flag(http) - buildable: True - other-modules: PGFService FastCGIUtils Cache URLEncoding - RunHTTP ServeStaticFile Fold - build-depends: base >=4.2 && <5, - old-time, + build-depends: base >=4.2 && <5, + time, time-compat, directory, filepath, containers, @@ -36,23 +30,34 @@ executable pgf-http gf >= 3.1, cgi >= 3001.1.7.3, httpd-shed, + mtl, network, json >= 0.3.3, utf8-string >= 0.3.1.1, bytestring, pretty, random - if os(windows) - ghc-options: -optl-mwindows - else - build-depends: unix + if os(windows) + ghc-options: -optl-mwindows + else + build-depends: unix + +executable pgf-http + main-is: pgf-http.hs + Hs-source-dirs: exec + ghc-options: -threaded + if impl(ghc>=7.0) + ghc-options: -rtsopts + + if flag(http) + buildable: True + build-depends: base >=4.2 && <5, gf-server, filepath, directory, cgi else buildable: False executable pgf-service main-is: pgf-fcgi.hs - Hs-source-dirs: . transfer - other-modules: PGFService FastCGIUtils Cache URLEncoding Fold + Hs-source-dirs: exec ghc-options: -threaded if impl(ghc>=7.0) ghc-options: -rtsopts @@ -60,22 +65,8 @@ executable pgf-service build-depends: fastcgi >= 3001.0.2.2 -- Install it in Ubuntu with: apt-get install libghc-fastcgi-dev - build-depends: base >=4.2 && <5, - mtl, - time, - time-compat, - directory, - filepath, - containers, - process, - gf >= 3.1, - cgi >= 3001.1.7.3, - network, - json >= 0.3.3, - utf8-string >= 0.3.1.1, - bytestring, - pretty, - random + build-depends: base >=4.2 && <5, gf-server + if os(windows) ghc-options: -optl-mwindows else @@ -93,3 +84,4 @@ executable content-service buildable: False main-is: ContentService.hs + Hs-source-dirs: exec diff --git a/src/server/pgf-fcgi.hs b/src/server/pgf-fcgi.hs deleted file mode 100644 index 3b5b0b3cf..000000000 --- a/src/server/pgf-fcgi.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE CPP #-} -import Control.Concurrent(forkIO) -import Network.FastCGI(runFastCGI,runFastCGIConcurrent') - -import PGFService(cgiMain,newPGFCache,stderrToFile,logFile) -import System.IO -main = do stderrToFile logFile - fcgiMain =<< newPGFCache - - -fcgiMain cache = -#ifndef mingw32_HOST_OS - runFastCGIConcurrent' forkIO 100 (cgiMain cache) -#else - runFastCGI (cgiMain cache) -#endif diff --git a/src/server/pgf-http.hs b/src/server/pgf-http.hs deleted file mode 100644 index 565843047..000000000 --- a/src/server/pgf-http.hs +++ /dev/null @@ -1,49 +0,0 @@ - -import Network.CGI(requestMethod,getVarWithDefault,logCGI,handleErrors,liftIO) -import System.Environment(getArgs) -import System.Directory(getDirectoryContents) -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 Paths_gf_server(getDataDir) - -main :: IO () -main = do datadir <- getDataDir - let defaults = Options { documentRoot = datadir"www", - port = 41296 } - cache <- newPGFCache - args <- getArgs - options <- case args of - [] -> return defaults - [port] -> do p <- readIO port - return defaults{port=p} - putStrLn $ "Starting HTTP server, open http://localhost:" - ++show (port options)++"/ in your web browser.\n" - print options - putStrLn $ "logFile="++logFile - stderrToFile logFile - httpMain cache options - - -httpMain cache options = runHTTP options (do log ; serve =<< getPath) - where - log = do method <- requestMethod - uri <- getVarWithDefault "REQUEST_URI" "-" - logCGI $ method++" "++uri - - serve path = - handleErrors . handleCGIErrors $ - if takeExtension path==".pgf" - then cgiMain' cache path - else if takeFileName path=="grammars.cgi" - then grammarList (takeDirectory path) - else serveStaticFile path - - grammarList dir = - do paths <- liftIO $ getDirectoryContents dir - let pgfs = [path|path<-paths, takeExtension path==".pgf"] - outputJSONP pgfs -- cgit v1.2.3