{-# 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 [ "", "", "
", " ", "