diff --git a/backfill_settings.json b/backfill_settings.json index 087008a..31ff7cf 100644 --- a/backfill_settings.json +++ b/backfill_settings.json @@ -1,5 +1,7 @@ { "postgrest_url": "http://localhost:3000", "jwt": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoiY2hhbl9hcmNoaXZlciJ9.rGIKZokTDKTuQLIv8138bUby5PELfDipYYIDpJzH02c", - "backup_read_root": "/home/phil/linixy/tmp/leftypol_back/lainchan.leftypol.org" + "backup_read_root": "/home/phil/linixy/tmp/leftypol_back/lainchan.leftypol.org", + "site_name": "leftychan", + "site_url": "https://leftychan.net" } diff --git a/chan-delorean.cabal b/chan-delorean.cabal index bb1e27d..12886de 100644 --- a/chan-delorean.cabal +++ b/chan-delorean.cabal @@ -67,6 +67,8 @@ executable chan-delorean -- Modules included in this executable, other than Main. other-modules: JSONParsing + DataClient + Types -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -79,7 +81,10 @@ executable chan-delorean directory, filepath, containers, - text + text, + http-conduit, + safe-exceptions, + http-types -- Directories containing source files. hs-source-dirs: src diff --git a/shell.nix b/shell.nix index afc55b1..c20881c 100644 --- a/shell.nix +++ b/shell.nix @@ -4,7 +4,8 @@ let inherit (nixpkgs) pkgs; f = { mkDerivation, base, stdenv, cabal-install, - aeson, safe-exceptions, bytestring, cmdargs + aeson, safe-exceptions, bytestring, cmdargs, + http-conduit }: mkDerivation { pname = "chan-delorean"; @@ -13,7 +14,7 @@ let isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base safe-exceptions aeson bytestring cmdargs + base safe-exceptions aeson bytestring cmdargs http-conduit ]; testHaskellDepends = [ cabal-install ]; license = "unknown"; diff --git a/sql/initialize.sql b/sql/initialize.sql index c199daa..7a4dc6d 100644 --- a/sql/initialize.sql +++ b/sql/initialize.sql @@ -33,7 +33,7 @@ DROP ROLE IF EXISTS chan_archive_anon; CREATE TABLE IF NOT EXISTS sites ( site_id serial primary key - , name text NOT NULL + , name text NOT NULL UNIQUE , url text NOT NULL ); @@ -43,6 +43,7 @@ CREATE TABLE IF NOT EXISTS boards , pathpart text NOT NULL -- if it's /a/ then the pathpart is a , site_id int NOT NULL , CONSTRAINT site_fk FOREIGN KEY (site_id) REFERENCES sites (site_id) ON DELETE CASCADE + , CONSTRAINT unique_site_board_id_constraint UNIQUE (site_id, pathpart) ); CREATE TABLE IF NOT EXISTS threads @@ -116,6 +117,7 @@ GRANT SELECT ON boards TO chan_archive_anon; GRANT SELECT ON threads TO chan_archive_anon; GRANT SELECT ON posts TO chan_archive_anon; GRANT SELECT ON attachments TO chan_archive_anon; +GRANT usage, select ON SEQUENCE sites_site_id_seq TO chan_archive_anon; GRANT chan_archive_anon TO admin; CREATE ROLE chan_archiver noinherit login password 'test_password'; @@ -127,6 +129,7 @@ GRANT ALL ON threads TO chan_archiver; GRANT ALL ON posts TO chan_archiver; 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 chan_archiver TO admin; COMMIT; diff --git a/src/Backfill.hs b/src/Backfill.hs index bbbfa37..595f170 100644 --- a/src/Backfill.hs +++ b/src/Backfill.hs @@ -1,32 +1,25 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE DeriveDataTypeable #-} +-- {-# LANGUAGE DeriveGeneric #-} +-- {-# LANGUAGE OverloadedStrings #-} module Main where import System.Exit import Control.Monad (filterM) -import Data.Aeson (FromJSON, decode) +import Data.Aeson (decode) import qualified Data.ByteString.Lazy as B import System.Console.CmdArgs -import GHC.Generics import System.Directory (listDirectory, doesFileExist) import System.FilePath (()) import JSONParsing +import Types +import qualified DataClient as Client data SettingsCLI = SettingsCLI { jsonFile :: FilePath } deriving (Show, Data, Typeable) -data JSONSettings = JSONSettings - { postgrest_url :: String - , jwt :: String - , backup_read_root :: FilePath - } deriving (Show, Generic) - -instance FromJSON JSONSettings - settingsCLI :: SettingsCLI settingsCLI = SettingsCLI { jsonFile = def &= args &= typ "settings-jsonfile-path" @@ -43,12 +36,36 @@ listCatalogDirectories settings = do doesFileExist catalogPath +ensureSiteExists :: JSONSettings -> IO () +ensureSiteExists settings = do + sitesResult <- Client.getAllSites settings + + case sitesResult of + Right siteList -> + if any (\site -> Client.name site == site_name settings) siteList + then putStrLn $ site_name settings ++ " already exists!" + else do + putStrLn "leftychan.net does not exist. Creating..." + postResult <- Client.postSite settings + case postResult of + Right _ -> putStrLn $ "Successfully created " ++ site_name settings ++ "." + Left err -> do + putStrLn $ "Failed to create leftychan.net. Error: " ++ show err + exitFailure + Left err -> do + putStrLn $ "Error fetching sites: " ++ show err + exitFailure + + processBackupDirectory :: JSONSettings -> IO () processBackupDirectory settings = do putStrLn "JSON successfully read!" print settings -- print the decoded JSON settings + ensureSiteExists settings dirs <- listCatalogDirectories settings - mapM_ print dirs + _ <- Client.getWebsiteBoards settings + putStrLn "Boards fetched!" + mapM_ putStrLn dirs mapM_ processDir dirs where backupDir :: FilePath diff --git a/src/DataClient.hs b/src/DataClient.hs new file mode 100644 index 0000000..2d2d56d --- /dev/null +++ b/src/DataClient.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} + +module DataClient + ( HttpError(..) + , get + , getWebsiteBoards + , getAllSites + , postSite + , post + , SiteResponse(..) + ) where + +import Network.HTTP.Simple +import qualified Data.ByteString.Lazy as LBS +import Network.HTTP.Types.Status (statusCode) +import Control.Exception.Safe (tryAny, SomeException) +import qualified Data.ByteString.Char8 as C8 +import Data.Aeson + ( eitherDecode + , FromJSON + , (.=) + , object + , encode + ) +import GHC.Generics +import qualified Types as T + +data HttpError + = HttpException SomeException + | StatusCodeError Int LBS.ByteString + deriving (Show) + +data SiteResponse = SiteResponse + { site_id :: Int + , name :: String + , url :: String + } deriving (Show, Generic, FromJSON) + + +get :: T.JSONSettings -> String -> IO (Either HttpError LBS.ByteString) +get settings path = do + let requestUrl = T.postgrest_url settings ++ path + initReq <- parseRequest requestUrl + let req = setRequestHeader "Authorization" [C8.pack $ "Bearer " ++ T.jwt settings] initReq + putStrLn $ "calling " ++ requestUrl + handleHttp (httpLBS req) + + +post :: T.JSONSettings -> String -> LBS.ByteString -> IO (Either HttpError LBS.ByteString) +post settings path payload = do + let requestUrl = T.postgrest_url settings ++ path + initReq <- parseRequest requestUrl + let req = setRequestMethod "POST" + . setRequestHeader "Authorization" [C8.pack $ "Bearer " ++ T.jwt settings] + . setRequestHeader "Content-Type" ["application/json"] + . setRequestBodyLBS payload + $ initReq + putStrLn $ "posting to " ++ requestUrl + handleHttp (httpLBS req) + + +handleHttp :: IO (Response LBS.ByteString) -> IO (Either HttpError LBS.ByteString) +handleHttp action = do + result <- tryAny action + case result of + Right response -> + let responseBody = getResponseBody response + in if 200 <= (statusCode $ getResponseStatus response) && (statusCode $ getResponseStatus response) < 300 + then return $ Right responseBody + else return $ Left (StatusCodeError (statusCode $ getResponseStatus response) responseBody) + Left e -> return $ Left $ HttpException e + + +getWebsiteBoards :: T.JSONSettings -> IO (Either HttpError [ String ]) +getWebsiteBoards settings = do + response <- get settings path + + case response of + Right body -> do + print body + undefined + Left err -> do + print err + return $ Left err + + where + path = "/boards?select=name,board_id,sites(site_id)&sites.name=eq." + ++ (T.site_name settings) + + +postSite :: T.JSONSettings -> IO (Either HttpError LBS.ByteString) +postSite settings = do + let payload = encode $ object ["name" .= T.site_name settings, "url" .= T.site_url settings] + post settings "/sites" payload + + +getAllSites :: T.JSONSettings -> IO (Either HttpError [SiteResponse]) +getAllSites settings = do + response <- get settings "/sites" + case response of + Right x -> do + putStrLn "getAllSites response:" + print x + + return $ case eitherDecode x :: Either String [SiteResponse] of + Right sites -> Right sites + Left _ -> Left $ StatusCodeError 500 "Failed to decode JSON" + Left err -> return $ Left err diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 0000000..cf14b58 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,16 @@ +module Types + ( JSONSettings(..) + ) where + +import GHC.Generics +import Data.Aeson (FromJSON) + +data JSONSettings = JSONSettings + { postgrest_url :: String + , jwt :: String + , backup_read_root :: FilePath + , site_name :: String + , site_url :: String + } deriving (Show, Generic) + +instance FromJSON JSONSettings