Move more things into Lib from Main

This commit is contained in:
towards-a-new-leftypol 2024-04-17 07:44:34 -04:00
parent d3495a9d2d
commit 34753c176a
4 changed files with 74 additions and 62 deletions

View File

@ -81,6 +81,7 @@ executable chan-delorean
Network.DataClient Network.DataClient
Network.DataClientTypes Network.DataClientTypes
Common.Server.JSONSettings Common.Server.JSONSettings
Common.Server.ConsumerSettings
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: -- other-extensions:

View File

@ -9,12 +9,13 @@ module Lib where
import System.Exit import System.Exit
import Data.Int (Int64) import Data.Int (Int64)
import Control.Monad (filterM) import Control.Monad (filterM)
import System.Console.CmdArgs import System.Console.CmdArgs hiding (name)
import System.Directory import System.Directory
( listDirectory ( listDirectory
, doesFileExist , doesFileExist
, copyFile , copyFile
, createDirectoryIfMissing , createDirectoryIfMissing
, removeFile
) )
import System.FilePath ((</>), (<.>), takeExtension) import System.FilePath ((</>), (<.>), takeExtension)
import Data.List (find, isSuffixOf, foldl', sortBy) import Data.List (find, isSuffixOf, foldl', sortBy)
@ -31,6 +32,8 @@ import Data.Text.Encoding (decodeUtf8)
import Network.Mime (defaultMimeLookup) import Network.Mime (defaultMimeLookup)
import PerceptualHash (fileHash) import PerceptualHash (fileHash)
import Control.Exception.Safe (tryAny, tryAsync, SomeException, displayException) import Control.Exception.Safe (tryAny, tryAsync, SomeException, displayException)
import qualified Data.ByteString.Lazy as B
import Data.Aeson (FromJSON)
import JSONParsing import JSONParsing
import Common.Server.JSONSettings import Common.Server.JSONSettings
@ -44,12 +47,20 @@ import qualified Common.AttachmentType as At
import qualified Common.PostsType as Posts import qualified Common.PostsType as Posts
import qualified Hash as Hash import qualified Hash as Hash
import qualified Data.WordUtil as Words import qualified Data.WordUtil as Words
import Common.Server.JSONSettings as J
import qualified Common.Server.ConsumerSettings as CS
newtype SettingsCLI = SettingsCLI newtype SettingsCLI = SettingsCLI
{ jsonFile :: FilePath { jsonFile :: FilePath
} deriving (Show, Data, Typeable) } deriving (Show, Data, Typeable)
-- Move a file by reading, writing, and then deleting the original
moveFile :: FilePath -> FilePath -> IO ()
moveFile src dst =
B.readFile src >>= B.writeFile dst >> removeFile src
listCatalogDirectories :: JSONSettings -> IO [ FilePath ] listCatalogDirectories :: JSONSettings -> IO [ FilePath ]
listCatalogDirectories settings = do listCatalogDirectories settings = do
allDirs <- listDirectory (backup_read_root settings) allDirs <- listDirectory (backup_read_root settings)
@ -715,3 +726,52 @@ processBackupDirectory settings = do
print settings -- print the decoded JSON settings print settings -- print the decoded JSON settings
boards <- listCatalogDirectories settings boards <- listCatalogDirectories settings
processBoards settings (localFileGetters settings) boards processBoards settings (localFileGetters settings) boards
toClientSettings :: CS.ConsumerJSONSettings -> CS.JSONSiteSettings -> J.JSONSettings
toClientSettings CS.ConsumerJSONSettings {..} CS.JSONSiteSettings {..} =
J.JSONSettings
{ J.postgrest_url = postgrest_url
, J.jwt = jwt
, J.backup_read_root = undefined
, J.media_root_path = media_root_path
, J.site_name = name
, J.site_url = root_url
}
httpGetJSON :: (FromJSON a) => Sites.Site -> String -> IO (Either String a)
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
httpFileGetters :: J.JSONSettings -> FileGetters
httpFileGetters settings = FileGetters
{ getJSONCatalog = httpGetJSON
, getJSONPosts = httpGetJSON
, addPathPrefix = ((++) $ J.site_url settings)
-- attachmentPaths here actually doesn't get the paths of the attachment,
-- it downloads them into a temporary file and gets that path of that.
, attachmentPaths = \paths -> do
filepath <- Client.getFile (At.file_path paths)
m_thumbpath <- case At.thumbnail_path paths of
Nothing -> return Nothing
Just thumbpath -> Client.getFile thumbpath
return $ filepath >>= \fp ->
case m_thumbpath of
Nothing -> return (At.Paths fp Nothing)
tp -> return (At.Paths fp tp)
, copyOrMove = \common_dest (src, dest) (m_thumb_src, thumb_dest) -> do
putStrLn $ "Copy Or Move (Move) src: " ++ src ++ " dest: " ++ dest
createDirectoryIfMissing True common_dest
moveFile src dest
case m_thumb_src of
Nothing -> return ()
Just thumb_src -> moveFile thumb_src thumb_dest
}

