works rudimentary

This commit is contained in:
Nicole Dresselhaus 2017-02-10 20:36:41 +01:00
parent c9580946a9
commit e4f51183fb
Signed by: Drezil
GPG Key ID: 057D94F356F41E25
3 changed files with 86 additions and 26 deletions

View File

@ -1,14 +1,64 @@
module Main where
import Lib
import Data.Time.Clock
import Data.Time.Calendar
import System.Environment
import Data.Monoid
import Debug.Trace
import Network.Mail.Mime hiding (mailFrom, mailTo)
import Options.Applicative
data CLIOptions = CLIOptions
{ filename :: String
, mailTo :: String
, mailFrom :: String
, mailFromName :: String
}
options :: Parser CLIOptions
options = CLIOptions
<$> strOption
( long "filename"
<> short 'f'
<> metavar "FILE"
<> help "Filename of Markdown-File"
)
<*> strOption
( long "to"
<> short 't'
<> metavar "TO"
<> help "Mail-address to send the reminder to"
)
<*> strOption
( long "from"
<> short 'f'
<> metavar "FROM"
<> help "Mail-address of the reminder"
)
<*> strOption
( long "name"
<> short 'n'
<> metavar "NAME"
<> help "Name in the reminder-mails"
)
opts = info (options <**> helper)
( fullDesc
<> progDesc "Send reminder from FILE to mail TO using FROM and NAME as identification for the sender"
<> header "md2mail - a small program for sending out reminder-mails from markdown"
)
main :: IO ()
main = do
args <- getArgs
case args of
[fn] -> do
md <- readFile fn
sequence_ $ sequence . fmap print <$> getMails md
_ -> do
print "please call with markdown-file"
args <- execParser opts
md <- readFile $ filename args
(UTCTime today _) <- getCurrentTime
sequence_ $ sequence . fmap (renderSendMail . snd) . filter (filterToday today) <$> getMails md (mailTo args) (mailFrom args) (mailFromName args)
filterToday :: Day -> (Day, Mail) -> Bool
filterToday d (d2,_) = trace (show d <> "==" <> show d2 <> "?") day1 == day2 && m1 == m2
where
(_,m1,day1) = toGregorian d
(_,m2,day2) = toGregorian d2

View File

@ -20,7 +20,10 @@ library
, time
, pandoc
, pandoc-types
, mime-mail
, text
default-language: Haskell2010
default-extensions: OverloadedStrings
executable md2mail
hs-source-dirs: app
@ -28,6 +31,9 @@ executable md2mail
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, md2mail
, time
, mime-mail
, optparse-applicative
default-language: Haskell2010
test-suite md2mail-test

View File

@ -11,41 +11,45 @@ import Data.Time.Format (parseTimeM, defaultTimeLocale)
import Data.Monoid
import Data.Maybe
import Debug.Trace
import Network.Mail.Mime
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
data Mail = Mail
{ title :: String
, content :: String
, to :: Maybe String --Alternate Adress to send to
} deriving (Eq, Show)
-- data Mail = Mail
-- { title :: String
-- , content :: String
-- , to :: Maybe String --Alternate Adress to send to
-- } deriving (Eq, Show)
mkTestmail :: (Show a) => a -> (Day,Mail)
mkTestmail s = (fromGregorian 1999 1 1, Mail "Test" (show s) Nothing)
-- mkTestmail :: (Show a) => a -> (Day,Mail)
-- mkTestmail s = (fromGregorian 1999 1 1, Mail "Test" (show s) Nothing)
getMails :: String -> Either PandocError [(Day, Mail)]
getMails markdown = do
getMails :: String -> String -> String -> String -> Either PandocError [(Day, Mail)]
getMails markdown to from name= do
(Pandoc meta document) <- readMarkdown def markdown
return $ filter isBullet document >>= mkMail
return $ filter isBullet document >>= mkMail to from name
isBullet :: Block -> Bool
isBullet (BulletList _) = True
isBullet _ = False
mkMail :: Block -> [(Day, Mail)]
mkMail (BulletList blocks) = catMaybes $ blToMail <$> blocks
mkMail _ = []
mkMail :: String -> String -> String -> Block -> [(Day, Mail)]
mkMail to from name (BulletList blocks) = catMaybes $ blToMail to from name <$> blocks
mkMail _ _ _ _ = []
blToMail :: [Block] -> Maybe (Day, Mail)
blToMail (Para (Str dat:Space:tit):CodeBlock ca cont:_) = trace (show ca) dayMailPair
blToMail :: String -> String -> String -> [Block] -> Maybe (Day, Mail)
blToMail to from name (Para (Str dat:Space:tit):CodeBlock ca cont:_) = dayMailPair
where
dayofmail d = parseTimeM True defaultTimeLocale "%d.%m." d :: Maybe Day
titleofmail = writePlain def (Pandoc (Meta mempty) [Para tit])
contentofmail (_,a,_) = if "mail" `elem` a then Just cont else Nothing
completeMail :: Maybe Mail
completeMail = Mail <$> pure titleofmail
<*> contentofmail ca
<*> pure Nothing
completeMail = simpleMail' <$> pure (Address (Just "Fachschaft Technik") (T.pack to)) --To
<*> pure (Address (Just (T.pack name)) (T.pack from)) --From
<*> pure (T.pack titleofmail)
<*> (TL.pack <$> contentofmail ca)
dayMailPair :: Maybe (Day, Mail)
dayMailPair = (,) <$> dayofmail dat
<*> completeMail
blToMail _ = Nothing -- Just $ mkTestmail a
blToMail _ _ _ _ = Nothing -- Just $ mkTestmail a