Allow cross origin requests to GF cloud & PGF services

By adding a header

	Access-Control-Allow-Origin: *

to the HTTP responses, web browsers are informed that it is OK to call the
services from web pages hosted on other sites.

This is apparently supported in most modern browsers, so it should no longer
be necessary to resort to JSONP.

See https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS

src/compiler/GFServer.hs

@@ -339,16 +339,16 @@ jsonp qs = json200' $ maybe id apply (lookup "jsonp" qs)
     apply f json = f++"("++json++")"
 
 -- * Standard HTTP responses
-ok200        = Response 200 [plainUTF8,noCache] . encodeString
-ok200' t     = Response 200 [t]
+ok200        = Response 200 [plainUTF8,noCache,xo] . encodeString
+ok200' t     = Response 200 [t,xo]
 json200 x    = json200' id x
 json200' f   = ok200' jsonUTF8 . encodeString . f . encode
 html200      = ok200' htmlUTF8 . encodeString
-resp204      = Response 204 [] "" -- no content
-resp400 msg  = Response 400 [plain] $ "Bad request: "++msg++"\n"
-resp404 path = Response 404 [plain] $ "Not found: "++path++"\n"
-resp500 msg  = Response 500 [plain] $ "Internal error: "++msg++"\n"
-resp501 msg  = Response 501 [plain] $ "Not implemented: "++msg++"\n"
+resp204      = Response 204 [xo] "" -- no content
+resp400 msg  = Response 400 [plain,xo] $ "Bad request: "++msg++"\n"
+resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n"
+resp500 msg  = Response 500 [plain,xo] $ "Internal error: "++msg++"\n"
+resp501 msg  = Response 501 [plain,xo] $ "Not implemented: "++msg++"\n"
 
 instance Error Response where
   noMsg = resp500 "no message"
@@ -360,6 +360,8 @@ plainUTF8 = ct "text/plain; charset=UTF-8"
 jsonUTF8 = ct "text/javascript; charset=UTF-8"
 htmlUTF8 = ct "text/html; charset=UTF-8"
 ct t = ("Content-Type",t)
+xo = ("Access-Control-Allow-Origin","*") -- Allow cross origin requests
+     -- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS
 
 contentTypeFromExt ext =
   case ext of
@@ -441,7 +443,9 @@ utf8inputs q = [(decodeString k,(decodeString v,v))|(k,v)<-inputs q]
 decoded = mapSnd fst
 raw = mapSnd snd
 
-inputs = decodeQuery
+inputs ('?':q) = decodeQuery q
+inputs q = decodeQuery q
+
 {-
 -- Stay clear of queryToArgument, which uses unEscapeString, which had
 -- backward incompatible changes in network-2.4.1.1, see

src/server/FastCGIUtils.hs

@@ -22,7 +22,8 @@ import System.Posix
 #endif
 
 --import Network.FastCGI
-import Network.CGI
+import Network.CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
+                   getInput,catchCGI,throwCGI)
 
 import Text.JSON
 import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
@@ -153,9 +154,10 @@ throwCGIError :: Int -> String -> [String] -> CGI a
 throwCGIError c m t = throwCGI $ toException $ CGIError c m t
 
 handleCGIErrors :: CGI CGIResult -> CGI CGIResult
-handleCGIErrors x = x `catchCGI` \e -> case fromException e of
-                                         Nothing -> throw e
-                                         Just (CGIError c m t) -> outputError c m t
+handleCGIErrors x =
+    x `catchCGI` \e -> case fromException e of
+                         Nothing -> throw e
+                         Just (CGIError c m t) -> do setXO; outputError c m t
 
 -- * General CGI and JSON stuff
 
@@ -174,11 +176,13 @@ outputEncodedJSONP json =
 outputPNG :: BS.ByteString -> CGI CGIResult
 outputPNG x = do
        setHeader "Content-Type" "image/png"
+       setXO
        outputFPS x
 
 outputBinary :: BS.ByteString -> CGI CGIResult
 outputBinary x = do
        setHeader "Content-Type" "application/binary"
+       setXO
        outputFPS x
 
 outputHTML :: String -> CGI CGIResult
@@ -192,9 +196,12 @@ outputPlain x = do
        outputStrict $ UTF8.encodeString x
 
 outputStrict :: String -> CGI CGIResult
-outputStrict x | x == x = output x
+outputStrict x | x == x = do 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
+
 -- * General utilities
 
 splitBy :: (a -> Bool) -> [a] -> [[a]]