Handle errors when creating phash

src/Lib.hs

@@ -30,6 +30,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8)
 import Network.Mime (defaultMimeLookup)
 import PerceptualHash (fileHash)
+import Control.Exception.Safe (tryAny, tryAsync, SomeException, displayException)
 
 import JSONParsing
 import Common.Server.JSONSettings
@@ -277,7 +278,7 @@ fileToAttachment i post file =
         }
 
     where
-      extension = JS.ext file
+      extension = T.filter (/= '.') $ JS.ext file
 
       thumb_extension = T.pack $ drop 1 $ takeExtension $ unpack $ JS.thumb_path file
 
@@ -403,8 +404,6 @@ processFiles settings fgs tuples = do -- perfect just means that our posts have
             let f = At.file_path p
 
             putStrLn $ "Reading " ++ f
-            -- putStrLn $ show p
-            -- putStrLn $ show (q { At.sha256_hash = "undefined" })
 
             sha256_sum <- Hash.computeSHA256 f
 
@@ -413,12 +412,21 @@ processFiles settings fgs tuples = do -- perfect just means that our posts have
             phash :: Maybe Int64 <-
                 case (At.mimetype q) `Set.member` phash_mimetypes of
                     True -> do
-                        either_phash <- fileHash f
+                        putStrLn $ "Running tryAny $ fileHash f " ++ f
+                        either_exception <- tryAny $ fileHash f
+                        putStrLn $ "Done tryAny $ fileHash f " ++ f
+
+                        case either_exception of
+                            Left (err :: SomeException) -> do
+                                putStrLn $ "Error while computing the perceptual hash of file " ++ f ++ " " ++ displayException err
+                                return Nothing
+                            Right either_phash ->
                                 case either_phash of
                                     Left err_str -> do
                                         putStrLn $ "Failed to compute phash for file " ++ (unpack sha256_sum) ++ " " ++ f ++ " " ++ err_str
                                         return Nothing
                                     Right phash_w -> do
+                                        result <- tryAsync $ do
                                             let phash_i = Words.wordToSignedInt64 phash_w
 
                                             if phash_i == 0 then do
@@ -428,6 +436,13 @@ processFiles settings fgs tuples = do -- perfect just means that our posts have
                                                 putStrLn $ "phash: " ++ show phash_w
                                                 return $ Just $ Words.wordToSignedInt64 phash_w
 
+                                        case result of
+                                            Left (err2 :: SomeException) -> do
+                                                putStrLn $ "Error handling phash result! " ++ displayException err2
+                                                return Nothing
+
+                                            Right w -> return w
+
                     False -> return Nothing