summaryrefslogtreecommitdiff
path: root/src/server/exec/ContentService.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/server/exec/ContentService.hs')
-rw-r--r--src/server/exec/ContentService.hs357
1 files changed, 357 insertions, 0 deletions
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 [
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">",
+ "<html>",
+ " <head>",
+ " <meta http-equiv=\"content-type\" content=\"text/html; charset=UTF-8\">",
+ " <title>Editor</title>",
+ " <script type=\"text/javascript\" language=\"javascript\" src=\"org.grammaticalframework.ui.gwt.EditorApp/org.grammaticalframework.ui.gwt.EditorApp.nocache.js\"></script>",
+ " </head>",
+ " <body onload=\"window.__gfInit = new Object(); "++
+ maybe "" (\id -> "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++
+ "\">",
+ " <iframe src=\"javascript:''\" id=\"__gwt_historyFrame\" tabIndex='-1' style=\"position:absolute;width:0;height:0;border:0\"></iframe>",
+ " </body>",
+ "</html>"]
+
+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")
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 09:01:42 +0000