summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/example-based/gf-exb.cabal4
-rw-r--r--src/runtime/c/gu/map.c107
-rw-r--r--src/runtime/c/gu/map.h3
-rw-r--r--src/runtime/c/pgf/parser.c4
-rw-r--r--src/server/FastCGIUtils.hs110
-rw-r--r--src/server/exec/ContentService.hs357
-rw-r--r--src/server/exec/MorphoService.hs88
-rw-r--r--src/server/exec/pgf-http.hs2
8 files changed, 68 insertions, 607 deletions
diff --git a/src/example-based/gf-exb.cabal b/src/example-based/gf-exb.cabal
index 1366e75da..1ca75c5ec 100644
--- a/src/example-based/gf-exb.cabal
+++ b/src/example-based/gf-exb.cabal
@@ -9,7 +9,7 @@ executable exb.fcgi
main-is: exb-fcgi.hs
Hs-source-dirs: . ../server ../compiler ../runtime/haskell
other-modules: ExampleService ExampleDemo
- FastCGIUtils Cache GF.Compile.ToAPI
+ CGIUtils Cache GF.Compile.ToAPI
-- and a lot more...
ghc-options: -threaded
if impl(ghc>=7.0)
@@ -17,7 +17,7 @@ executable exb.fcgi
build-depends: base >=4.2 && <5, json, cgi, fastcgi, random,
containers, old-time, directory, bytestring, utf8-string,
- pretty, array, mtl, fst, filepath
+ pretty, array, mtl, time, filepath
if os(windows)
ghc-options: -optl-mwindows
diff --git a/src/runtime/c/gu/map.c b/src/runtime/c/gu/map.c
index 9abebbe6e..7b61fa096 100644
--- a/src/runtime/c/gu/map.c
+++ b/src/runtime/c/gu/map.c
@@ -7,6 +7,9 @@
typedef struct GuMapData GuMapData;
+#define SKIP_DELETED 1
+#define SKIP_NONE 2
+
struct GuMapData {
uint8_t* keys;
uint8_t* values;
@@ -19,6 +22,7 @@ struct GuMap {
GuHasher* hasher;
size_t key_size;
size_t value_size;
+ size_t cell_size; // cell_size = GU_MAX(value_size,sizeof(uint8_t))
const void* default_value;
GuMapData data;
@@ -30,9 +34,7 @@ gu_map_finalize(GuFinalizer* fin)
{
GuMap* map = gu_container(fin, GuMap, fin);
gu_mem_buf_free(map->data.keys);
- if (map->value_size) {
- gu_mem_buf_free(map->data.values);
- }
+ gu_mem_buf_free(map->data.values);
}
static const GuWord gu_map_empty_key = 0;
@@ -68,7 +70,7 @@ gu_map_entry_is_free(GuMap* map, GuMapData* data, size_t idx)
}
static bool
-gu_map_lookup(GuMap* map, const void* key, size_t* idx_out)
+gu_map_lookup(GuMap* map, const void* key, uint8_t del, size_t* idx_out)
{
size_t n = map->data.n_entries;
if (map->hasher == gu_addr_hasher) {
@@ -78,13 +80,17 @@ gu_map_lookup(GuMap* map, const void* key, size_t* idx_out)
while (true) {
const void* entry_key =
((const void**)map->data.keys)[idx];
+
if (entry_key == NULL && map->data.zero_idx != idx) {
- *idx_out = idx;
- return false;
+ if (map->data.values[idx * map->cell_size] != del) { //skip deleted
+ *idx_out = idx;
+ return false;
+ }
} else if (entry_key == key) {
*idx_out = idx;
return true;
}
+
idx = (idx + offset) % n;
}
} else if (map->hasher == gu_word_hasher) {
@@ -156,33 +162,18 @@ gu_map_resize(GuMap* map, size_t req_entries)
size_t key_size = map->key_size;
size_t key_alloc = 0;
data->keys = gu_mem_buf_alloc(req_entries * key_size, &key_alloc);
+ memset(data->keys, 0, key_alloc);
- size_t value_size = map->value_size;
size_t value_alloc = 0;
- if (value_size) {
- data->values = gu_mem_buf_alloc(req_entries * value_size,
- &value_alloc);
- memset(data->values, 0, value_alloc);
- }
-
- data->n_entries = gu_twin_prime_inf(value_size ?
- GU_MIN(key_alloc / key_size,
- value_alloc / value_size)
- : key_alloc / key_size);
- if (map->hasher == gu_addr_hasher) {
- for (size_t i = 0; i < data->n_entries; i++) {
- ((const void**)data->keys)[i] = NULL;
- }
- } else if (map->hasher == gu_string_hasher) {
- for (size_t i = 0; i < data->n_entries; i++) {
- ((GuString*)data->keys)[i] = NULL;
- }
- } else {
- memset(data->keys, 0, key_alloc);
- }
+ size_t cell_size = map->cell_size;
+ data->values = gu_mem_buf_alloc(req_entries * cell_size, &value_alloc);
+ memset(data->values, 0, value_alloc);
+ data->n_entries = gu_twin_prime_inf(
+ GU_MIN(key_alloc / key_size,
+ value_alloc / cell_size));
gu_assert(data->n_entries > data->n_occupied);
-
+
data->n_occupied = 0;
data->zero_idx = SIZE_MAX;
@@ -196,16 +187,14 @@ gu_map_resize(GuMap* map, size_t req_entries)
} else if (map->hasher == gu_string_hasher) {
old_key = (void*) *(GuString*)old_key;
}
- void* old_value = &old_data.values[i * value_size];
+ void* old_value = &old_data.values[i * cell_size];
memcpy(gu_map_insert(map, old_key),
old_value, map->value_size);
}
gu_mem_buf_free(old_data.keys);
- if (value_size) {
- gu_mem_buf_free(old_data.values);
- }
+ gu_mem_buf_free(old_data.values);
}
@@ -226,9 +215,9 @@ GU_API void*
gu_map_find(GuMap* map, const void* key)
{
size_t idx;
- bool found = gu_map_lookup(map, key, &idx);
+ bool found = gu_map_lookup(map, key, SKIP_DELETED, &idx);
if (found) {
- return &map->data.values[idx * map->value_size];
+ return &map->data.values[idx * map->cell_size];
}
return NULL;
}
@@ -244,7 +233,7 @@ GU_API const void*
gu_map_find_key(GuMap* map, const void* key)
{
size_t idx;
- bool found = gu_map_lookup(map, key, &idx);
+ bool found = gu_map_lookup(map, key, SKIP_DELETED, &idx);
if (found) {
return &map->data.keys[idx * map->key_size];
}
@@ -255,17 +244,17 @@ GU_API bool
gu_map_has(GuMap* ht, const void* key)
{
size_t idx;
- return gu_map_lookup(ht, key, &idx);
+ return gu_map_lookup(ht, key, SKIP_DELETED, &idx);
}
GU_API void*
gu_map_insert(GuMap* map, const void* key)
{
size_t idx;
- bool found = gu_map_lookup(map, key, &idx);
+ bool found = gu_map_lookup(map, key, SKIP_NONE, &idx);
if (!found) {
if (gu_map_maybe_resize(map)) {
- found = gu_map_lookup(map, key, &idx);
+ found = gu_map_lookup(map, key, SKIP_NONE, &idx);
gu_assert(!found);
}
if (map->hasher == gu_addr_hasher) {
@@ -277,7 +266,7 @@ gu_map_insert(GuMap* map, const void* key)
key, map->key_size);
}
if (map->default_value) {
- memcpy(&map->data.values[idx * map->value_size],
+ memcpy(&map->data.values[idx * map->cell_size],
map->default_value, map->value_size);
}
if (gu_map_entry_is_free(map, &map->data, idx)) {
@@ -286,7 +275,32 @@ gu_map_insert(GuMap* map, const void* key)
}
map->data.n_occupied++;
}
- return &map->data.values[idx * map->value_size];
+ return &map->data.values[idx * map->cell_size];
+}
+
+GU_API void
+gu_map_delete(GuMap* map, const void* key)
+{
+ size_t idx;
+ bool found = gu_map_lookup(map, key, SKIP_NONE, &idx);
+ if (found) {
+ if (map->hasher == gu_addr_hasher) {
+ ((const void**)map->data.keys)[idx] = NULL;
+ } else if (map->hasher == gu_string_hasher) {
+ ((GuString*)map->data.keys)[idx] = NULL;
+ } else {
+ memset(&map->data.keys[idx * map->key_size],
+ 0, map->key_size);
+ }
+ map->data.values[idx * map->cell_size] = SKIP_DELETED;
+
+ if (gu_map_buf_is_zero(&map->data.keys[idx * map->key_size],
+ map->key_size)) {
+ map->data.zero_idx = SIZE_MAX;
+ }
+
+ map->data.n_occupied--;
+ }
}
GU_API void
@@ -297,7 +311,7 @@ gu_map_iter(GuMap* map, GuMapItor* itor, GuExn* err)
continue;
}
const void* key = &map->data.keys[i * map->key_size];
- void* value = &map->data.values[i * map->value_size];
+ void* value = &map->data.values[i * map->cell_size];
if (map->hasher == gu_addr_hasher) {
key = *(const void* const*) key;
} else if (map->hasher == gu_string_hasher) {
@@ -326,7 +340,7 @@ gu_map_enum_next(GuEnum* self, void* to, GuPool* pool)
continue;
}
en->x.key = &en->ht->data.keys[i * en->ht->key_size];
- en->x.value = &en->ht->data.values[i * en->ht->value_size];
+ en->x.value = &en->ht->data.values[i * en->ht->cell_size];
if (en->ht->hasher == gu_addr_hasher) {
en->x.key = *(const void* const*) en->x.key;
} else if (en->ht->hasher == gu_string_hasher) {
@@ -336,7 +350,7 @@ gu_map_enum_next(GuEnum* self, void* to, GuPool* pool)
*((GuMapKeyValue**) to) = &en->x;
break;
}
-
+
en->i = i+1;
}
@@ -363,8 +377,6 @@ gu_map_count(GuMap* map)
return count;
}
-static const uint8_t gu_map_no_values[1] = { 0 };
-
GU_API GuMap*
gu_make_map(size_t key_size, GuHasher* hasher,
size_t value_size, const void* default_value,
@@ -375,7 +387,7 @@ gu_make_map(size_t key_size, GuHasher* hasher,
.n_occupied = 0,
.n_entries = 0,
.keys = NULL,
- .values = value_size ? NULL : (uint8_t*) gu_map_no_values,
+ .values = NULL,
.zero_idx = SIZE_MAX
};
GuMap* map = gu_new(GuMap, pool);
@@ -384,6 +396,7 @@ gu_make_map(size_t key_size, GuHasher* hasher,
map->data = data;
map->key_size = key_size;
map->value_size = value_size;
+ map->cell_size = GU_MAX(value_size,sizeof(uint8_t));
map->fin.fn = gu_map_finalize;
gu_pool_finally(pool, &map->fin);
diff --git a/src/runtime/c/gu/map.h b/src/runtime/c/gu/map.h
index ffd937a01..aaea06a08 100644
--- a/src/runtime/c/gu/map.h
+++ b/src/runtime/c/gu/map.h
@@ -62,6 +62,9 @@ gu_map_has(GuMap* ht, const void* key);
GU_API_DECL void*
gu_map_insert(GuMap* ht, const void* key);
+GU_API_DECL void
+gu_map_delete(GuMap* ht, const void* key);
+
#define gu_map_put(MAP, KEYP, V, VAL) \
GU_BEGIN \
V* gu_map_put_p_ = gu_map_insert((MAP), (KEYP)); \
diff --git a/src/runtime/c/pgf/parser.c b/src/runtime/c/pgf/parser.c
index be672d571..428ec9f1e 100644
--- a/src/runtime/c/pgf/parser.c
+++ b/src/runtime/c/pgf/parser.c
@@ -1159,7 +1159,7 @@ pgf_parsing_scan(PgfParsing *ps)
PgfParseState* state =
pgf_new_parse_state(ps, 0, BIND_SOFT);
- while (state != NULL) {
+ while (state->end_offset < len) {
if (state->needs_bind) {
// We have encountered two tokens without space in between.
// Those can be accepted only if there is a BIND token
@@ -1177,7 +1177,7 @@ pgf_parsing_scan(PgfParsing *ps)
// skip one character and try again
GuString s = ps->sentence+state->end_offset;
gu_utf8_decode((const uint8_t**) &s);
- pgf_new_parse_state(ps, ps->sentence-s, BIND_NONE);
+ pgf_new_parse_state(ps, s-ps->sentence, BIND_NONE);
}
if (state == ps->before)
diff --git a/src/server/FastCGIUtils.hs b/src/server/FastCGIUtils.hs
deleted file mode 100644
index 5a61d5282..000000000
--- a/src/server/FastCGIUtils.hs
+++ /dev/null
@@ -1,110 +0,0 @@
-{-# LANGUAGE CPP #-}
-module FastCGIUtils(initFastCGI,loopFastCGI) where
-
-import Control.Concurrent(ThreadId,myThreadId)
-import Control.Exception(ErrorCall(..),throw,throwTo,catch)
-import Control.Monad(when,liftM,liftM2)
-import Data.IORef(IORef,newIORef,readIORef,writeIORef)
-import Prelude hiding (catch)
-import System.Environment(getArgs,getProgName)
-import System.Exit(ExitCode(..),exitWith)
-import System.IO(hPutStrLn,stderr)
-import System.IO.Unsafe(unsafePerformIO)
-#ifndef mingw32_HOST_OS
-import System.Posix
-#endif
-
-import Network.FastCGI
-
-import CGIUtils(logError)
-
- -- There are used in MorphoService.hs, but not in PGFService.hs
-initFastCGI :: IO ()
-initFastCGI = installSignalHandlers
-
-loopFastCGI :: CGI CGIResult -> IO ()
-loopFastCGI f =
- do (do runOneFastCGI f
- exitIfToldTo
- restartIfModified)
- `catchAborted` logError "Request aborted"
- loopFastCGI f
-
--- Signal handling for FastCGI programs.
-
-#ifndef mingw32_HOST_OS
-installSignalHandlers :: IO ()
-installSignalHandlers =
- do t <- myThreadId
- installHandler sigUSR1 (Catch gracefulExit) Nothing
- installHandler sigTERM (Catch gracelessExit) Nothing
- installHandler sigPIPE (Catch (requestAborted t)) Nothing
- return ()
-
-requestAborted :: ThreadId -> IO ()
-requestAborted t = throwTo t (ErrorCall "**aborted**")
-
-gracelessExit :: IO ()
-gracelessExit = do logError "Graceless exit"
- exitWith ExitSuccess
-
-gracefulExit :: IO ()
-gracefulExit =
- do logError "Graceful exit"
- writeIORef shouldExit True
-#else
-installSignalHandlers :: IO ()
-installSignalHandlers = return ()
-#endif
-
-exitIfToldTo :: IO ()
-exitIfToldTo =
- do b <- readIORef shouldExit
- when b $ do logError "Exiting..."
- exitWith ExitSuccess
-
-{-# NOINLINE shouldExit #-}
-shouldExit :: IORef Bool
-shouldExit = unsafePerformIO $ newIORef False
-
-catchAborted :: IO a -> IO a -> IO a
-catchAborted x y = x `catch` \e -> case e of
- ErrorCall "**aborted**" -> y
- _ -> throw e
-
--- Restart handling for FastCGI programs.
-
-#ifndef mingw32_HOST_OS
-{-# NOINLINE myModTimeRef #-}
-myModTimeRef :: IORef EpochTime
-myModTimeRef = unsafePerformIO (getProgModTime >>= newIORef)
-
--- FIXME: doesn't get directory
-myProgPath :: IO FilePath
-myProgPath = getProgName
-
-getProgModTime :: IO EpochTime
-getProgModTime = liftM modificationTime (myProgPath >>= getFileStatus)
-
-needsRestart :: IO Bool
-needsRestart = liftM2 (/=) (readIORef myModTimeRef) getProgModTime
-
-exitIfModified :: IO ()
-exitIfModified =
- do restart <- needsRestart
- when restart $ exitWith ExitSuccess
-
-restartIfModified :: IO ()
-restartIfModified =
- do restart <- needsRestart
- when restart $ do prog <- myProgPath
- args <- getArgs
- hPutStrLn stderr $ prog ++ " has been modified, restarting ..."
- -- FIXME: setCurrentDirectory?
- executeFile prog False args Nothing
-
-#else
-restartIfModified :: IO ()
-restartIfModified = return ()
-#endif
-
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")
diff --git a/src/server/exec/MorphoService.hs b/src/server/exec/MorphoService.hs
deleted file mode 100644
index 5c173c868..000000000
--- a/src/server/exec/MorphoService.hs
+++ /dev/null
@@ -1,88 +0,0 @@
-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-http.hs b/src/server/exec/pgf-http.hs
index 565843047..38ea588ff 100644
--- a/src/server/exec/pgf-http.hs
+++ b/src/server/exec/pgf-http.hs
@@ -7,7 +7,7 @@ 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 CGIUtils(outputJSONP,handleCGIErrors)
import Paths_gf_server(getDataDir)
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:48:45 +0000