diff --git a/.gitignore b/.gitignore index 672f0a3..ebbb203 100644 --- a/.gitignore +++ b/.gitignore @@ -28,3 +28,5 @@ cabal.project.local~ result result-* +# Other Stuff +secret/ diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..ade4885 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for choirMail + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/app/Config.hs b/app/Config.hs new file mode 100644 index 0000000..9e60a41 --- /dev/null +++ b/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 diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..1d86c9e --- /dev/null +++ b/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] diff --git a/app/NetworkGet.hs b/app/NetworkGet.hs new file mode 100644 index 0000000..e69de29 diff --git a/app/Requester.hs b/app/Requester.hs new file mode 100644 index 0000000..ee4bd23 --- /dev/null +++ b/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 diff --git a/app/Sender.hs b/app/Sender.hs new file mode 100644 index 0000000..db83590 --- /dev/null +++ b/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 + diff --git a/app/TableParser.hs b/app/TableParser.hs new file mode 100644 index 0000000..a422301 --- /dev/null +++ b/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 diff --git a/choirMail.cabal b/choirMail.cabal new file mode 100644 index 0000000..8f84479 --- /dev/null +++ b/choirMail.cabal @@ -0,0 +1,95 @@ +cabal-version: 3.0 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'choirMail' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: choirMail + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: "https://git.nerfingen.de/nerf/choirMail" + +-- The license under which the package is released. +license: GPL-3.0-or-later + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Dennis Frieberg + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: nerfingen@yahoo.de + +-- A copyright notice. +-- copyright: +category: Web +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: + +common warnings + ghc-options: -Wall + +executable choirMail + -- Import common warning flags. + import: warnings + + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + other-modules: Config + , TableParser + , Requester + , Sender + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + -- ^>=4.15.1.0 + build-depends: base ^>=4.15.1.0 + ,tomland >= 1.3.3.0 + ,smtp-mail + ,optparse-applicative + ,req + ,parsec + ,text + ,time + ,bytestring + ,mime-mail + ,modern-uri + + + -- Directories containing source files. + hs-source-dirs: app + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/choirMail.nix b/choirMail.nix new file mode 100644 index 0000000..450fd5e --- /dev/null +++ b/choirMail.nix @@ -0,0 +1,17 @@ +{ mkDerivation, base, bytestring, lib, mime-mail, modern-uri +, optparse-applicative, parsec, req, smtp-mail, text, time, tomland +}: +mkDerivation { + pname = "choirMail"; + version = "0.1.0.0"; + src = ./.; + isLibrary = false; + isExecutable = true; + executableHaskellDepends = [ + base bytestring mime-mail modern-uri optparse-applicative parsec + req smtp-mail text time tomland + ]; + homepage = ""https://git.nerfingen.de/nerf/choirMail""; + license = lib.licenses.gpl3Plus; + mainProgram = "choirMail"; +} diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..5a7b90a --- /dev/null +++ b/default.nix @@ -0,0 +1,2 @@ +{ pkgs , compiler ? "ghc902"}: + pkgs.haskell.packages.${compiler}.callPackage ./choirMail.nix { } diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..a47dca9 --- /dev/null +++ b/flake.lock @@ -0,0 +1,43 @@ +{ + "nodes": { + "flake-utils": { + "locked": { + "lastModified": 1667395993, + "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1667639549, + "narHash": "sha256-frqZKSG/933Ctwl9voSZnXDwo8CqddXcjQhnCzwNqaM=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "cae3751e9f74eea29c573d6c2f14523f41c2821a", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..9b482f6 --- /dev/null +++ b/flake.nix @@ -0,0 +1,82 @@ +{ + description = "choir Mail automatisation"; + + inputs = { + nixpkgs.url = github:NixOS/nixpkgs/nixpkgs-unstable; + flake-utils.url = github:numtide/flake-utils; + }; + + outputs = {self, nixpkgs, flake-utils} : + let + # name to be used as identifier for editor environments and such + name = "Application"; + compiler = "ghc902"; + + in + flake-utils.lib.eachDefaultSystem ( system: + let + pkgs = import nixpkgs {inherit system;}; + hpkgs = pkgs.haskell.packages.${compiler}; + in { + packages = { default = (import ./default.nix) {inherit pkgs compiler;};}; + + + devShells = + rec { + # This sets the default devShell + default = kakoune; + kakoune = + let + haskell-language-server = hpkgs.haskell-language-server; + myKakoune = + let + # this could also be done by generating toml with the + # nixpkgs lib, but I'm lazy + kak-lsp-config = pkgs.writeTextFile { + name = "kak-lsp-config.toml"; + text = '' + [language.haskell] + filetypes = ["haskell"] + roots = ["Setup.hs", "stack.yaml", "*.cabal"] + command = "haskell-language-server-wrapper" + args = ["--lsp"] + ''; + }; + config = pkgs.writeTextFile (rec { + name = "kakrc.kak"; + destination = "/share/kak/autoload/${name}"; + text = '' + colorscheme solarized-dark + set global tabstop 2 + set global indentwidth 2 + # eval %sh{kak-lsp --kakoune --session $kak_session -c ${kak-lsp-config}} + eval %sh{kak-lsp --kakoune --session $kak_session -c ${kak-lsp-config} --log /tmp/kak-lpsLog -vvvv} + hook global WinSetOption filetype=(haskell|nix) %{ + lsp-auto-hover-enable + lsp-enable-window + } + add-highlighter global/ number-lines + map global normal ': fzf-mode' + ''; + }); + in + pkgs.kakoune.override { + plugins = with pkgs.kakounePlugins; [fzf-kak kak-lsp config]; + }; + in + pkgs.mkShell { + inputsFrom = [self.outputs.packages.${system}.default]; + packages = [myKakoune haskell-language-server pkgs.git pkgs.fzf hpkgs.cabal2nix pkgs.cabal-install pkgs.zlib.dev]; + # TODO only try to start the kakoune session if no session with that + # name exists + shellHook = '' + alias ..="cd .." + export KAKOUNE_CONFIG_DIR="/dev/null/" + kak -d -s ${name} & + alias vim="kak -c ${name}" + ''; + }; + }; + } + ); +}