mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-30 06:52:49 -06:00
restore the FastCGI service and move some files back to src/server
This commit is contained in:
Krasimir Angelov
@@ -1,72 +0,0 @@
|
||||
-- | A file cache to avoid reading and parsing the same file many times
|
||||
module GF.Infra.Cache (Cache,newCache,flushCache,expireCache,listCache,readCache,readCache') where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Foldable as T(mapM_)
|
||||
import Data.Maybe(mapMaybe)
|
||||
import System.Directory (getModificationTime)
|
||||
import System.Mem(performGC)
|
||||
import Data.Time (UTCTime,getCurrentTime,diffUTCTime)
|
||||
--import Data.Time.Compat (toUTCTime)
|
||||
|
||||
data Cache a = Cache {
|
||||
cacheLoad :: Maybe a -> FilePath -> IO a,
|
||||
cacheObjects :: MVar (Map FilePath (MVar (Maybe (FileInfo a))))
|
||||
}
|
||||
|
||||
type FileInfo a = (UTCTime,UTCTime,a) -- modification time, access time, contents
|
||||
|
||||
-- | Create a new cache that uses the given function to read and parse files
|
||||
newCache :: (Maybe a -> FilePath -> IO a) -> IO (Cache a)
|
||||
newCache load =
|
||||
do objs <- newMVar Map.empty
|
||||
return $ Cache { cacheLoad = load, cacheObjects = objs }
|
||||
|
||||
-- | Forget all cached objects
|
||||
flushCache :: Cache a -> IO ()
|
||||
flushCache c = do modifyMVar_ (cacheObjects c) (const (return Map.empty))
|
||||
performGC
|
||||
|
||||
-- | Forget cached objects that have been unused for longer than the given time
|
||||
expireCache age c =
|
||||
do now <- getCurrentTime
|
||||
let expire object@(Just (_,t,_)) | diffUTCTime now t>age = return Nothing
|
||||
expire object = return object
|
||||
withMVar (cacheObjects c) (T.mapM_ (flip modifyMVar_ expire))
|
||||
performGC
|
||||
|
||||
-- | List currently cached files
|
||||
listCache :: Cache a -> IO [(FilePath,UTCTime)]
|
||||
listCache c =
|
||||
fmap (mapMaybe id) . mapM check . Map.toList =<< readMVar (cacheObjects c)
|
||||
where
|
||||
check (path,v) = maybe Nothing (Just . (,) path . fst3) `fmap` readMVar v
|
||||
|
||||
fst3 (x,y,z) = x
|
||||
|
||||
-- | Lookup a cached object (or read the file if it is not in the cache or if
|
||||
-- it has been modified)
|
||||
readCache :: Cache a -> FilePath -> IO a
|
||||
readCache c file = snd `fmap` readCache' c file
|
||||
|
||||
-- | Like 'readCache', but also return the last modification time of the file
|
||||
readCache' :: Cache a -> FilePath -> IO (UTCTime,a)
|
||||
readCache' c file =
|
||||
do v <- modifyMVar (cacheObjects c) findEntry
|
||||
modifyMVar v readObject
|
||||
where
|
||||
-- Find the cache entry, inserting a new one if neccessary.
|
||||
findEntry objs = case Map.lookup file objs of
|
||||
Just v -> return (objs,v)
|
||||
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
|
||||
now <- getCurrentTime
|
||||
x' <- case m of
|
||||
Just (t,_,x) | t' == t -> return x
|
||||
| otherwise -> cacheLoad c (Just x) file
|
||||
_ -> cacheLoad c Nothing file
|
||||
return (Just (t',now,x'), (t',x'))
|
||||
@@ -32,7 +32,7 @@ import Network.URI(URI(..))
|
||||
import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
|
||||
--import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
|
||||
import Network.CGI(handleErrors,liftIO)
|
||||
import GF.Server.CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile
|
||||
import CGIUtils(handleCGIErrors)
|
||||
import Text.JSON(encode,showJSON,makeObj)
|
||||
--import System.IO.Silently(hCapture)
|
||||
import System.Process(readProcessWithExitCode)
|
||||
@@ -41,13 +41,13 @@ import Codec.Binary.UTF8.String(decodeString,encodeString)
|
||||
import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn)
|
||||
import GF.Infra.SIO(captureSIO)
|
||||
import GF.Data.Utilities(apSnd,mapSnd)
|
||||
import qualified GF.Server.PGFService as PS
|
||||
import qualified PGFService as PS
|
||||
import Data.Version(showVersion)
|
||||
import Paths_gf(getDataDir,version)
|
||||
import GF.Infra.BuildInfo (buildInfo)
|
||||
import GF.Server.SimpleEditor.Convert(parseModule)
|
||||
import GF.Server.RunHTTP(cgiHandler)
|
||||
import GF.Server.URLEncoding(decodeQuery)
|
||||
import URLEncoding(decodeQuery)
|
||||
|
||||
--logFile :: FilePath
|
||||
--logFile = "pgf-error.log"
|
||||
|
||||
@@ -1,11 +0,0 @@
|
||||
-- | Isolate dependencies on the problematic cgi package to this module
|
||||
module GF.Server.CGI(module C) where
|
||||
import Network.CGI as C(
|
||||
CGI,ContentType(..),Accept(..),Language(..),
|
||||
getVarWithDefault,readInput,negotiate,requestAcceptLanguage,getInput,
|
||||
setHeader,output,outputFPS,outputError,
|
||||
handleErrors,
|
||||
liftIO)
|
||||
import Network.CGI.Protocol as C(CGIResult(..),CGIRequest(..),Input(..),
|
||||
Headers,HeaderName(..))
|
||||
import Network.CGI.Monad as C(runCGIT)
|
||||
@@ -1,108 +0,0 @@
|
||||
{-# LANGUAGE DeriveDataTypeable, CPP #-}
|
||||
-- | CGI utility functions for output, error handling and logging
|
||||
module GF.Server.CGIUtils (throwCGIError, handleCGIErrors,
|
||||
stderrToFile,logError,
|
||||
outputJSONP,outputEncodedJSONP,
|
||||
outputPNG,outputBinary,outputBinary',
|
||||
outputHTML,outputPlain,outputText) where
|
||||
|
||||
import Control.Exception(Exception(..),SomeException(..),throw)
|
||||
import Data.Typeable(Typeable,cast)
|
||||
import Prelude hiding (catch)
|
||||
import System.IO(hPutStrLn,stderr)
|
||||
#ifndef mingw32_HOST_OS
|
||||
import System.Posix
|
||||
#endif
|
||||
|
||||
import GF.Server.CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
|
||||
getInput)
|
||||
|
||||
import Text.JSON
|
||||
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Control.Monad.Catch (MonadThrow(throwM))
|
||||
import Network.CGI.Monad (catchCGI)
|
||||
import Control.Monad.Catch (MonadCatch(catch))
|
||||
|
||||
-- * Logging
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
logError :: String -> IO ()
|
||||
logError s = hPutStrLn stderr s
|
||||
|
||||
stderrToFile :: FilePath -> IO ()
|
||||
stderrToFile file =
|
||||
do let mode = ownerReadMode<>ownerWriteMode<>groupReadMode<>otherReadMode
|
||||
(<>) = unionFileModes
|
||||
flags = defaultFileFlags { append = True }
|
||||
fileFd <- openFd file WriteOnly (Just mode) flags
|
||||
dupTo fileFd stdError
|
||||
return ()
|
||||
#else
|
||||
logError :: String -> IO ()
|
||||
logError s = return ()
|
||||
|
||||
stderrToFile :: FilePath -> IO ()
|
||||
stderrToFile s = return ()
|
||||
#endif
|
||||
|
||||
-- * General CGI Error exception mechanism
|
||||
|
||||
data CGIError = CGIError { cgiErrorCode :: Int, cgiErrorMessage :: String, cgiErrorText :: [String] }
|
||||
deriving (Show,Typeable)
|
||||
|
||||
instance Exception CGIError where
|
||||
toException e = SomeException e
|
||||
fromException (SomeException e) = cast e
|
||||
|
||||
throwCGIError :: Int -> String -> [String] -> CGI a
|
||||
throwCGIError c m t = throwM $ toException $ CGIError c m t
|
||||
|
||||
handleCGIErrors :: CGI CGIResult -> CGI CGIResult
|
||||
handleCGIErrors x =
|
||||
x `catch` \e -> case fromException e of
|
||||
Nothing -> throw e
|
||||
Just (CGIError c m t) -> do setXO; outputError c m t
|
||||
|
||||
-- * General CGI and JSON stuff
|
||||
|
||||
outputJSONP :: JSON a => a -> CGI CGIResult
|
||||
outputJSONP = outputEncodedJSONP . encode
|
||||
|
||||
outputEncodedJSONP :: String -> CGI CGIResult
|
||||
outputEncodedJSONP json =
|
||||
do mc <- getInput "jsonp"
|
||||
let (ty,str) = case mc of
|
||||
Nothing -> ("json",json)
|
||||
Just c -> ("javascript",c ++ "(" ++ json ++ ")")
|
||||
ct = "application/"++ty++"; charset=utf-8"
|
||||
outputText ct str
|
||||
|
||||
outputPNG :: BS.ByteString -> CGI CGIResult
|
||||
outputPNG = outputBinary' "image/png"
|
||||
|
||||
outputBinary :: BS.ByteString -> CGI CGIResult
|
||||
outputBinary = outputBinary' "application/binary"
|
||||
|
||||
outputBinary' :: String -> BS.ByteString -> CGI CGIResult
|
||||
outputBinary' ct x = do
|
||||
setHeader "Content-Type" ct
|
||||
setXO
|
||||
outputFPS x
|
||||
|
||||
outputHTML :: String -> CGI CGIResult
|
||||
outputHTML = outputText "text/html; charset=utf-8"
|
||||
|
||||
outputPlain :: String -> CGI CGIResult
|
||||
outputPlain = outputText "text/plain; charset=utf-8"
|
||||
|
||||
outputText ct = outputStrict ct . UTF8.encodeString
|
||||
|
||||
outputStrict :: String -> String -> CGI CGIResult
|
||||
outputStrict ct x | x == x = do setHeader "Content-Type" ct
|
||||
setXO
|
||||
output x
|
||||
| otherwise = fail "I am the pope."
|
||||
|
||||
setXO = setHeader "Access-Control-Allow-Origin" "*"
|
||||
-- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS
|
||||
@@ -1,340 +0,0 @@
|
||||
GNU GENERAL PUBLIC LICENSE
|
||||
Version 2, June 1991
|
||||
|
||||
Copyright (C) 1989, 1991 Free Software Foundation, Inc.
|
||||
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
Preamble
|
||||
|
||||
The licenses for most software are designed to take away your
|
||||
freedom to share and change it. By contrast, the GNU General Public
|
||||
License is intended to guarantee your freedom to share and change free
|
||||
software--to make sure the software is free for all its users. This
|
||||
General Public License applies to most of the Free Software
|
||||
Foundation's software and to any other program whose authors commit to
|
||||
using it. (Some other Free Software Foundation software is covered by
|
||||
the GNU Library General Public License instead.) You can apply it to
|
||||
your programs, too.
|
||||
|
||||
When we speak of free software, we are referring to freedom, not
|
||||
price. Our General Public Licenses are designed to make sure that you
|
||||
have the freedom to distribute copies of free software (and charge for
|
||||
this service if you wish), that you receive source code or can get it
|
||||
if you want it, that you can change the software or use pieces of it
|
||||
in new free programs; and that you know you can do these things.
|
||||
|
||||
To protect your rights, we need to make restrictions that forbid
|
||||
anyone to deny you these rights or to ask you to surrender the rights.
|
||||
These restrictions translate to certain responsibilities for you if you
|
||||
distribute copies of the software, or if you modify it.
|
||||
|
||||
For example, if you distribute copies of such a program, whether
|
||||
gratis or for a fee, you must give the recipients all the rights that
|
||||
you have. You must make sure that they, too, receive or can get the
|
||||
source code. And you must show them these terms so they know their
|
||||
rights.
|
||||
|
||||
We protect your rights with two steps: (1) copyright the software, and
|
||||
(2) offer you this license which gives you legal permission to copy,
|
||||
distribute and/or modify the software.
|
||||
|
||||
Also, for each author's protection and ours, we want to make certain
|
||||
that everyone understands that there is no warranty for this free
|
||||
software. If the software is modified by someone else and passed on, we
|
||||
want its recipients to know that what they have is not the original, so
|
||||
that any problems introduced by others will not reflect on the original
|
||||
authors' reputations.
|
||||
|
||||
Finally, any free program is threatened constantly by software
|
||||
patents. We wish to avoid the danger that redistributors of a free
|
||||
program will individually obtain patent licenses, in effect making the
|
||||
program proprietary. To prevent this, we have made it clear that any
|
||||
patent must be licensed for everyone's free use or not licensed at all.
|
||||
|
||||
The precise terms and conditions for copying, distribution and
|
||||
modification follow.
|
||||
|
||||
GNU GENERAL PUBLIC LICENSE
|
||||
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
|
||||
|
||||
0. This License applies to any program or other work which contains
|
||||
a notice placed by the copyright holder saying it may be distributed
|
||||
under the terms of this General Public License. The "Program", below,
|
||||
refers to any such program or work, and a "work based on the Program"
|
||||
means either the Program or any derivative work under copyright law:
|
||||
that is to say, a work containing the Program or a portion of it,
|
||||
either verbatim or with modifications and/or translated into another
|
||||
language. (Hereinafter, translation is included without limitation in
|
||||
the term "modification".) Each licensee is addressed as "you".
|
||||
|
||||
Activities other than copying, distribution and modification are not
|
||||
covered by this License; they are outside its scope. The act of
|
||||
running the Program is not restricted, and the output from the Program
|
||||
is covered only if its contents constitute a work based on the
|
||||
Program (independent of having been made by running the Program).
|
||||
Whether that is true depends on what the Program does.
|
||||
|
||||
1. You may copy and distribute verbatim copies of the Program's
|
||||
source code as you receive it, in any medium, provided that you
|
||||
conspicuously and appropriately publish on each copy an appropriate
|
||||
copyright notice and disclaimer of warranty; keep intact all the
|
||||
notices that refer to this License and to the absence of any warranty;
|
||||
and give any other recipients of the Program a copy of this License
|
||||
along with the Program.
|
||||
|
||||
You may charge a fee for the physical act of transferring a copy, and
|
||||
you may at your option offer warranty protection in exchange for a fee.
|
||||
|
||||
2. You may modify your copy or copies of the Program or any portion
|
||||
of it, thus forming a work based on the Program, and copy and
|
||||
distribute such modifications or work under the terms of Section 1
|
||||
above, provided that you also meet all of these conditions:
|
||||
|
||||
a) You must cause the modified files to carry prominent notices
|
||||
stating that you changed the files and the date of any change.
|
||||
|
||||
b) You must cause any work that you distribute or publish, that in
|
||||
whole or in part contains or is derived from the Program or any
|
||||
part thereof, to be licensed as a whole at no charge to all third
|
||||
parties under the terms of this License.
|
||||
|
||||
c) If the modified program normally reads commands interactively
|
||||
when run, you must cause it, when started running for such
|
||||
interactive use in the most ordinary way, to print or display an
|
||||
announcement including an appropriate copyright notice and a
|
||||
notice that there is no warranty (or else, saying that you provide
|
||||
a warranty) and that users may redistribute the program under
|
||||
these conditions, and telling the user how to view a copy of this
|
||||
License. (Exception: if the Program itself is interactive but
|
||||
does not normally print such an announcement, your work based on
|
||||
the Program is not required to print an announcement.)
|
||||
|
||||
These requirements apply to the modified work as a whole. If
|
||||
identifiable sections of that work are not derived from the Program,
|
||||
and can be reasonably considered independent and separate works in
|
||||
themselves, then this License, and its terms, do not apply to those
|
||||
sections when you distribute them as separate works. But when you
|
||||
distribute the same sections as part of a whole which is a work based
|
||||
on the Program, the distribution of the whole must be on the terms of
|
||||
this License, whose permissions for other licensees extend to the
|
||||
entire whole, and thus to each and every part regardless of who wrote it.
|
||||
|
||||
Thus, it is not the intent of this section to claim rights or contest
|
||||
your rights to work written entirely by you; rather, the intent is to
|
||||
exercise the right to control the distribution of derivative or
|
||||
collective works based on the Program.
|
||||
|
||||
In addition, mere aggregation of another work not based on the Program
|
||||
with the Program (or with a work based on the Program) on a volume of
|
||||
a storage or distribution medium does not bring the other work under
|
||||
the scope of this License.
|
||||
|
||||
3. You may copy and distribute the Program (or a work based on it,
|
||||
under Section 2) in object code or executable form under the terms of
|
||||
Sections 1 and 2 above provided that you also do one of the following:
|
||||
|
||||
a) Accompany it with the complete corresponding machine-readable
|
||||
source code, which must be distributed under the terms of Sections
|
||||
1 and 2 above on a medium customarily used for software interchange; or,
|
||||
|
||||
b) Accompany it with a written offer, valid for at least three
|
||||
years, to give any third party, for a charge no more than your
|
||||
cost of physically performing source distribution, a complete
|
||||
machine-readable copy of the corresponding source code, to be
|
||||
distributed under the terms of Sections 1 and 2 above on a medium
|
||||
customarily used for software interchange; or,
|
||||
|
||||
c) Accompany it with the information you received as to the offer
|
||||
to distribute corresponding source code. (This alternative is
|
||||
allowed only for noncommercial distribution and only if you
|
||||
received the program in object code or executable form with such
|
||||
an offer, in accord with Subsection b above.)
|
||||
|
||||
The source code for a work means the preferred form of the work for
|
||||
making modifications to it. For an executable work, complete source
|
||||
code means all the source code for all modules it contains, plus any
|
||||
associated interface definition files, plus the scripts used to
|
||||
control compilation and installation of the executable. However, as a
|
||||
special exception, the source code distributed need not include
|
||||
anything that is normally distributed (in either source or binary
|
||||
form) with the major components (compiler, kernel, and so on) of the
|
||||
operating system on which the executable runs, unless that component
|
||||
itself accompanies the executable.
|
||||
|
||||
If distribution of executable or object code is made by offering
|
||||
access to copy from a designated place, then offering equivalent
|
||||
access to copy the source code from the same place counts as
|
||||
distribution of the source code, even though third parties are not
|
||||
compelled to copy the source along with the object code.
|
||||
|
||||
4. You may not copy, modify, sublicense, or distribute the Program
|
||||
except as expressly provided under this License. Any attempt
|
||||
otherwise to copy, modify, sublicense or distribute the Program is
|
||||
void, and will automatically terminate your rights under this License.
|
||||
However, parties who have received copies, or rights, from you under
|
||||
this License will not have their licenses terminated so long as such
|
||||
parties remain in full compliance.
|
||||
|
||||
5. You are not required to accept this License, since you have not
|
||||
signed it. However, nothing else grants you permission to modify or
|
||||
distribute the Program or its derivative works. These actions are
|
||||
prohibited by law if you do not accept this License. Therefore, by
|
||||
modifying or distributing the Program (or any work based on the
|
||||
Program), you indicate your acceptance of this License to do so, and
|
||||
all its terms and conditions for copying, distributing or modifying
|
||||
the Program or works based on it.
|
||||
|
||||
6. Each time you redistribute the Program (or any work based on the
|
||||
Program), the recipient automatically receives a license from the
|
||||
original licensor to copy, distribute or modify the Program subject to
|
||||
these terms and conditions. You may not impose any further
|
||||
restrictions on the recipients' exercise of the rights granted herein.
|
||||
You are not responsible for enforcing compliance by third parties to
|
||||
this License.
|
||||
|
||||
7. If, as a consequence of a court judgment or allegation of patent
|
||||
infringement or for any other reason (not limited to patent issues),
|
||||
conditions are imposed on you (whether by court order, agreement or
|
||||
otherwise) that contradict the conditions of this License, they do not
|
||||
excuse you from the conditions of this License. If you cannot
|
||||
distribute so as to satisfy simultaneously your obligations under this
|
||||
License and any other pertinent obligations, then as a consequence you
|
||||
may not distribute the Program at all. For example, if a patent
|
||||
license would not permit royalty-free redistribution of the Program by
|
||||
all those who receive copies directly or indirectly through you, then
|
||||
the only way you could satisfy both it and this License would be to
|
||||
refrain entirely from distribution of the Program.
|
||||
|
||||
If any portion of this section is held invalid or unenforceable under
|
||||
any particular circumstance, the balance of the section is intended to
|
||||
apply and the section as a whole is intended to apply in other
|
||||
circumstances.
|
||||
|
||||
It is not the purpose of this section to induce you to infringe any
|
||||
patents or other property right claims or to contest validity of any
|
||||
such claims; this section has the sole purpose of protecting the
|
||||
integrity of the free software distribution system, which is
|
||||
implemented by public license practices. Many people have made
|
||||
generous contributions to the wide range of software distributed
|
||||
through that system in reliance on consistent application of that
|
||||
system; it is up to the author/donor to decide if he or she is willing
|
||||
to distribute software through any other system and a licensee cannot
|
||||
impose that choice.
|
||||
|
||||
This section is intended to make thoroughly clear what is believed to
|
||||
be a consequence of the rest of this License.
|
||||
|
||||
8. If the distribution and/or use of the Program is restricted in
|
||||
certain countries either by patents or by copyrighted interfaces, the
|
||||
original copyright holder who places the Program under this License
|
||||
may add an explicit geographical distribution limitation excluding
|
||||
those countries, so that distribution is permitted only in or among
|
||||
countries not thus excluded. In such case, this License incorporates
|
||||
the limitation as if written in the body of this License.
|
||||
|
||||
9. The Free Software Foundation may publish revised and/or new versions
|
||||
of the General Public License from time to time. Such new versions will
|
||||
be similar in spirit to the present version, but may differ in detail to
|
||||
address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the Program
|
||||
specifies a version number of this License which applies to it and "any
|
||||
later version", you have the option of following the terms and conditions
|
||||
either of that version or of any later version published by the Free
|
||||
Software Foundation. If the Program does not specify a version number of
|
||||
this License, you may choose any version ever published by the Free Software
|
||||
Foundation.
|
||||
|
||||
10. If you wish to incorporate parts of the Program into other free
|
||||
programs whose distribution conditions are different, write to the author
|
||||
to ask for permission. For software which is copyrighted by the Free
|
||||
Software Foundation, write to the Free Software Foundation; we sometimes
|
||||
make exceptions for this. Our decision will be guided by the two goals
|
||||
of preserving the free status of all derivatives of our free software and
|
||||
of promoting the sharing and reuse of software generally.
|
||||
|
||||
NO WARRANTY
|
||||
|
||||
11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
|
||||
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
|
||||
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
|
||||
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
|
||||
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
|
||||
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
|
||||
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
|
||||
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
|
||||
REPAIR OR CORRECTION.
|
||||
|
||||
12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
|
||||
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
|
||||
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
|
||||
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
|
||||
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
|
||||
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
|
||||
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
|
||||
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGES.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
How to Apply These Terms to Your New Programs
|
||||
|
||||
If you develop a new program, and you want it to be of the greatest
|
||||
possible use to the public, the best way to achieve this is to make it
|
||||
free software which everyone can redistribute and change under these terms.
|
||||
|
||||
To do so, attach the following notices to the program. It is safest
|
||||
to attach them to the start of each source file to most effectively
|
||||
convey the exclusion of warranty; and each file should have at least
|
||||
the "copyright" line and a pointer to where the full notice is found.
|
||||
|
||||
<one line to give the program's name and a brief idea of what it does.>
|
||||
Copyright (C) <year> <name of author>
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 2 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
|
||||
Also add information on how to contact you by electronic and paper mail.
|
||||
|
||||
If the program is interactive, make it output a short notice like this
|
||||
when it starts in an interactive mode:
|
||||
|
||||
Gnomovision version 69, Copyright (C) year name of author
|
||||
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
|
||||
This is free software, and you are welcome to redistribute it
|
||||
under certain conditions; type `show c' for details.
|
||||
|
||||
The hypothetical commands `show w' and `show c' should show the appropriate
|
||||
parts of the General Public License. Of course, the commands you use may
|
||||
be called something other than `show w' and `show c'; they could even be
|
||||
mouse-clicks or menu items--whatever suits your program.
|
||||
|
||||
You should also get your employer (if you work as a programmer) or your
|
||||
school, if any, to sign a "copyright disclaimer" for the program, if
|
||||
necessary. Here is a sample; alter the names:
|
||||
|
||||
Yoyodyne, Inc., hereby disclaims all copyright interest in the program
|
||||
`Gnomovision' (which makes passes at compilers) written by James Hacker.
|
||||
|
||||
<signature of Ty Coon>, 1 April 1989
|
||||
Ty Coon, President of Vice
|
||||
|
||||
This General Public License does not permit incorporating your program into
|
||||
proprietary programs. If your program is a subroutine library, you may
|
||||
consider it more useful to permit linking proprietary applications with the
|
||||
library. If this is what you want to do, use the GNU Library General
|
||||
Public License instead of this License.
|
||||
@@ -1,486 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GF.Server.PGFService(cgiMain,cgiMain',getPath,
|
||||
logFile,stderrToFile,
|
||||
Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
|
||||
|
||||
import PGF2
|
||||
import PGF2.Transactions
|
||||
import GF.Text.Lexing
|
||||
import GF.Infra.Cache
|
||||
import GF.Server.CGIUtils(outputJSONP,outputPlain,outputHTML,outputText,
|
||||
outputBinary,outputBinary',
|
||||
logError,handleCGIErrors,throwCGIError,stderrToFile)
|
||||
import GF.Server.CGI(CGI,readInput,getInput,getVarWithDefault,
|
||||
CGIResult,requestAcceptLanguage,handleErrors,setHeader,
|
||||
Accept(..),Language(..),negotiate,liftIO)
|
||||
import GF.Server.URLEncoding
|
||||
|
||||
import Data.Time.Clock(UTCTime)
|
||||
import Data.Time.Format(formatTime)
|
||||
#if MIN_VERSION_time(1,5,0)
|
||||
import Data.Time.Format(defaultTimeLocale,rfc822DateFormat)
|
||||
#else
|
||||
import System.Locale(defaultTimeLocale,rfc822DateFormat)
|
||||
#endif
|
||||
import Text.JSON
|
||||
import Text.PrettyPrint as PP(render, text, (<+>))
|
||||
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
|
||||
import Control.Concurrent
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad
|
||||
import Control.Monad.State(State,evalState,get,put)
|
||||
import Control.Monad.Catch(bracket_)
|
||||
import Data.Char
|
||||
--import Data.Function (on)
|
||||
import Data.List ({-sortBy,-}intersperse,mapAccumL,nub,isSuffixOf,nubBy,stripPrefix)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import System.Random
|
||||
import System.Process
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.IO.Error(isDoesNotExistError)
|
||||
import System.Directory(removeFile)
|
||||
import System.FilePath(takeExtension,dropExtension,takeDirectory,(</>),(<.>))
|
||||
import System.Mem(performGC)
|
||||
|
||||
catchIOE :: IO a -> (E.IOException -> IO a) -> IO a
|
||||
catchIOE = E.catch
|
||||
|
||||
withQSem qsem = bracket_ (liftIO $ waitQSem qsem) (liftIO $ signalQSem qsem)
|
||||
|
||||
logFile :: FilePath
|
||||
logFile = "pgf-error.log"
|
||||
|
||||
data Caches = Caches { qsem :: QSem,
|
||||
pgfCache :: Cache PGF,
|
||||
labelsCache :: Cache Labels }
|
||||
|
||||
newPGFCache jobs = do let n = maybe 4 id jobs
|
||||
qsem <- newQSem n
|
||||
pgfCache <- newCache' readGrammar
|
||||
lblCache <- newCache' (const (fmap getDepLabels . readFile))
|
||||
return $ Caches qsem pgfCache lblCache
|
||||
flushPGFCache c = do flushCache (pgfCache c)
|
||||
flushCache (labelsCache c)
|
||||
listPGFCache c = listCache (pgfCache c)
|
||||
|
||||
readGrammar mb_pgf path =
|
||||
case takeExtension path of
|
||||
".pgf" -> readPGF path
|
||||
".ngf" -> case mb_pgf of
|
||||
Nothing -> readNGF path
|
||||
Just gr -> checkoutPGF gr
|
||||
_ -> error "Extension must be .pgf or .ngf"
|
||||
|
||||
newCache' rd = do c <- newCache rd
|
||||
forkIO $ forever $ clean c
|
||||
return c
|
||||
where
|
||||
clean c = do threadDelay 2000000000 -- 2000 seconds, i.e. ~33 minutes
|
||||
expireCache (24*60*60) c -- 24 hours
|
||||
|
||||
getPath =
|
||||
do path <- getVarWithDefault "PATH_TRANSLATED" "" -- apache mod_fastcgi
|
||||
if null path
|
||||
then getVarWithDefault "SCRIPT_FILENAME" "" -- lighttpd
|
||||
else return path
|
||||
|
||||
cgiMain :: Caches -> CGI CGIResult
|
||||
cgiMain cache = handleErrors . handleCGIErrors $
|
||||
cgiMain' cache =<< getPath
|
||||
|
||||
cgiMain' :: Caches -> FilePath -> CGI CGIResult
|
||||
cgiMain' cache path =
|
||||
do command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString))
|
||||
(getInput "command")
|
||||
case command of
|
||||
"download" -> outputBinary =<< getFile BS.readFile path
|
||||
_ -> do tpgf <- getFile (readCache' (pgfCache cache)) path
|
||||
pgfMain (qsem cache) command tpgf
|
||||
|
||||
getFile get path =
|
||||
either failed return =<< liftIO (E.try (get path))
|
||||
where
|
||||
failed e = if isDoesNotExistError e
|
||||
then notFound path
|
||||
else liftIO $ ioError e
|
||||
|
||||
|
||||
pgfMain qsem command (t,pgf) =
|
||||
case command of
|
||||
"parse" -> withQSem qsem $
|
||||
out t=<< join (parse # input % cat % start % limit % treeopts)
|
||||
-- "parseToChart" -> withQSem qsem $
|
||||
-- out t=<< join (parseToChart # input % cat % limit)
|
||||
"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 % cat % to % start % limit%treeopts)
|
||||
"lookupmorpho" -> out t=<< morpho # from1 % textInput
|
||||
"lookupcohorts" -> out t=<< cohorts # from1 % getInput "filter" % textInput
|
||||
"flush" -> out t=<< flush
|
||||
"grammar" -> out t grammar
|
||||
"abstrtree" -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree
|
||||
"parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from1 %tree
|
||||
"wordforword" -> out t =<< wordforword # input % cat % to
|
||||
_ -> badRequest "Unknown command" command
|
||||
where
|
||||
flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
|
||||
performGC
|
||||
return $ showJSON ()
|
||||
|
||||
cat :: CGI Type
|
||||
cat =
|
||||
do mcat <- getInput1 "cat"
|
||||
case mcat of
|
||||
Nothing -> return (startCat pgf)
|
||||
Just cat -> case readType cat of
|
||||
Nothing -> badRequest "Bad category" cat
|
||||
Just typ -> return typ
|
||||
|
||||
langs = languages pgf
|
||||
|
||||
grammar = showJSON $ makeObj
|
||||
["name".=abstractName pgf,
|
||||
"lastmodified".=show t,
|
||||
"startcat".=showType [] (startCat pgf),
|
||||
"languages".=languages]
|
||||
where
|
||||
languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
|
||||
|
||||
parse input@((from,_),_) cat start mlimit (trie,json) =
|
||||
do r <- parse' cat start mlimit input
|
||||
return $ showJSON [makeObj ("from".=from:jsonParseResult json r)]
|
||||
|
||||
jsonParseResult json = either bad good
|
||||
where
|
||||
bad err = ["parseFailed".=err]
|
||||
good trees = "trees".=map tp trees :[] -- :addTrie trie trees
|
||||
tp (tree,prob) = makeObj ["tree".=tree
|
||||
,"prob".=prob
|
||||
]
|
||||
|
||||
-- Without caching parse results:
|
||||
parse' cat start mlimit ((from,concr),input) =
|
||||
case parseWithHeuristics concr cat input (-1) callbacks of
|
||||
ParseOk ts -> return (Right (maybe id take mlimit (drop start ts)))
|
||||
ParseFailed _ tok -> return (Left tok)
|
||||
ParseIncomplete -> return (Left "")
|
||||
where
|
||||
callbacks = undefined
|
||||
|
||||
parseToChart ((from,concr),input) cat mlimit = undefined {-
|
||||
do r <- case C.parseToChart concr cat input (-1) callbacks (fromMaybe 5 mlimit) of
|
||||
ParseOk chart -> return (good chart)
|
||||
ParseFailed _ tok -> return (bad tok)
|
||||
ParseIncomplete -> return (bad "")
|
||||
return $ showJSON [makeObj ("from".=from:r)]
|
||||
where
|
||||
callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks
|
||||
cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs]
|
||||
|
||||
bad err = ["parseFailed".=err]
|
||||
good (roots,chart) = ["roots".=showJSON roots,
|
||||
"chart".=makeObj [show fid .= mkChartObj inf | (fid,inf)<-Map.toList chart]]
|
||||
|
||||
mkChartObj (brackets,prods,cat) =
|
||||
makeObj ["brackets".=map mkChartBracket brackets
|
||||
,"prods" .=map mkChartProd prods
|
||||
,"cat" .=cat
|
||||
]
|
||||
|
||||
mkChartBracket (s,e,ann) =
|
||||
makeObj ["start".=s,"end".=e,"ann".=ann]
|
||||
|
||||
mkChartProd (expr,args,prob) =
|
||||
makeObj ["tree".=expr,"args".=map mkChartPArg args,"prob".=prob]
|
||||
|
||||
mkChartPArg (PArg _ fid) = showJSON fid
|
||||
-}
|
||||
linAll tree to = showJSON (linAll' tree to)
|
||||
linAll' tree (tos,unlex) =
|
||||
[makeObj ["to".=to,
|
||||
"texts".=map unlex (linearizeAll c tree)]|(to,c)<-tos]
|
||||
|
||||
lin tree to = showJSON (lin' tree to)
|
||||
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,_),_) cat to start mlimit (trie,jsontree) =
|
||||
do parses <- parse' cat start mlimit input
|
||||
return $
|
||||
showJSON [ makeObj ["from".=from,
|
||||
"translations".= jsonParses parses]]
|
||||
where
|
||||
jsonParses = either bad good
|
||||
where
|
||||
bad err = [makeObj ["error".=err]]
|
||||
good parses = [makeObj ["tree".=tree
|
||||
,"prob".=prob
|
||||
,"linearizations".=lin' tree to]
|
||||
| (tree,prob) <- parses]
|
||||
|
||||
morpho (from,concr) input =
|
||||
showJSON [makeObj ["lemma".=l
|
||||
,"analysis".=a
|
||||
,"prob".=p]
|
||||
| (l,a,p)<-lookupMorpho concr input]
|
||||
|
||||
cohorts (from,concr) filter input =
|
||||
showJSON [makeObj ["start" .=showJSON s
|
||||
,"word" .=showJSON w
|
||||
,"morpho".=showJSON [makeObj ["lemma".=l
|
||||
,"analysis".=a
|
||||
,"prob".=p]
|
||||
| (l,a,p)<-ms]
|
||||
,"end" .=showJSON e
|
||||
]
|
||||
| (s,w,ms,e) <- (case filter of
|
||||
Just "longest" -> filterLongest
|
||||
Just "best" -> filterBest
|
||||
_ -> id)
|
||||
(lookupCohorts concr input)]
|
||||
|
||||
wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat
|
||||
|
||||
jsonWFW from rs =
|
||||
showJSON
|
||||
[makeObj
|
||||
["from".=from,
|
||||
"translations".=[makeObj ["linearizations".=
|
||||
[makeObj["to".=to,"text".=text]
|
||||
| (to,text)<-rs]]]]]
|
||||
|
||||
wordforword' inp@((from,concr),input) cat (tos,unlex) =
|
||||
[(to,unlex . unwords $ map (lin_word' c) pws)
|
||||
|let pws=map parse_word' (words input),(to,c)<-tos]
|
||||
where
|
||||
lin_word' c = either id (lin1 c)
|
||||
|
||||
lin1 c = dropq . linearize c
|
||||
where
|
||||
dropq (q:' ':s) | q `elem` "+*" = s
|
||||
dropq s = s
|
||||
|
||||
parse_word' w = if all (\c->isSpace c||isPunctuation c) w
|
||||
then Left w
|
||||
else parse_word w
|
||||
|
||||
|
||||
parse_word w =
|
||||
maybe (Left ("["++w++"]")) Right $
|
||||
msum [parse1 w,parse1 ow,morph w,morph ow]
|
||||
where
|
||||
ow = case w of
|
||||
c:cs | isLower c -> toUpper c : cs
|
||||
| isUpper c -> toLower c : cs
|
||||
s -> s
|
||||
|
||||
parse1 s = case PGF2.parse concr cat s of
|
||||
ParseOk ((t,_):ts) -> Just t
|
||||
_ -> Nothing
|
||||
morph w = listToMaybe
|
||||
[t | (f,a,p)<-lookupMorpho concr w,
|
||||
t<-maybeToList (readExpr f)]
|
||||
|
||||
---
|
||||
|
||||
input = lexit # from % textInput
|
||||
where
|
||||
lexit (from,lex) input = (from,lex input)
|
||||
|
||||
from = maybe (missing "from") getlexer =<< from'
|
||||
where
|
||||
getlexer f@(_,concr) = (,) f # c_lexer concr
|
||||
|
||||
from1 = maybe (missing "from") return =<< from'
|
||||
from' = getLang "from"
|
||||
|
||||
to = (,) # getLangs "to" % unlexerC (const False)
|
||||
|
||||
getLangs = getLangs' readLang
|
||||
getLang = getLang' readLang
|
||||
|
||||
readLang :: String -> CGI (String,Concr)
|
||||
readLang lang =
|
||||
case Map.lookup lang langs of
|
||||
Nothing -> badRequest "Bad language" lang
|
||||
Just c -> return (lang,c)
|
||||
|
||||
tree = do s <- maybe (missing "tree") return =<< getInput1 "tree"
|
||||
maybe (badRequest "bad tree" s) return (readExpr s)
|
||||
|
||||
c_lexer concr = lexer (not . null . lookupMorpho concr)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- * Lexing
|
||||
|
||||
-- | Standard lexers
|
||||
lexer good = maybe (return id) lexerfun =<< getInput "lexer"
|
||||
where
|
||||
lexerfun name =
|
||||
case stringOp good ("lex"++name) of
|
||||
Just fn -> return fn
|
||||
Nothing -> badRequest "Unknown lexer" name
|
||||
|
||||
|
||||
type Unlexer = String->String
|
||||
|
||||
-- | Unlexing for the C runtime system, &+ is already applied
|
||||
unlexerC :: (String -> Bool) -> CGI Unlexer
|
||||
unlexerC = unlexer' id
|
||||
|
||||
-- | Unlexing for the Haskell runtime system, the default is to just apply &+
|
||||
unlexerH :: CGI Unlexer
|
||||
unlexerH = unlexer' (unwords . bindTok . words) (const False)
|
||||
|
||||
unlexer' defaultUnlexer good =
|
||||
maybe (return defaultUnlexer) unlexerfun =<< getInput "unlexer"
|
||||
where
|
||||
unlexerfun name =
|
||||
case stringOp good ("unlex"++name) of
|
||||
Just fn -> return (fn . cleanMarker)
|
||||
Nothing -> badRequest "Unknown unlexer" name
|
||||
|
||||
cleanMarker ('+':cs) = cs
|
||||
cleanMarker ('*':cs) = cs
|
||||
cleanMarker cs = cs
|
||||
|
||||
out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t
|
||||
setHeader "Last-Modified" fmt
|
||||
outputJSONP r
|
||||
|
||||
getInput1 x = nonEmpty # getInput x
|
||||
nonEmpty (Just "") = Nothing
|
||||
nonEmpty r = r
|
||||
|
||||
textInput :: CGI String
|
||||
textInput = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
|
||||
|
||||
getLangs' readLang i = mapM readLang . maybe [] words =<< getInput i
|
||||
|
||||
getLang' readLang i =
|
||||
do mlang <- getInput i
|
||||
case mlang of
|
||||
Just l@(_:_) -> Just # readLang l
|
||||
_ -> return Nothing
|
||||
|
||||
|
||||
limit, depth :: CGI (Maybe Int)
|
||||
limit = readInput "limit"
|
||||
depth = readInput "depth"
|
||||
|
||||
start :: CGI Int
|
||||
start = maybe 0 id # readInput "start"
|
||||
|
||||
treeopts :: CGI TreeOpts
|
||||
treeopts = (,) # getBool "trie" % getBool "jsontree"
|
||||
|
||||
getBool x = maybe False toBool # getInput x
|
||||
toBool s = s `elem` ["","yes","true","True"]
|
||||
|
||||
missing = badRequest "Missing parameter"
|
||||
errorMissingId = badRequest "Missing identifier" ""
|
||||
|
||||
notFound = throw 404 "Not found"
|
||||
badRequest = throw 400
|
||||
|
||||
throw code msg extra =
|
||||
throwCGIError code msg [msg ++(if null extra then "" else ": "++extra)]
|
||||
|
||||
format def = maybe def id # getInput "format"
|
||||
|
||||
type From = (Maybe Concr,String)
|
||||
type To = ([Concr],Unlexer)
|
||||
type TreeOpts = (Bool,Bool) -- (trie,jsontree)
|
||||
|
||||
outputGraphviz code =
|
||||
do fmt <- format "png"
|
||||
case fmt of
|
||||
"gv" -> outputPlain code
|
||||
_ -> outputFPS' fmt =<< liftIO (pipeIt2graphviz fmt code)
|
||||
where
|
||||
outputFPS' = outputBinary' . mimeType
|
||||
|
||||
mimeType fmt =
|
||||
case fmt of
|
||||
"png" -> "image/png"
|
||||
"gif" -> "image/gif"
|
||||
"svg" -> "image/svg+xml"
|
||||
-- ...
|
||||
_ -> "application/binary"
|
||||
|
||||
pipeIt2graphviz :: String -> String -> IO BS.ByteString
|
||||
pipeIt2graphviz fmt code = do
|
||||
(Just inh, Just outh, _, pid) <-
|
||||
createProcess (proc "dot" ["-T",fmt])
|
||||
{ std_in = CreatePipe,
|
||||
std_out = CreatePipe,
|
||||
std_err = Inherit }
|
||||
|
||||
hSetBinaryMode outh True
|
||||
hSetEncoding inh utf8
|
||||
|
||||
-- fork off a thread to start consuming the output
|
||||
output <- BS.hGetContents outh
|
||||
outMVar <- newEmptyMVar
|
||||
_ <- forkIO $ E.evaluate (BS.length output) >> putMVar outMVar ()
|
||||
|
||||
-- now write and flush any input
|
||||
hPutStr inh code
|
||||
hFlush inh
|
||||
hClose inh -- done with stdin
|
||||
|
||||
-- wait on the output
|
||||
takeMVar outMVar
|
||||
hClose outh
|
||||
|
||||
-- wait on the process
|
||||
ex <- waitForProcess pid
|
||||
|
||||
case ex of
|
||||
ExitSuccess -> return output
|
||||
ExitFailure r -> fail ("pipeIt2graphviz: (exit " ++ show r ++ ")")
|
||||
|
||||
instance JSON Expr where
|
||||
readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . readExpr
|
||||
showJSON = showJSON . showExpr []
|
||||
|
||||
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 BIND = makeObj ["bind".=True]
|
||||
showJSON (Leaf s) = makeObj ["token".=s]
|
||||
|
||||
-- * PGF utilities
|
||||
|
||||
selectLanguage :: PGF -> Maybe (Accept Language) -> Concr
|
||||
selectLanguage pgf macc = case acceptable 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 languageCode (Map.elems (languages pgf))
|
||||
acceptable = negotiate (map Language langCodes) macc
|
||||
|
||||
langCodeLanguage :: PGF -> String -> Maybe Concr
|
||||
langCodeLanguage pgf code = listToMaybe [concr | concr <- Map.elems (languages pgf), languageCode concr == Just code]
|
||||
|
||||
-- * General utilities
|
||||
|
||||
infixl 2 #,%
|
||||
|
||||
f .= v = (f,showJSON v)
|
||||
f # x = fmap f x
|
||||
f % x = ap f x
|
||||
@@ -1,10 +1,10 @@
|
||||
module GF.Server.RunHTTP(runHTTP,Options(..),cgiHandler) where
|
||||
|
||||
import GF.Server.CGI(ContentType(..),
|
||||
CGIResult(..),CGIRequest(..),Input(..),
|
||||
Headers,HeaderName(..),
|
||||
runCGIT)
|
||||
import GF.Server.URLEncoding(decodeQuery)
|
||||
import Network.CGI(ContentType(..))
|
||||
import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..),
|
||||
Headers,HeaderName(..))
|
||||
import Network.CGI.Monad(runCGIT)
|
||||
import URLEncoding(decodeQuery)
|
||||
import Network.URI(uriPath,uriQuery)
|
||||
import Network.Shed.Httpd(initServer,Request(..),Response(..))
|
||||
import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack,empty)
|
||||
|
||||
@@ -1,26 +0,0 @@
|
||||
module ServeStaticFile where
|
||||
import System.FilePath
|
||||
import System.Directory(doesDirectoryExist)
|
||||
import CGI(setHeader,outputFPS,liftIO)
|
||||
import qualified Data.ByteString.Lazy.Char8 as BS
|
||||
|
||||
serveStaticFile path =
|
||||
do b <- liftIO $ doesDirectoryExist path
|
||||
let path' = if b then path </> "index.html" else path
|
||||
serveStaticFile' path'
|
||||
|
||||
serveStaticFile' path =
|
||||
do setHeader "Content-Type" (contentTypeFromExt (takeExtension path))
|
||||
outputFPS =<< liftIO (BS.readFile path)
|
||||
|
||||
contentTypeFromExt ext =
|
||||
case ext of
|
||||
".html" -> "text/html"
|
||||
".htm" -> "text/html"
|
||||
".xml" -> "text/xml"
|
||||
".txt" -> "text/plain"
|
||||
".css" -> "text/css"
|
||||
".js" -> "text/javascript"
|
||||
".png" -> "image/png"
|
||||
".jpg" -> "image/jpg"
|
||||
_ -> "application/octet-stream"
|
||||
@@ -1,91 +0,0 @@
|
||||
{-# OPTIONS_GHC -fwarn-unused-imports #-}
|
||||
|
||||
import Control.Monad(when)
|
||||
import System.Directory(createDirectoryIfMissing,doesFileExist,
|
||||
getDirectoryContents,copyFile,removeFile)
|
||||
import System.FilePath((</>))
|
||||
import System.Process(system)
|
||||
import System.Exit(ExitCode(..))
|
||||
|
||||
import Distribution.Simple
|
||||
import Distribution.Simple.Setup
|
||||
import Distribution.Simple.LocalBuildInfo(datadir,buildDir,absoluteInstallDirs)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMainWithHooks simpleUserHooks{ postInst = instWWW
|
||||
, postCopy = copyWWW
|
||||
}
|
||||
--------------------------------------------------------------------------------
|
||||
-- To test the GF web service and minibar, use "cabal install" (or
|
||||
-- "runhaskell Setup.hs install") to install the program pgf-http, the
|
||||
-- example grammars listed below, and the minibar. Then start the server with
|
||||
-- the command "pgf-http" and open http://localhost:41296/minibar/minibar.html
|
||||
-- in your web browser (Firefox, Safari, Opera or Chrome).
|
||||
|
||||
example_grammars =
|
||||
-- (pgf, tmp, src)
|
||||
[("Foods.pgf","foods",
|
||||
".."</>".."</>"contrib"</>"summerschool"</>"foods"</>"Foods???.gf"),
|
||||
("Letter.pgf","letter",
|
||||
".."</>".."</>"examples"</>"letter"</>"Letter???.gf")]
|
||||
|
||||
minibar_src = ".."</>"www"</>"minibar"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
instWWW args flags pki lbi = setupWWW args dest pki lbi
|
||||
where
|
||||
dest = NoCopyDest
|
||||
|
||||
copyWWW args flags pki lbi = setupWWW args dest pki lbi
|
||||
where
|
||||
dest = case copyDest flags of
|
||||
NoFlag -> NoCopyDest
|
||||
Flag d -> d
|
||||
|
||||
setupWWW args dest pkg lbi =
|
||||
do mapM_ (createDirectoryIfMissing True) [grammars_dir,minibar_dir]
|
||||
mapM_ build_pgf example_grammars
|
||||
copy_minibar
|
||||
create_root_index
|
||||
where
|
||||
grammars_dir = www_dir </> "grammars"
|
||||
minibar_dir = www_dir </> "minibar"
|
||||
www_dir = datadir (absoluteInstallDirs pkg lbi dest) </> "www"
|
||||
gfo_dir = buildDir lbi </> "gfo"
|
||||
|
||||
build_pgf (pgf,tmp,src) =
|
||||
do createDirectoryIfMissing True tmp_dir
|
||||
execute cmd
|
||||
copyFile pgf (grammars_dir</>pgf)
|
||||
removeFile pgf
|
||||
where
|
||||
tmp_dir = gfo_dir</>tmp
|
||||
cmd = "gf -make -s -optimize-pgf --gfo-dir="++tmp_dir++
|
||||
-- " --output-dir="++grammars_dir++ -- has no effect?!
|
||||
" "++src
|
||||
|
||||
copy_minibar =
|
||||
do files <- getDirectoryContents minibar_src
|
||||
mapM_ copy files
|
||||
where
|
||||
copy file =
|
||||
do isFile <- doesFileExist src
|
||||
when isFile $ copyFile src (minibar_dir</>file)
|
||||
where
|
||||
src = minibar_src</>file
|
||||
|
||||
create_root_index = writeFile (www_dir</>"index.html") index_html
|
||||
|
||||
index_html = "<h1>PGF service</h1>\n<h2>Available demos</h2>\n"
|
||||
++"<ul><li><a href=\"minibar/minibar.html\">Minibar</a></ul>"
|
||||
++"Additional grammars can be installed in"
|
||||
++"<blockquote><code>"++grammars_dir++"</code></blockquote>"
|
||||
++"<a href=\"http://www.grammaticalframework.org/\">"
|
||||
++"Grammatical Framework</a>"
|
||||
execute command =
|
||||
do putStrLn command
|
||||
e <- system command
|
||||
case e of
|
||||
ExitSuccess -> return ()
|
||||
_ -> fail "Command failed"
|
||||
return ()
|
||||
@@ -1,61 +0,0 @@
|
||||
module GF.Server.URLEncoding(urlDecodeUnicode,decodeQuery) where
|
||||
|
||||
import Data.Bits (shiftL, (.|.))
|
||||
import Data.Char (chr,digitToInt,isHexDigit)
|
||||
|
||||
-- | Decode hexadecimal escapes
|
||||
urlDecodeUnicode :: String -> String
|
||||
urlDecodeUnicode [] = ""
|
||||
urlDecodeUnicode ('%':'u':x1:x2:x3:x4:s)
|
||||
| all isHexDigit [x1,x2,x3,x4] =
|
||||
chr ( digitToInt x1 `shiftL` 12
|
||||
.|. digitToInt x2 `shiftL` 8
|
||||
.|. digitToInt x3 `shiftL` 4
|
||||
.|. digitToInt x4) : urlDecodeUnicode s
|
||||
urlDecodeUnicode ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 =
|
||||
chr ( digitToInt x1 `shiftL` 4
|
||||
.|. digitToInt x2) : urlDecodeUnicode s
|
||||
urlDecodeUnicode (c:s) = c : urlDecodeUnicode s
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type Query = [(String,String)]
|
||||
|
||||
-- | Decode application/x-www-form-urlencoded
|
||||
decodeQuery :: String -> Query
|
||||
decodeQuery = map (aboth decode . breakAt '=') . chopList (breakAt '&')
|
||||
|
||||
aboth f (x,y) = (f x,f y)
|
||||
|
||||
-- | Decode "+" and hexadecimal escapes
|
||||
decode [] = []
|
||||
decode ('%':'u':d1:d2:d3:d4:cs)
|
||||
| all isHexDigit [d1,d2,d3,d4] = chr(fromhex4 d1 d2 d3 d4):decode cs
|
||||
decode ('%':d1:d2:cs)
|
||||
| all isHexDigit [d1,d2] = chr(fromhex2 d1 d2):decode cs
|
||||
decode ('+':cs) = ' ':decode cs
|
||||
decode (c:cs) = c:decode cs
|
||||
|
||||
fromhex4 d1 d2 d3 d4 = 256*fromhex2 d1 d2+fromhex2 d3 d4
|
||||
fromhex2 d1 d2 = 16*digitToInt d1+digitToInt d2
|
||||
|
||||
|
||||
-- From hbc-library ListUtil ---------------------------------------------------
|
||||
|
||||
-- Repeatedly extract (and transform) values until a predicate hold. Return the list of values.
|
||||
unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
|
||||
unfoldr f p x | p x = []
|
||||
| otherwise = y:unfoldr f p x'
|
||||
where (y, x') = f x
|
||||
|
||||
chopList :: ([a] -> (b, [a])) -> [a] -> [b]
|
||||
chopList f l = unfoldr f null l
|
||||
|
||||
breakAt :: (Eq a) => a -> [a] -> ([a], [a])
|
||||
breakAt _ [] = ([], [])
|
||||
breakAt x (x':xs) =
|
||||
if x == x' then
|
||||
([], xs)
|
||||
else
|
||||
let (ys, zs) = breakAt x xs
|
||||
in (x':ys, zs)
|
||||
@@ -1,16 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
import Control.Concurrent(forkIO)
|
||||
import Network.FastCGI(runFastCGI,runFastCGIConcurrent')
|
||||
|
||||
import PGFService(cgiMain,newPGFCache,stderrToFile,logFile)
|
||||
|
||||
main = do stderrToFile logFile
|
||||
fcgiMain =<< newPGFCache Nothing
|
||||
|
||||
|
||||
fcgiMain cache =
|
||||
#ifndef mingw32_HOST_OS
|
||||
runFastCGIConcurrent' forkIO 100 (cgiMain cache)
|
||||
#else
|
||||
runFastCGI (cgiMain cache)
|
||||
#endif
|
||||
@@ -1,49 +0,0 @@
|
||||
|
||||
import Network.CGI(requestMethod,getVarWithDefault,logCGI,handleErrors,liftIO)
|
||||
import System.Environment(getArgs)
|
||||
import System.Directory(getDirectoryContents)
|
||||
import System.FilePath(takeExtension,takeFileName,takeDirectory,(</>))
|
||||
|
||||
import RunHTTP(runHTTP,Options(..))
|
||||
import ServeStaticFile(serveStaticFile)
|
||||
import PGFService(cgiMain',getPath,stderrToFile,logFile,newPGFCache)
|
||||
import CGIUtils(outputJSONP,handleCGIErrors)
|
||||
|
||||
import Paths_gf_server(getDataDir)
|
||||
|
||||
main :: IO ()
|
||||
main = do datadir <- getDataDir
|
||||
let defaults = Options { documentRoot = datadir</>"www",
|
||||
port = 41296 }
|
||||
cache <- newPGFCache
|
||||
args <- getArgs
|
||||
options <- case args of
|
||||
[] -> return defaults
|
||||
[port] -> do p <- readIO port
|
||||
return defaults{port=p}
|
||||
putStrLn $ "Starting HTTP server, open http://localhost:"
|
||||
++show (port options)++"/ in your web browser.\n"
|
||||
print options
|
||||
putStrLn $ "logFile="++logFile
|
||||
stderrToFile logFile
|
||||
httpMain cache options
|
||||
|
||||
|
||||
httpMain cache options = runHTTP options (do log ; serve =<< getPath)
|
||||
where
|
||||
log = do method <- requestMethod
|
||||
uri <- getVarWithDefault "REQUEST_URI" "-"
|
||||
logCGI $ method++" "++uri
|
||||
|
||||
serve path =
|
||||
handleErrors . handleCGIErrors $
|
||||
if takeExtension path==".pgf"
|
||||
then cgiMain' cache path
|
||||
else if takeFileName path=="grammars.cgi"
|
||||
then grammarList (takeDirectory path)
|
||||
else serveStaticFile path
|
||||
|
||||
grammarList dir =
|
||||
do paths <- liftIO $ getDirectoryContents dir
|
||||
let pgfs = [path|path<-paths, takeExtension path==".pgf"]
|
||||
outputJSONP pgfs
|
||||
@@ -1,122 +0,0 @@
|
||||
var gf = new Object();
|
||||
var pgf_base_url = "pgf";
|
||||
|
||||
gf.grammars = function (callback) {
|
||||
gf.httpGetJSONP(pgf_base_url, callback);
|
||||
};
|
||||
|
||||
gf.grammar = function (grammar, callback) {
|
||||
gf.callFunction(grammar, "", [], callback);
|
||||
};
|
||||
|
||||
gf.parse = function (grammar,input,from,cat,callback) {
|
||||
var args = [];
|
||||
args["input"] = input;
|
||||
args["from"] = from;
|
||||
args["cat"] = cat;
|
||||
gf.callFunction(grammar, "parse", args, callback);
|
||||
};
|
||||
|
||||
gf.complete = function (grammar,input,from,cat,callback) {
|
||||
var args = [];
|
||||
args["input"] = input;
|
||||
args["from"] = from;
|
||||
args["cat"] = cat;
|
||||
gf.callFunction(grammar, "complete", args, callback);
|
||||
};
|
||||
|
||||
gf.linearize = function (grammar,tree,to,callback) {
|
||||
var args = [];
|
||||
args["tree"] = tree;
|
||||
args["to"] = to;
|
||||
gf.callFunction(grammar, "linearize", args, callback);
|
||||
};
|
||||
|
||||
gf.random = function (grammar,cat,limit,callback) {
|
||||
var args = [];
|
||||
args["cat"] = cat;
|
||||
args["limit"] = limit;
|
||||
gf.callFunction(grammar, "random", args, callback);
|
||||
};
|
||||
|
||||
gf.translate = function (grammar,input,from,to,cat,callback) {
|
||||
var args = [];
|
||||
args["input"] = input;
|
||||
args["from"] = from;
|
||||
args["to"] = to;
|
||||
args["cat"] = cat;
|
||||
gf.callFunction(grammar, "translate", args, callback);
|
||||
};
|
||||
|
||||
gf.callFunction = function (grammar, fun, args, callback) {
|
||||
var query = "";
|
||||
for (var i in args) {
|
||||
query += (query == "") ? "?" : "&";
|
||||
query += i + "=" + encodeURIComponent(args[i]);
|
||||
}
|
||||
var url = pgf_base_url + "/" + grammar +"/" + fun + query;
|
||||
|
||||
// FIXME: if same domain, use gf.httpGetText
|
||||
gf.httpGetJSONP(url, callback);
|
||||
}
|
||||
|
||||
gf.httpGetJSONP = function (url, callback) {
|
||||
var script = document.createElement("script");
|
||||
|
||||
if (!window.jsonCallbacks) {
|
||||
window.jsonCallbacks = new Array();
|
||||
}
|
||||
var callbackIndex = window.jsonCallbacks.length;
|
||||
window.jsonCallbacks.push(function (output) {
|
||||
// get rid of the script tag
|
||||
document.getElementsByTagName("head")[0].removeChild(script);
|
||||
// let this function be garbage-collected
|
||||
window.jsonCallbacks[callbackIndex] = null;
|
||||
// shrink the array if possible
|
||||
while (window.jsonCallbacks.length > 0 && window.jsonCallbacks[window.jsonCallbacks.length-1] == null) {
|
||||
window.jsonCallbacks.pop();
|
||||
}
|
||||
callback(output);
|
||||
});
|
||||
var callbackName = "jsonCallbacks[" + callbackIndex + "]";
|
||||
|
||||
var questionMarkPos = url.indexOf("?");
|
||||
if (questionMarkPos > -1) {
|
||||
url += (questionMarkPos < url.length-1) ? "&" : "";
|
||||
} else {
|
||||
url += "?";
|
||||
}
|
||||
url += "jsonp=" + callbackName;
|
||||
script.setAttribute("src", url);
|
||||
script.setAttribute("type", "text/javascript");
|
||||
document.getElementsByTagName("head")[0].appendChild(script);
|
||||
};
|
||||
|
||||
gf.httpGetText = function (url, callback) {
|
||||
var XMLHttpRequestObject = false;
|
||||
|
||||
if (window.XMLHttpRequest) {
|
||||
XMLHttpRequestObject = new XMLHttpRequest();
|
||||
} else if (window.ActiveXObject) {
|
||||
XMLHttpRequestObject = new ActiveXObject("Microsoft.XMLHTTP");
|
||||
}
|
||||
|
||||
if (XMLHttpRequestObject) {
|
||||
XMLHttpRequestObject.open("GET", url);
|
||||
|
||||
XMLHttpRequestObject.onreadystatechange = function () {
|
||||
if (XMLHttpRequestObject.readyState == 4 && XMLHttpRequestObject.status == 200) {
|
||||
callback(XMLHttpRequestObject.responseText);
|
||||
delete XMLHttpRequestObject;
|
||||
XMLHttpRequestObject = null;
|
||||
}
|
||||
}
|
||||
|
||||
XMLHttpRequestObject.send(null);
|
||||
|
||||
}
|
||||
};
|
||||
|
||||
gf.readJSON = function (text) {
|
||||
return eval("("+text+")");
|
||||
};
|
||||
@@ -1,99 +0,0 @@
|
||||
# Run with (with -D for no-daemon)
|
||||
# /usr/sbin/lighttpd -f lighttpd.conf -D
|
||||
#
|
||||
|
||||
server.modules = (
|
||||
"mod_access",
|
||||
"mod_fastcgi",
|
||||
"mod_accesslog",
|
||||
"mod_redirect",
|
||||
"mod_cgi"
|
||||
)
|
||||
|
||||
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"
|
||||
|
||||
cgi.assign = ( ".cgi" => "" )
|
||||
cgi.execute-x-only = "enable"
|
||||
|
||||
index-file.names = ( "index.html" )
|
||||
|
||||
## set the event-handler (read the performance section in the manual)
|
||||
# server.event-handler = "freebsd-kqueue" # needed on OS X # Crashes on osx
|
||||
#server.event-handler = "poll"
|
||||
server.event-handler = "select"
|
||||
|
||||
# mimetype mapping
|
||||
mimetype.assign = (
|
||||
".gif" => "image/gif",
|
||||
".jpg" => "image/jpeg",
|
||||
".jpeg" => "image/jpeg",
|
||||
".png" => "image/png",
|
||||
".css" => "text/css",
|
||||
".html" => "text/html",
|
||||
".htm" => "text/html",
|
||||
".js" => "text/javascript",
|
||||
# default mime type
|
||||
"" => "application/octet-stream",
|
||||
)
|
||||
|
||||
accesslog.filename = basedir + "/access.log"
|
||||
|
||||
debug.log-request-header = "disable"
|
||||
debug.log-response-header = "disable"
|
||||
debug.log-request-handling = "disable"
|
||||
|
||||
$HTTP["host"] =~ "^(.*)$" {
|
||||
url.redirect = ( "^/$" => "http://%1/translate/" )
|
||||
}
|
||||
|
||||
fastcgi.debug = 0
|
||||
fastcgi.server = (".pgf" =>
|
||||
((
|
||||
"socket" => basedir + "/" + var.PID + "-pgf.socket",
|
||||
"bin-path" => basedir + "/dist/build/pgf-service/pgf-service",
|
||||
# Use 2 OS threads (to be able to use 2 cores).
|
||||
# Limit heap size to 512 MB.
|
||||
"bin-environment" => ("GHCRTS" => "-N2 -M512M"),
|
||||
"min-procs" => 1,
|
||||
"max-procs" => 1,
|
||||
"broken-scriptfilename" => "disable",
|
||||
"check-local" => "disable"
|
||||
)),
|
||||
".fcgi" =>
|
||||
((
|
||||
"socket" => basedir + "/" + var.PID + "-morpho.socket",
|
||||
# "bin-path" => basedir + "/dist/build/morpho-server/morpho-server",
|
||||
"bin-environment" => ("GHCRTS" => "-M512M"),
|
||||
"min-procs" => 1,
|
||||
"max-procs" => 1,
|
||||
"broken-scriptfilename" => "disable",
|
||||
"check-local" => "disable"
|
||||
))
|
||||
)
|
||||
|
||||
## deny access the file-extensions
|
||||
#
|
||||
# ~ is for backupfiles from vi, emacs, joe, ...
|
||||
# .inc is often used for code includes which should in general not be part
|
||||
# of the document-root
|
||||
url.access-deny = ( "~", ".inc" )
|
||||
|
||||
$HTTP["url"] =~ "\.pdf$" {
|
||||
server.range-requests = "disable"
|
||||
}
|
||||
|
||||
##
|
||||
# which extensions should not be handle via static-file transfer
|
||||
#
|
||||
# .php, .pl, .fcgi are most often handled by mod_fastcgi or mod_cgi
|
||||
static-file.exclude-extensions = ( ".php", ".pl", ".fcgi" )
|
||||
|
||||
######### Options that are good to be but not neccesary to be changed #######
|
||||
|
||||
## bind to port (default: 80)
|
||||
server.port = 41296
|
||||
@@ -1,111 +0,0 @@
|
||||
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
|
||||
|
||||
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
|
||||
<meta name="viewport" content="initial-scale=2.3" />
|
||||
<meta name="viewport" content="width=320; initial-scale=1.0; maximum-scale=1.0;" />
|
||||
<link rel="stylesheet" type="text/css" href="translator.css" />
|
||||
<script type="text/javascript" src="gf-server-jsapi.js"></script>
|
||||
<script type="text/javascript" src="translator.js"></script>
|
||||
<script type="text/javascript">
|
||||
function getGrammar () {
|
||||
return document.getElementById('grammar').value;
|
||||
}
|
||||
|
||||
function updateTranslation () {
|
||||
var input = document.getElementById('inputText').value;
|
||||
var fromLang = document.getElementById('fromLang').value;
|
||||
var toLang = document.getElementById('toLang').value;
|
||||
var output = document.getElementById('translation');
|
||||
|
||||
var callback = function(translation) {
|
||||
clearTranslation();
|
||||
output.appendChild(formatTranslation(translation));
|
||||
};
|
||||
gf.translate(getGrammar(), input, fromLang, toLang, '', callback);
|
||||
}
|
||||
|
||||
function updateGrammars () {
|
||||
gf.grammars(populateGrammars);
|
||||
}
|
||||
|
||||
function populateGrammars (grammars) {
|
||||
var l = document.getElementById('grammar');
|
||||
var langs = grammar.languages;
|
||||
for (var i in grammars) {
|
||||
addOption(l, grammars[i].name, grammars[i].name);
|
||||
}
|
||||
updateLanguages();
|
||||
}
|
||||
|
||||
function updateLanguages () {
|
||||
gf.grammar(getGrammar(), populateLangs);
|
||||
}
|
||||
|
||||
function populateLangs (grammar) {
|
||||
var f = document.getElementById('fromLang');
|
||||
var t = document.getElementById('toLang');
|
||||
var langs = grammar.languages;
|
||||
for (var i in langs) {
|
||||
if (langs[i].canParse) {
|
||||
addOption(f, langs[i].name, langs[i].name);
|
||||
}
|
||||
addOption(t, langs[i].name, langs[i].name);
|
||||
}
|
||||
}
|
||||
|
||||
function updateCompletion() {
|
||||
var input = document.getElementById('inputText').value;
|
||||
var fromLang = document.getElementById('fromLang').value;
|
||||
var completions = document.getElementById('completion');
|
||||
|
||||
// if (document.getElementById('enableCompletion').checked) {
|
||||
var callback = function(output) {
|
||||
clearCompletion();
|
||||
completions.appendChild(formatCompletions(output));
|
||||
};
|
||||
gf.complete(getGrammar(), input, fromLang, '', callback);
|
||||
// }
|
||||
}
|
||||
|
||||
function update() {
|
||||
// updateCompletion();
|
||||
updateTranslation();
|
||||
}
|
||||
|
||||
function clearTranslation() {
|
||||
var output = document.getElementById('translation');
|
||||
removeChildren(output);
|
||||
}
|
||||
|
||||
function clearCompletion() {
|
||||
var completions = document.getElementById('completion');
|
||||
removeChildren(completions);
|
||||
}
|
||||
|
||||
function initialize() {
|
||||
updateGrammars();
|
||||
}
|
||||
</script>
|
||||
<title>AJAX GF Translator</title>
|
||||
</head>
|
||||
<body onload="initialize()">
|
||||
<div id="translator">
|
||||
<form onsubmit="update(); return false;">
|
||||
<p>
|
||||
<input type="text" id="inputText" value="" size="50" />
|
||||
</p>
|
||||
<p>
|
||||
<label>Grammar: <select id="grammar" onchange="updateLanguages()"></select></label>
|
||||
<label>From: <select id="fromLang" onchange="update()"><option value="" selected="selected">Any language</option></select></label>
|
||||
<label>To: <select id="toLang" onchange="update()"><option value="" selected="selected">All languages</option></select></label>
|
||||
<input type="button" value="Completions" onclick="updateCompletion()" />
|
||||
<input type="submit" value="Translate" />
|
||||
</p>
|
||||
</form>
|
||||
<div id="completion"></div>
|
||||
<div id="translation"></div>
|
||||
</div>
|
||||
</body>
|
||||
</html>
|
||||
@@ -1,32 +0,0 @@
|
||||
module Fold where
|
||||
|
||||
import PGF2
|
||||
import Data.Map as M (lookup, fromList)
|
||||
|
||||
--import Debug.Trace
|
||||
|
||||
|
||||
foldable = fromList [(c, "bin_" ++ c) | c <- ops]
|
||||
where ops = words "plus times and or xor cartesian_product intersect union"
|
||||
|
||||
fold :: Expr -> Expr
|
||||
fold t =
|
||||
case unApp t of
|
||||
Just (i,[x]) ->
|
||||
case M.lookup i foldable of
|
||||
Just j -> appFold j x
|
||||
_ -> mkApp i [fold x]
|
||||
Just (i,xs) -> mkApp i $ map fold xs
|
||||
_ -> t
|
||||
|
||||
<<<<<<< HEAD
|
||||
appFold :: Fun -> Expr -> Expr
|
||||
appFold j t =
|
||||
=======
|
||||
appFold :: CId -> Tree -> Tree
|
||||
appFold j t =
|
||||
>>>>>>> master
|
||||
case unApp t of
|
||||
Just (i,[t,ts]) | isPre i "Cons" -> mkApp j [fold t, appFold j ts]
|
||||
Just (i,[t,s]) | isPre i "Base" -> mkApp j [fold t, fold s]
|
||||
where isPre i s = take 4 (show i) == s
|
||||
@@ -1,76 +0,0 @@
|
||||
body {
|
||||
color: black;
|
||||
background-color: white;
|
||||
font-family: sans-serif;
|
||||
}
|
||||
|
||||
dl {
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
dt {
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
dl dd {
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
ul {
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
li {
|
||||
list-style-type: none;
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
/* Translator widget */
|
||||
|
||||
#translator {
|
||||
|
||||
}
|
||||
|
||||
/* Translations */
|
||||
|
||||
#translation {
|
||||
clear: both;
|
||||
}
|
||||
|
||||
#translation dl {
|
||||
border-width: 0 0 1px 0;
|
||||
border-style: solid;
|
||||
border-color: #c0c0c0;
|
||||
}
|
||||
|
||||
#translation dt {
|
||||
display: none;
|
||||
}
|
||||
|
||||
#translation dd {
|
||||
border-width: 1px 0 0 0;
|
||||
border-style: solid;
|
||||
border-color: #c0c0c0;
|
||||
}
|
||||
|
||||
|
||||
/* Completions */
|
||||
|
||||
#completion {
|
||||
font-size: 80%;
|
||||
color: #c0c0c0;
|
||||
white-space: nowrap;
|
||||
width: 100%;
|
||||
overflow: hidden;
|
||||
}
|
||||
|
||||
#completion li {
|
||||
display: inline;
|
||||
padding: 0 0.1em;
|
||||
}
|
||||
|
||||
@@ -1,51 +0,0 @@
|
||||
function formatTranslation (outputs) {
|
||||
var dl1 = document.createElement("dl");
|
||||
for (var i in outputs) {
|
||||
var o = outputs[i];
|
||||
addDefinition(dl1, document.createTextNode(o.to), document.createTextNode(o.text));
|
||||
}
|
||||
|
||||
return dl1;
|
||||
}
|
||||
|
||||
function formatCompletions (compls) {
|
||||
var ul = document.createElement("ul");
|
||||
for (var i in compls) {
|
||||
var c = compls[i];
|
||||
addItem(ul, document.createTextNode(c.text));
|
||||
}
|
||||
return ul;
|
||||
}
|
||||
|
||||
/* DOM utilities for specific tags */
|
||||
|
||||
function addDefinition (dl, t, d) {
|
||||
var dt = document.createElement("dt");
|
||||
dt.appendChild(t);
|
||||
dl.appendChild(dt);
|
||||
var dd = document.createElement("dd");
|
||||
dd.appendChild(d);
|
||||
dl.appendChild(dd);
|
||||
}
|
||||
|
||||
function addItem (ul, i) {
|
||||
var li = document.createElement("li");
|
||||
li.appendChild(i);
|
||||
ul.appendChild(li);
|
||||
}
|
||||
|
||||
function addOption (select, value, content) {
|
||||
var option = document.createElement("option");
|
||||
option.value = value;
|
||||
option.appendChild(document.createTextNode(content));
|
||||
select.appendChild(option);
|
||||
}
|
||||
|
||||
/* General DOM utilities */
|
||||
|
||||
/* Removes all the children of a node */
|
||||
function removeChildren(node) {
|
||||
while (node.hasChildNodes()) {
|
||||
node.removeChild(node.firstChild);
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user