From caf354c7e5bcb5142d8b4358824d22d3de122f34 Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Fri, 27 May 2022 18:57:24 +1000 Subject: break apart the code, timestamp read imp. --- Main.hs | 130 ----------------------------------------------------- f2md.cabal | 37 +++++++++++++++ src/F2Md/Config.hs | 41 +++++++++++++++++ src/F2Md/Export.hs | 40 +++++++++++++++++ src/F2Md/Import.hs | 102 +++++++++++++++++++++++++++++++++++++++++ src/F2Md/Types.hs | 21 +++++++++ src/F2Md/Utils.hs | 12 +++++ src/Main.hs | 19 ++++++++ src/Main.hs~ | 127 +++++++++++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 399 insertions(+), 130 deletions(-) delete mode 100644 Main.hs create mode 100644 f2md.cabal create mode 100644 src/F2Md/Config.hs create mode 100644 src/F2Md/Export.hs create mode 100644 src/F2Md/Import.hs create mode 100644 src/F2Md/Types.hs create mode 100644 src/F2Md/Utils.hs create mode 100644 src/Main.hs create mode 100644 src/Main.hs~ diff --git a/Main.hs b/Main.hs deleted file mode 100644 index 5b9b021..0000000 --- a/Main.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Data.UUID.V4 -import System.Directory -import Control.Monad.Extra -import Data.UUID -import Data.Char -import Data.Generics -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Text.Feed.Import -import Text.Feed.Query -import Text.Feed.Types -import Text.RSS.Syntax hiding (RSSItem) -import Data.XML.Types -import Data.Time -import System.Posix.Process -import System.Posix.Files -import Network.HostName -import System.Random -import System.FilePath - -data FeedMetadata = FeedMetadata - { title :: Text, - author :: Maybe Text, - home :: Maybe Text - } - deriving (Show) - -data Message = Message - { from :: Text, - subject :: Text, - date :: Text, - messageId :: Text, - body :: Text --- newsGroup :: Text - } - deriving (Show) - -formatMessage :: Message -> Text -formatMessage (Message from subject date messageId body) = - "MIME-Version: 1.0\n" <> "Date: " <> date <> "\nSubject: " <> subject <> - "\nFrom: " <> from <> "\nMessage-ID: " <> messageId <> - "\nContent-Type: text/html" <> "\n\n" <> body - -getItemAuthor' :: Item -> Maybe Text -getItemAuthor' item = case getItemAuthor item of - Just "" -> Nothing - Just author -> Just author - Nothing -> Nothing - -getItemContent' :: Item -> Maybe Text -getItemContent' (RSSItem item) = - (fmap (T.concat . elementText) . listToMaybe . - filter (\e -> namePrefix (elementName e) == Just "content")) - $ rssItemOther item -getItemContent' _ = Nothing - -toMessage :: FeedMetadata -> Item -> IO Message -toMessage (FeedMetadata title author home) 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 - messageId - (formatBody (getItemLink item) $ - (getItemContent item) `orElse` (getItemContent' item) `orElse` - (getItemDescription item)) --- title - -formatBody :: Maybe Text -> Maybe Text -> Text -formatBody link desc = - let linkText = case link of - Nothing -> "" - Just link' -> "Link: " <> link' <> "\n\n" in - linkText <> (fromMaybe "" desc) - -toFeedMetadata :: Feed -> FeedMetadata -toFeedMetadata feed = - FeedMetadata (getFeedTitle feed) (getFeedAuthor feed) (getFeedHome feed) - -genFilename :: FilePath -> IO String -genFilename root = do - epoch <- formatTime defaultTimeLocale "%s" <$> getCurrentTime - pid <- getProcessID - host <- getHostName - rand <- randomRIO (10000, 99999) :: IO Int - return $ root "new" epoch <> "." <> show pid <> "." <> - host <> "." <> show rand - -genUniqFilename :: FilePath -> IO String -genUniqFilename root = do - filename <- genFilename root - exists <- fileExist filename - if exists then genUniqFilename root else return filename - -hyphenateNonAlNum :: Char -> Char -hyphenateNonAlNum c - | isAlphaNum c = c - | otherwise = '-' - -genMessageId :: Text -> Maybe Text -> IO Text -genMessageId feedLink guid = do - id <- case guid of - Just guid' -> return $ T.map hyphenateNonAlNum guid' - Nothing -> toText <$> nextRandom - return $ id <> "@" <> (T.map hyphenateNonAlNum feedLink) <> ".gnu" - --- for testing purposes -writeFirstItem :: [Text] -> IO () -writeFirstItem msgs = - writeFile "./firstMsg" $ T.unpack $ head $ msgs - -writeMessage :: FilePath -> Message -> IO () -writeMessage root msg = - genUniqFilename root >>= - \filename -> writeFile filename $ T.unpack (formatMessage msg) - -main :: IO () -main = do - feed <- parseFeedFromFile "./plug.xml" - let root = "." - createDirectoryIfMissing True root - whenJust feed $ - \feed' -> - mapM_ (\msg -> - writeMessage root =<< toMessage (toFeedMetadata feed') msg) - (getFeedItems feed') diff --git a/f2md.cabal b/f2md.cabal new file mode 100644 index 0000000..e7723fe --- /dev/null +++ b/f2md.cabal @@ -0,0 +1,37 @@ +cabal-version: 2.4 +name: f2md +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: + +-- The package author(s). +-- author: +maintainer: hi@ypei.me + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +executable f2md + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: + base, uuid, syb, feed, time, text, unix, hostname, random, filepath, directory, extra, xml-types, process, aeson, bytestring, unordered-containers + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/F2Md/Config.hs b/src/F2Md/Config.hs new file mode 100644 index 0000000..ccb1871 --- /dev/null +++ b/src/F2Md/Config.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveGeneric #-} + +module F2Md.Config (getUserdata, FeedUserdata(..)) where + +import F2Md.Utils +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 + , maildir :: String + , feeds :: [Text] + } deriving (Generic, Show) + +instance FromJSON Config + +data FeedUserdata = FeedUserdata + { url :: Text + , lastUpdated :: Maybe ZonedTime } deriving (Generic, Show) + +getUserdata :: FilePath -> IO ([FeedUserdata], Maybe FilePath) +getUserdata file = do + config <- decode <$> BSL.readFile file + case config of + Nothing -> return ([], Nothing) + Just config' -> do + feedData <- getUserdata' config' + maildir' <- expandPath $ maildir config' + return (feedData, Just maildir') + +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 diff --git a/src/F2Md/Export.hs b/src/F2Md/Export.hs new file mode 100644 index 0000000..284ab22 --- /dev/null +++ b/src/F2Md/Export.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module F2Md.Export (writeMessage) where + +import F2Md.Types +import Data.Text (Text) +import qualified Data.Text as T +import System.Posix.Process +import System.Posix.Files +import Data.Time +import Network.HostName +import System.Random +import System.FilePath + + +formatMessage :: Message -> Text +formatMessage (Message from subject date messageId body) = + "MIME-Version: 1.0\n" <> "Date: " <> date <> "\nSubject: " <> subject <> + "\nFrom: " <> from <> "\nMessage-ID: " <> messageId <> + "\nContent-Type: text/html" <> "\n\n" <> body + +genFilename :: FilePath -> IO String +genFilename root = do + epoch <- formatTime defaultTimeLocale "%s" <$> getCurrentTime + pid <- getProcessID + host <- getHostName + rand <- randomRIO (10000, 99999) :: IO Int + return $ root "new" epoch <> "." <> show pid <> "." <> + host <> "." <> show rand + +genUniqFilename :: FilePath -> IO String +genUniqFilename root = do + filename <- genFilename root + exists <- fileExist filename + if exists then genUniqFilename root else return filename + +writeMessage :: FilePath -> Message -> IO () +writeMessage root msg = + genUniqFilename root >>= + \filename -> writeFile filename $ T.unpack (formatMessage msg) diff --git a/src/F2Md/Import.hs b/src/F2Md/Import.hs new file mode 100644 index 0000000..ee68578 --- /dev/null +++ b/src/F2Md/Import.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} + +module F2Md.Import (toMessagesFromFile, toMessagesFromUrl) where + +import Control.Monad +import Data.Time +import System.Process +import Data.UUID +import Data.UUID.V4 +import Data.Char +import Data.Text (Text) +import Text.Feed.Types +import qualified Data.Text as T +import Data.Maybe +import Text.Feed.Query +import Data.Generics +import Text.RSS.Syntax hiding (RSSItem) +import Data.XML.Types +import Text.Feed.Import +import Text.Feed.Types +import F2Md.Types + +toMessagesFromFile :: FilePath -> IO [Message] +toMessagesFromFile file = do + feed <- parseFeedFromFile file + case feed of + Nothing -> return [] + Just feed' -> + mapM (\msg -> toMessage (toFeedMetadata feed') msg) (getFeedItems feed') + +toMessagesFromUrl :: Text -> Maybe ZonedTime -> IO [Message] +toMessagesFromUrl url after = do + feed <- parseFeedString <$> (fetchFeed $ T.unpack url) + case feed of + Nothing -> return [] + Just feed' -> catMaybes <$> + mapM (\msg -> toMessage' after (toFeedMetadata feed') msg) (getFeedItems feed') + +wgetCommand :: String +wgetCommand = "wget -O- 2>/dev/null" + +fetchFeed :: String -> IO String +fetchFeed url = readCreateProcess (shell $ wgetCommand ++ " " ++ url) "" + +toMessage' :: Maybe ZonedTime -> FeedMetadata -> Item -> IO (Maybe Message) +toMessage' after feed item + | isNothing after = toMessage feed item >>= return . Just + | isNothing date || 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 + 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 + messageId + (formatBody (getItemLink item) $ + (getItemContent item) `orElse` (getItemContent' item) `orElse` + (getItemDescription item)) +-- title + +getItemAuthor' :: Item -> Maybe Text +getItemAuthor' item = case getItemAuthor item of + Just "" -> Nothing + Just author -> Just author + Nothing -> Nothing + +getItemContent' :: Item -> Maybe Text +getItemContent' (RSSItem item) = + (fmap (T.concat . elementText) . listToMaybe . + filter (\e -> namePrefix (elementName e) == Just "content")) + $ rssItemOther item +getItemContent' _ = Nothing + +formatBody :: Maybe Text -> Maybe Text -> Text +formatBody link desc = + let linkText = case link of + Nothing -> "" + Just link' -> "Link: " <> link' <> "\n\n" in + linkText <> (fromMaybe "" desc) + +toFeedMetadata :: Feed -> FeedMetadata +toFeedMetadata feed = + FeedMetadata (getFeedTitle feed) (getFeedAuthor feed) (getFeedHome feed) + +genMessageId :: Text -> Maybe Text -> IO Text +genMessageId feedLink guid = do + id <- case guid of + Just guid' -> return $ T.map hyphenateNonAlNum guid' + Nothing -> toText <$> nextRandom + return $ + "<" <> id <> "@" <> (T.map hyphenateNonAlNum feedLink) <> ".gnu" <> ">" + +hyphenateNonAlNum :: Char -> Char +hyphenateNonAlNum c + | isAlphaNum c = c + | otherwise = '-' + diff --git a/src/F2Md/Types.hs b/src/F2Md/Types.hs new file mode 100644 index 0000000..cd579ce --- /dev/null +++ b/src/F2Md/Types.hs @@ -0,0 +1,21 @@ +module F2Md.Types where + +import Data.Text (Text) +import Data.Time + +data FeedMetadata = FeedMetadata + { title :: Text, + author :: Maybe Text, + home :: Maybe Text + } + deriving (Show) + +data Message = Message + { from :: Text, + subject :: Text, + date :: Text, + messageId :: Text, + body :: Text +-- newsGroup :: Text + } + deriving (Show) diff --git a/src/F2Md/Utils.hs b/src/F2Md/Utils.hs new file mode 100644 index 0000000..149730e --- /dev/null +++ b/src/F2Md/Utils.hs @@ -0,0 +1,12 @@ +module F2Md.Utils (expandPath) where + +import System.Directory +import System.Posix.User + +expandPath :: FilePath -> IO FilePath +expandPath path = + let (pre, post) = break (=='/') path in + case pre of + "~" -> (++ post) <$> getHomeDirectory + '~' : user -> (++ post) <$> homeDirectory <$> getUserEntryForName user + _ -> return path diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..f3f8a5a --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} + +import System.Directory +import Control.Monad.Extra +import F2Md.Types +import F2Md.Import +import F2Md.Export +import F2Md.Config +import System.FilePath + +main :: IO () +main = do + (feeds, maildir) <- 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 diff --git a/src/Main.hs~ b/src/Main.hs~ new file mode 100644 index 0000000..81ef417 --- /dev/null +++ b/src/Main.hs~ @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Data.UUID.V4 +import System.Directory +import Control.Monad.Extra +import Data.UUID +import Data.Char +import Data.Generics +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Text.Feed.Import +import Text.Feed.Query +import Text.Feed.Types +import Text.RSS.Syntax hiding (RSSItem) +import Data.XML.Types +import Data.Time +import System.Posix.Process +import System.Posix.Files +import Network.HostName +import System.Random +import System.FilePath + +data FeedMetadata = FeedMetadata + { title :: Text, + author :: Maybe Text, + home :: Maybe Text + } + deriving (Show) + +data Message = Message + { from :: Text, + subject :: Text, + date :: Text, + messageId :: Text, + body :: Text +-- newsGroup :: Text + } + deriving (Show) + +formatMessage :: Message -> Text +formatMessage (Message from subject date messageId body) = + "MIME-Version: 1.0\n" <> "Date: " <> date <> "\nSubject: " <> subject <> + "\nFrom: " <> from <> "\nMessage-ID: " <> messageId <> + "\nContent-Type: text/html" <> "\n\n" <> body + +getItemAuthor' :: Item -> Maybe Text +getItemAuthor' item = case getItemAuthor item of + Just "" -> Nothing + Just author -> Just author + Nothing -> Nothing + +getItemContent' :: Item -> Maybe Text +getItemContent' (RSSItem item) = + (fmap (T.concat . elementText) . listToMaybe . + filter (\e -> namePrefix (elementName e) == Just "content")) + $ rssItemOther item +getItemContent' _ = Nothing + +toMessage :: FeedMetadata -> Item -> IO Message +toMessage (FeedMetadata title author home) 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 + messageId + (formatBody (getItemLink item) $ + (getItemContent item) `orElse` (getItemContent' item) `orElse` + (getItemDescription item)) +-- title + +formatBody :: Maybe Text -> Maybe Text -> Text +formatBody link desc = + let linkText = case link of + Nothing -> "" + Just link' -> "Link: " <> link' <> "\n\n" in + linkText <> (fromMaybe "" desc) + +toFeedMetadata :: Feed -> FeedMetadata +toFeedMetadata feed = + FeedMetadata (getFeedTitle feed) (getFeedAuthor feed) (getFeedHome feed) + +genFilename :: FilePath -> IO String +genFilename root = do + epoch <- formatTime defaultTimeLocale "%s" <$> getCurrentTime + pid <- getProcessID + host <- getHostName + rand <- randomRIO (10000, 99999) :: IO Int + return $ root "new" epoch <> "." <> show pid <> "." <> + host <> "." <> show rand + +genUniqFilename :: FilePath -> IO String +genUniqFilename root = do + filename <- genFilename root + exists <- fileExist filename + if exists then genUniqFilename root else return filename + +hyphenateNonAlNum :: Char -> Char +hyphenateNonAlNum c + | isAlphaNum c = c + | otherwise = '-' + +genMessageId :: Text -> Maybe Text -> IO Text +genMessageId feedLink guid = do + id <- case guid of + Just guid' -> return $ T.map hyphenateNonAlNum guid' + Nothing -> toText <$> nextRandom + return $ + "<" <> id <> "@" <> (T.map hyphenateNonAlNum feedLink) <> ".gnu" <> ">" + +writeMessage :: FilePath -> Message -> IO () +writeMessage root msg = + genUniqFilename root >>= + \filename -> writeFile filename $ T.unpack (formatMessage msg) + +main :: IO () +main = do + feed <- parseFeedFromFile "./stallman.xml" + let root = "./maildir" + mapM_ (createDirectoryIfMissing True) + [root "new", root "cur", root "tmp"] + whenJust feed $ + \feed' -> + mapM_ (\msg -> + writeMessage root =<< toMessage (toFeedMetadata feed') msg) + (getFeedItems feed') -- cgit v1.2.3