mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 11:19:32 -06:00
Merge branch 'master' of https://github.com/GrammaticalFramework/gf-core
This commit is contained in:
Thomas Hallgren
@@ -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
|
||||
|
||||
@@ -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);
|
||||
|
||||
|
||||
@@ -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)); \
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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")
|
||||
@@ -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."
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user