diff options
Diffstat (limited to 'src/server')
| -rw-r--r-- | src/server/ContentService.hs | 98 |
1 files changed, 76 insertions, 22 deletions
diff --git a/src/server/ContentService.hs b/src/server/ContentService.hs index ef92e8cf9..c0d0a713f 100644 --- a/src/server/ContentService.hs +++ b/src/server/ContentService.hs @@ -50,15 +50,21 @@ 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 + id <- getGrammarId name <- getFileName descr <- getDescription - doUpdateGrammar c mb_pgf name descr + doUpdateGrammar c mb_pgf id name descr + Just "delete_grammar" + -> do id <- getGrammarId + doDeleteGrammar c id + Just "grammars" + -> doGrammars c + 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 -> throwCGIError 400 "No command given" ["No command given"] where @@ -70,19 +76,71 @@ cgiMain' cache path = getQuery :: CGI String getQuery = fmap (fromMaybe "") (getInput "query") - + + getGrammarId :: CGI String + getGrammarId = do + mb_url <- getInput "url" + return (maybe "null" (reverse . drop 4 . reverse) mb_url) + getFile :: CGI (Maybe BS.ByteString) - getFile = getInputFPS "file" + getFile = do + getInputFPS "file" getFileName :: CGI String getFileName = do - mb_name <- getInput "name" + 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") +doGrammars c = do + r <- liftIO $ handleSql (return . Left) $ do + s <- query c "call getGrammars()" + rows <- collectRows getGrammar s + return (Right rows) + case r of + Right rows -> outputJSONP rows + Left e -> throwCGIError 400 "Loading failed" (lines (show e)) + where + getGrammar s = do + id <- getFieldValue s "id" + name <- getFieldValue s "name" + description <- getFieldValue s "description" + return $ toJSObject [ ("url", showJSON (addExtension (show (id :: Int)) "pgf")) + , ("name", showJSON (name :: String)) + , ("description", showJSON (description :: String)) + ] + +doUpdateGrammar c mb_pgf id name descr = do + r <- liftIO $ handleSql (return . Left) $ do + s <- query c ("call updateGrammar("++id++","++toSqlValue name++","++toSqlValue descr++")") + [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 = do + r <- liftIO $ handleSql (return . Left) $ do + execute c ("call deleteGrammar("++id++")") + 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 @@ -151,20 +209,6 @@ doDelete c ids = do 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 @@ -207,3 +251,13 @@ dbInit c = " select id;\n"++ " END IF;\n"++ "END") + execute c "DROP PROCEDURE IF EXISTS deleteGrammar" + execute c ("CREATE PROCEDURE deleteGrammar(IN grammarId INTEGER)\n"++ + "BEGIN\n"++ + " DELETE FROM Grammars WHERE id = grammarId;\n"++ + "END") + execute c "DROP PROCEDURE IF EXISTS getGrammars" + execute c ("CREATE PROCEDURE getGrammars()\n"++ + "BEGIN\n"++ + " SELECT id,name,description FROM Grammars ORDER BY name;\n"++ + "END") |