create site if not exists

- get and post implemented in DataClient, and some helper methods

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"
 }

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

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";

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;

src/Backfill.hs

@@ -1,32 +1,25 @@
-{-# LANGUAGE DeriveDataTypeable #-}
+-- {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+-- {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+-- {-# 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

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

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