From 1c6c1250e33af8a748b361e610ef65dcbed705fc Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Fri, 5 Apr 2024 19:07:20 -0400 Subject: [PATCH] Begin generalizing backfill code to use either local or http functions --- chan-delorean.cabal | 5 ++- src/Common | 2 +- src/Lib.hs | 80 ++++++++++++++++++++++++--------------- src/Main.hs | 26 +++++++++++-- src/Network/DataClient.hs | 5 +++ 5 files changed, 83 insertions(+), 35 deletions(-) diff --git a/chan-delorean.cabal b/chan-delorean.cabal index 9f65b09..3dd2901 100644 --- a/chan-delorean.cabal +++ b/chan-delorean.cabal @@ -66,6 +66,7 @@ executable chan-delorean -- Modules included in this executable, other than Main. other-modules: + Lib JSONParsing SitesType BoardsType @@ -118,6 +119,7 @@ executable chan-delorean-consoomer -- Modules included in this executable, other than Main. other-modules: + Lib JSONParsing SitesType BoardsType @@ -154,7 +156,8 @@ executable chan-delorean-consoomer cryptonite, memory, mime-types, - perceptual-hash + perceptual-hash, + async -- Directories containing source files. hs-source-dirs: src diff --git a/src/Common b/src/Common index 202f0eb..390165e 160000 --- a/src/Common +++ b/src/Common @@ -1 +1 @@ -Subproject commit 202f0eb9616b6675e3fa011c69d8fda9028e5e59 +Subproject commit 390165edf85e26c53f2fd53353270ee2ad4c4a38 diff --git a/src/Lib.hs b/src/Lib.hs index 29b8bc3..e0b53be 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -2,6 +2,7 @@ {-# HLINT ignore "Redundant bracket" #-} {-# HLINT ignore "Use fromMaybe" #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Lib where @@ -105,19 +106,22 @@ createArchivesForNewBoards settings dirsSet archived_boards siteid = do -- Find boards that are in dirs but not in archived_boards let boardsToArchive = dirsSet `Set.difference` archivedBoardsSet - putStrLn "Creating boards:" + putStrLn $ "Creating " ++ (show $ length boardsToArchive) ++ " boards:" mapM_ putStrLn boardsToArchive - post_result <- Client.postBoards settings (Set.toList boardsToArchive) siteid + if Set.null boardsToArchive + then return [] + else do + post_result <- Client.postBoards settings (Set.toList boardsToArchive) siteid - case post_result of - Left err -> do - putStrLn $ "Error posting boards: " ++ show err - exitFailure - Right boards -> do - putStrLn "Created the following boards:" - mapM_ (putStrLn . Boards.pathpart) boards - return boards + case post_result of + Left err -> do + putStrLn $ "Error posting boards: " ++ show err + exitFailure + Right boards -> do + putStrLn "Created the following boards:" + mapM_ (putStrLn . Boards.pathpart) boards + return boards apiThreadToArchiveThread :: Int -> Thread -> Threads.Thread @@ -179,10 +183,12 @@ ensureThreads settings board all_threads = do readPosts :: JSONSettings + -> FileGetters -> Boards.Board -> Threads.Thread -> IO (Threads.Thread, [ JSONPosts.Post ]) -readPosts settings board thread = do +readPosts settings fgs board thread = do +-- parsePosts :: FilePath -> IO (Either String Post.PostWrapper) result <- parsePosts thread_filename case result of @@ -588,20 +594,32 @@ createNewPosts settings tuples = do thread_id = Client.thread_id c -processBoard :: JSONSettings -> Sites.Site -> Boards.Board -> IO () -processBoard settings site board = do - let catalogPath = backupDir "catalog.json" + +data FileGetters = FileGetters + { getJSONCatalog :: Sites.Site -> String -> IO (Either String [ Catalog ]) + } + + +localFileGetters :: JSONSettings -> FileGetters +localFileGetters settings = FileGetters + { getJSONCatalog = const $ parseJSONCatalog . (backup_read_root settings ) + } + + +processBoard :: JSONSettings -> FileGetters -> Sites.Site -> Boards.Board -> IO () +processBoard settings fgs@FileGetters {..} site board = do + let catalogPath = Boards.pathpart board "catalog.json" putStrLn $ "catalog file path: " ++ catalogPath - result <- parseJSONCatalog catalogPath + result <- getJSONCatalog site catalogPath case result of - Right catalogs -> do + Right (catalogs :: [ Catalog ]) -> do let threads_on_board = concatMap ((maybe [] id) . threads) catalogs all_threads_for_board :: [ Threads.Thread ] <- ensureThreads settings board threads_on_board - all_posts_on_board :: [(Threads.Thread, [ JSONPosts.Post ])] <- mapM (readPosts settings board) all_threads_for_board + all_posts_on_board :: [(Threads.Thread, [ JSONPosts.Post ])] <- mapM (readPosts settings fgs board) all_threads_for_board let tuples :: [(Sites.Site, Boards.Board, Threads.Thread, JSONPosts.Post)] = concatMap @@ -623,18 +641,11 @@ processBoard settings site board = do putStrLn $ "Failed to parse the JSON file in directory: " ++ (Boards.pathpart board) ++ ". Error: " ++ errMsg - where - backupDir :: FilePath - backupDir = backup_read_root settings (Boards.pathpart board) - -processBackupDirectory :: JSONSettings -> IO () -processBackupDirectory settings = do - putStrLn "JSON successfully read!" - print settings -- print the decoded JSON settings +processBoards :: JSONSettings -> FileGetters -> [ FilePath ] -> IO () +processBoards settings fgs board_names = do site :: Sites.Site <- ensureSiteExists settings - dirs <- listCatalogDirectories settings - let dirsSet = Set.fromList dirs + let boardsSet = Set.fromList board_names let site_id_ = Sites.site_id site boards_result <- Client.getSiteBoards settings site_id_ putStrLn "Boards fetched!" @@ -645,7 +656,16 @@ processBackupDirectory settings = do exitFailure Right archived_boards -> do let boardnames = map Boards.pathpart archived_boards - created_boards <- createArchivesForNewBoards settings dirsSet boardnames site_id_ + created_boards <- createArchivesForNewBoards settings boardsSet boardnames site_id_ let boards :: [ Boards.Board ] = archived_boards ++ created_boards - let boards_we_have_data_for = filter (\board -> Set.member (Boards.pathpart board) dirsSet) boards - mapM_ (processBoard settings site) boards_we_have_data_for + let boards_we_have_data_for = filter (\board -> Set.member (Boards.pathpart board) boardsSet) boards + mapM_ (processBoard settings fgs site) boards_we_have_data_for + + + +processBackupDirectory :: JSONSettings -> IO () +processBackupDirectory settings = do + putStrLn "JSON successfully read!" + print settings -- print the decoded JSON settings + boards <- listCatalogDirectories settings + processBoards settings (localFileGetters settings) boards diff --git a/src/Main.hs b/src/Main.hs index bae1fb3..1de3ac8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,12 +6,18 @@ import System.Exit (exitFailure) import qualified Data.ByteString.Lazy as B import System.Console.CmdArgs (cmdArgs, Data, Typeable) import Data.Aeson (decode) +import System.FilePath (()) +import Control.Concurrent.Async (mapConcurrently) +import qualified SitesType as Sites import Common.Server.ConsumerSettings import Common.Server.JSONSettings as J import Lib - ( ensureSiteExists + ( processBoards + , FileGetters (..) ) +import JSONParsing (Catalog) +import qualified Network.DataClient as Client newtype CliArgs = CliArgs { settingsFile :: String @@ -46,11 +52,23 @@ getSettings = do exitFailure Just settings -> return settings +httpFileGetters :: JSONSettings -> FileGetters +httpFileGetters _ = FileGetters + { getJSONCatalog = httpGetJSON + } + +httpGetJSON :: Sites.Site -> String -> IO (Either String [Catalog]) +httpGetJSON site path = (Client.getJSON $ Sites.url site path) + >>= getErrMsg + where + getErrMsg :: Either Client.HttpError a -> IO (Either String a) + getErrMsg (Left err) = return $ Left $ show err + getErrMsg (Right x) = return $ Right x processWebsite :: ConsumerJSONSettings -> JSONSiteSettings -> IO () processWebsite settings site_settings = do let client_settings = toClientSettings settings site_settings - site <- ensureSiteExists client_settings + processBoards client_settings (httpFileGetters client_settings) (boards site_settings) return () main :: IO () @@ -60,4 +78,6 @@ main = do settings <- getSettings print settings - mapM_ (processWebsite settings) (websites settings) + _ <- mapConcurrently (processWebsite settings) (websites settings) + + putStrLn "Done." diff --git a/src/Network/DataClient.hs b/src/Network/DataClient.hs index 38addb2..d5ebeab 100644 --- a/src/Network/DataClient.hs +++ b/src/Network/DataClient.hs @@ -17,6 +17,7 @@ module Network.DataClient , postPosts , getAttachments , postAttachments + , getJSON ) where import Control.Monad (forM) @@ -215,3 +216,7 @@ eitherDecodeResponse (Right bs) = case eitherDecode bs of Right val -> Right val Left err -> Left $ StatusCodeError 500 $ LC8.pack $ "Failed to decode JSON: " ++ err ++ " " ++ (show bs) + + +getJSON :: (FromJSON a) => String -> IO (Either HttpError a) +getJSON url = get_ url [] >>= return . eitherDecodeResponse