module Imm.Config (
FromFormat(FromFormat),
SubjectFormat(SubjectFormat),
BodyFormat(BodyFormat),
Config,
maildir,
fileDatabase,
dateParsers,
formatFrom,
formatSubject,
formatBody,
decoder,
withConfig,
addFeeds,
) where
import Imm.Database
import Imm.Error
import Imm.Feed (FeedParser)
import qualified Imm.Feed as F
import Imm.Maildir (Maildir, MaildirWriter(..))
import Imm.HTTP (Decoder(..))
import qualified Imm.Mail as Mail
import Imm.Util
import Control.Lens hiding((??))
import Control.Monad.Error hiding(forM_, guard)
import Control.Monad.Reader hiding(forM_, guard)
import Data.Foldable hiding(concat)
import Data.Text.ICU.Convert
import qualified Data.Text.Lazy as TL
import Data.Time as T
import Data.Time.RFC2822
import Data.Time.RFC3339
import Prelude hiding(init)
import Text.Feed.Query as F
import System.Directory
import System.Locale
newtype FromFormat = FromFormat { unFromFormat :: Mail.Format }
newtype SubjectFormat = SubjectFormat { unSubjectFormat :: Mail.Format }
newtype BodyFormat = BodyFormat { unBodyFormat :: Mail.Format }
instance Default FromFormat where
def = FromFormat $ \(item, feed) -> fromMaybe (getFeedTitle feed) $ getItemAuthor item
instance Default SubjectFormat where
def = SubjectFormat $ \(item, _feed) -> fromMaybe "Untitled" $ getItemTitle item
instance Default BodyFormat where
def = BodyFormat $ \(item, _feed) -> let
link = fromMaybe "No link found." $ getItemLink item
content = F.getItemContent item
description = fromMaybe "No description." $ getItemDescription item
in "<p>" ++ link ++ "</p><p>" ++ (null content ? description ?? content) ++ "</p>"
data Config = Config {
_maildir :: Maildir,
_fileDatabase :: FileDatabase,
_dateParsers :: [String -> Maybe UTCTime],
_formatFrom :: FromFormat,
_formatSubject :: SubjectFormat,
_formatBody :: BodyFormat,
_decoder :: String
}
makeLenses ''Config
instance Default (IO Config) where
def = do
theDatabase <- def
mailDir <- getHomeDirectory >/> "feeds"
return Config {
_maildir = mailDir,
_fileDatabase = theDatabase,
_dateParsers = [
return . zonedTimeToUTC <=< readRFC2822,
return . zonedTimeToUTC <=< readRFC3339,
T.parseTime defaultTimeLocale "%a, %d %b %G %T",
T.parseTime defaultTimeLocale "%Y-%m-%d",
T.parseTime defaultTimeLocale "%e %b %Y",
T.parseTime defaultTimeLocale "%a, %e %b %Y %k:%M:%S %z",
T.parseTime defaultTimeLocale "%a, %e %b %Y %T %Z"],
_formatFrom = def,
_formatSubject = def,
_formatBody = def,
_decoder = "UTF-8"
}
instance (Monad m) => FeedParser (ReaderT Config m) where
parseDate date = return . listToMaybe . catMaybes =<< tryParsers strippedDate
where
tryParsers string = return . map ($ string) =<< asks (view dateParsers)
strippedDate = TL.unpack . TL.strip . TL.pack $ date
instance (Applicative m, MonadBase IO m) => Decoder (ReaderT Config m) where
converter = io . (`open` Nothing) =<< asks (view decoder)
instance (MonadBase IO m) => DatabaseReader (ReaderT Config m) where
getLastCheck = withReaderT (view fileDatabase) . getLastCheck
instance (MonadError ImmError m, MonadBase IO m) => DatabaseWriter (ReaderT Config m) where
storeLastCheck uri = withReaderT (view fileDatabase) . storeLastCheck uri
forget = withReaderT (view fileDatabase) . forget
instance (MonadBase IO m, MonadError ImmError m) => MaildirWriter (ReaderT Config m) where
init = do
theMaildir <- asks $ view maildir
lift $ runReaderT init theMaildir
write mail = do
theMaildir <- asks $ view maildir
lift $ runReaderT (write mail) theMaildir
instance (Monad m) => Mail.MailFormatter (ReaderT Config m) where
formatFrom = asks $ unFromFormat . view formatFrom
formatSubject = asks $ unSubjectFormat . view formatSubject
formatBody = asks $ unBodyFormat . view formatBody
withConfig :: (MonadBase IO m) => (Config -> Config) -> ReaderT Config m a -> m a
withConfig f g = do
theConfig <- f <$> io def
runReaderT g theConfig
addFeeds :: (MonadBase IO m) => [(String, [String])] -> m ()
addFeeds feeds = do
io . putStrLn . unlines $
"import Imm":
"import Control.Lens":
"import System.FilePath":
"":
"main :: IO ()":
"main = imm myFeeds":
"":
"maildirRoot = \"/home/<user>/feeds\" -- TODO: fill <user>":
"":
("myFeeds = concat $ " ++ intercalate ":" (map (map toLower . concat . words . fst) feeds) ++ ":[]"):
[]
forM_ feeds addFeedsGroup
addFeedsGroup :: (MonadBase IO m) => (String, [String]) -> m ()
addFeedsGroup (groupTitle, uris) = io $ do
putStr . unlines $
("-- Group " ++ groupTitle):
(groupID ++ "Config = set maildir (maildirRoot </> \"" ++ groupID ++ "\")"):
(groupID ++ " = zip (repeat " ++ groupID ++ "Config) $"):
[]
putStr . unlines $ map (\u -> " " ++ show u ++ ":") uris
putStrLn " []"
putStrLn ""
where
groupID = map toLower . concat . words $ groupTitle