From 271f2949e76613741f93c91be5bf740dae500284 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Mon, 20 Jan 2020 22:44:13 +0100 Subject: [PATCH 01/21] Add logfeed --- .envrc | 1 + CHANGELOG.md | 5 ++ LICENSE | 0 Main.hs | 233 ++++++++++++++++++++++++++++++++++++++++++++++++++ default.nix | 19 ++++ logfeed.cabal | 40 +++++++++ shell.nix | 1 + 7 files changed, 299 insertions(+) create mode 100644 .envrc create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 Main.hs create mode 100644 default.nix create mode 100644 logfeed.cabal create mode 100644 shell.nix diff --git a/.envrc b/.envrc new file mode 100644 index 00000000..051d09d2 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +eval "$(lorri direnv)" diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 00000000..b79f4b19 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for logfeed + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..e69de29b diff --git a/Main.hs b/Main.hs new file mode 100644 index 00000000..972ccd74 --- /dev/null +++ b/Main.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE ViewPatterns, ScopedTypeVariables, NamedFieldPuns, OverloadedStrings, NoImplicitPrelude, ExtendedDefaultRules, QuasiQuotes #-} +module Main where + +import Data.Char +import Data.Function +import Data.String.Interpolate ( i ) +import Relude hiding ( intercalate + , dropWhile + , zip + ) +import qualified Relude.Unsafe as Unsafe +import Data.Text ( intercalate + , dropWhile + , replace + ) +import Text.Atom.Feed.Export ( textFeed ) +import qualified Data.Text as Text +import Data.List.NonEmpty ( groupBy + , zip + ) +import Text.Atom.Feed +import qualified Data.Time.Calendar as T +import qualified Data.Time.Clock as T +import qualified Data.Time.Format as T +import qualified Text.Megaparsec as MP +import qualified Text.Megaparsec.Char as MP +import qualified Text.Megaparsec.Char as MPC +import qualified Text.Megaparsec.Char.Lexer as MP +import System.FilePattern.Directory ( getDirectoryFiles ) +import qualified Data.List.Extra as L +import qualified Data.Set as Set +import System.Environment ( getArgs ) +-- TODO: use Text instead of linked lists of chars + +type WeechatLog = [WeechatLine] +data WeechatLine = WeechatLine { wlDate :: Text + , wlTime :: Text + , wlNick :: Text + , wlMsg :: Text } deriving (Show, Eq, Ord) +-- TODO: specific handling of join/part/network messages + +header = unlines + [ "" + , "" + , " " + , " " + , " IRC log" + , " " + ] + +data LogFile = LogFile { path :: Text, server :: Text, channel :: Text } deriving (Show, Eq, Ord, Read) + +type Parser = MP.Parsec Text Text + +hyphen = MP.char '-' +date = do + MP.decimal + hyphen + MP.decimal + hyphen + MP.decimal +dirSep = MP.char '/' +symbol = MP.symbol MPC.space +folder = toText <$> MP.manyTill MP.asciiChar dirSep + +matrixParser :: Text -> Parser LogFile +matrixParser = \p -> do + MP.decimal -- year + dirSep + prefix <- symbol "matrix:" + server <- folder + folder -- room_id + date + hyphen + symbol server + MP.char '.' + channel <- toText <$> MP.manyTill MP.asciiChar (symbol ".weechatlog") + pure $ LogFile p (prefix <> server) channel + +ircParser :: Text -> Parser LogFile +ircParser = \p -> do + MP.decimal -- year + dirSep + prefix <- symbol "irc:" :: Parser Text + server <- folder + channel <- folder + date + symbol ".weechatlog" + pure $ LogFile p (prefix <> server) channel + +logFolder = "/home/maralorn/logs/" + +main = do + now <- T.getCurrentTime + let today = T.utctDay now + yesterday = T.addDays (0 - 1) today + getFiles = \t p -> + L.groupSortOn (\x -> (channel x, server x)) + . mapMaybe (\x -> (MP.parseMaybe (p x) x)) + . fmap toText + <$> getDirectoryFiles + (toString logFolder) + (T.formatTime T.defaultTimeLocale t <$> [yesterday, today]) + matrixFiles <- getFiles "%Y/matrix:*/*.!*/%Y-%m-%d-*.weechatlog" matrixParser + ircFiles <- getFiles "%Y/irc:*/#*/%Y-%m-%d.weechatlog" ircParser + logs <- mapM readLogFiles $ mapMaybe nonEmpty $ matrixFiles <> ircFiles + --(flip mapM_) logs $ \(Log { logchannel, logserver, messages }) -> do + let + timestamp = toText $ T.formatTime T.defaultTimeLocale "%Y-%m-%d %H:%M" now + cutoff = + toText $ T.formatTime T.defaultTimeLocale "%Y-%m-%d 19:55" yesterday + msgFilter msg = [i|#{wlDate msg} #{wlTime msg}|] >= cutoff + entries = logs & mapMaybe + (\(Log { logchannel, logserver, messages = filter msgFilter -> messages }) -> + if length messages > 0 + then Just (nullEntry + [i|#{logserver}-#{logchannel}-#{timestamp}|] + (TextString [i|#{logchannel} - (#{logserver})|]) + timestamp + ) + { entryContent = Just $ HTMLContent $ printHTML messages + } + else Nothing + ) + feed = nullFeed [i|weechat-logs-#{timestamp}|] + (TextString "Weechat Logs") + timestamp + [pathToWrite] <- getArgs + whenJust (textFeed feed { feedEntries = entries }) + $ \file -> writeFileLText pathToWrite file + + +data Log = Log { logchannel :: Text, logserver :: Text, messages :: [WeechatLine] } deriving (Show, Eq, Ord) + +readLogFiles :: NonEmpty LogFile -> IO Log +readLogFiles files = + readLogFile (head files) + <$> mapM (readFileText . toString . (logFolder <>) . path) files + + +readLogFile :: LogFile -> NonEmpty Text -> Log +readLogFile = \LogFile { channel, server } contents -> Log + { logchannel = channel + , logserver = server + , messages = L.sortOn (\x -> (wlDate x, wlTime x)) + . concat + $ parseWeechatLog + <$> contents + } + +parseWeechatLog :: Text -> [WeechatLine] +parseWeechatLog = mapMaybe parseWeechatLine . lines + where + parseWeechatLine l + | [date, time, nick] <- take 3 . words $ l + = let + msg = + drop (length (toString $ unwords [date, time, nick]) + 1) (toString l) + in if (nick `elem` ["-->", "<--", "--"]) + then Nothing + else Just (WeechatLine date time nick (toText msg)) + | otherwise + = trace ([i|Couldn‘t parse line #{show l}|]) Nothing + +printHTML :: [WeechatLine] -> Text +printHTML log = + intercalate "\n" + $ [header, ""] + ++ map printDay days + ++ ["", ""] + where + allNicks = Set.fromList . map (dropWhile sigil . wlNick) $ log + days = groupBy ((==) `on` wlDate) log + printDay ls = + intercalate "" + $ ["

" <> wlDate (head ls) <> "

