From a3ca024d1e45e5b11e7ce93077fe78cd47d419e5 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 25 Dec 2012 15:46:31 +0200
Subject: [PATCH] Catch more IO exceptions during file reading

---
 yesod/Build.hs | 37 ++++++++++++++++++++++++++-----------
 yesod/Devel.hs | 22 ++++++++++++++--------
 2 files changed, 40 insertions(+), 19 deletions(-)

diff --git a/yesod/Build.hs b/yesod/Build.hs
index 83084e19..83209ca6 100644
--- a/yesod/Build.hs
+++ b/yesod/Build.hs
@@ -7,22 +7,27 @@ module Build
     , touch
     , recompDeps
     , isNewerThan
+    , safeReadFile
     ) where
 
 -- FIXME there's a bug when getFileStatus applies to a file
 -- temporary deleted (e.g., Vim saving a file)
 
 import           Control.Applicative ((<|>), many, (<$>))
-import qualified Data.Attoparsec.Text.Lazy as A
+import qualified Data.Attoparsec.Text as A
 import           Data.Char (isSpace, isUpper)
-import qualified Data.Text.Lazy.IO as TIO
+import qualified Data.Text as T
+import           Data.Text.Encoding (decodeUtf8With)
+import           Data.Text.Encoding.Error (lenientDecode)
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as S
 
-import           Control.Exception (SomeException, try)
+import           Control.Exception (SomeException, try, IOException)
 import           Control.Exception.Lifted (handle)
 import           Control.Monad (when, filterM, forM, forM_, (>=>))
 import           Control.Monad.Trans.State (StateT, get, put, execStateT)
 import           Control.Monad.Trans.Writer (WriterT, tell, execWriterT)
-import           Control.Monad.IO.Class (liftIO)
+import           Control.Monad.IO.Class (MonadIO, liftIO)
 import           Control.Monad.Trans.Class (lift)
 
 import           Data.Monoid (Monoid (mappend, mempty))
@@ -40,6 +45,9 @@ import           Text.Julius      (juliusUsedIdentifiers)
 import           Text.Cassius     (cassiusUsedIdentifiers)
 import           Text.Lucius      (luciusUsedIdentifiers)
 
+safeReadFile :: MonadIO m => FilePath -> m (Either IOException ByteString)
+safeReadFile = liftIO . try . S.readFile
+
 touch :: IO ()
 touch = do
     m <- handle (\(_ :: SomeException) -> return Map.empty) $ readFile touchCache >>= readIO
@@ -86,8 +94,11 @@ touchDeps f action deps = (mapM_ go . Map.toList) deps
                 AlwaysOutdated -> return True
                 CompareUsedIdentifiers getDerefs -> do
                     derefMap <- get
-                    s <- liftIO $ readFile x
-                    let newDerefs = Set.fromList $ getDerefs s
+                    ebs <- safeReadFile x
+                    let newDerefs =
+                            case ebs of
+                                Left _ -> Set.empty
+                                Right bs -> Set.fromList $ getDerefs $ T.unpack $ decodeUtf8With lenientDecode bs
                     put $ Map.insert x newDerefs derefMap
                     case Map.lookup x derefMap of
                         Just oldDerefs | oldDerefs == newDerefs -> return False
@@ -176,11 +187,15 @@ data ComparisonType = AlwaysOutdated
 
 determineDeps :: FilePath -> IO [(ComparisonType, FilePath)]
 determineDeps x = do
-    y <- TIO.readFile x -- FIXME catch IO exceptions
-    let z = A.parse (many $ (parser <|> (A.anyChar >> return Nothing))) y
-    case z of
-        A.Fail{} -> return []
-        A.Done _ r -> mapM go r >>= filterM (doesFileExist . snd) . concat
+    y <- safeReadFile x
+    case y of
+        Left _ -> return []
+        Right bs -> do
+            let z = A.parseOnly (many $ (parser <|> (A.anyChar >> return Nothing)))
+                  $ decodeUtf8With lenientDecode bs
+            case z of
+                Left _ -> return []
+                Right r -> mapM go r >>= filterM (doesFileExist . snd) . concat
   where
     go (Just (StaticFiles fp, _)) = map ((,) AlwaysOutdated) <$> getFolderContents fp
     go (Just (Hamlet, f)) = return [(AlwaysOutdated, f)]
diff --git a/yesod/Devel.hs b/yesod/Devel.hs
index fe19b5da..73d55cc8 100644
--- a/yesod/Devel.hs
+++ b/yesod/Devel.hs
@@ -39,6 +39,9 @@ import qualified Data.List                             as L
 import qualified Data.Map                              as Map
 import           Data.Maybe                            (fromMaybe)
 import qualified Data.Set                              as Set
+import qualified Data.Text as T
+import           Data.Text.Encoding (decodeUtf8With)
+import           Data.Text.Encoding.Error (lenientDecode)
 
 import           System.Directory
 import           System.Environment                    (getEnvironment)
@@ -62,7 +65,7 @@ import           System.Process                        (ProcessHandle,
 import           System.Timeout                        (timeout)
 
 import           Build                                 (getDeps, isNewerThan,
-                                                        recompDeps)
+                                                        recompDeps, safeReadFile)
 import           GhcBuild                              (buildPackage,
                                                         getBuildFlags)
 
@@ -439,13 +442,16 @@ getPersistConfigLenient opts = do
   if not exists
     then return (Left $ "file does not exist: " ++ file)
     else do
-      xs <- readFile file
-      return $ case lines xs of
-                 [_,l2]  -> -- two lines, header and serialized rest
-                   case reads l2 of
-                     [(bi,_)] -> Right bi
-                     _        -> (Left "cannot parse contents")
-                 _       -> (Left "not a valid header/content file")
+      xs <- safeReadFile file
+      case xs of
+        Left e -> return $ Left $ show e
+        Right bs ->
+          return $ case lines $ T.unpack $ decodeUtf8With lenientDecode bs of
+                     [_,l2]  -> -- two lines, header and serialized rest
+                       case reads l2 of
+                         [(bi,_)] -> Right bi
+                         _        -> (Left "cannot parse contents")
+                     _       -> (Left "not a valid header/content file")
 
 fromMaybeErr :: String -> Maybe b -> IO b
 fromMaybeErr err Nothing = failWith err