diff options
Diffstat (limited to 'Main.hs')
-rw-r--r-- | Main.hs | 130 |
1 files changed, 0 insertions, 130 deletions
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') |