src/server/gf-server.cabal: compile it as a common library + executables

4 files changed, 510 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")
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