lookupLang is now case-insensitive

2 files changed, 9 insertions, 4 deletions

diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs
index 6e265e0c..5222258e 100644
--- a/Presence/ConsoleWriter.hs
+++ b/Presence/ConsoleWriter.hs
@@ -136,10 +136,15 @@ getPreferedLang = do
         return $ lc_all `mplus` lc_messages `mplus` lang
     return $ maybe "en" (Text.pack . toBCP47) lang
 
+cimatch w t = Text.toLower w == Text.toLower t
+cimatches w ts = dropWhile (not . cimatch w) ts
+
 -- rfc4647 lookup of best match language tag
-lookupLang (w:ws) tags | Text.null w   = lookupLang ws tags
-                       | w `elem` tags = Just w
-                       | otherwise     = lookupLang (reduce w:ws) tags
+lookupLang (w:ws) tags
+    | Text.null w = lookupLang ws tags
+    | otherwise   = case cimatches w tags of
+                        (t:_) -> Just t
+                        []    -> lookupLang (reduce w:ws) tags
  where
     reduce w = Text.concat $ reverse nopriv
         where
diff --git a/xmppServer.hs b/xmppServer.hs
index af145906..d5ad7c6a 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -579,7 +579,7 @@ informPeerPresence state k stanza = do
         is_avail <- atomically $ clientIsAvailable client
         when is_avail $ do
         putStrLn $ "reversing for client: " ++ show from
-        froms <- do
+        froms <- flip (maybe $ return [from]) k . const $ do
             let ClientKey laddr = ck
             (_,trip) <- multiplyJIDForClient laddr from
             return (map unsplitJID trip)