Compare commits
2 Commits
359869984e
...
8fcea9c84b
Author | SHA1 | Date |
---|---|---|
|
8fcea9c84b | |
|
cb2da26c64 |
|
@ -1 +1 @@
|
||||||
Subproject commit 390165edf85e26c53f2fd53353270ee2ad4c4a38
|
Subproject commit e67b24b5f1035c9096e729437579794a7677bd3a
|
|
@ -32,7 +32,7 @@ data Thread = Thread
|
||||||
, locked :: Maybe Int
|
, locked :: Maybe Int
|
||||||
, cyclical :: Maybe J.Cyclical
|
, cyclical :: Maybe J.Cyclical
|
||||||
, last_modified :: Int
|
, last_modified :: Int
|
||||||
, board :: Text
|
-- , board :: Text
|
||||||
, files :: Maybe [J.File]
|
, files :: Maybe [J.File]
|
||||||
, resto :: Int
|
, resto :: Int
|
||||||
, unique_ips :: Maybe Int
|
, unique_ips :: Maybe Int
|
||||||
|
|
|
@ -23,7 +23,7 @@ data Post = Post
|
||||||
, cyclical :: Maybe J.Cyclical
|
, cyclical :: Maybe J.Cyclical
|
||||||
, last_modified :: Int
|
, last_modified :: Int
|
||||||
, embed :: Maybe Text
|
, embed :: Maybe Text
|
||||||
, board :: Text
|
-- , board :: Text
|
||||||
, files :: Maybe [J.File]
|
, files :: Maybe [J.File]
|
||||||
, resto :: Int
|
, resto :: Int
|
||||||
, unique_ips :: Maybe Int
|
, unique_ips :: Maybe Int
|
||||||
|
|
36
src/Lib.hs
36
src/Lib.hs
|
@ -312,7 +312,7 @@ copyOrMoveFiles settings fgs (site, board, thread, _, path, attachment) = do
|
||||||
src :: FilePath
|
src :: FilePath
|
||||||
src = At.file_path path
|
src = At.file_path path
|
||||||
|
|
||||||
thumb_src :: FilePath
|
thumb_src :: Maybe FilePath
|
||||||
thumb_src = At.thumbnail_path path
|
thumb_src = At.thumbnail_path path
|
||||||
|
|
||||||
dest :: FilePath
|
dest :: FilePath
|
||||||
|
@ -451,8 +451,8 @@ processFiles settings fgs tuples = do -- perfect just means that our posts have
|
||||||
, At.phash = phash
|
, At.phash = phash
|
||||||
}
|
}
|
||||||
|
|
||||||
parseLegacyPaths :: JSONPosts.Post -> Maybe (At.Paths, At.Attachment)
|
parseLegacyPaths :: Boards.Board -> JSONPosts.Post -> Maybe (At.Paths, At.Attachment)
|
||||||
parseLegacyPaths post = do
|
parseLegacyPaths board post = do
|
||||||
tim <- JSONPosts.tim post
|
tim <- JSONPosts.tim post
|
||||||
ext <- JSONPosts.ext post
|
ext <- JSONPosts.ext post
|
||||||
filename <- JSONPosts.filename post
|
filename <- JSONPosts.filename post
|
||||||
|
@ -460,11 +460,12 @@ processFiles settings fgs tuples = do -- perfect just means that our posts have
|
||||||
spoiler <- JSONPosts.fsize post
|
spoiler <- JSONPosts.fsize post
|
||||||
|
|
||||||
let
|
let
|
||||||
board = JSONPosts.board post
|
board_pathpart = T.pack $ Boards.pathpart board
|
||||||
file_path = withPathPrefix $ board <> "/src/" <> tim <> ext
|
file_path = (withPathPrefix "") </> (T.unpack $ board_pathpart <> "/src/" <> tim <> ext)
|
||||||
thumbnail_path = withPathPrefix $ board <> "/thumb/" <> tim <> ext
|
thumb_extension = "png"
|
||||||
|
thumbnail_path = (withPathPrefix "") </> (T.unpack $ board_pathpart <> "/thumb/" <> tim <> "." <> thumb_extension)
|
||||||
|
|
||||||
p = At.Paths file_path thumbnail_path
|
p = At.Paths file_path (Just thumbnail_path)
|
||||||
|
|
||||||
mime = getMimeType ext
|
mime = getMimeType ext
|
||||||
|
|
||||||
|
@ -477,7 +478,7 @@ processFiles settings fgs tuples = do -- perfect just means that our posts have
|
||||||
, At.post_id = undefined
|
, At.post_id = undefined
|
||||||
, At.resolution = undefined
|
, At.resolution = undefined
|
||||||
, At.file_extension = Just $ T.drop 1 ext
|
, At.file_extension = Just $ T.drop 1 ext
|
||||||
, At.thumb_extension = Just $ "png"
|
, At.thumb_extension = Just $ thumb_extension
|
||||||
, At.original_filename = Just $ filename <> ext
|
, At.original_filename = Just $ filename <> ext
|
||||||
, At.file_size_bytes = size
|
, At.file_size_bytes = size
|
||||||
, At.board_filename = tim
|
, At.board_filename = tim
|
||||||
|
@ -505,12 +506,12 @@ processFiles settings fgs tuples = do -- perfect just means that our posts have
|
||||||
, board
|
, board
|
||||||
, thread
|
, thread
|
||||||
, q
|
, q
|
||||||
, At.Paths (withPathPrefix $ JS.file_path x) (withPathPrefix $ JS.thumb_path x)
|
, At.Paths (withPathPrefix $ JS.file_path x) (Just $ withPathPrefix $ JS.thumb_path x)
|
||||||
, fileToAttachment i q x
|
, fileToAttachment i q x
|
||||||
)
|
)
|
||||||
) (zip [1..] files)
|
) (zip [1..] files)
|
||||||
Nothing ->
|
Nothing ->
|
||||||
case parseLegacyPaths p of
|
case parseLegacyPaths board p of
|
||||||
Nothing -> []
|
Nothing -> []
|
||||||
Just (paths, a) ->
|
Just (paths, a) ->
|
||||||
let
|
let
|
||||||
|
@ -606,7 +607,7 @@ data FileGetters = FileGetters
|
||||||
, getJSONPosts :: Sites.Site -> String -> IO (Either String JSONPosts.PostWrapper)
|
, getJSONPosts :: Sites.Site -> String -> IO (Either String JSONPosts.PostWrapper)
|
||||||
, addPathPrefix :: String -> String
|
, addPathPrefix :: String -> String
|
||||||
, attachmentPaths :: At.Paths -> IO (Maybe At.Paths)
|
, attachmentPaths :: At.Paths -> IO (Maybe At.Paths)
|
||||||
, copyOrMove :: String -> (String, String) -> (String, String) -> IO ()
|
, copyOrMove :: String -> (String, String) -> (Maybe String, String) -> IO ()
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@ -618,7 +619,7 @@ localFileGetters settings = FileGetters
|
||||||
, attachmentPaths = \p -> do
|
, attachmentPaths = \p -> do
|
||||||
exists <- doesFileExist (At.file_path p)
|
exists <- doesFileExist (At.file_path p)
|
||||||
if exists then return (Just p) else return Nothing
|
if exists then return (Just p) else return Nothing
|
||||||
, copyOrMove = \common_dest (src, dest) (thumb_src, thumb_dest) -> do
|
, copyOrMove = \common_dest (src, dest) (m_thumb_src, thumb_dest) -> do
|
||||||
destination_exists <- doesFileExist dest
|
destination_exists <- doesFileExist dest
|
||||||
|
|
||||||
if not destination_exists
|
if not destination_exists
|
||||||
|
@ -631,11 +632,14 @@ localFileGetters settings = FileGetters
|
||||||
then putStrLn ("Copying " ++ src) >> copyFile src dest
|
then putStrLn ("Copying " ++ src) >> copyFile src dest
|
||||||
else return ()
|
else return ()
|
||||||
|
|
||||||
thumb_exists <- doesFileExist thumb_src
|
case m_thumb_src of
|
||||||
|
Nothing -> return ()
|
||||||
|
Just thumb_src -> do
|
||||||
|
thumb_exists <- doesFileExist thumb_src
|
||||||
|
|
||||||
if thumb_exists
|
if thumb_exists
|
||||||
then putStrLn ("Copying " ++ thumb_src) >> copyFile thumb_src thumb_dest
|
then putStrLn ("Copying " ++ thumb_src) >> copyFile thumb_src thumb_dest
|
||||||
else return ()
|
else return ()
|
||||||
|
|
||||||
else return ()
|
else return ()
|
||||||
}
|
}
|
||||||
|
|
15
src/Main.hs
15
src/Main.hs
|
@ -70,17 +70,22 @@ httpFileGetters settings = FileGetters
|
||||||
-- it downloads them into a temporary file and gets that path of that.
|
-- it downloads them into a temporary file and gets that path of that.
|
||||||
, attachmentPaths = \paths -> do
|
, attachmentPaths = \paths -> do
|
||||||
filepath <- Client.getFile (At.file_path paths)
|
filepath <- Client.getFile (At.file_path paths)
|
||||||
thumbpath <- Client.getFile (At.thumbnail_path paths)
|
m_thumbpath <- case At.thumbnail_path paths of
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just thumbpath -> Client.getFile thumbpath
|
||||||
|
|
||||||
return $ filepath >>= \fp ->
|
return $ filepath >>= \fp ->
|
||||||
thumbpath >>= \tp -> do
|
case m_thumbpath of
|
||||||
return (At.Paths fp tp)
|
Nothing -> return (At.Paths fp Nothing)
|
||||||
|
tp -> return (At.Paths fp tp)
|
||||||
|
|
||||||
, copyOrMove = \common_dest (src, dest) (thumb_src, thumb_dest) -> do
|
, copyOrMove = \common_dest (src, dest) (m_thumb_src, thumb_dest) -> do
|
||||||
putStrLn $ "Copy Or Move (Move) src: " ++ src ++ " dest: " ++ dest
|
putStrLn $ "Copy Or Move (Move) src: " ++ src ++ " dest: " ++ dest
|
||||||
createDirectoryIfMissing True common_dest
|
createDirectoryIfMissing True common_dest
|
||||||
moveFile src dest
|
moveFile src dest
|
||||||
moveFile thumb_src thumb_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 :: (FromJSON a) => Sites.Site -> String -> IO (Either String a)
|
||||||
|
|
Loading…
Reference in New Issue