aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/F2Md/Config.hs54
-rw-r--r--src/F2Md/Export.hs4
-rw-r--r--src/F2Md/Import.hs24
-rw-r--r--src/F2Md/Types.hs21
-rw-r--r--src/Main.hs9
5 files changed, 73 insertions, 39 deletions
diff --git a/src/F2Md/Config.hs b/src/F2Md/Config.hs
index ccb1871..ef209dc 100644
--- a/src/F2Md/Config.hs
+++ b/src/F2Md/Config.hs
@@ -1,15 +1,20 @@
{-# LANGUAGE DeriveGeneric #-}
-module F2Md.Config (getUserdata, FeedUserdata(..)) where
+module F2Md.Config
+ ( getUserdata
+ , FeedUserdata(..)
+ , updateLastUpdated
+ ) where
+import Data.List
import F2Md.Utils
+import F2Md.Types
import Data.Maybe
import Data.Text (Text)
import Data.Time
import GHC.Generics
import qualified Data.HashMap.Strict as HM
import Data.Aeson
-import qualified Data.ByteString.Lazy as BSL
data Config = Config
{ dbPath :: String
@@ -20,22 +25,47 @@ data Config = Config
instance FromJSON Config
data FeedUserdata = FeedUserdata
- { url :: Text
- , lastUpdated :: Maybe ZonedTime } deriving (Generic, Show)
+ { fuUrl :: Text
+ , fuLastUpdated :: Maybe ZonedTime } deriving (Show)
-getUserdata :: FilePath -> IO ([FeedUserdata], Maybe FilePath)
+getUserdata :: FilePath -> IO ([FeedUserdata], Maybe FilePath, Maybe FilePath)
getUserdata file = do
- config <- decode <$> BSL.readFile file
+ config <- decodeFileStrict file
case config of
- Nothing -> return ([], Nothing)
+ Nothing -> return ([], Nothing, Nothing)
Just config' -> do
feedData <- getUserdata' config'
maildir' <- expandPath $ maildir config'
- return (feedData, Just maildir')
+ dbPath' <- expandPath $ dbPath config'
+ return (feedData, Just maildir', Just dbPath')
getUserdata' :: Config -> IO [FeedUserdata]
getUserdata' (Config dbPath _ feeds) = do
- decoded <- decode <$> (BSL.readFile =<< expandPath dbPath)
- let decoded' = fromMaybe (HM.fromList []) decoded
- return $
- map (\url -> FeedUserdata url $ HM.lookup url decoded') feeds
+ decoded <- getLastUpdatedMap dbPath
+ return $ map (\url -> FeedUserdata url $ HM.lookup url decoded) feeds
+
+getLastUpdatedMap :: FilePath -> IO (HM.HashMap Text ZonedTime)
+getLastUpdatedMap dbPath =
+ fromMaybe (HM.fromList []) <$> (decodeFileStrict =<< expandPath dbPath)
+
+updateLastUpdated :: FilePath -> [FeedUserdata] -> [[Message]] -> IO ()
+updateLastUpdated path feeds feedMsgs = do
+ decoded <- getLastUpdatedMap path
+ encodeFile path $ foldl'
+ (\hm (feed, msgs) ->
+ case msgs of
+ [] -> hm
+ h : _ -> HM.insert (fuUrl feed)
+ (utcToZonedTime (zonedTimeZone $ mDate h) . maximum $
+ (zonedTimeToUTC . mDate) <$> msgs)
+ hm)
+ decoded (zip feeds feedMsgs)
+ -- HM.fromList $
+ -- mapMaybe
+ -- (\(feed, msgs) ->
+ -- case msgs of
+ -- [] -> fuLastUpdated feed >>= \date -> return (fuUrl feed, date)
+ -- h : _ ->
+ -- Just (fuUrl feed,
+ -- utcToZonedTime (zonedTimeZone $ mDate h) . maximum $
+ -- (zonedTimeToUTC . mDate) <$> msgs)) $ zip feeds feedMsgs
diff --git a/src/F2Md/Export.hs b/src/F2Md/Export.hs
index 284ab22..83da783 100644
--- a/src/F2Md/Export.hs
+++ b/src/F2Md/Export.hs
@@ -14,8 +14,8 @@ import System.FilePath
formatMessage :: Message -> Text
-formatMessage (Message from subject date messageId body) =
- "MIME-Version: 1.0\n" <> "Date: " <> date <> "\nSubject: " <> subject <>
+formatMessage (Message from subject date messageId body _) =
+ "MIME-Version: 1.0\n" <> "Date: " <> (T.pack $ show date) <> "\nSubject: " <> subject <>
"\nFrom: " <> from <> "\nMessage-ID: " <> messageId <>
"\nContent-Type: text/html" <> "\n\n" <> body
diff --git a/src/F2Md/Import.hs b/src/F2Md/Import.hs
index ee68578..3ed4d2f 100644
--- a/src/F2Md/Import.hs
+++ b/src/F2Md/Import.hs
@@ -20,13 +20,13 @@ import Text.Feed.Import
import Text.Feed.Types
import F2Md.Types
-toMessagesFromFile :: FilePath -> IO [Message]
-toMessagesFromFile file = do
+toMessagesFromFile :: Text -> FilePath -> IO [Message]
+toMessagesFromFile url file = do
feed <- parseFeedFromFile file
case feed of
Nothing -> return []
Just feed' ->
- mapM (\msg -> toMessage (toFeedMetadata feed') msg) (getFeedItems feed')
+ mapM (\msg -> toMessage (toFeedMetadata feed' url) msg) (getFeedItems feed')
toMessagesFromUrl :: Text -> Maybe ZonedTime -> IO [Message]
toMessagesFromUrl url after = do
@@ -34,7 +34,7 @@ toMessagesFromUrl url after = do
case feed of
Nothing -> return []
Just feed' -> catMaybes <$>
- mapM (\msg -> toMessage' after (toFeedMetadata feed') msg) (getFeedItems feed')
+ mapM (\msg -> toMessage' after (toFeedMetadata feed' url) msg) (getFeedItems feed')
wgetCommand :: String
wgetCommand = "wget -O- 2>/dev/null"
@@ -44,24 +44,24 @@ fetchFeed url = readCreateProcess (shell $ wgetCommand ++ " " ++ url) ""
toMessage' :: Maybe ZonedTime -> FeedMetadata -> Item -> IO (Maybe Message)
toMessage' after feed item
+ | isNothing date = return Nothing
| isNothing after = toMessage feed item >>= return . Just
- | isNothing date || zonedTimeToUTC (fromJust after) >= fromJust date =
- return Nothing
+ | zonedTimeToUTC (fromJust after) >= fromJust date = return Nothing
| otherwise = toMessage feed item >>= return . Just
where date = join $ getItemPublishDate item
toMessage :: FeedMetadata -> Item -> IO Message
-toMessage (FeedMetadata title author home) item = do
+toMessage (FeedMetadata title author home url) item = do
messageId <- genMessageId (fromMaybe "" home) (snd <$> getItemId item)
return $ Message
(fromMaybe title $ orElse (getItemAuthor' item) author)
(fromMaybe "Untitled" $ getItemTitle item)
- (fromMaybe "" $ getItemDate item) -- default should be current date
+ (fromJust $ join $ getItemPublishDate item) -- default should be current date
messageId
(formatBody (getItemLink item) $
(getItemContent item) `orElse` (getItemContent' item) `orElse`
(getItemDescription item))
--- title
+ url
getItemAuthor' :: Item -> Maybe Text
getItemAuthor' item = case getItemAuthor item of
@@ -83,9 +83,9 @@ formatBody link desc =
Just link' -> "Link: " <> link' <> "\n\n" in
linkText <> (fromMaybe "" desc)
-toFeedMetadata :: Feed -> FeedMetadata
-toFeedMetadata feed =
- FeedMetadata (getFeedTitle feed) (getFeedAuthor feed) (getFeedHome feed)
+toFeedMetadata :: Feed -> Text -> FeedMetadata
+toFeedMetadata feed url =
+ FeedMetadata (getFeedTitle feed) (getFeedAuthor feed) (getFeedHome feed) url
genMessageId :: Text -> Maybe Text -> IO Text
genMessageId feedLink guid = do
diff --git a/src/F2Md/Types.hs b/src/F2Md/Types.hs
index cd579ce..de63985 100644
--- a/src/F2Md/Types.hs
+++ b/src/F2Md/Types.hs
@@ -4,18 +4,21 @@ import Data.Text (Text)
import Data.Time
data FeedMetadata = FeedMetadata
- { title :: Text,
- author :: Maybe Text,
- home :: Maybe Text
+ { fTitle :: Text
+ , fAuthor :: Maybe Text
+ , fHome :: Maybe Text
+ , fUrl :: Text
}
deriving (Show)
data Message = Message
- { from :: Text,
- subject :: Text,
- date :: Text,
- messageId :: Text,
- body :: Text
--- newsGroup :: Text
+ { mFrom :: Text
+ , mSubject :: Text
+ , mDate :: ZonedTime
+ , mMessageId :: Text
+ , mBody :: Text
+ , mFeed :: Text
}
deriving (Show)
+
+-- date format: Sun, 08 May 2022 09:23:01 +0000
diff --git a/src/Main.hs b/src/Main.hs
index f3f8a5a..133d155 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -10,10 +10,11 @@ import System.FilePath
main :: IO ()
main = do
- (feeds, maildir) <- getUserdata "./.f2m.json"
+ (feeds, maildir, dbPath) <- getUserdata "./.f2m.json"
whenJust maildir $ \root -> do
mapM_ (createDirectoryIfMissing True)
[root </> "new", root </> "cur", root </> "tmp"]
- messages <- (fmap concat . sequence) $
- (\feed -> toMessagesFromUrl (url feed) (lastUpdated feed)) <$> feeds
- mapM_ (writeMessage root) messages
+ feedMessages <- sequence $
+ (\feed -> toMessagesFromUrl (fuUrl feed) (fuLastUpdated feed)) <$> feeds
+ mapM_ (writeMessage root) $ concat feedMessages
+ whenJust dbPath $ \dbPath' -> updateLastUpdated dbPath' feeds feedMessages
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 08:18:09 +0000