Notmuch: handle JSON with broken UTF-8

2 files changed, 20 insertions, 5 deletions

diff --git a/Data/Aeson/Extends.hs b/Data/Aeson/Extends.hs
new file mode 100644
index 0000000..d78f81d
--- /dev/null
+++ b/Data/Aeson/Extends.hs
@@ -0,0 +1,15 @@
+module Data.Aeson.Extends (module Data.Aeson.Extends) where
+
+import Data.Aeson as Data.Aeson.Extends
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text.Encoding.Error as TE
+import qualified Data.Text.Lazy.Encoding as LT
+
+
+eitherDecodeLenient' :: FromJSON a => LBS.ByteString -> Either String a
+eitherDecodeLenient' s =
+    either (const $ eitherDecode' $ lenientReencode s) id (eitherDecode' s)
+  where
+    lenientReencode = LT.encodeUtf8 . LT.decodeUtf8With TE.lenientDecode
+
diff --git a/Notmuch.hs b/Notmuch.hs
index 00ac5a3..4d0ddd1 100644
--- a/Notmuch.hs
+++ b/Notmuch.hs
@@ -10,7 +10,7 @@ import qualified Network.Mail.Mime as M
 import Control.Concurrent
 import Control.DeepSeq (rnf)
 import Control.Exception
-import Data.Aeson
+import Data.Aeson.Extends
 import Data.Tree
 import Notmuch.Class
 import Notmuch.Message
@@ -142,7 +142,7 @@ notmuchWithInput args input = do
 search :: [String] -> IO (Either String [SearchResult])
 search args =
     notmuch ("search" : "--format=json" : "--format-version=2" : args)
-        >>= return . eitherDecode'
+        >>= return . eitherDecodeLenient'
 
 
 data ReplyTo = ToAll | ToSender
@@ -158,7 +158,7 @@ notmuchReply replyTo term =
         , "--reply-to=" ++ show replyTo
         , term
         ]
- --       >>= return . eitherDecode'
+ --       >>= return . eitherDecodeLenient'
 
 
 notmuchShow :: String -> IO (Forest Message)
@@ -167,7 +167,7 @@ notmuchShow term = do
                    , term ]
     -- TODO why head?
     return $ threadForest $ head $
-        either error id (eitherDecode' c')
+        either error id (eitherDecodeLenient' c')
 
 
 notmuchShowPart :: String -> Int -> IO (Either String MessagePart)
@@ -178,7 +178,7 @@ notmuchShowPart term partId = do
                  , "--part=" <> show partId
                  , term ]
     return $ case exitCode of
-        ExitSuccess -> eitherDecode' out
+        ExitSuccess -> eitherDecodeLenient' out
         _ -> Left $ show exitCode <> ": " <> LBS8.unpack err