forked from GitHub/gf-core
restore the FastCGI service and move some files back to src/server
This commit is contained in:
Krasimir Angelov
107
src/server/CGIUtils.hs
Normal file
107
src/server/CGIUtils.hs
Normal file
@@ -0,0 +1,107 @@
|
||||
{-# LANGUAGE DeriveDataTypeable, CPP #-}
|
||||
-- | CGI utility functions for output, error handling and logging
|
||||
module 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 Network.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 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
|
||||
72
src/server/Cache.hs
Normal file
72
src/server/Cache.hs
Normal file
@@ -0,0 +1,72 @@
|
||||
-- | A file cache to avoid reading and parsing the same file many times
|
||||
module 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'))
|
||||
340
src/server/LICENSE
Normal file
340
src/server/LICENSE
Normal file
@@ -0,0 +1,340 @@
|
||||
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.
|
||||
426
src/server/PGFService.hs
Normal file
426
src/server/PGFService.hs
Normal file
@@ -0,0 +1,426 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module PGFService(cgiMain,cgiMain',getPath,
|
||||
logFile,stderrToFile,
|
||||
Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
|
||||
|
||||
import PGF2
|
||||
import PGF2.Transactions
|
||||
import Cache
|
||||
import Network.CGI(CGI,readInput,getInput,getVarWithDefault,
|
||||
CGIResult,handleErrors,setHeader,
|
||||
Accept(..),Language(..),negotiate,liftIO)
|
||||
import CGIUtils(outputJSONP,outputPlain,
|
||||
outputBinary,outputBinary',
|
||||
handleCGIErrors,throwCGIError,stderrToFile)
|
||||
import URLEncoding
|
||||
|
||||
import Data.Time.Format(formatTime)
|
||||
import Data.Time.Format(defaultTimeLocale,rfc822DateFormat)
|
||||
import Text.JSON
|
||||
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.Catch(bracket_)
|
||||
import Data.Char
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import System.Process
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.IO.Error(isDoesNotExistError)
|
||||
import System.FilePath(takeExtension)
|
||||
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 # from % textInput
|
||||
"lookupcohorts" -> out t=<< cohorts # from % getInput "filter" % textInput
|
||||
"flush" -> out t=<< flush
|
||||
"grammar" -> out t grammar
|
||||
"abstrtree" -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree
|
||||
"parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from %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 =
|
||||
[makeObj ["to".=to,
|
||||
"texts".=linearizeAll c tree]|(to,c)<-tos]
|
||||
|
||||
lin tree to = showJSON (lin' tree to)
|
||||
lin' tree tos =
|
||||
[makeObj ["to".=to,"text".=linearize c tree]|(to,c)<-tos]
|
||||
|
||||
bracketedLin tree to = showJSON (bracketedLin' tree to)
|
||||
bracketedLin' tree tos =
|
||||
[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
|
||||
where
|
||||
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 =
|
||||
[(to,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 = (,) # from % textInput
|
||||
|
||||
from = maybe (missing "from") return =<< getLang "from"
|
||||
|
||||
to = getLangs "to"
|
||||
|
||||
getLangs i = mapM readLang . maybe [] words =<< getInput i
|
||||
|
||||
getLang i = do
|
||||
mlang <- getInput i
|
||||
case mlang of
|
||||
Just lang@(_:_) -> Just # readLang lang
|
||||
_ -> return Nothing
|
||||
|
||||
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)
|
||||
|
||||
|
||||
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"
|
||||
|
||||
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 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
|
||||
61
src/server/URLEncoding.hs
Normal file
61
src/server/URLEncoding.hs
Normal file
@@ -0,0 +1,61 @@
|
||||
module 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)
|
||||
99
src/server/lighttpd.conf
Normal file
99
src/server/lighttpd.conf
Normal file
@@ -0,0 +1,99 @@
|
||||
# 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-fcgi",
|
||||
# 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
|
||||
16
src/server/pgf-fcgi.hs
Normal file
16
src/server/pgf-fcgi.hs
Normal file
@@ -0,0 +1,16 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
import Control.Concurrent(forkIO)
|
||||
import Network.FastCGI
|
||||
|
||||
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
|
||||
74
src/server/pgf-service.cabal
Normal file
74
src/server/pgf-service.cabal
Normal file
@@ -0,0 +1,74 @@
|
||||
name: pgf-service
|
||||
version: 1.0
|
||||
cabal-version: >= 1.8
|
||||
build-type: Simple
|
||||
license: GPL
|
||||
license-file: LICENSE
|
||||
synopsis: CGI library and FastCGI Service for Grammatical Framework
|
||||
|
||||
flag fastcgi
|
||||
Description: Build library & pgf-fcgi executable with fastcgi support
|
||||
Default: True
|
||||
|
||||
flag network-uri
|
||||
description: Get Network.URI from the network-uri package
|
||||
default: True
|
||||
|
||||
Library
|
||||
exposed-modules: PGFService URLEncoding CGIUtils Cache
|
||||
|
||||
build-depends: base >=4.2 && <5,
|
||||
time,
|
||||
directory,
|
||||
filepath,
|
||||
containers,
|
||||
process,
|
||||
pgf2 >= 2,
|
||||
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
|
||||
|
||||
executable pgf-fcgi
|
||||
main-is: pgf-fcgi.hs
|
||||
other-modules: URLEncoding Cache CGIUtils PGFService
|
||||
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, pgf-service,
|
||||
time,
|
||||
directory,
|
||||
filepath,
|
||||
containers,
|
||||
process,
|
||||
pgf2 >= 2,
|
||||
cgi >= 3001.1.7.3,
|
||||
exceptions,
|
||||
json >= 0.3.3,
|
||||
utf8-string >= 0.3.1.1,
|
||||
bytestring
|
||||
if os(windows)
|
||||
ghc-options: -optl-mwindows
|
||||
else
|
||||
build-depends: unix
|
||||
Reference in New Issue
Block a user