first working commit

app/Config.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Config where
+  
+import qualified Toml
+import Toml(TomlCodec, (.=))
+import qualified Data.Text as T
+
+data Config = Config {
+  mailDomain :: String
+  ,mailUsername :: String
+  ,mailPassword :: String
+  ,mailTo       :: T.Text
+  ,mailFrom     :: T.Text
+  } deriving Show
+
+configCodec :: TomlCodec Config
+configCodec = Config
+  <$> Toml.string "mailDomain"   .= mailDomain
+  <*> Toml.string "mailUser"     .= mailUsername
+  <*> Toml.string "mailPassword" .= mailPassword
+  <*> Toml.text   "mailTo"       .= mailTo
+  <*> Toml.text   "mailFrom"     .= mailFrom
+
+parseFile :: String -> IO (Either String Config)
+parseFile path = do
+  config <- Toml.decodeFileEither configCodec path
+  case config of
+    Left errors -> return $ Left $ unwords $ fmap show errors
+    Right x -> return $ Right $ x

app/Main.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+  
+import TableParser
+import Requester
+import Config
+import Data.Time.Calendar
+import Data.Time.Clock
+import qualified Data.List as L
+import System.IO
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as LT
+import Data.Maybe
+import System.Environment
+import System.Exit
+import Data.Time.Format.ISO8601
+import Sender
+
+isChoirThisWeek :: Day -> Day -> Bool
+isChoirThisWeek today day = today <= day && diffDays day today <= 6
+  
+getToday :: IO Day
+getToday = utctDay <$> getCurrentTime
+
+reportError :: String -> IO ()
+reportError err = hPutStr stderr err
+
+main :: IO ()
+main = do
+  args <- getArgs
+  if length args /= 1
+  then
+    die "We need exactly one argument"
+  else do
+    configE <- parseFile (head args)
+    case configE of
+      Left text -> hPutStr stderr text
+      Right config -> do
+        bs <- request
+        let eitherTable = parseBString bs
+        case eitherTable of
+          Left x -> reportError x
+          Right table -> do
+            today <- getToday
+            maybe 
+              (T.putStr "Keine Probe :(")
+              (\record -> send (mailDomain config) (mailUsername config) (mailPassword config) (mailTo config) (mailFrom config) (mailSubject record) (mailText record))
+              (L.find ((isChoirThisWeek today) . date) table)
+
+mailText :: MailRecord -> LT.Text
+mailText record = LT.fromStrict $T.concat ["Guten Morgen,\n\n"
+                           , announcement record
+                           ,"\n\ndiesen Donnerstag\n\nDurchsingen: "
+                           ,song1 record
+                           ,", "
+                           ,song2 record
+                           ,"\nStimmproben: "
+                           ,voice1 record
+                           ,", "
+                           ,voice2 record
+                           ,"\n\nLG\nMalte\n" ]
+
+mailSubject :: MailRecord -> T.Text
+mailSubject record = T.concat ["Donnerstag ", T.pack $ iso8601Show $ date record]

app/Requester.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE OverloadedStrings, DataKinds#-}
+module Requester(request) where
+  
+import Network.HTTP.Req
+-- import qualified Data.Text as T
+import Control.Monad.IO.Class(MonadIO)
+import qualified Data.ByteString as B
+import Text.URI
+
+url :: Url 'Https
+url = https "md.darmstadt.ccc.de" /: "mathechor-probenplanung" /: "download"
+
+
+
+requestRunner :: (MonadIO m)=> m BsResponse
+requestRunner = runReq defaultHttpConfig $ req GET url NoReqBody bsResponse mempty
+
+request :: (MonadIO m) => m B.ByteString
+request = fmap responseBody requestRunner

app/Sender.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Sender where
+  
+import Network.Mail.Mime
+import Network.Mail.SMTP
+import qualified Data.Text as ST
+import qualified Data.Text.Lazy as LT
+
+
+generateMail :: ST.Text -> ST.Text -> ST.Text -> LT.Text -> Mail
+generateMail to from subj = simpleMail' (Address Nothing to) (Address Nothing from) subj
+
+--     domain -> Username -> password -> To  -> From   -> Subject -> Body
+send :: String -> String -> String -> ST.Text -> ST.Text -> ST.Text -> LT.Text -> IO ()
+send domain user pass to from subj body = sendMailWithLoginTLS domain user pass mail
+  where
+    mail = generateMail to from subj body
+

app/TableParser.hs

@@ -0,0 +1,88 @@
+module TableParser(MailRecord(..), parseBString, parseTable) where
+
+import qualified Text.Parsec as P
+-- import qualified Text.Parsec.Char as P
+import qualified Text.Parsec.Text as P
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Time.Calendar as D
+import qualified Data.ByteString as B
+import Control.Monad
+
+
+data MailRecord = MailRecord {
+  date :: D.Day,
+  voice1 :: T.Text,
+  voice2 :: T.Text,
+  song1 :: T.Text,
+  song2 :: T.Text,
+  announcement :: T.Text
+  } deriving (Show)
+
+seperator :: Char
+seperator = '\t'
+
+sepParser :: P.Parser ()
+sepParser = void $ P.char seperator
+
+textCellParser :: P.Parser T.Text
+textCellParser = fmap T.pack $ P.many $ P.noneOf [seperator,'\n','\r']
+
+dateCellParser :: P.Parser D.Day
+dateCellParser = do
+  year <- parseYear
+  _ <- P.char '-'
+  month <- parseMonth
+  _ <- P.char '-'
+  day <- parseDay
+  return $ D.fromGregorian year month day
+
+parseYear :: P.Parser Integer
+parseYear = read <$> P.count 4 P.digit
+
+parseMonth :: P.Parser Int
+parseMonth = read <$> P.count 2 P.digit
+
+parseDay :: P.Parser Int
+parseDay = read <$> P.count 2 P.digit
+
+parseRow :: P.Parser MailRecord
+parseRow = do
+  date <- dateCellParser
+  sepParser
+  voice1 <- textCellParser
+  sepParser
+  voice2 <- textCellParser
+  sepParser
+  song1 <- textCellParser
+  sepParser
+  song2 <- textCellParser
+  sepParser
+  announcments <- textCellParser
+  return $ MailRecord date voice1 voice2 song1 song2 announcments
+
+parseFirstRow :: P.Parser ()
+parseFirstRow = void (P.string "Datum\tStimmprobe 1\tStimmprobe 2\tLied 1\tLied 2\tWeitere Ansagen" >> P.endOfLine)
+
+parseTable :: P.Parser [MailRecord]
+parseTable = do
+  parseFirstRow
+  x <- parseRow `P.sepEndBy` P.endOfLine
+  P.eof
+  return x
+
+textToMailRecord :: T.Text -> Either String [MailRecord]
+textToMailRecord t = case P.parse parseTable "" t of
+  Left x -> Left $ show x
+  Right x -> Right x
+
+
+parseBString :: B.ByteString -> Either String [MailRecord]
+parseBString t = do
+  text <- toText t
+  textToMailRecord text
+
+toText :: B.ByteString -> Either String T.Text
+toText t = case T.decodeUtf8' t of
+  Left x -> Left $ show x
+  Right x -> Right x