tweak gf-server.cabal

2 files changed, 232 insertions, 18 deletions

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 "<H1>Done.</H1>"
+
+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,24 +3,19 @@ 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
-  main-is: pgf-fcgi.hs
+executable pgf-http
+  main-is: pgf-http.hs
   other-modules: PGFService FastCGIUtils Cache URLEncoding
+                 RunHTTP ServeStaticFile
   ghc-options: -threaded
 
-  if flag(fastcgi)
-    build-depends: fastcgi >= 3001.0.2.2
-    buildable: True
-  else
-    buildable: False
-
   build-depends: base >=4.2 && <5,
                  old-time,
                  directory,
@@ -29,6 +24,7 @@ executable pgf-fcgi
                  process,
                  gf >= 3.1,
                  cgi >= 3001.1.8.0,
+                 httpd-shed,
                  network,
                  json >= 0.3.3,
                  utf8-string >= 0.3.1.1,
@@ -40,13 +36,17 @@ executable pgf-fcgi
   else
     build-depends: unix
 
-
-executable pgf-http
-  main-is: pgf-http.hs
+executable pgf-service
+  main-is: pgf-fcgi.hs
   other-modules: PGFService FastCGIUtils Cache URLEncoding
-                 RunHTTP ServeStaticFile
   ghc-options: -threaded
 
+  if flag(fastcgi)
+    build-depends: fastcgi >= 3001.0.2.2
+    buildable: True
+  else
+    buildable: False
+
   build-depends: base >=4.2 && <5,
                  old-time,
                  directory,
@@ -55,7 +55,6 @@ executable pgf-http
                  process,
                  gf >= 3.1,
                  cgi >= 3001.1.8.0,
-                 httpd-shed,
                  network,
                  json >= 0.3.3,
                  utf8-string >= 0.3.1.1,
@@ -67,7 +66,13 @@ executable pgf-http
   else
     build-depends: unix
 
-executable content-server
-  buildable: False
-  build-depends: base >=4.2 && <5
+executable content-service
+  if flag(fastcgi)
+    build-depends: fastcgi >= 3001.0.2.2
+    buildable: True
+  else
+    buildable: False
+
+  build-depends: base >=4.2 && <5,
+                 hsql, hsql-mysql, old-locale
   main-is: ContentService.hs