remove obsolete code

1 files changed, 0 insertions, 357 deletions

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 [
-  "<!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")