Fix UTF-8 decoding problem in gf -server

The package network-2.4.1.1 thoughlessly introduced a backward incompatible
change to the function Network.URI.unEscapeString, see

    https://github.com/haskell/network/commit/f2168b1f8978b4ad9c504e545755f0795ac869ce

This also affects the function Network.Shed.Httpd.queryToArguments, which is
used in GFServer.hs.

To remain compatible with older and newer versions of the network package,
we need to stay clear of queryToArguments and unEscapeString. A replacement
function has been added to server/URLEncoding.hs.

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)