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 [ - "", - "", - " ", - " ", - " Editor", - " ", - " ", - " "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++ - "\">", - " ", - " ", - ""] - -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)