View File

@ -6,37 +6,20 @@ import System.Exit (exitFailure)
import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as B
import System.Console.CmdArgs (cmdArgs, Data, Typeable) import System.Console.CmdArgs (cmdArgs, Data, Typeable)
import Data.Aeson (decode) import Data.Aeson (decode)
import System.FilePath ((</>))
import Control.Concurrent.Async (mapConcurrently) import Control.Concurrent.Async (mapConcurrently)
import Data.Aeson (FromJSON)
import System.Directory (createDirectoryIfMissing, removeFile)
import qualified SitesType as Sites
import Common.Server.ConsumerSettings import Common.Server.ConsumerSettings
import Common.Server.JSONSettings as J
import Lib import Lib
( processBoards ( processBoards
, FileGetters (..) , toClientSettings
, httpFileGetters
) )
import qualified Network.DataClient as Client
import qualified Common.AttachmentType as At
import Sync import Sync
newtype CliArgs = CliArgs newtype CliArgs = CliArgs
{ settingsFile :: String { settingsFile :: String
} deriving (Show, Data, Typeable) } deriving (Show, Data, Typeable)
toClientSettings :: ConsumerJSONSettings -> JSONSiteSettings -> J.JSONSettings
toClientSettings ConsumerJSONSettings {..} JSONSiteSettings {..} =
J.JSONSettings
{ J.postgrest_url = postgrest_url
, J.jwt = jwt
, J.backup_read_root = undefined
, J.media_root_path = media_root_path
, J.site_name = name
, J.site_url = root_url
}
getSettings :: IO ConsumerJSONSettings getSettings :: IO ConsumerJSONSettings
getSettings = do getSettings = do
cliArgs <- cmdArgs $ CliArgs "consumer_settings.json" cliArgs <- cmdArgs $ CliArgs "consumer_settings.json"
@ -56,48 +39,6 @@ getSettings = do
Just settings -> return settings Just settings -> return settings
-- Move a file by reading, writing, and then deleting the original
moveFile :: FilePath -> FilePath -> IO ()
moveFile src dst =
B.readFile src >>= B.writeFile dst >> removeFile src
httpFileGetters :: JSONSettings -> FileGetters
httpFileGetters settings = FileGetters
{ getJSONCatalog = httpGetJSON
, getJSONPosts = httpGetJSON
, addPathPrefix = ((++) $ site_url settings)
-- attachmentPaths here actually doesn't get the paths of the attachment,
-- it downloads them into a temporary file and gets that path of that.
, attachmentPaths = \paths -> do
filepath <- Client.getFile (At.file_path paths)
m_thumbpath <- case At.thumbnail_path paths of
Nothing -> return Nothing
Just thumbpath -> Client.getFile thumbpath
return $ filepath >>= \fp ->
case m_thumbpath of
Nothing -> return (At.Paths fp Nothing)
tp -> return (At.Paths fp tp)
, copyOrMove = \common_dest (src, dest) (m_thumb_src, thumb_dest) -> do
putStrLn $ "Copy Or Move (Move) src: " ++ src ++ " dest: " ++ dest
createDirectoryIfMissing True common_dest
moveFile src dest
case m_thumb_src of
Nothing -> return ()
Just thumb_src -> moveFile thumb_src thumb_dest
}
httpGetJSON :: (FromJSON a) => Sites.Site -> String -> IO (Either String a)
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 :: ConsumerJSONSettings -> JSONSiteSettings -> IO ()
processWebsite settings site_settings = do processWebsite settings site_settings = do
let client_settings = toClientSettings settings site_settings let client_settings = toClientSettings settings site_settings

View File

@ -1,6 +1,16 @@
module Sync where module Sync where
import Common.Server.ConsumerSettings import Common.Server.ConsumerSettings
import Lib (getBoards, toClientSettings)
import SitesType (Site)
import BoardsType (Board)
getSiteBoards :: ConsumerJSONSettings -> JSONSiteSettings -> IO (Site, [ Board ])
getSiteBoards settings site_settings =
let client_settings = toClientSettings settings site_settings
in getBoards
client_settings
(boards site_settings)
syncWebsites :: ConsumerJSONSettings -> IO () syncWebsites :: ConsumerJSONSettings -> IO ()
syncWebsites _ = do syncWebsites _ = do