diff --git a/src/Lib.hs b/src/Lib.hs index 702e0e2..1d97878 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -378,7 +378,6 @@ processFiles settings fgs tuples = do -- perfect just means that our posts have to_insert_ <- mapM ensureAttachmentExists to_insert let to_insert_exist = catMaybes to_insert_ - -- to_insert_exist <- filterM attachmentFileExists to_insert with_hashes <- mapM computeAttachmentHash to_insert_exist @@ -391,7 +390,7 @@ processFiles settings fgs tuples = do -- perfect just means that our posts have Right saved -> do putStrLn $ "Saved " ++ (show $ length saved) ++ " attachments!" - mapM_ (copyOrMoveFiles settings fgs) attachments_on_board + mapM_ (copyOrMoveFiles settings fgs) to_insert_exist where ensureAttachmentExists :: Details -> IO (Maybe Details) diff --git a/src/Main.hs b/src/Main.hs index 79a8a79..866a686 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,7 +9,7 @@ import Data.Aeson (decode) import System.FilePath (()) import Control.Concurrent.Async (mapConcurrently) import Data.Aeson (FromJSON) -import System.Directory (createDirectoryIfMissing, renameFile) +import System.Directory (createDirectoryIfMissing, removeFile) import qualified SitesType as Sites import Common.Server.ConsumerSettings @@ -54,6 +54,13 @@ getSettings = do exitFailure Just settings -> return settings + +-- Move a file by reading, writing, and then deleting the original +moveFile :: FilePath -> FilePath -> IO () +moveFile src dst = + B.readFile src >>= B.writeFile dst >> removeFile src + + httpFileGetters :: JSONSettings -> FileGetters httpFileGetters settings = FileGetters { getJSONCatalog = httpGetJSON @@ -66,12 +73,14 @@ httpFileGetters settings = FileGetters thumbpath <- Client.getFile (At.thumbnail_path paths) return $ filepath >>= \fp -> - thumbpath >>= \tp -> + thumbpath >>= \tp -> do return (At.Paths fp tp) + , copyOrMove = \common_dest (src, dest) (thumb_src, thumb_dest) -> do + putStrLn $ "Copy Or Move (Move) src: " ++ src ++ " dest: " ++ dest createDirectoryIfMissing True common_dest - renameFile src dest - renameFile thumb_src thumb_dest + moveFile src dest + moveFile thumb_src thumb_dest } httpGetJSON :: (FromJSON a) => Sites.Site -> String -> IO (Either String a) diff --git a/src/Network/DataClient.hs b/src/Network/DataClient.hs index 7004cb2..c7b3879 100644 --- a/src/Network/DataClient.hs +++ b/src/Network/DataClient.hs @@ -39,6 +39,7 @@ import Data.Aeson ) import GHC.Generics import System.IO.Temp (openBinaryTempFile, getCanonicalTemporaryDirectory) +import System.IO (hClose) import qualified Common.Server.JSONSettings as T import qualified SitesType as Sites @@ -226,15 +227,20 @@ getJSON url = get_ url [] >>= return . eitherDecodeResponse getFile :: String -> IO (Maybe String) getFile url = do + putStrLn $ "getFile " ++ url result <- get_ url [] case result of Left (err :: HttpError) -> do + putStrLn $ "getFile " ++ url ++ " Error!" putStrLn $ show err return Nothing Right lbs -> do + putStrLn $ "getFile " ++ url ++ " SUCCESS!" tmp_root <- getCanonicalTemporaryDirectory (tmp_filepath, tmp_filehandle) <- openBinaryTempFile tmp_root "chan.attachment" - LBS.writeFile tmp_filepath lbs + putStrLn $ "Created " ++ tmp_filepath + putStrLn $ "Writing attachment..." LBS.hPut tmp_filehandle lbs + hClose tmp_filehandle return $ Just tmp_filepath