"] + <> (toList $ printRow <$> zip (WeechatLine "" "" "" "" :| toList ls) ls) + printRow :: (WeechatLine, WeechatLine) -> Text + printRow (prevRow, curRow) = + "" + <> wlTime curRow + <> " " + <> nick + <> " " + <> (escape $ wlMsg curRow) + <> "
" + where + prevNick = wlNick prevRow + curNick = wlNick curRow + nick | specialNick curNick = curNick + | prevNick == curNick = " " + | otherwise = curNick + +specialNick = (`elem` ["-->", "<--", "--", "*"]) + +sigil :: Char -> Bool +sigil = (`elem` ("@%+" :: String)) +-- Weechat default nick hash function = sum of unicode values +hash :: Text -> Text +hash = show . (`mod` (length colors)) . sum . map ord . toString + +colors = + [ "cyan" + , "magenta" + , "green" + , "brown" + , "lightblue" + , "default" + , "lightcyan" + , "lightmagenta" + , "lightgreen" + , "blue" + ] + +colorhl allNicks msg + | firstWord == "" + = msg + | Text.last firstWord == ':' && nick `Set.member` allNicks + = sigils + <> " hash nick + <> "\">" + <> nick + <> ":" + <> rest + | otherwise + = msg + where + (firstWord, rest ) = Text.span (not . isSpace) msg + (sigils , nick') = Text.span sigil firstWord + nick = Text.init nick' + +escape = replace "<" "<" . replace ">" ">" diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..10dd82b0 --- /dev/null +++ b/default.nix @@ -0,0 +1,19 @@ +{ pkgs ? import { } }: + +let + haskellPackages = pkgs.haskellPackages; + drv = haskellPackages.callCabal2nix "logfeed" ./. { }; +in { + taskwarrior = drv; + shell = haskellPackages.shellFor { + withHoogle = true; + packages = p: [ drv ]; + buildInputs = with haskellPackages; [ + hlint + cabal-install + brittany + pkgs.coreutils + pkgs.zlib + ]; + }; +} diff --git a/logfeed.cabal b/logfeed.cabal new file mode 100644 index 00000000..e08884a9 --- /dev/null +++ b/logfeed.cabal @@ -0,0 +1,40 @@ +cabal-version: >=1.10 + +-- Initial package description 'logfeed.cabal' generated by 'cabal init'. +-- For further documentation, see http://haskell.org/cabal/users-guide/ + +name: logfeed +version: 0.1.0.0 + +-- synopsis: +-- description: +-- bug-reports: +-- license: +license-file: LICENSE +author: Malte Brandy +maintainer: malte.brandy@maralorn.de + +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md + +executable logfeed + main-is: Main.hs + + -- other-modules: + -- other-extensions: + build-depends: + base >=4.12 && <4.13 + , containers + , extra + , feed >=1.3.0.0 + , filepattern + , megaparsec + , relude + , string-interpolate + , text + , time + + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/shell.nix b/shell.nix new file mode 100644 index 00000000..a6bdf202 --- /dev/null +++ b/shell.nix @@ -0,0 +1 @@ +(import ./. { }).shell From 4102d44eee0cab98b85c3a836710580fda194411 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Tue, 21 Jan 2020 13:51:12 +0100 Subject: [PATCH 02/21] Improve log representation --- .gitignore | 1 + Main.hs | 195 +++++++++++++++++++++++--------------------------- logfeed.cabal | 1 + 3 files changed, 92 insertions(+), 105 deletions(-) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..48a004cd --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle diff --git a/Main.hs b/Main.hs index 972ccd74..34fb1e87 100644 --- a/Main.hs +++ b/Main.hs @@ -1,16 +1,11 @@ -{-# LANGUAGE ViewPatterns, ScopedTypeVariables, NamedFieldPuns, OverloadedStrings, NoImplicitPrelude, ExtendedDefaultRules, QuasiQuotes #-} +{-# LANGUAGE ViewPatterns, ScopedTypeVariables, NamedFieldPuns, OverloadedStrings, NoImplicitPrelude, ExtendedDefaultRules, QuasiQuotes, MultiWayIf #-} module Main where -import Data.Char -import Data.Function import Data.String.Interpolate ( i ) import Relude hiding ( intercalate - , dropWhile , zip ) -import qualified Relude.Unsafe as Unsafe import Data.Text ( intercalate - , dropWhile , replace ) import Text.Atom.Feed.Export ( textFeed ) @@ -28,7 +23,6 @@ import qualified Text.Megaparsec.Char as MPC import qualified Text.Megaparsec.Char.Lexer as MP import System.FilePattern.Directory ( getDirectoryFiles ) import qualified Data.List.Extra as L -import qualified Data.Set as Set import System.Environment ( getArgs ) -- TODO: use Text instead of linked lists of chars @@ -39,6 +33,7 @@ data WeechatLine = WeechatLine { wlDate :: Text , wlMsg :: Text } deriving (Show, Eq, Ord) -- TODO: specific handling of join/part/network messages +header :: Text header = unlines [ "" , "" @@ -52,83 +47,106 @@ data LogFile = LogFile { path :: Text, server :: Text, channel :: Text } derivin type Parser = MP.Parsec Text Text +hyphen :: Parser Char hyphen = MP.char '-' -date = do - MP.decimal - hyphen - MP.decimal - hyphen - MP.decimal +parseDate :: Parser Text +parseDate = do + year <- MP.count 4 MP.digitChar + void $ hyphen + month <- MP.count 2 MP.digitChar + void $ hyphen + day <- MP.count 2 MP.digitChar + pure [i|#{year}-#{month}-#{day}|] +parseTime :: Parser Text +parseTime = do + hour <- MP.count 2 MP.digitChar + void $ MP.char ':' + minute <- MP.count 2 MP.digitChar + void $ MP.char ':' + seconds <- MP.count 2 MP.digitChar + pure [i|#{hour}:#{minute}:#{seconds}|] +dirSep :: Parser Char dirSep = MP.char '/' +symbol :: Text -> Parser Text symbol = MP.symbol MPC.space +folder :: Parser Text folder = toText <$> MP.manyTill MP.asciiChar dirSep matrixParser :: Text -> Parser LogFile matrixParser = \p -> do - MP.decimal -- year - dirSep + void $ MP.count 4 (MP.digitChar) -- year + void dirSep prefix <- symbol "matrix:" server <- folder - folder -- room_id - date - hyphen - symbol server - MP.char '.' + void folder -- room_id + void parseDate + void hyphen + void $ symbol server + void $ MP.char '.' channel <- toText <$> MP.manyTill MP.asciiChar (symbol ".weechatlog") pure $ LogFile p (prefix <> server) channel ircParser :: Text -> Parser LogFile ircParser = \p -> do - MP.decimal -- year - dirSep + void $ MP.count 4 (MP.digitChar) + void dirSep prefix <- symbol "irc:" :: Parser Text server <- folder channel <- folder - date - symbol ".weechatlog" + void parseDate + void $ symbol ".weechatlog" pure $ LogFile p (prefix <> server) channel +logFolder :: Text logFolder = "/home/maralorn/logs/" +main :: IO () main = do now <- T.getCurrentTime - let today = T.utctDay now - yesterday = T.addDays (0 - 1) today - getFiles = \t p -> + let getFiles = \t p -> L.groupSortOn (\x -> (channel x, server x)) . mapMaybe (\x -> (MP.parseMaybe (p x) x)) . fmap toText <$> getDirectoryFiles (toString logFolder) - (T.formatTime T.defaultTimeLocale t <$> [yesterday, today]) + ( T.formatTime T.defaultTimeLocale t + <$> [yesterday now, today now] + ) matrixFiles <- getFiles "%Y/matrix:*/*.!*/%Y-%m-%d-*.weechatlog" matrixParser ircFiles <- getFiles "%Y/irc:*/#*/%Y-%m-%d.weechatlog" ircParser logs <- mapM readLogFiles $ mapMaybe nonEmpty $ matrixFiles <> ircFiles --(flip mapM_) logs $ \(Log { logchannel, logserver, messages }) -> do - let - timestamp = toText $ T.formatTime T.defaultTimeLocale "%Y-%m-%d %H:%M" now - cutoff = - toText $ T.formatTime T.defaultTimeLocale "%Y-%m-%d 19:55" yesterday - msgFilter msg = [i|#{wlDate msg} #{wlTime msg}|] >= cutoff - entries = logs & mapMaybe - (\(Log { logchannel, logserver, messages = filter msgFilter -> messages }) -> - if length messages > 0 - then Just (nullEntry - [i|#{logserver}-#{logchannel}-#{timestamp}|] - (TextString [i|#{logchannel} - (#{logserver})|]) - timestamp - ) - { entryContent = Just $ HTMLContent $ printHTML messages - } - else Nothing - ) - feed = nullFeed [i|weechat-logs-#{timestamp}|] - (TextString "Weechat Logs") - timestamp + let entries = logs & mapMaybe (logToFeedEntry now) + feed = nullFeed [i|weechat-logs-#{timestamp now}|] + (TextString "Weechat Logs") + (timestamp now) [pathToWrite] <- getArgs whenJust (textFeed feed { feedEntries = entries }) $ \file -> writeFileLText pathToWrite file +today :: T.UTCTime -> T.Day +today = T.utctDay +yesterday :: T.UTCTime -> T.Day +yesterday = T.addDays (0 - 1) . today + +timestamp :: T.UTCTime -> Text +timestamp = toText . T.formatTime T.defaultTimeLocale "%Y-%m-%d %H:%M" + +logToFeedEntry :: T.UTCTime -> Log -> Maybe Entry +logToFeedEntry now = + \Log { logchannel, logserver, messages = filter msgFilter -> messages } -> if + | length messages > 0 -> Just + (nullEntry [i|#{logserver}-#{logchannel}-#{timestamp now}|] + (TextString [i|#{logchannel} - (#{logserver})|]) + (timestamp now) + ) + { entryContent = Just $ HTMLContent $ printHTML messages + } + | otherwise -> Nothing + where + cutoff = + toText $ T.formatTime T.defaultTimeLocale "%Y-%m-%d 19:50" $ yesterday now + msgFilter msg = [i|#{wlDate msg} #{wlTime msg}|] >= cutoff data Log = Log { logchannel :: Text, logserver :: Text, messages :: [WeechatLine] } deriving (Show, Eq, Ord) @@ -148,19 +166,22 @@ readLogFile = \LogFile { channel, server } contents -> Log <$> contents } + +parseWeechatLine :: Parser WeechatLine +parseWeechatLine = do + date <- parseDate + void $ MP.char ' ' + time <- parseTime + void $ MP.tab + nick <- toText <$> MP.manyTill MP.printChar MP.tab + msg <- MP.takeRest + pure $ WeechatLine date time nick msg + parseWeechatLog :: Text -> [WeechatLine] -parseWeechatLog = mapMaybe parseWeechatLine . lines +parseWeechatLog = filter actualMessage . mapMaybe parseLine . lines where - parseWeechatLine l - | [date, time, nick] <- take 3 . words $ l - = let - msg = - drop (length (toString $ unwords [date, time, nick]) + 1) (toString l) - in if (nick `elem` ["-->", "<--", "--"]) - then Nothing - else Just (WeechatLine date time nick (toText msg)) - | otherwise - = trace ([i|Couldn‘t parse line #{show l}|]) Nothing + actualMessage = not . (`elem` ["-->", "<--", "--"]) . wlNick + parseLine = MP.parseMaybe parseWeechatLine printHTML :: [WeechatLine] -> Text printHTML log = @@ -169,65 +190,29 @@ printHTML log = ++ map printDay days ++ ["", ""] where - allNicks = Set.fromList . map (dropWhile sigil . wlNick) $ log - days = groupBy ((==) `on` wlDate) log + days = groupBy ((==) `on` wlDate) log printDay ls = - intercalate "" + intercalate "\n" $ ["

" <> wlDate (head ls) <> "

"] <> (toList $ printRow <$> zip (WeechatLine "" "" "" "" :| toList ls) ls) printRow :: (WeechatLine, WeechatLine) -> Text printRow (prevRow, curRow) = "" - <> wlTime curRow + <> time <> " " <> nick <> " " <> (escape $ wlMsg curRow) <> "
" where + prevTime = Text.take 5 $ wlTime prevRow + curTime = Text.take 5 $ wlTime curRow prevNick = wlNick prevRow curNick = wlNick curRow + time | prevTime == curTime = "" + | otherwise = curTime nick | specialNick curNick = curNick - | prevNick == curNick = " " + | prevNick == curNick = "" | otherwise = curNick - -specialNick = (`elem` ["-->", "<--", "--", "*"]) - -sigil :: Char -> Bool -sigil = (`elem` ("@%+" :: String)) --- Weechat default nick hash function = sum of unicode values -hash :: Text -> Text -hash = show . (`mod` (length colors)) . sum . map ord . toString - -colors = - [ "cyan" - , "magenta" - , "green" - , "brown" - , "lightblue" - , "default" - , "lightcyan" - , "lightmagenta" - , "lightgreen" - , "blue" - ] - -colorhl allNicks msg - | firstWord == "" - = msg - | Text.last firstWord == ':' && nick `Set.member` allNicks - = sigils - <> " hash nick - <> "\">" - <> nick - <> ":" - <> rest - | otherwise - = msg - where - (firstWord, rest ) = Text.span (not . isSpace) msg - (sigils , nick') = Text.span sigil firstWord - nick = Text.init nick' - -escape = replace "<" "<" . replace ">" ">" + specialNick = (`elem` ["-->", "<--", "--", "*"]) + escape = replace "<" "<" . replace ">" ">" diff --git a/logfeed.cabal b/logfeed.cabal index e08884a9..7e68ad94 100644 --- a/logfeed.cabal +++ b/logfeed.cabal @@ -21,6 +21,7 @@ extra-source-files: CHANGELOG.md executable logfeed main-is: Main.hs + ghc-options: -Wall -- other-modules: -- other-extensions: From eb02d708a67e7129239967ea6fde39bf602ee55f Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sun, 26 Jan 2020 18:23:06 +0100 Subject: [PATCH 03/21] Improve formatting --- Main.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/Main.hs b/Main.hs index 34fb1e87..18ba1a45 100644 --- a/Main.hs +++ b/Main.hs @@ -115,7 +115,6 @@ main = do matrixFiles <- getFiles "%Y/matrix:*/*.!*/%Y-%m-%d-*.weechatlog" matrixParser ircFiles <- getFiles "%Y/irc:*/#*/%Y-%m-%d.weechatlog" ircParser logs <- mapM readLogFiles $ mapMaybe nonEmpty $ matrixFiles <> ircFiles - --(flip mapM_) logs $ \(Log { logchannel, logserver, messages }) -> do let entries = logs & mapMaybe (logToFeedEntry now) feed = nullFeed [i|weechat-logs-#{timestamp now}|] (TextString "Weechat Logs") @@ -166,7 +165,6 @@ readLogFile = \LogFile { channel, server } contents -> Log <$> contents } - parseWeechatLine :: Parser WeechatLine parseWeechatLine = do date <- parseDate @@ -200,9 +198,9 @@ printHTML log = "" <> time <> " " - <> nick + <> printNick <> " " - <> (escape $ wlMsg curRow) + <> message <> "
" where prevTime = Text.take 5 $ wlTime prevRow @@ -214,5 +212,12 @@ printHTML log = nick | specialNick curNick = curNick | prevNick == curNick = "" | otherwise = curNick + printNick = Text.dropWhile (`elem` "&@") nick + msg = wlMsg curRow + message + | not (Text.null msg) && Text.head msg == '>' + = "|" <> escape (Text.tail msg) <> "" + | otherwise + = escape msg specialNick = (`elem` ["-->", "<--", "--", "*"]) escape = replace "<" "<" . replace ">" ">" From 6f0132abbab58da56e109cedf851a9d9f8a2f8c6 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Wed, 9 Dec 2020 20:51:21 +0100 Subject: [PATCH 04/21] Fix bounds --- logfeed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/logfeed.cabal b/logfeed.cabal index 7e68ad94..0e07f4ea 100644 --- a/logfeed.cabal +++ b/logfeed.cabal @@ -26,7 +26,7 @@ executable logfeed -- other-modules: -- other-extensions: build-depends: - base >=4.12 && <4.13 + base , containers , extra , feed >=1.3.0.0 From 5ec07f2fc03ca29b93dd2146277f6aac51624248 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sat, 12 Dec 2020 15:31:42 +0100 Subject: [PATCH 05/21] Apply hlints --- Main.hs | 70 ++++++++++++++++++++++++++++++++------------------------- 1 file changed, 40 insertions(+), 30 deletions(-) diff --git a/Main.hs b/Main.hs index 18ba1a45..f27aa4e8 100644 --- a/Main.hs +++ b/Main.hs @@ -27,10 +27,13 @@ import System.Environment ( getArgs ) -- TODO: use Text instead of linked lists of chars type WeechatLog = [WeechatLine] -data WeechatLine = WeechatLine { wlDate :: Text - , wlTime :: Text - , wlNick :: Text - , wlMsg :: Text } deriving (Show, Eq, Ord) +data WeechatLine = WeechatLine + { wlDate :: Text + , wlTime :: Text + , wlNick :: Text + , wlMsg :: Text + } + deriving (Show, Eq, Ord) -- TODO: specific handling of join/part/network messages header :: Text @@ -43,7 +46,12 @@ header = unlines , " " ] -data LogFile = LogFile { path :: Text, server :: Text, channel :: Text } deriving (Show, Eq, Ord, Read) +data LogFile = LogFile + { path :: Text + , server :: Text + , channel :: Text + } + deriving (Show, Eq, Ord, Read) type Parser = MP.Parsec Text Text @@ -52,9 +60,9 @@ hyphen = MP.char '-' parseDate :: Parser Text parseDate = do year <- MP.count 4 MP.digitChar - void $ hyphen + void hyphen month <- MP.count 2 MP.digitChar - void $ hyphen + void hyphen day <- MP.count 2 MP.digitChar pure [i|#{year}-#{month}-#{day}|] parseTime :: Parser Text @@ -73,8 +81,8 @@ folder :: Parser Text folder = toText <$> MP.manyTill MP.asciiChar dirSep matrixParser :: Text -> Parser LogFile -matrixParser = \p -> do - void $ MP.count 4 (MP.digitChar) -- year +matrixParser p = do + void $ MP.count 4 MP.digitChar -- year void dirSep prefix <- symbol "matrix:" server <- folder @@ -87,8 +95,8 @@ matrixParser = \p -> do pure $ LogFile p (prefix <> server) channel ircParser :: Text -> Parser LogFile -ircParser = \p -> do - void $ MP.count 4 (MP.digitChar) +ircParser p = do + void $ MP.count 4 MP.digitChar void dirSep prefix <- symbol "irc:" :: Parser Text server <- folder @@ -105,8 +113,7 @@ main = do now <- T.getCurrentTime let getFiles = \t p -> L.groupSortOn (\x -> (channel x, server x)) - . mapMaybe (\x -> (MP.parseMaybe (p x) x)) - . fmap toText + . mapMaybe ((\x -> MP.parseMaybe (p x) x) . toText) <$> getDirectoryFiles (toString logFolder) ( T.formatTime T.defaultTimeLocale t @@ -126,28 +133,33 @@ main = do today :: T.UTCTime -> T.Day today = T.utctDay yesterday :: T.UTCTime -> T.Day -yesterday = T.addDays (0 - 1) . today +yesterday = T.addDays (negate 1) . today timestamp :: T.UTCTime -> Text timestamp = toText . T.formatTime T.defaultTimeLocale "%Y-%m-%d %H:%M" logToFeedEntry :: T.UTCTime -> Log -> Maybe Entry logToFeedEntry now = - \Log { logchannel, logserver, messages = filter msgFilter -> messages } -> if - | length messages > 0 -> Just - (nullEntry [i|#{logserver}-#{logchannel}-#{timestamp now}|] - (TextString [i|#{logchannel} - (#{logserver})|]) - (timestamp now) - ) + \Log { logchannel, logserver, messages = filter msgFilter -> messages } -> + if not (null messages) + then Just (nullEntry [i|#{logserver}-#{logchannel}-#{timestamp now}|] + (TextString [i|#{logchannel} - (#{logserver})|]) + (timestamp now) + ) { entryContent = Just $ HTMLContent $ printHTML messages } - | otherwise -> Nothing + else Nothing where cutoff = toText $ T.formatTime T.defaultTimeLocale "%Y-%m-%d 19:50" $ yesterday now msgFilter msg = [i|#{wlDate msg} #{wlTime msg}|] >= cutoff -data Log = Log { logchannel :: Text, logserver :: Text, messages :: [WeechatLine] } deriving (Show, Eq, Ord) +data Log = Log + { logchannel :: Text + , logserver :: Text + , messages :: [WeechatLine] + } + deriving (Show, Eq, Ord) readLogFiles :: NonEmpty LogFile -> IO Log readLogFiles files = @@ -156,7 +168,7 @@ readLogFiles files = readLogFile :: LogFile -> NonEmpty Text -> Log -readLogFile = \LogFile { channel, server } contents -> Log +readLogFile LogFile { channel, server } contents = Log { logchannel = channel , logserver = server , messages = L.sortOn (\x -> (wlDate x, wlTime x)) @@ -170,10 +182,9 @@ parseWeechatLine = do date <- parseDate void $ MP.char ' ' time <- parseTime - void $ MP.tab + void MP.tab nick <- toText <$> MP.manyTill MP.printChar MP.tab - msg <- MP.takeRest - pure $ WeechatLine date time nick msg + WeechatLine date time nick <$> MP.takeRest parseWeechatLog :: Text -> [WeechatLine] parseWeechatLog = filter actualMessage . mapMaybe parseLine . lines @@ -190,9 +201,8 @@ printHTML log = where days = groupBy ((==) `on` wlDate) log printDay ls = - intercalate "\n" - $ ["

" <> wlDate (head ls) <> "

"] - <> (toList $ printRow <$> zip (WeechatLine "" "" "" "" :| toList ls) ls) + intercalate "\n" $ ["

" <> wlDate (head ls) <> "

"] <> toList + (printRow <$> zip (WeechatLine "" "" "" "" :| toList ls) ls) printRow :: (WeechatLine, WeechatLine) -> Text printRow (prevRow, curRow) = "" @@ -212,7 +222,7 @@ printHTML log = nick | specialNick curNick = curNick | prevNick == curNick = "" | otherwise = curNick - printNick = Text.dropWhile (`elem` "&@") nick + printNick = Text.dropWhile (`elem` ['&', '@']) nick msg = wlMsg curRow message | not (Text.null msg) && Text.head msg == '>' From 29c4cbd2e7f5fae3597e1d5be929271dc4100a57 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sat, 12 Dec 2020 15:31:58 +0100 Subject: [PATCH 06/21] Save Mail export progress --- Mail.hs | 163 ++++++++++++++++++++++++++++++++++++++++++++++++++ logfeed.cabal | 26 +++++++- 2 files changed, 187 insertions(+), 2 deletions(-) create mode 100644 Mail.hs diff --git a/Mail.hs b/Mail.hs new file mode 100644 index 00000000..6483e2b4 --- /dev/null +++ b/Mail.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +import Prelude ( ) +import Relude +import Notmuch hiding ( Thread ) +import qualified Notmuch +import Say +import Data.String.Interpolate +import Data.MIME as MIME +import Data.MIME.Charset +import Control.Lens hiding ( argument ) +import Control.Error ( withExceptT ) +import qualified Data.Text as T +import Control.Exception +import Data.Time +import Relude.Extra.Group +import qualified Data.Map as Map +import Options.Applicative +import Text.Atom.Feed.Export ( textFeed ) +import Text.Atom.Feed + +data Options = Options + { dbPath :: String + , folder :: String + } + +type Thread = Text +type Error = Text +type MyMessage = (UTCTime, Text) + +main :: IO () +main = do + Options { dbPath, folder } <- execParser $ info + ( Options + <$> argument + str + (metavar "DBPATH" <> help "The full path to the notmuch database") + <*> argument + str + (metavar "FOLDER" <> help "The maildir to scan for messages.") + <**> helper) + fullDesc + res <- runExceptT do + (thrds, msgs) <- withExceptT + (\(er :: Status) -> + [i|Failed to read notmuch data.\ndb path: #{dbPath}\nquery: Folder #{folder}\nerror: #{er}|] + ) + do + db <- databaseOpenReadOnly dbPath + q <- query db (Folder folder) + (,) <$> threads q <*> messages q + msgsByThread <- forM msgs \msg -> threadId msg <&> (, Right msg) + thrdsByThread <- forM thrds \thrd -> threadId thrd <&> (, Left thrd) + result <- + mapM (runExceptT . processThread) . Map.toList $ fmap snd <$> groupBy + fst + (msgsByThread <> thrdsByThread) + now <- lift getCurrentTime + let entries = threadToEntry $ fst <$> rights result + feed = nullFeed [i|mail-threads-#{timestamp now}|] + (TextString "Read-Later-Mail") + (timestamp now) + forM_ (rights result) (say . fst) + forM_ (rights result) (mapM_ sayErr . snd) + forM_ (lefts result) sayErr + + feedText <- hoistEither + . maybeToRight [i|Failed to generate feed.|] . textFeed $ feed { feedEntries = entries } + say $ toStrict feedText + either + (\(er :: Text) -> + sayErr [i|mail2feed failed to export mails to rss.\n#{er}|] + ) + (const pass) + res + +threadToEntry :: [Thread] -> [Entry] +threadToEntry = error "not implemented" + +errorsToEntry :: [Error] -> Entry +errorsToEntry er = undefined + +timestamp :: UTCTime -> Text +timestamp = toText . formatTime defaultTimeLocale "%Y-%m-%d %H:%M" + +processThread + :: (MonadIO m) + => (ThreadId, NonEmpty (Either (Notmuch.Thread a) (Notmuch.Message n a))) + -> ExceptT Error m (Thread, [Error]) +processThread (thrdId, toList -> thrdAndMsgs) = do + thread <- + hoistEither + . maybeToRight [i|No Thread object found for Threadid #{thrdId}|] + . viaNonEmpty head + . lefts + $ thrdAndMsgs + subject <- threadSubject thread + msgCount <- threadTotalMessages thread + let + msgs = rights thrdAndMsgs + threadHeader = + [i|Showing #{length msgs} of #{msgCount} e-mails from thread\nSubject: #{subject}\n\n|] :: Text + results <- mapM (runExceptT . processMessage) msgs + let goodResults = snd <$> sortOn fst (rights results) + pure + ([i|#{threadHeader}\n#{T.intercalate "\n\n" goodResults}|], lefts results) + +processMessage + :: (MonadIO m) => Notmuch.Message n a -> ExceptT Error m MyMessage +processMessage msg = do + fileName <- messageFilename msg + withExceptT + (\er -> [i|Failed to read msg #{fileName}\nerror: #{er}|]) + do + date <- messageDate msg + subject <- + hoistEither + . maybeToRight [i|Failed to get subject|] + =<< messageHeader "subject" msg + fromField <- + hoistEither + . maybeToRight [i|Failed to get from|] + =<< messageHeader "from" msg + toField <- + hoistEither + . maybeToRight [i|Failed to get to|] + =<< messageHeader "to" msg + cc <- + hoistEither + . maybeToRight [i|Failed to get cc|] + =<< messageHeader "cc" msg + msgContent <- withExceptT (\(er :: IOException) -> [i|IOError: #{er}|]) + $ readFileBS fileName + parseResult <- hoistEither . first toText $ parse (message mime) + msgContent + textPart <- + hoistEither . maybeToRight [i|No text part in message|] $ firstOf + (entities . filtered isTextPlain) + parseResult + textAsText <- + hoistEither . maybeToRight [i|Could not decode message|] $ decode + textPart + pure + ( date + , [i|Subject: #{subject}\nFrom: #{fromField}\nTo: #{toField}#{if cc /= "" then "\nCc: " <> cc else ""}\nDate: #{date}\n\n#{textAsText}|] + ) + +isTextPlain :: WireEntity -> Bool +isTextPlain = matchContentType "text" (Just "plain") . view contentType + +decode :: WireEntity -> Maybe Text +decode = + preview (transferDecoded' . _Right . charsetText' defaultCharsets . _Right) diff --git a/logfeed.cabal b/logfeed.cabal index 0e07f4ea..fae8695b 100644 --- a/logfeed.cabal +++ b/logfeed.cabal @@ -21,7 +21,7 @@ extra-source-files: CHANGELOG.md executable logfeed main-is: Main.hs - ghc-options: -Wall + ghc-options: -Wall -Wcompat -- other-modules: -- other-extensions: @@ -37,5 +37,27 @@ executable logfeed , text , time - -- hs-source-dirs: + default-language: Haskell2010 + +executable mail2feed + main-is: Mail.hs + ghc-options: -Wall -Wcompat + build-depends: + base + , containers + , errors + , extra + , feed >=1.3.0.0 + , filepattern + , lens + , megaparsec + , notmuch + , purebred-email + , relude + , say + , string-interpolate + , text + , time + , optparse-applicative + default-language: Haskell2010 From 0229faa30d1797e0025dceced08b220b28718fcf Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sat, 12 Dec 2020 15:32:40 +0100 Subject: [PATCH 07/21] Update harness --- .envrc | 2 +- .gitignore | 1 + default.nix | 6 +++--- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/.envrc b/.envrc index 051d09d2..4a4726a5 100644 --- a/.envrc +++ b/.envrc @@ -1 +1 @@ -eval "$(lorri direnv)" +use_nix diff --git a/.gitignore b/.gitignore index 48a004cd..39dffb9e 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,2 @@ dist-newstyle +.direnv diff --git a/default.nix b/default.nix index 10dd82b0..7e168c83 100644 --- a/default.nix +++ b/default.nix @@ -1,10 +1,8 @@ -{ pkgs ? import { } }: - +{ pkgs ? import { } }: let haskellPackages = pkgs.haskellPackages; drv = haskellPackages.callCabal2nix "logfeed" ./. { }; in { - taskwarrior = drv; shell = haskellPackages.shellFor { withHoogle = true; packages = p: [ drv ]; @@ -14,6 +12,8 @@ in { brittany pkgs.coreutils pkgs.zlib + notmuch + hsemail ]; }; } From 785be7591474b7c0b535ef41a2240b30b0a430aa Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sat, 12 Dec 2020 17:45:43 +0100 Subject: [PATCH 08/21] Create real mailfeed --- Mail.hs | 160 +++++++++++++++++++++++++++++++++----------------------- 1 file changed, 96 insertions(+), 64 deletions(-) diff --git a/Mail.hs b/Mail.hs index 6483e2b4..bfd6c970 100644 --- a/Mail.hs +++ b/Mail.hs @@ -19,7 +19,9 @@ import Data.String.Interpolate import Data.MIME as MIME import Data.MIME.Charset import Control.Lens hiding ( argument ) -import Control.Error ( withExceptT ) +import Control.Error ( tryIO + , withExceptT + ) import qualified Data.Text as T import Control.Exception import Data.Time @@ -34,21 +36,28 @@ data Options = Options , folder :: String } -type Thread = Text +data Thread = Thread + { subject :: Text + , threadid :: ByteString + , count :: Int + , totalCount :: Int + , content :: Text + } type Error = Text -type MyMessage = (UTCTime, Text) +type MyMessage = Text main :: IO () main = do Options { dbPath, folder } <- execParser $ info - ( Options - <$> argument - str - (metavar "DBPATH" <> help "The full path to the notmuch database") - <*> argument - str - (metavar "FOLDER" <> help "The maildir to scan for messages.") - <**> helper) + ( Options + <$> argument + str + (metavar "DBPATH" <> help "The full path to the notmuch database") + <*> argument + str + (metavar "FOLDER" <> help "The maildir to scan for messages.") + <**> helper + ) fullDesc res <- runExceptT do (thrds, msgs) <- withExceptT @@ -66,16 +75,16 @@ main = do fst (msgsByThread <> thrdsByThread) now <- lift getCurrentTime - let entries = threadToEntry $ fst <$> rights result + let entries = threadToEntry now <$> rights result feed = nullFeed [i|mail-threads-#{timestamp now}|] (TextString "Read-Later-Mail") (timestamp now) - forM_ (rights result) (say . fst) - forM_ (rights result) (mapM_ sayErr . snd) - forM_ (lefts result) sayErr - - feedText <- hoistEither - . maybeToRight [i|Failed to generate feed.|] . textFeed $ feed { feedEntries = entries } + let errors = lefts result + feedText <- + hoistEither . maybeToRight [i|Failed to generate feed.|] . textFeed $ feed + { feedEntries = + (if null errors then id else (errorsToEntry now errors :)) entries + } say $ toStrict feedText either (\(er :: Text) -> @@ -84,11 +93,31 @@ main = do (const pass) res -threadToEntry :: [Thread] -> [Entry] -threadToEntry = error "not implemented" +threadToEntry :: UTCTime -> Thread -> Entry +threadToEntry now Thread { subject, content, threadid, count, totalCount } = + (nullEntry [i|thread-#{threadid}-#{timestamp now}|] + (TextString [i|#{subject} (#{count}/#{totalCount})|]) + (timestamp now) + ) + { entryContent = Just + . HTMLContent + . T.intercalate "
\n" + . T.splitOn "\n" + $ content + } -errorsToEntry :: [Error] -> Entry -errorsToEntry er = undefined +errorsToEntry :: UTCTime -> [Error] -> Entry +errorsToEntry now er = (nullEntry [i|mailerrors - #{timestamp now}|] + (TextString [i|Mail processing Errors|]) + (timestamp now) + ) + { entryContent = Just + . HTMLContent + . T.intercalate "
\n" + . T.splitOn "\n" + . T.intercalate "\n" + $ er + } timestamp :: UTCTime -> Text timestamp = toText . formatTime defaultTimeLocale "%Y-%m-%d %H:%M" @@ -96,68 +125,71 @@ timestamp = toText . formatTime defaultTimeLocale "%Y-%m-%d %H:%M" processThread :: (MonadIO m) => (ThreadId, NonEmpty (Either (Notmuch.Thread a) (Notmuch.Message n a))) - -> ExceptT Error m (Thread, [Error]) -processThread (thrdId, toList -> thrdAndMsgs) = do + -> ExceptT Error m Thread +processThread (threadid, toList -> thrdAndMsgs) = do thread <- hoistEither - . maybeToRight [i|No Thread object found for Threadid #{thrdId}|] + . maybeToRight [i|No Thread object found for Threadid #{threadid}|] . viaNonEmpty head . lefts $ thrdAndMsgs - subject <- threadSubject thread - msgCount <- threadTotalMessages thread - let - msgs = rights thrdAndMsgs - threadHeader = - [i|Showing #{length msgs} of #{msgCount} e-mails from thread\nSubject: #{subject}\n\n|] :: Text - results <- mapM (runExceptT . processMessage) msgs - let goodResults = snd <$> sortOn fst (rights results) - pure - ([i|#{threadHeader}\n#{T.intercalate "\n\n" goodResults}|], lefts results) + subject <- decodeUtf8 <$> threadSubject thread + totalCount <- threadTotalMessages thread + let msgs = rights thrdAndMsgs + results <- mapM processMessage msgs + let allMsgs = either id id . snd <$> sortOn fst results + content = T.intercalate [i|\n#{replicate 80 '-'}\n|] allMsgs + pure (Thread { subject, threadid, content, totalCount, count = length msgs }) processMessage - :: (MonadIO m) => Notmuch.Message n a -> ExceptT Error m MyMessage + :: MonadIO m => Notmuch.Message n a -> m (UTCTime, Either Error MyMessage) processMessage msg = do - fileName <- messageFilename msg - withExceptT - (\er -> [i|Failed to read msg #{fileName}\nerror: #{er}|]) + fileName <- messageFilename msg + date <- messageDate msg + subject <- tryHdr "subject" msg + fromField <- tryHdr "from" msg + toField <- tryHdr "to" msg + cc <- tryHdr "cc" msg + let hdrs = fold + [ "Subject" `hdr` subject + , "From" `hdr` fromField + , "To" `hdr` toField + , "Cc" `hdr` cc + , [i|Date: #{date}\n|] + ] + ((date, ) <$>) . runExceptT $ withExceptT + (\er -> [i|Failed to read msg\nFilename:#{fileName}\n#{hdrs}error: #{er}|]) do - date <- messageDate msg - subject <- - hoistEither - . maybeToRight [i|Failed to get subject|] - =<< messageHeader "subject" msg - fromField <- - hoistEither - . maybeToRight [i|Failed to get from|] - =<< messageHeader "from" msg - toField <- - hoistEither - . maybeToRight [i|Failed to get to|] - =<< messageHeader "to" msg - cc <- - hoistEither - . maybeToRight [i|Failed to get cc|] - =<< messageHeader "cc" msg - msgContent <- withExceptT (\(er :: IOException) -> [i|IOError: #{er}|]) + msgContent <- + withExceptT (\(er :: IOException) -> [i|IOError: #{er}|]) + . tryIO $ readFileBS fileName parseResult <- hoistEither . first toText $ parse (message mime) msgContent textPart <- - hoistEither . maybeToRight [i|No text part in message|] $ firstOf - (entities . filtered isTextPlain) - parseResult + hoistEither + . maybeToRight [i|No text or html part in message|] + $ firstOf + (entities . filtered isTextPlain <> entities . filtered isHtml) + parseResult textAsText <- hoistEither . maybeToRight [i|Could not decode message|] $ decode textPart - pure - ( date - , [i|Subject: #{subject}\nFrom: #{fromField}\nTo: #{toField}#{if cc /= "" then "\nCc: " <> cc else ""}\nDate: #{date}\n\n#{textAsText}|] - ) + pure [i|#{hdrs}\n#{textAsText}|] + +tryHdr :: MonadIO f => ByteString -> Notmuch.Message n a -> f ByteString +tryHdr h = fmap (fromMaybe "") . messageHeader h + +hdr :: Text -> ByteString -> Text +hdr _ "" = "" +hdr label content = [i|#{label}: #{content}\n|] isTextPlain :: WireEntity -> Bool isTextPlain = matchContentType "text" (Just "plain") . view contentType +isHtml :: WireEntity -> Bool +isHtml = matchContentType "text" (Just "html") . view contentType + decode :: WireEntity -> Maybe Text decode = preview (transferDecoded' . _Right . charsetText' defaultCharsets . _Right) From acfbbcc0144dab51f75409adfe24cadb2974c6fa Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sat, 12 Dec 2020 23:47:52 +0100 Subject: [PATCH 09/21] Rename to 2rss schema --- logfeed.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/logfeed.cabal b/logfeed.cabal index fae8695b..ccc7ebb2 100644 --- a/logfeed.cabal +++ b/logfeed.cabal @@ -19,7 +19,7 @@ maintainer: malte.brandy@maralorn.de build-type: Simple extra-source-files: CHANGELOG.md -executable logfeed +executable log2rss main-is: Main.hs ghc-options: -Wall -Wcompat @@ -39,7 +39,7 @@ executable logfeed default-language: Haskell2010 -executable mail2feed +executable mail2rss main-is: Mail.hs ghc-options: -Wall -Wcompat build-depends: From e4a99e4e49c09fb5d5e87c76453b43a2a9d367fb Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sun, 13 Dec 2020 17:54:12 +0100 Subject: [PATCH 10/21] Improve Mail-Feed a lot --- Mail.hs | 210 +++++++++++++++++++++++++++----------------------- logfeed.cabal | 1 + 2 files changed, 115 insertions(+), 96 deletions(-) diff --git a/Mail.hs b/Mail.hs index bfd6c970..633967f0 100644 --- a/Mail.hs +++ b/Mail.hs @@ -10,24 +10,28 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} + import Prelude ( ) import Relude -import Notmuch hiding ( Thread ) import qualified Notmuch import Say import Data.String.Interpolate -import Data.MIME as MIME +import qualified Data.MIME as MIME import Data.MIME.Charset import Control.Lens hiding ( argument ) -import Control.Error ( tryIO - , withExceptT +import Control.Error ( withExceptT + , throwE + , tryJust ) import qualified Data.Text as T -import Control.Exception +import Control.Monad.Catch ( MonadCatch + , handleIOError + ) import Data.Time import Relude.Extra.Group import qualified Data.Map as Map -import Options.Applicative +import qualified Options.Applicative as O import Text.Atom.Feed.Export ( textFeed ) import Text.Atom.Feed @@ -39,49 +43,59 @@ data Options = Options data Thread = Thread { subject :: Text , threadid :: ByteString - , count :: Int + , authors :: [Text] + , date :: UTCTime , totalCount :: Int - , content :: Text + , messages :: [Message] } type Error = Text -type MyMessage = Text + +data Body = HTMLBody Text | TextBody Text + +data Message = Message + { date :: UTCTime + , header :: [(Text, Text)] + , body :: Body + } main :: IO () main = do - Options { dbPath, folder } <- execParser $ info + Options { dbPath, folder } <- O.execParser $ O.info ( Options - <$> argument - str - (metavar "DBPATH" <> help "The full path to the notmuch database") - <*> argument - str - (metavar "FOLDER" <> help "The maildir to scan for messages.") - <**> helper + <$> O.argument + O.str + ( O.metavar "DBPATH" + <> O.help "The full path to the notmuch database" + ) + <*> O.argument + O.str + (O.metavar "FOLDER" <> O.help "The maildir to scan for messages.") + <**> O.helper ) - fullDesc + O.fullDesc res <- runExceptT do (thrds, msgs) <- withExceptT - (\(er :: Status) -> + (\(er :: Notmuch.Status) -> [i|Failed to read notmuch data.\ndb path: #{dbPath}\nquery: Folder #{folder}\nerror: #{er}|] ) do - db <- databaseOpenReadOnly dbPath - q <- query db (Folder folder) - (,) <$> threads q <*> messages q - msgsByThread <- forM msgs \msg -> threadId msg <&> (, Right msg) - thrdsByThread <- forM thrds \thrd -> threadId thrd <&> (, Left thrd) + db <- Notmuch.databaseOpenReadOnly dbPath + q <- Notmuch.query db (Notmuch.Folder folder) + (,) <$> Notmuch.threads q <*> Notmuch.messages q + msgsByThread <- forM msgs \msg -> Notmuch.threadId msg <&> (, Right msg) + thrdsByThread <- forM thrds \thrd -> Notmuch.threadId thrd <&> (, Left thrd) result <- mapM (runExceptT . processThread) . Map.toList $ fmap snd <$> groupBy fst (msgsByThread <> thrdsByThread) now <- lift getCurrentTime - let entries = threadToEntry now <$> rights result - feed = nullFeed [i|mail-threads-#{timestamp now}|] - (TextString "Read-Later-Mail") + let entries = threadToEntry <$> sortOn (date :: Thread -> UTCTime) (rights result) + feed = nullFeed [i|read-later-e-mails-#{timestamp now}|] + (TextString "Readlater-E-Mail") (timestamp now) - let errors = lefts result + errors = lefts result feedText <- - hoistEither . maybeToRight [i|Failed to generate feed.|] . textFeed $ feed + tryJust [i|Failed to generate feed.|] . textFeed $ feed { feedEntries = (if null errors then id else (errorsToEntry now errors :)) entries } @@ -93,18 +107,16 @@ main = do (const pass) res -threadToEntry :: UTCTime -> Thread -> Entry -threadToEntry now Thread { subject, content, threadid, count, totalCount } = - (nullEntry [i|thread-#{threadid}-#{timestamp now}|] - (TextString [i|#{subject} (#{count}/#{totalCount})|]) - (timestamp now) - ) - { entryContent = Just - . HTMLContent - . T.intercalate "
\n" - . T.splitOn "\n" - $ content +threadToEntry :: Thread -> Entry +threadToEntry Thread { subject, messages, threadid, totalCount, date, authors } = + (nullEntry threadUrl threadTitle (timestamp date)) + { entryContent = Just . HTMLContent $ content, + entryAuthors = (\x -> nullPerson { personName = x }) <$> authors } + where + threadUrl = [i|thread-#{threadid}-#{timestamp date}|] + threadTitle = TextString [i|#{subject} (#{length messages}/#{totalCount})|] + content = T.intercalate [i|
\n
\n|] (messageToHtml <$> messages) errorsToEntry :: UTCTime -> [Error] -> Entry errorsToEntry now er = (nullEntry [i|mailerrors - #{timestamp now}|] @@ -123,73 +135,79 @@ timestamp :: UTCTime -> Text timestamp = toText . formatTime defaultTimeLocale "%Y-%m-%d %H:%M" processThread - :: (MonadIO m) - => (ThreadId, NonEmpty (Either (Notmuch.Thread a) (Notmuch.Message n a))) + :: (MonadIO m, MonadCatch m) + => ( Notmuch.ThreadId + , NonEmpty (Either (Notmuch.Thread a) (Notmuch.Message n a)) + ) -> ExceptT Error m Thread -processThread (threadid, toList -> thrdAndMsgs) = do - thread <- - hoistEither - . maybeToRight [i|No Thread object found for Threadid #{threadid}|] - . viaNonEmpty head - . lefts - $ thrdAndMsgs - subject <- decodeUtf8 <$> threadSubject thread - totalCount <- threadTotalMessages thread - let msgs = rights thrdAndMsgs - results <- mapM processMessage msgs - let allMsgs = either id id . snd <$> sortOn fst results - content = T.intercalate [i|\n#{replicate 80 '-'}\n|] allMsgs - pure (Thread { subject, threadid, content, totalCount, count = length msgs }) +processThread (threadid, toList -> thrdAndMsgs) = + handleIOError (\er -> throwE [i|IOError: #{er}|]) $ do + thread <- + tryJust [i|No Thread object found for Threadid #{threadid}|] + . viaNonEmpty head + . lefts + $ thrdAndMsgs + let msgs = rights thrdAndMsgs + results <- mapM processMessage msgs + let messages = sortOn (date :: Message -> UTCTime) results + subject <- decodeUtf8 <$> Notmuch.threadSubject thread + totalCount <- Notmuch.threadTotalMessages thread + authors <- (^. Notmuch.matchedAuthors) <$> Notmuch.threadAuthors thread + date <- Notmuch.threadNewestDate thread + pure (Thread { subject, threadid, messages, totalCount, authors, date }) -processMessage - :: MonadIO m => Notmuch.Message n a -> m (UTCTime, Either Error MyMessage) + +messageToHtml :: Message -> Text +messageToHtml Message { header, body } = T.intercalate "
\n" $ ((\(name, content) -> [i|#{name}: #{content}|]) <$> header) <> ["
\n", bodyToHtml body] + +bodyToHtml :: Body -> Text +bodyToHtml (HTMLBody x) = x +bodyToHtml (TextBody x) = T.intercalate "
\n" . T.splitOn "\n" $ x + +processMessage :: (MonadIO m, MonadCatch m) => Notmuch.Message n a -> m Message processMessage msg = do - fileName <- messageFilename msg - date <- messageDate msg + fileName <- Notmuch.messageFilename msg + date <- Notmuch.messageDate msg subject <- tryHdr "subject" msg fromField <- tryHdr "from" msg toField <- tryHdr "to" msg cc <- tryHdr "cc" msg - let hdrs = fold - [ "Subject" `hdr` subject - , "From" `hdr` fromField - , "To" `hdr` toField - , "Cc" `hdr` cc - , [i|Date: #{date}\n|] + let hdrs = mapMaybe + (\(x, a) -> (x, ) <$> a) + [ ("Subject", subject) + , ("From" , fromField) + , ("To" , toField) + , ("Cc" , cc) + , ("Date" , Just (timestamp date)) ] - ((date, ) <$>) . runExceptT $ withExceptT - (\er -> [i|Failed to read msg\nFilename:#{fileName}\n#{hdrs}error: #{er}|]) + msgEither <- runExceptT $ withExceptT + (\er -> [i|Failed to read msg\nFilename:#{fileName}\nerror: #{er}|]) do - msgContent <- - withExceptT (\(er :: IOException) -> [i|IOError: #{er}|]) - . tryIO + msgContent <- handleIOError (\er -> throwE [i|IOError: #{er}|]) $ readFileBS fileName - parseResult <- hoistEither . first toText $ parse (message mime) - msgContent - textPart <- - hoistEither - . maybeToRight [i|No text or html part in message|] - $ firstOf - (entities . filtered isTextPlain <> entities . filtered isHtml) - parseResult - textAsText <- - hoistEither . maybeToRight [i|Could not decode message|] $ decode - textPart - pure [i|#{hdrs}\n#{textAsText}|] + parseResult <- hoistEither . first toText $ MIME.parse + (MIME.message MIME.mime) + msgContent + textPart <- tryJust [i|No text or html part in message|] $ firstOf + (MIME.entities . filtered isHtml <> MIME.entities . filtered isTextPlain + ) + parseResult + (if isHtml textPart then HTMLBody else TextBody) + <$> tryJust [i|Could not decode message|] (decode textPart) + pure $ Message { date, header = hdrs, body = either TextBody id msgEither } -tryHdr :: MonadIO f => ByteString -> Notmuch.Message n a -> f ByteString -tryHdr h = fmap (fromMaybe "") . messageHeader h +tryHdr :: MonadIO m => ByteString -> Notmuch.Message n a -> m (Maybe Text) +tryHdr h msg = + ((\x -> if x /= "" then Just x else Nothing) . decodeUtf8 =<<) + <$> Notmuch.messageHeader h msg -hdr :: Text -> ByteString -> Text -hdr _ "" = "" -hdr label content = [i|#{label}: #{content}\n|] +isTextPlain :: MIME.WireEntity -> Bool +isTextPlain = + MIME.matchContentType "text" (Just "plain") . view MIME.contentType -isTextPlain :: WireEntity -> Bool -isTextPlain = matchContentType "text" (Just "plain") . view contentType +isHtml :: MIME.WireEntity -> Bool +isHtml = MIME.matchContentType "text" (Just "html") . view MIME.contentType -isHtml :: WireEntity -> Bool -isHtml = matchContentType "text" (Just "html") . view contentType - -decode :: WireEntity -> Maybe Text -decode = - preview (transferDecoded' . _Right . charsetText' defaultCharsets . _Right) +decode :: MIME.WireEntity -> Maybe Text +decode = preview + (MIME.transferDecoded' . _Right . charsetText' defaultCharsets . _Right) diff --git a/logfeed.cabal b/logfeed.cabal index ccc7ebb2..9f18e495 100644 --- a/logfeed.cabal +++ b/logfeed.cabal @@ -59,5 +59,6 @@ executable mail2rss , text , time , optparse-applicative + , exceptions default-language: Haskell2010 From 5de2118aeb0eb4be09a2a825d052a705378d9cc8 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sun, 13 Dec 2020 19:43:09 +0100 Subject: [PATCH 11/21] Improve html body handling --- Mail.hs | 49 +++++++++++++++++++++++++++---------------------- logfeed.cabal | 1 + 2 files changed, 28 insertions(+), 22 deletions(-) diff --git a/Mail.hs b/Mail.hs index 633967f0..111cfb38 100644 --- a/Mail.hs +++ b/Mail.hs @@ -34,6 +34,7 @@ import qualified Data.Map as Map import qualified Options.Applicative as O import Text.Atom.Feed.Export ( textFeed ) import Text.Atom.Feed +import Text.HTML.TagSoup data Options = Options { dbPath :: String @@ -53,9 +54,9 @@ type Error = Text data Body = HTMLBody Text | TextBody Text data Message = Message - { date :: UTCTime - , header :: [(Text, Text)] - , body :: Body + { date :: UTCTime + , headers :: [(Text, Text)] + , body :: Body } main :: IO () @@ -89,16 +90,16 @@ main = do fst (msgsByThread <> thrdsByThread) now <- lift getCurrentTime - let entries = threadToEntry <$> sortOn (date :: Thread -> UTCTime) (rights result) - feed = nullFeed [i|read-later-e-mails-#{timestamp now}|] - (TextString "Readlater-E-Mail") - (timestamp now) + let entries = + threadToEntry <$> sortOn (date :: Thread -> UTCTime) (rights result) + feed = nullFeed [i|read-later-e-mails-#{timestamp now}|] + (TextString "Readlater-E-Mail") + (timestamp now) errors = lefts result - feedText <- - tryJust [i|Failed to generate feed.|] . textFeed $ feed - { feedEntries = - (if null errors then id else (errorsToEntry now errors :)) entries - } + feedText <- tryJust [i|Failed to generate feed.|] . textFeed $ feed + { feedEntries = (if null errors then id else (errorsToEntry now errors :)) + entries + } say $ toStrict feedText either (\(er :: Text) -> @@ -108,13 +109,13 @@ main = do res threadToEntry :: Thread -> Entry -threadToEntry Thread { subject, messages, threadid, totalCount, date, authors } = - (nullEntry threadUrl threadTitle (timestamp date)) - { entryContent = Just . HTMLContent $ content, - entryAuthors = (\x -> nullPerson { personName = x }) <$> authors +threadToEntry Thread { subject, messages, threadid, totalCount, date, authors } + = (nullEntry threadUrl threadTitle (timestamp date)) + { entryContent = Just . HTMLContent $ content + , entryAuthors = (\x -> nullPerson { personName = x }) <$> authors } where - threadUrl = [i|thread-#{threadid}-#{timestamp date}|] + threadUrl = [i|thread-#{threadid}-#{timestamp date}|] threadTitle = TextString [i|#{subject} (#{length messages}/#{totalCount})|] content = T.intercalate [i|
\n
\n|] (messageToHtml <$> messages) @@ -152,16 +153,20 @@ processThread (threadid, toList -> thrdAndMsgs) = let messages = sortOn (date :: Message -> UTCTime) results subject <- decodeUtf8 <$> Notmuch.threadSubject thread totalCount <- Notmuch.threadTotalMessages thread - authors <- (^. Notmuch.matchedAuthors) <$> Notmuch.threadAuthors thread - date <- Notmuch.threadNewestDate thread + authors <- (^. Notmuch.matchedAuthors) <$> Notmuch.threadAuthors thread + date <- Notmuch.threadNewestDate thread pure (Thread { subject, threadid, messages, totalCount, authors, date }) messageToHtml :: Message -> Text -messageToHtml Message { header, body } = T.intercalate "
\n" $ ((\(name, content) -> [i|#{name}: #{content}|]) <$> header) <> ["
\n", bodyToHtml body] +messageToHtml Message { headers, body } = + T.intercalate "
\n" + $ ((\(name, content) -> [i|#{name}: #{content}|]) <$> headers) + <> one (bodyToHtml body) bodyToHtml :: Body -> Text -bodyToHtml (HTMLBody x) = x +bodyToHtml (HTMLBody x) = fromMaybe x onlyBody + where onlyBody = renderTags . takeWhile (not . isTagCloseName "body") <$> (viaNonEmpty tail . dropWhile (not . isTagOpenName "body") . parseTags $ x) bodyToHtml (TextBody x) = T.intercalate "
\n" . T.splitOn "\n" $ x processMessage :: (MonadIO m, MonadCatch m) => Notmuch.Message n a -> m Message @@ -194,7 +199,7 @@ processMessage msg = do parseResult (if isHtml textPart then HTMLBody else TextBody) <$> tryJust [i|Could not decode message|] (decode textPart) - pure $ Message { date, header = hdrs, body = either TextBody id msgEither } + pure $ Message { date, headers = hdrs, body = either TextBody id msgEither } tryHdr :: MonadIO m => ByteString -> Notmuch.Message n a -> m (Maybe Text) tryHdr h msg = diff --git a/logfeed.cabal b/logfeed.cabal index 9f18e495..6a7c5435 100644 --- a/logfeed.cabal +++ b/logfeed.cabal @@ -60,5 +60,6 @@ executable mail2rss , time , optparse-applicative , exceptions + , tagsoup default-language: Haskell2010 From ba0a7b29aa87de42caa2ad41dcc40b2711be50a4 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Fri, 15 Jan 2021 23:48:47 +0100 Subject: [PATCH 12/21] Improve Markup --- Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Main.hs b/Main.hs index f27aa4e8..d3e5e660 100644 --- a/Main.hs +++ b/Main.hs @@ -205,11 +205,11 @@ printHTML log = (printRow <$> zip (WeechatLine "" "" "" "" :| toList ls) ls) printRow :: (WeechatLine, WeechatLine) -> Text printRow (prevRow, curRow) = - "" + "" <> time - <> " " + <> " " <> printNick - <> " " + <> " " <> message <> "
" where From 485fbc19ca6aa02ec15e03bd6cab03cda25d8aae Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sat, 16 Jan 2021 00:05:41 +0100 Subject: [PATCH 13/21] Add build target --- Main.hs | 4 ++-- default.nix | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Main.hs b/Main.hs index d3e5e660..e5fed749 100644 --- a/Main.hs +++ b/Main.hs @@ -207,9 +207,9 @@ printHTML log = printRow (prevRow, curRow) = "" <> time - <> " " + <> " " <> printNick - <> " " + <> " " <> message <> "
" where diff --git a/default.nix b/default.nix index 7e168c83..32792be9 100644 --- a/default.nix +++ b/default.nix @@ -16,4 +16,5 @@ in { hsemail ]; }; + pkg = drv; } From 11b8e259edb31efb6e8dfff8675e879c5a855ec0 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sat, 16 Jan 2021 00:10:53 +0100 Subject: [PATCH 14/21] Remove unnecessary shenanigans --- Main.hs | 50 +++++++++++++++----------------------------------- 1 file changed, 15 insertions(+), 35 deletions(-) diff --git a/Main.hs b/Main.hs index e5fed749..6601dbdf 100644 --- a/Main.hs +++ b/Main.hs @@ -1,29 +1,29 @@ {-# LANGUAGE ViewPatterns, ScopedTypeVariables, NamedFieldPuns, OverloadedStrings, NoImplicitPrelude, ExtendedDefaultRules, QuasiQuotes, MultiWayIf #-} module Main where -import Data.String.Interpolate ( i ) -import Relude hiding ( intercalate - , zip - ) -import Data.Text ( intercalate - , replace - ) -import Text.Atom.Feed.Export ( textFeed ) -import qualified Data.Text as Text +import qualified Data.List.Extra as L import Data.List.NonEmpty ( groupBy , zip ) -import Text.Atom.Feed +import Data.String.Interpolate ( i ) +import Data.Text ( intercalate + , replace + ) +import qualified Data.Text as Text import qualified Data.Time.Calendar as T import qualified Data.Time.Clock as T import qualified Data.Time.Format as T +import Relude hiding ( intercalate + , zip + ) +import System.Environment ( getArgs ) +import System.FilePattern.Directory ( getDirectoryFiles ) +import Text.Atom.Feed +import Text.Atom.Feed.Export ( textFeed ) import qualified Text.Megaparsec as MP import qualified Text.Megaparsec.Char as MP import qualified Text.Megaparsec.Char as MPC import qualified Text.Megaparsec.Char.Lexer as MP -import System.FilePattern.Directory ( getDirectoryFiles ) -import qualified Data.List.Extra as L -import System.Environment ( getArgs ) -- TODO: use Text instead of linked lists of chars type WeechatLog = [WeechatLine] @@ -36,16 +36,6 @@ data WeechatLine = WeechatLine deriving (Show, Eq, Ord) -- TODO: specific handling of join/part/network messages -header :: Text -header = unlines - [ "" - , "" - , " " - , " " - , " IRC log" - , " " - ] - data LogFile = LogFile { path :: Text , server :: Text @@ -193,11 +183,7 @@ parseWeechatLog = filter actualMessage . mapMaybe parseLine . lines parseLine = MP.parseMaybe parseWeechatLine printHTML :: [WeechatLine] -> Text -printHTML log = - intercalate "\n" - $ [header, ""] - ++ map printDay days - ++ ["", ""] +printHTML log = intercalate "\n" $ map printDay days where days = groupBy ((==) `on` wlDate) log printDay ls = @@ -205,13 +191,7 @@ printHTML log = (printRow <$> zip (WeechatLine "" "" "" "" :| toList ls) ls) printRow :: (WeechatLine, WeechatLine) -> Text printRow (prevRow, curRow) = - "" - <> time - <> " " - <> printNick - <> " " - <> message - <> "
" + "" <> time <> " " <> printNick <> " " <> message <> "
" where prevTime = Text.take 5 $ wlTime prevRow curTime = Text.take 5 $ wlTime curRow From efb3e962f7ce7e685e72bc67d9835e501c047e2a Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sat, 16 Jan 2021 00:16:18 +0100 Subject: [PATCH 15/21] Pin a nixpkgs --- default.nix | 2 +- nix/sources.json | 26 +++++++ nix/sources.nix | 174 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 201 insertions(+), 1 deletion(-) create mode 100644 nix/sources.json create mode 100644 nix/sources.nix diff --git a/default.nix b/default.nix index 32792be9..3a9f414d 100644 --- a/default.nix +++ b/default.nix @@ -1,4 +1,4 @@ -{ pkgs ? import { } }: +{ pkgs ? import (import nix/sources.nix).nixpkgs { } }: let haskellPackages = pkgs.haskellPackages; drv = haskellPackages.callCabal2nix "logfeed" ./. { }; diff --git a/nix/sources.json b/nix/sources.json new file mode 100644 index 00000000..629830c3 --- /dev/null +++ b/nix/sources.json @@ -0,0 +1,26 @@ +{ + "niv": { + "branch": "master", + "description": "Easy dependency management for Nix projects", + "homepage": "https://github.com/nmattia/niv", + "owner": "nmattia", + "repo": "niv", + "rev": "3cd7914b2c4cff48927e11c216dadfab7d903fe5", + "sha256": "1agq4nvbhrylf2s77kb4xhh9k7xcwdwggq764k4jgsbs70py8cw3", + "type": "tarball", + "url": "https://github.com/nmattia/niv/archive/3cd7914b2c4cff48927e11c216dadfab7d903fe5.tar.gz", + "url_template": "https://github.com///archive/.tar.gz" + }, + "nixpkgs": { + "branch": "nixos-unstable", + "description": "Nix Packages collection", + "homepage": "", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "257cbbcd3ab7bd96f5d24d50adc807de7c82e06d", + "sha256": "0g3n725kjk2fc9yn9rvdjwci4mrx58yrdgp3waby9ky3d5xhcaw4", + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/257cbbcd3ab7bd96f5d24d50adc807de7c82e06d.tar.gz", + "url_template": "https://github.com///archive/.tar.gz" + } +} diff --git a/nix/sources.nix b/nix/sources.nix new file mode 100644 index 00000000..1938409d --- /dev/null +++ b/nix/sources.nix @@ -0,0 +1,174 @@ +# This file has been generated by Niv. + +let + + # + # The fetchers. fetch_ fetches specs of type . + # + + fetch_file = pkgs: name: spec: + let + name' = sanitizeName name + "-src"; + in + if spec.builtin or true then + builtins_fetchurl { inherit (spec) url sha256; name = name'; } + else + pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; + + fetch_tarball = pkgs: name: spec: + let + name' = sanitizeName name + "-src"; + in + if spec.builtin or true then + builtins_fetchTarball { name = name'; inherit (spec) url sha256; } + else + pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; + + fetch_git = name: spec: + let + ref = + if spec ? ref then spec.ref else + if spec ? branch then "refs/heads/${spec.branch}" else + if spec ? tag then "refs/tags/${spec.tag}" else + abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; + in + builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; + + fetch_local = spec: spec.path; + + fetch_builtin-tarball = name: throw + ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=tarball -a builtin=true''; + + fetch_builtin-url = name: throw + ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=file -a builtin=true''; + + # + # Various helpers + # + + # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 + sanitizeName = name: + ( + concatMapStrings (s: if builtins.isList s then "-" else s) + ( + builtins.split "[^[:alnum:]+._?=-]+" + ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) + ) + ); + + # The set of packages used when specs are fetched using non-builtins. + mkPkgs = sources: system: + let + sourcesNixpkgs = + import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; + hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; + hasThisAsNixpkgsPath = == ./.; + in + if builtins.hasAttr "nixpkgs" sources + then sourcesNixpkgs + else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then + import {} + else + abort + '' + Please specify either (through -I or NIX_PATH=nixpkgs=...) or + add a package called "nixpkgs" to your sources.json. + ''; + + # The actual fetching function. + fetch = pkgs: name: spec: + + if ! builtins.hasAttr "type" spec then + abort "ERROR: niv spec ${name} does not have a 'type' attribute" + else if spec.type == "file" then fetch_file pkgs name spec + else if spec.type == "tarball" then fetch_tarball pkgs name spec + else if spec.type == "git" then fetch_git name spec + else if spec.type == "local" then fetch_local spec + else if spec.type == "builtin-tarball" then fetch_builtin-tarball name + else if spec.type == "builtin-url" then fetch_builtin-url name + else + abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; + + # If the environment variable NIV_OVERRIDE_${name} is set, then use + # the path directly as opposed to the fetched source. + replace = name: drv: + let + saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; + ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; + in + if ersatz == "" then drv else + # this turns the string into an actual Nix path (for both absolute and + # relative paths) + if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; + + # Ports of functions for older nix versions + + # a Nix version of mapAttrs if the built-in doesn't exist + mapAttrs = builtins.mapAttrs or ( + f: set: with builtins; + listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) + ); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 + range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 + stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 + stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); + concatMapStrings = f: list: concatStrings (map f list); + concatStrings = builtins.concatStringsSep ""; + + # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 + optionalAttrs = cond: as: if cond then as else {}; + + # fetchTarball version that is compatible between all the versions of Nix + builtins_fetchTarball = { url, name ? null, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchTarball; + in + if lessThan nixVersion "1.12" then + fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) + else + fetchTarball attrs; + + # fetchurl version that is compatible between all the versions of Nix + builtins_fetchurl = { url, name ? null, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchurl; + in + if lessThan nixVersion "1.12" then + fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) + else + fetchurl attrs; + + # Create the final "sources" from the config + mkSources = config: + mapAttrs ( + name: spec: + if builtins.hasAttr "outPath" spec + then abort + "The values in sources.json should not have an 'outPath' attribute" + else + spec // { outPath = replace name (fetch config.pkgs name spec); } + ) config.sources; + + # The "config" used by the fetchers + mkConfig = + { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null + , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) + , system ? builtins.currentSystem + , pkgs ? mkPkgs sources system + }: rec { + # The sources, i.e. the attribute set of spec name to spec + inherit sources; + + # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers + inherit pkgs; + }; + +in +mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } From 546d9afefb5c98c43dac572b94bef24b44dac6b5 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Sun, 13 Jun 2021 01:55:42 +0200 Subject: [PATCH 16/21] Improve nix setup --- .gitignore | 3 ++- default.nix | 22 ++-------------------- shell.nix | 13 ++++++++++++- 3 files changed, 16 insertions(+), 22 deletions(-) diff --git a/.gitignore b/.gitignore index 39dffb9e..121be88f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ -dist-newstyle +/dist-newstyle +/result .direnv diff --git a/default.nix b/default.nix index 3a9f414d..cad05055 100644 --- a/default.nix +++ b/default.nix @@ -1,20 +1,2 @@ -{ pkgs ? import (import nix/sources.nix).nixpkgs { } }: -let - haskellPackages = pkgs.haskellPackages; - drv = haskellPackages.callCabal2nix "logfeed" ./. { }; -in { - shell = haskellPackages.shellFor { - withHoogle = true; - packages = p: [ drv ]; - buildInputs = with haskellPackages; [ - hlint - cabal-install - brittany - pkgs.coreutils - pkgs.zlib - notmuch - hsemail - ]; - }; - pkg = drv; -} +{ pkgs ? import (import nix/sources.nix).nixpkgs {} }: +pkgs.haskellPackages.callCabal2nix "logfeed" ./. {} diff --git a/shell.nix b/shell.nix index a6bdf202..72306cfe 100644 --- a/shell.nix +++ b/shell.nix @@ -1 +1,12 @@ -(import ./. { }).shell +{ pkgs ? import (import nix/sources.nix).nixpkgs {} }: +let + inherit (pkgs) haskellPackages; +in +haskellPackages.shellFor { + withHoogle = true; + packages = p: [ (import ./. { inherit pkgs; }) ]; + buildInputs = builtins.attrValues { + inherit (haskellPackages) hlint cabal-install notmuch hsemail; + inherit (pkgs) coreutils zlib; + }; +} From a614b41ea0bdc5c1c17e84ad5c2d0bc70a0b5773 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Tue, 6 Jul 2021 03:19:02 +0200 Subject: [PATCH 17/21] Bump nixpkgs --- nix/sources.json | 18 +++--------------- 1 file changed, 3 insertions(+), 15 deletions(-) diff --git a/nix/sources.json b/nix/sources.json index 629830c3..eea3facd 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -1,26 +1,14 @@ { - "niv": { - "branch": "master", - "description": "Easy dependency management for Nix projects", - "homepage": "https://github.com/nmattia/niv", - "owner": "nmattia", - "repo": "niv", - "rev": "3cd7914b2c4cff48927e11c216dadfab7d903fe5", - "sha256": "1agq4nvbhrylf2s77kb4xhh9k7xcwdwggq764k4jgsbs70py8cw3", - "type": "tarball", - "url": "https://github.com/nmattia/niv/archive/3cd7914b2c4cff48927e11c216dadfab7d903fe5.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, "nixpkgs": { "branch": "nixos-unstable", "description": "Nix Packages collection", "homepage": "", "owner": "NixOS", "repo": "nixpkgs", - "rev": "257cbbcd3ab7bd96f5d24d50adc807de7c82e06d", - "sha256": "0g3n725kjk2fc9yn9rvdjwci4mrx58yrdgp3waby9ky3d5xhcaw4", + "rev": "20887e4bbfdae3aed6bfa1f53ddf138ee325515e", + "sha256": "0hc79sv59appb7bynz5bzyqvrapyjdq63s79i649vxl93504kmnv", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/257cbbcd3ab7bd96f5d24d50adc807de7c82e06d.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/20887e4bbfdae3aed6bfa1f53ddf138ee325515e.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } From ce50c4dc682343a64198dfa75bc688b5e860e2e7 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Tue, 6 Jul 2021 03:20:37 +0200 Subject: [PATCH 18/21] Show Unsubscribe header --- Mail.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Mail.hs b/Mail.hs index 111cfb38..699c89d8 100644 --- a/Mail.hs +++ b/Mail.hs @@ -177,6 +177,7 @@ processMessage msg = do fromField <- tryHdr "from" msg toField <- tryHdr "to" msg cc <- tryHdr "cc" msg + unsub <- tryHdr "list-unsubscribe" msg let hdrs = mapMaybe (\(x, a) -> (x, ) <$> a) [ ("Subject", subject) @@ -184,6 +185,7 @@ processMessage msg = do , ("To" , toField) , ("Cc" , cc) , ("Date" , Just (timestamp date)) + , ("Unsubscribe" , unsub) ] msgEither <- runExceptT $ withExceptT (\er -> [i|Failed to read msg\nFilename:#{fileName}\nerror: #{er}|]) From e232c0b64ee2bb8baf87d3e541948f8c40dc2f29 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Tue, 6 Jul 2021 03:21:02 +0200 Subject: [PATCH 19/21] Show more error messages when decoding fails --- Mail.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Mail.hs b/Mail.hs index 699c89d8..395c9262 100644 --- a/Mail.hs +++ b/Mail.hs @@ -22,7 +22,7 @@ import Data.MIME.Charset import Control.Lens hiding ( argument ) import Control.Error ( withExceptT , throwE - , tryJust + , tryJust, tryRight ) import qualified Data.Text as T import Control.Monad.Catch ( MonadCatch @@ -35,6 +35,7 @@ import qualified Options.Applicative as O import Text.Atom.Feed.Export ( textFeed ) import Text.Atom.Feed import Text.HTML.TagSoup +import Data.Either.Extra (mapLeft) data Options = Options { dbPath :: String @@ -200,7 +201,7 @@ processMessage msg = do ) parseResult (if isHtml textPart then HTMLBody else TextBody) - <$> tryJust [i|Could not decode message|] (decode textPart) + <$> tryRight (mapLeft ("Could not decode message "<> ) $ decode textPart) pure $ Message { date, headers = hdrs, body = either TextBody id msgEither } tryHdr :: MonadIO m => ByteString -> Notmuch.Message n a -> m (Maybe Text) @@ -215,6 +216,5 @@ isTextPlain = isHtml :: MIME.WireEntity -> Bool isHtml = MIME.matchContentType "text" (Just "html") . view MIME.contentType -decode :: MIME.WireEntity -> Maybe Text -decode = preview - (MIME.transferDecoded' . _Right . charsetText' defaultCharsets . _Right) +decode :: MIME.WireEntity -> Either Text Text +decode = mapLeft show . view MIME.transferDecoded' >=> mapLeft show . view (charsetText' defaultCharsets) From 5efd50132edb72365d30347092371ab11d9355dd Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Thu, 2 Jun 2022 01:48:00 +0200 Subject: [PATCH 20/21] bump nixpkgs version --- Main.hs | 5 ++--- default.nix | 3 ++- nix/sources.json | 6 +++--- nix/sources.nix | 22 +++++++++++++++++++++- 4 files changed, 28 insertions(+), 8 deletions(-) diff --git a/Main.hs b/Main.hs index 6601dbdf..96c18fe0 100644 --- a/Main.hs +++ b/Main.hs @@ -16,7 +16,7 @@ import qualified Data.Time.Format as T import Relude hiding ( intercalate , zip ) -import System.Environment ( getArgs ) +import System.Environment () import System.FilePattern.Directory ( getDirectoryFiles ) import Text.Atom.Feed import Text.Atom.Feed.Export ( textFeed ) @@ -101,8 +101,7 @@ logFolder = "/home/maralorn/logs/" main :: IO () main = do now <- T.getCurrentTime - let getFiles = \t p -> - L.groupSortOn (\x -> (channel x, server x)) + let getFiles t p = L.groupSortOn (\x -> (channel x, server x)) . mapMaybe ((\x -> MP.parseMaybe (p x) x) . toText) <$> getDirectoryFiles (toString logFolder) diff --git a/default.nix b/default.nix index cad05055..7ebbb4d9 100644 --- a/default.nix +++ b/default.nix @@ -1,2 +1,3 @@ { pkgs ? import (import nix/sources.nix).nixpkgs {} }: -pkgs.haskellPackages.callCabal2nix "logfeed" ./. {} +with pkgs; with haskell.lib; with haskellPackages; +callCabal2nix "logfeed" ./. { purebred-email = doJailbreak (unmarkBroken (dontCheck purebred-email)); } diff --git a/nix/sources.json b/nix/sources.json index eea3facd..eadbed21 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -5,10 +5,10 @@ "homepage": "", "owner": "NixOS", "repo": "nixpkgs", - "rev": "20887e4bbfdae3aed6bfa1f53ddf138ee325515e", - "sha256": "0hc79sv59appb7bynz5bzyqvrapyjdq63s79i649vxl93504kmnv", + "rev": "f1c167688a6f81f4a51ab542e5f476c8c595e457", + "sha256": "00ac3axj7jdfcajj3macdydf9w9bvqqvgrqkh1xxr3rfi9q2fz1v", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/20887e4bbfdae3aed6bfa1f53ddf138ee325515e.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/f1c167688a6f81f4a51ab542e5f476c8c595e457.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } diff --git a/nix/sources.nix b/nix/sources.nix index 1938409d..9a01c8ac 100644 --- a/nix/sources.nix +++ b/nix/sources.nix @@ -31,8 +31,28 @@ let if spec ? branch then "refs/heads/${spec.branch}" else if spec ? tag then "refs/tags/${spec.tag}" else abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; + submodules = if spec ? submodules then spec.submodules else false; + submoduleArg = + let + nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0; + emptyArgWithWarning = + if submodules == true + then + builtins.trace + ( + "The niv input \"${name}\" uses submodules " + + "but your nix's (${builtins.nixVersion}) builtins.fetchGit " + + "does not support them" + ) + {} + else {}; + in + if nixSupportsSubmodules + then { inherit submodules; } + else emptyArgWithWarning; in - builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; + builtins.fetchGit + ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg); fetch_local = spec: spec.path; From c27a8703ff784c05f9841f0853126bf7d558b471 Mon Sep 17 00:00:00 2001 From: maralorn Date: Mon, 16 Jan 2023 00:38:41 +0100 Subject: [PATCH 21/21] Move files to subdir --- .envrc | 1 - CHANGELOG.md | 5 ----- LICENSE | 0 .gitignore => apps/logfeed/.gitignore | 0 Mail.hs => apps/logfeed/Mail.hs | 0 Main.hs => apps/logfeed/Main.hs | 0 default.nix => apps/logfeed/default.nix | 0 logfeed.cabal => apps/logfeed/logfeed.cabal | 0 {nix => apps/logfeed/nix}/sources.json | 0 {nix => apps/logfeed/nix}/sources.nix | 0 shell.nix => apps/logfeed/shell.nix | 0 11 files changed, 6 deletions(-) delete mode 100644 .envrc delete mode 100644 CHANGELOG.md delete mode 100644 LICENSE rename .gitignore => apps/logfeed/.gitignore (100%) rename Mail.hs => apps/logfeed/Mail.hs (100%) rename Main.hs => apps/logfeed/Main.hs (100%) rename default.nix => apps/logfeed/default.nix (100%) rename logfeed.cabal => apps/logfeed/logfeed.cabal (100%) rename {nix => apps/logfeed/nix}/sources.json (100%) rename {nix => apps/logfeed/nix}/sources.nix (100%) rename shell.nix => apps/logfeed/shell.nix (100%) diff --git a/.envrc b/.envrc deleted file mode 100644 index 4a4726a5..00000000 --- a/.envrc +++ /dev/null @@ -1 +0,0 @@ -use_nix diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 index b79f4b19..00000000 --- a/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for logfeed - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE deleted file mode 100644 index e69de29b..00000000 diff --git a/.gitignore b/apps/logfeed/.gitignore similarity index 100% rename from .gitignore rename to apps/logfeed/.gitignore diff --git a/Mail.hs b/apps/logfeed/Mail.hs similarity index 100% rename from Mail.hs rename to apps/logfeed/Mail.hs diff --git a/Main.hs b/apps/logfeed/Main.hs similarity index 100% rename from Main.hs rename to apps/logfeed/Main.hs diff --git a/default.nix b/apps/logfeed/default.nix similarity index 100% rename from default.nix rename to apps/logfeed/default.nix diff --git a/logfeed.cabal b/apps/logfeed/logfeed.cabal similarity index 100% rename from logfeed.cabal rename to apps/logfeed/logfeed.cabal diff --git a/nix/sources.json b/apps/logfeed/nix/sources.json similarity index 100% rename from nix/sources.json rename to apps/logfeed/nix/sources.json diff --git a/nix/sources.nix b/apps/logfeed/nix/sources.nix similarity index 100% rename from nix/sources.nix rename to apps/logfeed/nix/sources.nix diff --git a/shell.nix b/apps/logfeed/shell.nix similarity index 100% rename from shell.nix rename to apps/logfeed/shell.nix