blob: 81ef417300f6002a8c5ee1b34c0c41c9b7fde891 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
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')
|
