diff --git a/src/server/ContentService.hs b/src/server/ContentService.hs new file mode 100644 index 000000000..ef92e8cf9 --- /dev/null +++ b/src/server/ContentService.hs @@ -0,0 +1,209 @@ +{-# 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 System.Environment(getArgs) +import System.Time +import System.Locale +import System.FilePath +import Database.HSQL.MySQL + +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 "save" -> doSave c =<< getId + Just "load" -> doLoad c =<< getId + Just "search" -> doSearch c =<< getQuery + Just "delete" -> doDelete c =<< getIds + Just "update_grammar" + -> do mb_pgf <- getFile + name <- getFileName + descr <- getDescription + doUpdateGrammar c mb_pgf name descr + Just cmd -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show cmd] + Nothing -> throwCGIError 400 "No command given" ["No command given"] + where + getId :: CGI (Maybe Int) + getId = readInput "id" + + getIds :: CGI [Int] + getIds = fmap (map read) (getMultiInput "id") + + getQuery :: CGI String + getQuery = fmap (fromMaybe "") (getInput "query") + + getFile :: CGI (Maybe BS.ByteString) + getFile = getInputFPS "file" + + getFileName :: CGI String + getFileName = do + mb_name <- getInput "name" + mb_file <- getInputFilename "file" + return (fromMaybe "" (mb_name `mplus` mb_file)) + + getDescription :: CGI String + getDescription = fmap (fromMaybe "") (getInput "description") + +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)])) + +doUpdateGrammar c mb_pgf name descr = do + r <- liftIO $ handleSql (return . Left) $ do + s <- query c ("call updateGrammar(null,"++toSqlValue name++","++toSqlValue descr++")") + [id] <- collectRows (\s -> getFieldValue s "id") s + return (Right id) + id <- 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 -> liftIO (BS.writeFile (path ".." "grammars" addExtension (show id) "pgf") pgf) + Nothing -> return () + outputHTML "

Done.

" + +dbConnect fpath = do + [host,db,user,pwd] <- fmap words $ readFile fpath + connect host db user pwd + +dbInit c = + handleSql (fail . show) $ do + inTransaction c $ \c -> do + execute c "DROP TABLE IF EXISTS Documents" + 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 "DROP TABLE IF EXISTS Grammars" + 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 "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))\n"++ + "BEGIN\n"++ + " IF id IS NULL THEN\n"++ + " INSERT INTO Grammars(name,description,created,modified) VALUES (name,description,NOW(),NOW());\n"++ + " SELECT LAST_INSERT_ID() as id;\n"++ + " ELSE\n"++ + " UPDATE Grammars gr SET name = name, description=description, modified=NOW() WHERE gr.id = id;\n"++ + " select id;\n"++ + " END IF;\n"++ + "END") diff --git a/src/server/gf-server.cabal b/src/server/gf-server.cabal index fe7ad17c8..b993294d3 100644 --- a/src/server/gf-server.cabal +++ b/src/server/gf-server.cabal @@ -3,14 +3,40 @@ version: 1.0 cabal-version: >= 1.2 build-type: Custom license: GPL -license-file: LICENSE +license-file: ../../LICENSE synopsis: FastCGI Server for Grammatical Framework flag fastcgi - Description: Build pgf-fcgi (requires the fastcgi package) + Description: Build the fcgi services (requires the fastcgi package) Default: True -executable pgf-fcgi +executable pgf-http + main-is: pgf-http.hs + other-modules: PGFService FastCGIUtils Cache URLEncoding + RunHTTP ServeStaticFile + ghc-options: -threaded + + build-depends: base >=4.2 && <5, + old-time, + directory, + filepath, + containers, + process, + gf >= 3.1, + cgi >= 3001.1.8.0, + httpd-shed, + 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 + +executable pgf-service main-is: pgf-fcgi.hs other-modules: PGFService FastCGIUtils Cache URLEncoding ghc-options: -threaded @@ -40,34 +66,13 @@ executable pgf-fcgi else build-depends: unix - -executable pgf-http - main-is: pgf-http.hs - other-modules: PGFService FastCGIUtils Cache URLEncoding - RunHTTP ServeStaticFile - ghc-options: -threaded +executable content-service + if flag(fastcgi) + build-depends: fastcgi >= 3001.0.2.2 + buildable: True + else + buildable: False build-depends: base >=4.2 && <5, - old-time, - directory, - filepath, - containers, - process, - gf >= 3.1, - cgi >= 3001.1.8.0, - httpd-shed, - 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 - -executable content-server - buildable: False - build-depends: base >=4.2 && <5 + hsql, hsql-mysql, old-locale main-is: ContentService.hs