diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index 0df8a19f2..4e794ae33 100644 --- a/src/compiler/GFServer.hs +++ b/src/compiler/GFServer.hs @@ -24,8 +24,7 @@ import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink, #endif import Control.Concurrent(newMVar,modifyMVar) import Network.URI(URI(..)) -import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments, - noCache) +import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache) --import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi import Network.CGI(handleErrors,liftIO) import FastCGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile @@ -43,6 +42,7 @@ import Paths_gf(getDataDir,version) import GF.Infra.BuildInfo (buildInfo) import SimpleEditor.Convert(parseModule) import RunHTTP(cgiHandler) +import URLEncoding(decodeQuery) --logFile :: FilePath --logFile = "pgf-error.log" @@ -441,11 +441,17 @@ utf8inputs q = [(decodeString k,(decodeString v,v))|(k,v)<-inputs q] decoded = mapSnd fst raw = mapSnd snd +inputs = decodeQuery +{- +-- Stay clear of queryToArgument, which uses unEscapeString, which had +-- backward incompatible changes in network-2.4.1.1, see +-- https://github.com/haskell/network/commit/f2168b1f8978b4ad9c504e545755f0795ac869ce inputs = queryToArguments . fixplus where fixplus = concatMap decode decode '+' = "%20" -- httpd-shed bug workaround decode c = [c] +-} mapFst f xys = [(f x,y)|(x,y)<-xys] mapSnd f xys = [(x,f y)|(x,y)<-xys] diff --git a/src/server/RunHTTP.hs b/src/server/RunHTTP.hs index 2afc92afc..2b4627add 100644 --- a/src/server/RunHTTP.hs +++ b/src/server/RunHTTP.hs @@ -4,9 +4,10 @@ import Network.CGI(ContentType(..)) import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..), Headers,HeaderName(..)) import Network.CGI.Monad(runCGIT) -import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments) +import Network.Shed.Httpd(initServer,Request(..),Response(..)) import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack) import qualified Data.Map as M(fromList) +import URLEncoding(decodeQuery) data Options = Options { documentRoot :: String, port :: Int } deriving Show @@ -36,13 +37,15 @@ cgiReq root (Request method uri hdrs body) = CGIRequest vars inputs body' '?':s -> s s -> s al = maybe "" id $ lookup "Accept-Language" hdrs - inputs = map input $ queryToArguments $ fixplus qs -- assumes method=="GET" +-- inputs = map input $ queryToArguments $ fixplus qs -- assumes method=="GET" + inputs = map input $ decodeQuery qs -- assumes method=="GET" body' = BS.pack body input (name,val) = (name,Input (BS.pack val) Nothing plaintext) plaintext = ContentType "text" "plain" [] - +{- fixplus = concatMap decode where decode '+' = "%20" -- httpd-shed bug workaround decode c = [c] +-} \ No newline at end of file diff --git a/src/server/URLEncoding.hs b/src/server/URLEncoding.hs index ad5fb0dd9..881ca21cd 100644 --- a/src/server/URLEncoding.hs +++ b/src/server/URLEncoding.hs @@ -1,9 +1,9 @@ -module URLEncoding where +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) @@ -16,3 +16,46 @@ 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)