Merge with master and drop the Haskell runtime completely

src/server/Cache.hs

@@ -9,7 +9,7 @@ import Data.Maybe(mapMaybe)
 import System.Directory (getModificationTime)
 import System.Mem(performGC)
 import Data.Time (UTCTime,getCurrentTime,diffUTCTime)
-import Data.Time.Compat (toUTCTime)
+--import Data.Time.Compat (toUTCTime)
 
 data Cache a = Cache {
       cacheLoad :: FilePath -> IO a,
@@ -63,7 +63,7 @@ readCache' c file =
                        Nothing -> do v <- newMVar Nothing
                                      return (Map.insert file v objs, v)
     -- Check time stamp, and reload if different than the cache entry
-    readObject m = do t' <- toUTCTime `fmap` getModificationTime file
+    readObject m = do t' <- {-toUTCTime `fmap`-} getModificationTime file
                       now <- getCurrentTime
                       x' <- case m of
                               Just (t,_,x) | t' == t -> return x

src/server/FastCGIUtils.hs

@@ -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
-

src/server/PGFService.hs

@@ -3,10 +3,8 @@ module PGFService(cgiMain,cgiMain',getPath,
                   logFile,stderrToFile,
                   Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
 
-import PGF (PGF,Labels,CncLabels)
 import PGF2
 import GF.Text.Lexing
-import qualified PGF
 import Cache
 import CGIUtils(outputJSONP,outputPlain,outputHTML,outputText,
                 outputBinary,outputBinary',
@@ -62,8 +60,8 @@ data Caches = Caches { qsem :: QSem,
 
 newPGFCache jobs = do let n = maybe 4 id jobs
                       qsem <- newQSem n
-                      pgfCache <- newCache' PGF.readPGF
-                      lblCache <- newCache' (fmap PGF.getDepLabels . readFile)
+                      pgfCache <- newCache' readPGF
+                      lblCache <- newCache' (fmap getDepLabels . readFile)
                       return $ Caches qsem pgfCache lblCache
 flushPGFCache c = do flushCache (pgfCache c)
                      flushCache (labelsCache c)
@@ -108,6 +106,8 @@ pgfMain qsem command (t,pgf) =
     "parse"       -> withQSem qsem $
                        out t=<< join (parse # input % start % limit % treeopts)
     "linearize"   -> out t=<< lin # tree % to
+    "bracketedLinearize"
+                  -> out t=<< bracketedLin # tree % to
     "linearizeAll"-> out t=<< linAll # tree % to
     "translate"   -> withQSem qsem $
                        out t=<<join(trans # input % to % start % limit%treeopts)
@@ -142,7 +142,9 @@ pgfMain qsem command (t,pgf) =
       where
         bad err = ["parseFailed".=err]
         good trees = "trees".=map tp trees :[]  -- :addTrie trie trees
-        tp (tree,prob) = makeObj (addTree json tree++["prob".=prob])
+        tp (tree,prob) = makeObj ["tree".=tree
+                                 ,"prob".=prob
+                                 ]
 
     parse' start mlimit ((from,concr),input) =
         case parseWithHeuristics concr cat input (-1) callbacks of
@@ -162,6 +164,10 @@ pgfMain qsem command (t,pgf) =
     lin' tree (tos,unlex) =
         [makeObj ["to".=to,"text".=unlex (linearize c tree)]|(to,c)<-tos]
 
+    bracketedLin tree to = showJSON (bracketedLin' tree to)
+    bracketedLin' tree (tos,unlex) =
+        [makeObj ["to".=to,"brackets".=showJSON (bracketedLinearize c tree)]|(to,c)<-tos]
+
     trans input@((from,_),_) to start mlimit (trie,jsontree) =
       do parses <- parse' start mlimit input
          return $
@@ -171,9 +177,9 @@ pgfMain qsem command (t,pgf) =
         jsonParses = either bad good
           where
             bad err = [makeObj ["error".=err]]
-            good parses = [makeObj (addTree jsontree tree++
-                                    ["prob".=prob,
-                                     "linearizations".=lin' tree to])
+            good parses = [makeObj ["tree".=tree
+                                   ,"prob".=prob
+                                   ,"linearizations".=lin' tree to]
                                     | (tree,prob) <- parses]
 
     morpho (from,concr) input =
@@ -465,8 +471,8 @@ doLookupMorpho pgf from input =
     ms = PGF.lookupMorpho (PGF.buildMorpho pgf from) input
 
 -}
-type From = (Maybe PGF.Language,String)
-type To = ([PGF.Language],Unlexer)
+type From = (Maybe Concr,String)
+type To = ([Concr],Unlexer)
 type TreeOpts = (Bool,Bool) -- (trie,jsontree)
 {-
 doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> TreeOpts -> JSValue
@@ -560,10 +566,7 @@ doParse pgf (mfrom,input) mcat mlimit (trie,jsontree) = showJSON $ map makeObj
 
 addTrie trie trees =
     ["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie]
--}
-addTree json tree = "tree".=showTree tree:
-                    ["jsontree".= jsonExpr tree | json]
-{-
+
 doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue
 doComplete pgf (mfrom,input) mcat mlimit full = showJSON
     [makeObj (
@@ -849,107 +852,34 @@ doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format
     annotatePrintNames = "<DL>"++(unwords pns)++"</DL>"
       where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | lang <- PGF.languages pgf ]
 -}
-class ToATree a where 
-  showTree :: a -> String
-  toATree :: a -> PGF.ATree a
 
-instance ToATree PGF.Expr where
-  showTree = PGF.showExpr []
-  toATree = PGF.toATree
+instance JSON Expr where
+    readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . readExpr
+    showJSON = showJSON . showExpr []
 
--- | Render trees as JSON with numbered functions
-jsonExpr e = evalState (expr (toATree e)) 0
-  where
-    expr e =
-      case e of
-        PGF.Other e -> return (makeObj ["other".=e])
-        PGF.App f es ->
-                do js <- mapM expr es
-                   let children=["children".=js | not (null js)]
-                   i<-inc
-                   return $ makeObj (["fun".=f,"fid".=i]++children)
-
-    inc :: State Int Int
-    inc = do i <- get; put (i+1); return i
-
-instance JSON PGF.Trie where
-    showJSON (PGF.Oth e) = makeObj ["other".=e]
-    showJSON (PGF.Ap f [[]]) = makeObj ["fun".=f] -- leaf
---  showJSON (PGF.Ap f [es]) = makeObj ["fun".=f,"children".=es] -- one alternative
-    showJSON (PGF.Ap f alts) = makeObj ["fun".=f,"alts".=alts]
-
-instance JSON PGF.CId where
-    readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage
-    showJSON = showJSON . PGF.showLanguage
-
-instance JSON PGF.Expr where
-    readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . PGF.readExpr
-    showJSON = showJSON . PGF.showExpr []
-
-instance JSON PGF.BracketedString where
-    readJSON x = return (PGF.Leaf "")
-    showJSON (PGF.Bracket cat fid index fun bs) =
+instance JSON BracketedString where
+    readJSON x = return (Leaf "")
+    showJSON (Bracket cat fid index fun bs) =
         makeObj ["cat".=cat, "fid".=fid, "index".=index, "fun".=fun, "children".=bs]
-    showJSON (PGF.Leaf s) = makeObj ["token".=s]
+    showJSON (Leaf s) = makeObj ["token".=s]
 
 -- * PGF utilities
-{-
-cat :: PGF -> Maybe PGF.Type -> PGF.Type
-cat pgf mcat = fromMaybe (PGF.startCat pgf) mcat
--}
-parse' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,PGF.ParseOutput,PGF.BracketedString)]
-parse' pgf input mcat mfrom = 
-   [(from,po,bs) | from <- froms, (po,bs) <- [PGF.parse_ pgf from cat Nothing input]]
-  where froms = maybe (PGF.languages pgf) (:[]) mfrom
-        cat = fromMaybe (PGF.startCat pgf) mcat
-
-complete' :: PGF -> PGF.Language -> PGF.Type -> Maybe Int -> String
-         -> (PGF.BracketedString, String, Map.Map PGF.Token [PGF.CId])
-complete' pgf from typ mlimit input =
-  let (ws,prefix) = tokensAndPrefix input
-  in PGF.complete pgf from typ (unwords ws) prefix
-  where
-    tokensAndPrefix :: String -> ([String],String)
-    tokensAndPrefix s | not (null s) && isSpace (last s) = (ws, "")
-                      | null ws = ([],"")
-                      | otherwise = (init ws, last ws)
-        where ws = words s
-
 
 transfer lang = if "LaTeX" `isSuffixOf` show lang
                 then fold -- OpenMath LaTeX transfer
                 else id
 
--- | tabulate all variants and their forms
-linearizeTabular
-  :: PGF -> To -> PGF.Tree -> [(PGF.Language,[(String,[String])])]
-linearizeTabular pgf (tos,unlex) tree =
-    [(to,lintab to (transfer to tree)) | to <- langs]
-  where
-    langs = if null tos then PGF.languages pgf else tos
-    lintab to t = [(p,map unlex (nub [t|(p',t)<-vs,p'==p]))|p<-ps]
-      where
-        ps = nub (map fst vs)
-        vs = concat (PGF.tabularLinearizes pgf to t)
-
-linearizeAndUnlex pgf (mto,unlex) tree =
-    [(to,s,bss) | to<-langs,
-                 let bss = PGF.bracketedLinearize pgf to (transfer to tree)
-                     s   = unlex . unwords $ concatMap PGF.flattenBracketedString bss]
-  where
-    langs = if null mto then PGF.languages pgf else mto
-
-selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language
+selectLanguage :: PGF -> Maybe (Accept Language) -> Concr
 selectLanguage pgf macc = case acceptable of
-                            []  -> case PGF.languages pgf of
+                            []  -> case Map.elems (languages pgf) of
                                      []  -> error "No concrete syntaxes in PGF grammar."
                                      l:_ -> l
                             Language c:_ -> fromJust (langCodeLanguage pgf c)
-  where langCodes = mapMaybe (PGF.languageCode pgf) (PGF.languages pgf)
+  where langCodes = mapMaybe languageCode (Map.elems (languages pgf))
         acceptable = negotiate (map Language langCodes) macc
 
-langCodeLanguage :: PGF -> String -> Maybe PGF.Language
-langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languageCode pgf l == Just code]
+langCodeLanguage :: PGF -> String -> Maybe Concr
+langCodeLanguage pgf code = listToMaybe [concr | concr <- Map.elems (languages pgf), languageCode concr == Just code]
 
 -- * General utilities
 

src/server/exec/ContentService.hs

@@ -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")

src/server/exec/MorphoService.hs

@@ -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."
-

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)
 

src/server/gf-server.cabal

@@ -1,118 +0,0 @@
-name: gf-server
-version: 1.0
-cabal-version: >= 1.8
-build-type: Custom
-license: GPL
-license-file: ../../LICENSE
-synopsis: FastCGI Server for Grammatical Framework
-
-flag content
-  Description:
-      Build content service (requires fastcgi and hsql-mysql packages)
-      (In Ubuntu: apt-get install libghc-fastcgi-dev libghc-hsql-mysql-dev)
-  Default:     False
-
-flag http
-  Description: Build pgf-http (deprecated, replaced by gf -server)
-  Default: False
-
-flag fastcgi
-  Description: Build librar & pgf-service executable with fastcgi support
-  Default: True
-
-flag c-runtime
-  Description: Include functionality from the C run-time library (which must be installed already)
-  Default:     False
-
-flag network-uri
-   description: Get Network.URI from the network-uri package
-   default: True
-
-Library
-  exposed-modules: PGFService FastCGIUtils CGIUtils ServeStaticFile RunHTTP Cache
-  other-modules: URLEncoding CGI Fold
-  hs-source-dirs: . transfer
-
-  if flag(fastcgi)
-    build-depends: fastcgi >= 3001.0.2.2
-       -- Install it in Ubuntu with: apt-get install libghc-fastcgi-dev
-  else
-    Buildable: False
-
-  build-depends:   base >=4.2 && <5,
-                   time, time-compat, old-locale,
-                   directory,
-                   filepath,
-                   containers,
-                   process,
-                   gf >= 3.6,
-                   cgi >= 3001.1.7.3,
-                   httpd-shed>=0.4.0.2,
-                   mtl,
-                   exceptions,
-                   json >= 0.3.3,
-                   utf8-string >= 0.3.1.1,
-                   bytestring,
-                   pretty,
-                   random
-
-  if flag(network-uri)
-    build-depends: network-uri>=2.6, network>=2.6
-  else
-    build-depends: network>=2.3 && <2.6
-
-  ghc-options: -fwarn-unused-imports
-  if os(windows)
-    ghc-options: -optl-mwindows
-  else
-    build-depends: unix
-
-  if flag(c-runtime)
-    cpp-options: -DC_RUNTIME
-
-executable pgf-http
-  main-is: pgf-http.hs
-  Hs-source-dirs: exec
-  ghc-options: -threaded
-  if impl(ghc>=7.0)
-    ghc-options: -rtsopts
-
-  if flag(http)
-    buildable: True
-    build-depends: base >=4.2 && <5, gf-server, filepath, directory, cgi
-  else
-    buildable: False
-
-executable pgf-service
-  main-is: pgf-fcgi.hs
-  Hs-source-dirs: exec
-  ghc-options: -threaded -fwarn-unused-imports
-  if impl(ghc>=7.0)
-    ghc-options: -rtsopts
-
-  if flag(fastcgi)
-    build-depends: fastcgi >= 3001.0.2.2
-       -- Install it in Ubuntu with: apt-get install libghc-fastcgi-dev
-  else
-    Buildable: False
-
-  build-depends: base >=4.2 && <5, gf-server
-
-  if os(windows)
-    ghc-options: -optl-mwindows
-  else
-    build-depends: unix
-
-executable content-service
-  if flag(content)
-    build-depends: base >=4.2 && <5, old-locale,
-                   fastcgi >= 3001.0.2.2,
-                       -- In Ubuntu: apt-get install libghc-fastcgi-dev
-                   hsql-mysql, hsql
-                       -- In Ubuntu: apt-get install libghc-hsql-mysql-dev
-    buildable: True
-  else
-    buildable: False
-
-  main-is: ContentService.hs
-  Hs-source-dirs: exec

src/server/lighttpd.conf

@@ -1,4 +1,4 @@
-# Run with (with -D for no-daemon) 
+# Run with (with -D for no-daemon)
 # /usr/sbin/lighttpd -f lighttpd.conf -D
 #
 
@@ -10,8 +10,9 @@ server.modules              = (
                                 "mod_cgi"
                               )
 
-var.basedir = var.CWD 
+var.basedir = var.CWD
 
+# John: no longer valid after removing `src/ui` 2018-11-15
 server.document-root        = basedir + "/../ui/gwt/www"
 
 server.errorlog             = basedir + "/error.log"
@@ -96,4 +97,3 @@ static-file.exclude-extensions = ( ".php", ".pl", ".fcgi" )
 
 ## bind to port (default: 80)
 server.port                = 41296
-