From ce097414db49601f2efe927d38ce596f390efc89 Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Sat, 7 Oct 2023 16:58:59 -0400 Subject: [PATCH] Can create all the threads on a board now --- chan-delorean.cabal | 4 ++- sql/initialize.sql | 1 + src/Backfill.hs | 82 ++++++++++++++++++++++++++++++++++++++++++--- src/DataClient.hs | 31 ++++++++++++++++- src/ThreadType.hs | 16 +++++++++ 5 files changed, 128 insertions(+), 6 deletions(-) create mode 100644 src/ThreadType.hs diff --git a/chan-delorean.cabal b/chan-delorean.cabal index 8a31bea..0a20289 100644 --- a/chan-delorean.cabal +++ b/chan-delorean.cabal @@ -71,6 +71,7 @@ executable chan-delorean Types SitesType BoardsType + ThreadType -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -86,7 +87,8 @@ executable chan-delorean text, http-conduit, safe-exceptions, - http-types + http-types, + time -- Directories containing source files. hs-source-dirs: src diff --git a/sql/initialize.sql b/sql/initialize.sql index c1e8f4c..787b8c8 100644 --- a/sql/initialize.sql +++ b/sql/initialize.sql @@ -132,6 +132,7 @@ GRANT ALL ON attachments TO chan_archiver; GRANT EXECUTE ON FUNCTION update_post_body_search_index TO chan_archiver; GRANT usage, select ON SEQUENCE sites_site_id_seq TO chan_archiver; GRANT usage, select ON SEQUENCE boards_board_id_seq TO chan_archiver; +GRANT usage, select ON SEQUENCE threads_thread_id_seq TO chan_archiver; GRANT chan_archiver TO admin; COMMIT; diff --git a/src/Backfill.hs b/src/Backfill.hs index b5cc045..b5cd975 100644 --- a/src/Backfill.hs +++ b/src/Backfill.hs @@ -13,12 +13,16 @@ import System.Directory (listDirectory, doesFileExist) import System.FilePath (()) import Data.List (find) import qualified Data.Set as Set +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Clock (UTCTime) + import JSONParsing import Types import qualified DataClient as Client import qualified SitesType as Sites import qualified BoardsType as Boards +import qualified ThreadType as Threads data SettingsCLI = SettingsCLI { jsonFile :: FilePath @@ -32,9 +36,13 @@ settingsCLI = SettingsCLI listCatalogDirectories :: JSONSettings -> IO [FilePath] listCatalogDirectories settings = do - dirs <- listDirectory (backup_read_root settings) - filterM hasCatalog dirs + allDirs <- listDirectory (backup_read_root settings) + let filteredDirs = filter (`notElem` excludedDirs) allDirs + filterM hasCatalog filteredDirs + where + excludedDirs = ["sfw", "alt", "overboard"] + hasCatalog dir = do let catalogPath = (backup_read_root settings) dir "catalog.json" doesFileExist catalogPath @@ -71,7 +79,12 @@ ensureSiteExists settings = do exitFailure -createArchivesForNewBoards :: JSONSettings -> [ String ] -> [ String ] -> Int -> IO [ Boards.Board ] +createArchivesForNewBoards + :: JSONSettings -> + [ String ] -> + [ String ] -> + Int -> + IO [ Boards.Board ] createArchivesForNewBoards settings dirs archived_boards siteid = do let dirsSet = Set.fromList dirs let archivedBoardsSet = Set.fromList archived_boards @@ -93,6 +106,64 @@ createArchivesForNewBoards settings dirs archived_boards siteid = do mapM_ putStrLn (map Boards.pathpart boards) return boards + +apiThreadToArchiveThread :: Int -> Thread -> Threads.Thread +apiThreadToArchiveThread board_id_ json_thread = + Threads.Thread + { Threads.thread_id = undefined + , Threads.board_thread_id = no json_thread + , Threads.creation_time = epochToUTCTime $ fromIntegral (time json_thread) + , Threads.board_id = board_id_ + } + +epochToUTCTime :: Int -> UTCTime +epochToUTCTime = posixSecondsToUTCTime . realToFrac + + +createArchivesForNewThreads + :: JSONSettings + -> [ Thread ] + -> [ Threads.Thread ] + -> Boards.Board + -> IO [ Threads.Thread ] +createArchivesForNewThreads settings all_threads archived_threads board = do + putStrLn $ "Creating " ++ (show $ length threads_to_create) ++ " threads." + threads_result <- Client.postThreads settings (map (apiThreadToArchiveThread board_id) threads_to_create) + + case threads_result of + Left err -> do + putStrLn $ "Error creating threads: " ++ show err + exitFailure + Right new_threads -> return new_threads + + where + board_id :: Int = Boards.board_id board + + archived_board_thread_ids :: Set.Set Int + archived_board_thread_ids = + Set.fromList $ map Threads.board_thread_id archived_threads + + threads_to_create :: [ Thread ] + threads_to_create = + filter + ((`Set.notMember` archived_board_thread_ids) . no) + all_threads + + +ensureThreads :: JSONSettings -> Boards.Board -> [ Thread ] -> IO [ Threads.Thread ] +ensureThreads settings board all_threads = do + threads_result <- Client.getThreads settings (Boards.board_id board) (map no all_threads) + + case threads_result of + Left err -> do + putStrLn $ "Error fetching threads: " ++ show err + exitFailure + Right archived_threads -> do + putStrLn $ (show $ length archived_threads)++ " threads already exist." + new_threads <- createArchivesForNewThreads settings all_threads archived_threads board + return $ archived_threads ++ new_threads + + processBoard :: JSONSettings -> Boards.Board -> IO () processBoard settings board = do let catalogPath = backupDir (Boards.pathpart board) "catalog.json" @@ -103,9 +174,12 @@ processBoard settings board = do case result of Right catalogs -> do let threads_on_board = concatMap threads catalogs + + new_threads <- ensureThreads settings board threads_on_board -- catalogs can be turned into [ Thread ] -- ensureThreads :: ( Board, [ Thread ] ) -> IO () - mapM_ (print . no) threads_on_board + -- mapM_ (print . no) threads_on_board + return () Left errMsg -> putStrLn $ "Failed to parse the JSON file in directory: " ++ (Boards.pathpart board) ++ ". Error: " ++ errMsg diff --git a/src/DataClient.hs b/src/DataClient.hs index 9d26637..26cd70b 100644 --- a/src/DataClient.hs +++ b/src/DataClient.hs @@ -8,6 +8,8 @@ module DataClient , postSite , post , postBoards + , getThreads + , postThreads ) where import Network.HTTP.Simple @@ -15,6 +17,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LC8 import Network.HTTP.Types.Status (statusCode) import Control.Exception.Safe (tryAny, SomeException) +import Data.List (intercalate) import qualified Data.ByteString.Char8 as C8 import Data.Aeson ( eitherDecode @@ -28,6 +31,7 @@ import Data.Aeson import qualified Types as T import qualified SitesType as Sites import qualified BoardsType as Boards +import qualified ThreadType as Threads data HttpError = HttpException SomeException @@ -86,7 +90,7 @@ handleHttp action = do getSiteBoards :: T.JSONSettings -> Int -> IO (Either HttpError [ Boards.Board ]) getSiteBoards settings site_id_ = get settings path >>= return . eitherDecodeResponse where - path = "/boards?select=*&site_id=eq." ++ show site_id_ + path = "/boards?site_id=eq." ++ show site_id_ postSite :: T.JSONSettings -> IO (Either HttpError [ Sites.Site ]) @@ -117,9 +121,34 @@ postBoards settings boards siteid = ] +postThreads + :: T.JSONSettings + -> [ Threads.Thread ] + -> IO (Either HttpError [ Threads.Thread ]) +postThreads settings threads = + post settings "/threads" payload True >>= return . eitherDecodeResponse + + where + payload = encode $ fmap mk_obj threads + + mk_obj :: Threads.Thread -> Value + mk_obj thread = object + [ "board_thread_id" .= Threads.board_thread_id thread + , "creation_time" .= Threads.creation_time thread + , "board_id" .= Threads.board_id thread + ] + + getAllSites :: T.JSONSettings -> IO (Either HttpError [ Sites.Site ]) getAllSites settings = get settings "/sites" >>= return . eitherDecodeResponse +getThreads :: T.JSONSettings -> Int -> [ Int ] -> IO (Either HttpError [ Threads.Thread ]) +getThreads settings board_id board_thread_ids = + get settings path >>= return . eitherDecodeResponse + + where + path = "/threads?board_thread_id=in.(" ++ ids ++ ")&board_id=eq." ++ show board_id + ids :: String = intercalate "," $ map show board_thread_ids eitherDecodeResponse :: (FromJSON a) => Either HttpError LBS.ByteString -> Either HttpError a eitherDecodeResponse (Left err) = Left err diff --git a/src/ThreadType.hs b/src/ThreadType.hs new file mode 100644 index 0000000..75379cc --- /dev/null +++ b/src/ThreadType.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module ThreadType + ( Thread (..) ) + where + +import GHC.Generics +import Data.Aeson (FromJSON) +import Data.Time.Clock (UTCTime) -- Required for timestamp with time zone + +data Thread = Thread + { thread_id :: Int + , board_thread_id :: Int + , creation_time :: UTCTime + , board_id :: Int + } deriving (Show, Generic, FromJSON)