web: fix non-ascii handling with ghc 6.12

The "GHC 6.12.1 has UTF8 support on board. Using System.IO.UTF8 can cause problems."
patch was over-zealous. Restore and clarify UTF8 handling with 6.12.
This commit is contained in:
Simon Michael 2010-05-23 21:46:15 +00:00
parent 287e71d54f
commit 7dbcb035bb

View File

@ -6,9 +6,7 @@ A web-based UI.
module Hledger.Cli.Commands.Web module Hledger.Cli.Commands.Web
where where
#if __GLASGOW_HASKELL__ <= 610
import Codec.Binary.UTF8.String (decodeString) import Codec.Binary.UTF8.String (decodeString)
#endif
import Control.Applicative.Error (Failing(Success,Failure)) import Control.Applicative.Error (Failing(Success,Failure))
import Control.Concurrent import Control.Concurrent
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
@ -83,8 +81,8 @@ server opts args j =
#endif #endif
\env -> do -- IO Response \env -> do -- IO Response
-- general request handler -- general request handler
let a = intercalate "+" $ reqparam env "a" let a = intercalate "+" $ map decodeString $ reqParamUtf8 env "a"
p = intercalate "+" $ reqparam env "p" p = intercalate "+" $ map decodeString $ reqParamUtf8 env "p"
opts' = opts ++ [Period p] opts' = opts ++ [Period p]
args' = args ++ words a args' = args ++ words a
j' <- fromJust `fmap` getValue "hledger" "journal" j' <- fromJust `fmap` getValue "hledger" "journal"
@ -110,12 +108,8 @@ getenv = ask
response = update response = update
redirect u c = response $ Hack.Contrib.Response.redirect u c redirect u c = response $ Hack.Contrib.Response.redirect u c
reqparam :: Hack.Env -> String -> [String] reqParamUtf8 :: Hack.Env -> String -> [String]
#if __GLASGOW_HASKELL__ <= 610 reqParamUtf8 env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
reqparam env p = map (decodeString.snd) $ filter ((==p).fst) $ Hack.Contrib.Request.params env
#else
reqparam env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
#endif
journalReloadIfChanged :: [Opt] -> [String] -> Journal -> IO Journal journalReloadIfChanged :: [Opt] -> [String] -> Journal -> IO Journal
journalReloadIfChanged opts _ j@Journal{filepath=f,filereadtime=tread} = do journalReloadIfChanged opts _ j@Journal{filepath=f,filereadtime=tread} = do
@ -170,7 +164,7 @@ hsp msgs f = do
hackEnvToHspEnv :: Hack.Env -> IO HSPEnv hackEnvToHspEnv :: Hack.Env -> IO HSPEnv
hackEnvToHspEnv env = do hackEnvToHspEnv env = do
x <- newIORef 0 x <- newIORef 0
let req = HSP.Request (reqparam env) (Hack.http env) let req = HSP.Request (reqParamUtf8 env) (Hack.http env)
num = NumberGen (atomicModifyIORef x (\a -> (a+1,a))) num = NumberGen (atomicModifyIORef x (\a -> (a+1,a)))
return $ HSPEnv req num return $ HSPEnv req num
@ -203,11 +197,7 @@ navbar env =
<a href="http://hledger.org/MANUAL.html" id="helplink">help</a> <a href="http://hledger.org/MANUAL.html" id="helplink">help</a>
</div> </div>
#if __GLASGOW_HASKELL__ <= 610
getParamOrNull p = (decodeString . fromMaybe "") `fmap` getParam p getParamOrNull p = (decodeString . fromMaybe "") `fmap` getParam p
#else
getParamOrNull p = fromMaybe "" `fmap` getParam p
#endif
navlinks :: Hack.Env -> HSP XML navlinks :: Hack.Env -> HSP XML
navlinks _ = do navlinks _ = do
@ -241,13 +231,8 @@ addform :: Hack.Env -> HSP XML
addform env = do addform env = do
today <- io $ liftM showDate $ getCurrentDay today <- io $ liftM showDate $ getCurrentDay
let inputs = Hack.Contrib.Request.inputs env let inputs = Hack.Contrib.Request.inputs env
#if __GLASGOW_HASKELL__ <= 610
date = decodeString $ fromMaybe today $ lookup "date" inputs date = decodeString $ fromMaybe today $ lookup "date" inputs
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
#else
date = fromMaybe today $ lookup "date" inputs
desc = fromMaybe "" $ lookup "desc" inputs
#endif
<div> <div>
<div id="addform"> <div id="addform">
<form action="" method="POST"> <form action="" method="POST">
@ -277,13 +262,8 @@ help topic = <a href=u>?</a>
transactionfields :: Int -> Hack.Env -> HSP XML transactionfields :: Int -> Hack.Env -> HSP XML
transactionfields n env = do transactionfields n env = do
let inputs = Hack.Contrib.Request.inputs env let inputs = Hack.Contrib.Request.inputs env
#if __GLASGOW_HASKELL__ <= 610
acct = decodeString $ fromMaybe "" $ lookup acctvar inputs acct = decodeString $ fromMaybe "" $ lookup acctvar inputs
amt = decodeString $ fromMaybe "" $ lookup amtvar inputs amt = decodeString $ fromMaybe "" $ lookup amtvar inputs
#else
acct = fromMaybe "" $ lookup acctvar inputs
amt = fromMaybe "" $ lookup amtvar inputs
#endif
<tr> <tr>
<td> <td>
<% nbsp %><% nbsp %> <% nbsp %><% nbsp %>
@ -306,21 +286,12 @@ handleAddform j = do
validate :: Hack.Env -> Day -> Failing Transaction validate :: Hack.Env -> Day -> Failing Transaction
validate env today = validate env today =
let inputs = Hack.Contrib.Request.inputs env let inputs = Hack.Contrib.Request.inputs env
#if __GLASGOW_HASKELL__ <= 610
date = decodeString $ fromMaybe "today" $ lookup "date" inputs date = decodeString $ fromMaybe "today" $ lookup "date" inputs
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs
amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs
acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs
amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs
#else
date = fromMaybe "today" $ lookup "date" inputs
desc = fromMaybe "" $ lookup "desc" inputs
acct1 = fromMaybe "" $ lookup "acct1" inputs
amt1 = fromMaybe "" $ lookup "amt1" inputs
acct2 = fromMaybe "" $ lookup "acct2" inputs
amt2 = fromMaybe "" $ lookup "amt2" inputs
#endif
validateDate "" = ["missing date"] validateDate "" = ["missing date"]
validateDate _ = [] validateDate _ = []
validateDesc "" = ["missing description"] validateDesc "" = ["missing description"]