diff --git a/Imm/Core.hs b/Imm/Core.hs new file mode 100644 --- /dev/null +++ b/Imm/Core.hs @@ -0,0 +1,179 @@ +module Imm.Core where + +-- {{{ Imports +import Imm.Mail +import qualified Imm.Maildir as Maildir +import Imm.Types +import Imm.Util + +import qualified Config.Dyre as D +import Config.Dyre.Paths + +--import Control.Arrow +import Control.Monad hiding(forM_) + +import Data.Foldable +--import Data.Functor +--import Data.Maybe +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Time.Format + +import Network.HTTP hiding(Response) +import Network.URI + +import System.Console.CmdArgs +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error +import System.Locale + +import qualified Text.Feed.Import as F +import Text.Feed.Query +import Text.Feed.Types +-- }}} + +-- {{{ Commandline options +-- | Available commandline options +cliOptions :: CliOptions +cliOptions = CliOptions { + mParameter = def &= help "option description" &= explicit &= name "p" &= name "parameter" &= typ "type of the argument" +} + +getOptions :: IO CliOptions +getOptions = cmdArgs $ cliOptions + &= verbosityArgs [explicit, name "Verbose", name "v"] [] + &= versionArg [ignore] + &= help "Fetch and send items from RSS/Atom feeds to a custom mail address." + &= helpArg [explicit, name "help", name "h"] + &= program "imm" +-- }}} + +-- {{{ Configuration +dyreParameters :: D.Params Parameters +dyreParameters = D.defaultParams { + D.projectName = "imm", + D.showError = showError, + D.realMain = realMain, + D.ghcOpts = ["-threaded"], + D.statusOut = hPutStrLn stderr +} + +showError :: Parameters -> String -> Parameters +showError parameters message = parameters { mError = Just message } + +-- | Default configuration. +defaultParameters :: Parameters +defaultParameters = Parameters { + mCacheDirectory = Nothing, + mFeedURIs = [], + mMailDirectory = "rss", + mError = Nothing +} +-- }}} + +-- | +imm :: Parameters -> IO () +imm = D.wrapMain dyreParameters + +-- Entry point +realMain :: Parameters -> IO () +realMain parameters@Parameters{ mMailDirectory = directory } = do +-- Print configuration error, if any + forM_ (mError parameters) putStrLn + +-- Parse commandline arguments + options <- getOptions + +-- Print in-use paths + (a, b, c, d, e) <- getPaths dyreParameters + whenLoud . putStrLn . unlines $ [ + "Current binary: " ++ a, + "Custom binary: " ++ b, + "Config file: " ++ c, + "Cache directory: " ++ d, + "Lib directory: " ++ e] + +-- Initialize mailbox + result <- Maildir.init directory + case result of + False -> putStrLn $ "Unable to initialize maildir at: " ++ directory + _ -> realMain' parameters + +-- At this point, a maildir has been setup. +realMain' :: Parameters -> IO () +realMain' parameters@Parameters{ mFeedURIs = feedURIs } = do + let uris = map parseURI' feedURIs + rawFeeds <- mapM (either (return . Left) downloadRaw) uris + let feeds = zip feedURIs . map (parseFeedString =<<) $ rawFeeds + + void . mapM (processFeed parameters) $ feeds + return () + +parseURI' :: String -> Either String URI +parseURI' uri = maybe (Left . ("Ill-formatted URI: " ++) $ uri) (Right) . parseURI $ uri + +processFeed :: Parameters -> (String, Either String Feed) -> IO () +processFeed _ (_, Left e) = putStrLn e +processFeed parameters (uri, Right feed) = do + whenLoud . putStr . unlines $ [ + "Processing feed: " ++ uri, + ("Title: " ++) . getFeedTitle $ feed, + ("Author: " ++) . maybe "No author" id . getFeedAuthor $ feed, + ("Home: " ++) . maybe "No home" id . getFeedHome $ feed] + + (_, _, _, d, _) <- getPaths dyreParameters + let directory = maybe d id . mCacheDirectory $ parameters + let fileName = uri >>= escapeFileName + +-- + oldTime <- try $ readFile (directory fileName) + let threshold = either + (const $ posixSecondsToUTCTime 0) + (maybe (posixSecondsToUTCTime 0) id . parseTime defaultTimeLocale "%F %T %Z") + oldTime + + lastTime <- foldlM (\acc item -> processItem parameters threshold item >>= (return . (max acc))) threshold (feedItems feed) + +-- + (file, handle) <- openTempFile directory fileName + hPutStrLn handle (show lastTime) + hClose handle + renameFile file (directory fileName) + + return () + +processItem :: Parameters -> UTCTime -> Item -> IO UTCTime +processItem parameters@Parameters{ mMailDirectory = directory } threshold item = do + currentTime <- getCurrentTime :: IO UTCTime + let time = getItemDate item + + whenLoud . putStr . unlines $ ["", + " Item author: " ++ (maybe "" id $ getItemAuthor item), + " Item title: " ++ (maybe "" id $ getItemTitle item), + " Item URI: " ++ (maybe "" id $ getItemLink item), + " Item date: " ++ (maybe "" id $ time)] + + case time >>= stringToUTC of + Just y -> do + when (threshold < y) $ do + whenLoud . putStrLn $ "==> New entry added to maildir." + Maildir.add directory . itemToMail $ item + return y + _ -> do + Maildir.add directory . itemToMail $ item + return threshold + +downloadRaw :: URI -> IO (Either String String) +downloadRaw uri = do + result <- simpleHTTP . getRequest $ show uri + return . either (Left . show) (Right . decodeIfNeeded . rspBody) $ result + +-- | Same as Text.Feed.Import.ParseFeedString, but with Either monad. +parseFeedString :: String -> Either String Feed +parseFeedString = maybe + (Left "Unable to parse XML from raw page.") + Right + . F.parseFeedString + diff --git a/Imm/Mail.hs b/Imm/Mail.hs new file mode 100644 --- /dev/null +++ b/Imm/Mail.hs @@ -0,0 +1,33 @@ +module Imm.Mail where + +-- {{{ Imports +import Imm.Types +import Imm.Util + +import Control.Monad + +import Data.Time.Clock.POSIX + +import Text.Feed.Query +import Text.Feed.Types +-- }}} + + +defaultMail :: Mail +defaultMail = Mail { + mCharset = "utf-8", + mContent = "", + mContentDisposition = "inline", + mDate = posixSecondsToUTCTime 0, + mFrom = "imm", + mMIME = "text/html", + mSubject = "Untitled", + mReturnPath = ""} + + +itemToMail :: Item -> Mail +itemToMail item = defaultMail { + mDate = maybe (posixSecondsToUTCTime 0) id . (stringToUTC <=< getItemDate) $ item, + mFrom = maybe "Anonymous" id $ getItemAuthor item, + mSubject = maybe "Untitled" id $ getItemTitle item, + mContent = maybe "Empty" id $ getItemDescription item} diff --git a/Imm/Maildir.hs b/Imm/Maildir.hs new file mode 100644 --- /dev/null +++ b/Imm/Maildir.hs @@ -0,0 +1,41 @@ +module Imm.Maildir where + +-- {{{ Imports +import Imm.Mail() +import Imm.Types + +import Data.Time.Clock.POSIX + +import Network.BSD + +import System.Directory +import System.FilePath +import System.IO.Error +import System.Random +-- }}} + +init :: FilePath -> IO Bool +init directory = do + root <- try $ createDirectoryIfMissing True directory + cur <- try . createDirectoryIfMissing True . (directory ) $ "cur" + new <- try . createDirectoryIfMissing True . (directory ) $ "new" + tmp <- try . createDirectoryIfMissing True . (directory ) $ "tmp" + + case (root, cur, new, tmp) of + (Right _, Right _, Right _, Right _) -> return True + _ -> return False + +add :: FilePath -> Mail -> IO () +add directory mail = do + fileName <- getUniqueName + writeFile (directory "new" fileName) (show mail) + + +getUniqueName :: IO String +getUniqueName = do + time <- getPOSIXTime >>= (return . show) + hostname <- getHostName + rand <- (getStdRandom $ randomR (1,100000) :: IO Int) >>= (return . show) + + return $ time ++ "." ++ rand ++ "." ++ hostname + diff --git a/Imm/Main.hs b/Imm/Main.hs new file mode 100644 --- /dev/null +++ b/Imm/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Imm.Core +--import Imm.Types + +main :: IO () +main = imm defaultParameters diff --git a/Imm/Types.hs b/Imm/Types.hs new file mode 100644 --- /dev/null +++ b/Imm/Types.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Imm.Types where + +-- {{{ Imports +import Network.URI + +import Data.Time.Clock + +import System.Console.CmdArgs + +import Text.Feed.Types +-- }}} + + +data CliOptions = CliOptions { + mParameter :: Maybe String +} deriving (Data, Typeable, Show, Eq) + +-- | +data Parameters = Parameters { + mCacheDirectory :: Maybe String, + mFeedURIs :: [String], -- ^ Feeds list + mMailDirectory :: FilePath, + mError :: Maybe String -- ^ Error +} + +data ImmFeed = ImmFeed { + mURI :: URI, + mFeed :: Feed +} + +data Mail = Mail { + mReturnPath :: String, + mDate :: UTCTime, + mFrom :: String, + mSubject :: String, + mMIME :: String, + mCharset :: String, + mContentDisposition :: String, + mContent :: String +} + +instance Show Mail where + show mail = unlines [ + "Return-Path: " ++ mReturnPath mail, + "Date: " ++ (show $ mDate mail), + "From: " ++ mFrom mail, + "Subject: " ++ mSubject mail, + "Content-Type: " ++ mMIME mail ++ "; charset=" ++ mCharset mail, + "Content-Disposition: " ++ mContentDisposition mail, + "", + mContent mail] diff --git a/Imm/Util.hs b/Imm/Util.hs new file mode 100644 --- /dev/null +++ b/Imm/Util.hs @@ -0,0 +1,24 @@ +module Imm.Util where + +-- {{{ Imports +import Codec.Binary.UTF8.String + +import Data.Time.Clock +import Data.Time.Format + +--import Network.URI + +import System.Locale +-- }}} + +escapeFileName :: Char -> String +escapeFileName '/' = "|" +escapeFileName x = x:[] + +stringToUTC :: String -> Maybe UTCTime +stringToUTC = parseTime defaultTimeLocale "%a, %e %b %Y %T %z" + +decodeIfNeeded :: String -> String +decodeIfNeeded text = case isUTF8Encoded text of + False -> text + _ -> decodeString text diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE +Version 2, December 2004 + +Copyright (C) 2011 koral + +Everyone is permitted to copy and distribute verbatim or modified +copies of this license document, and changing it is allowed as long +as the name is changed. + +DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE +TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + +0. You just DO WHAT THE FUCK YOU WANT TO. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/imm.cabal b/imm.cabal new file mode 100644 --- /dev/null +++ b/imm.cabal @@ -0,0 +1,55 @@ +Name: imm +Version: 0.1.0.0 +Synopsis: RSS-to-maildir tool +--Description: +--Homepage: +Category: Web + +License: OtherLicense +License-file: LICENSE +-- Copyright: +Author: kamaradclimber, koral +Maintainer: koral att mailoo dott org + +Cabal-version: >=1.8 +Build-type: Simple +-- Extra-source-files: + +Source-repository head + Type: git + Location: git@github:k0ral/imm.git + +Library + Exposed-modules: + Imm.Core, + Imm.Types, + Imm.Util, + Imm.Mail, + Imm.Maildir + Build-depends: + base == 4.*, + directory, + dyre, + feed, + filepath, + HTTP, + time, + xml, + old-locale, + random, + bytestring, + mime-mail, + text, + cmdargs, + network, + utf8-string + + -- Other-modules: + -- Build-tools: + Ghc-options: -Wall + +Executable imm + Build-depends: imm, base == 4.* + Main-is: Main.hs + Hs-Source-Dirs: Imm + Ghc-options: -Wall -threaded