aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/F2Md/Config.hs41
-rw-r--r--src/F2Md/Export.hs40
-rw-r--r--src/F2Md/Import.hs102
-rw-r--r--src/F2Md/Types.hs21
-rw-r--r--src/F2Md/Utils.hs12
-rw-r--r--src/Main.hs19
-rw-r--r--src/Main.hs~127
7 files changed, 362 insertions, 0 deletions
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')
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 08:33:42 +0000