Can create all the threads on a board now

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

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;

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)
+    allDirs <- listDirectory (backup_read_root settings)
-    filterM hasCatalog dirs
+    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

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

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)