From eb2b5a65d67dc5be17df9dd1c3d5c00d1e05e87a Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Thu, 25 Jul 2013 16:04:43 +0000
Subject: [PATCH] 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   | 20 ++++++++++++--------
 src/server/FastCGIUtils.hs | 17 ++++++++++++-----
 2 files changed, 24 insertions(+), 13 deletions(-)

diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs
index 4e794ae33..b45862aca 100644
--- a/src/compiler/GFServer.hs
+++ b/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
diff --git a/src/server/FastCGIUtils.hs b/src/server/FastCGIUtils.hs
index 05aa29eac..6c93b2801 100644
--- a/src/server/FastCGIUtils.hs
+++ b/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]]