blob: 5b9b02144963ff4b24c36d16d03711877c518bcb (
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
128
129
130
|
{-# 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')
|
