3 files changed, 59 insertions, 7 deletions

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)