From 0108f1ee7f55df4ef4ba2f0e3954ae744a75918b Mon Sep 17 00:00:00 2001 From: maralorn Date: Mon, 16 Jan 2023 02:18:18 +0100 Subject: [PATCH] Formatting --- .hlint.yaml | 5 + apps/kassandra/backend/src/Backend.hs | 10 +- apps/kassandra/default.nix | 304 ++++++++++-------- apps/kassandra/frontend/src/Frontend.hs | 5 +- apps/kassandra/frontend/src/Frontend/Route.hs | 4 +- .../kassandra/src/Kassandra/Config.hs | 34 +- apps/kassandra/kassandra/src/Kassandra/Css.hs | 34 +- .../kassandra/src/Kassandra/Debug.hs | 9 +- .../kassandra/src/Kassandra/MainWidget.hs | 23 +- .../kassandra/src/Kassandra/ReflexUtil.hs | 48 +-- .../src/Kassandra/RemoteBackendWidget.hs | 6 +- .../kassandra/src/Kassandra/Sorting.hs | 28 +- .../kassandra/src/Kassandra/TaskWidget.hs | 27 +- apps/kassandra/kassandra/src/Prelude.hs | 19 +- apps/kassandra/obelisk-shell.nix | 2 +- apps/kassandra/release.nix | 14 +- .../src/Kassandra/Backend/Calendar.hs | 19 +- .../src/Kassandra/Standalone/Config.hs | 9 +- apps/logfeed/Mail.hs | 287 +++++++++-------- apps/logfeed/Main.hs | 173 +++++----- apps/logfeed/default.nix | 8 +- apps/logfeed/shell.nix | 19 +- apps/nixpkgs-bot/exe/Main.hs | 72 +++-- .../nixpkgs-bot/lib/NixpkgsBot/GraphQL/API.hs | 4 +- 24 files changed, 626 insertions(+), 537 deletions(-) create mode 100644 .hlint.yaml diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 00000000..d0267995 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,5 @@ +- arguments: + - -XRecursiveDo + - -XQuasiQuotes +- ignore: + name: Eta reduce diff --git a/apps/kassandra/backend/src/Backend.hs b/apps/kassandra/backend/src/Backend.hs index 6aa4fedd..673022ee 100644 --- a/apps/kassandra/backend/src/Backend.hs +++ b/apps/kassandra/backend/src/Backend.hs @@ -50,13 +50,13 @@ serveWebsocket config backendRequestQueue params = mayCreds = liftA2 (,) mayUsername mayPassword action (Just (username, password)) | Just userConfig <- lookup username (users config) - , PasswordCheckSuccess <- checkPassword (mkPassword password) (passwordHash userConfig) = - acceptSocket backendRequestQueue username userConfig + , PasswordCheckSuccess <- checkPassword (mkPassword password) (passwordHash userConfig) = + acceptSocket backendRequestQueue username userConfig action (Just (username, _)) | Just _ <- lookup username (users config) = - \connection -> do - say [i|Rejecting Websocket request for #{username :: Text}, wrong password.|] - rejectRequest connection "No valid 'username' and 'password' provided." + \connection -> do + say [i|Rejecting Websocket request for #{username :: Text}, wrong password.|] + rejectRequest connection "No valid 'username' and 'password' provided." action _ = \connection -> do say [i|Rejecting Websocket request #{show mayUsername :: Text}. No matching user found.|] rejectRequest connection "No valid 'username' and 'password' provided." diff --git a/apps/kassandra/default.nix b/apps/kassandra/default.nix index 30ccc367..9025ea40 100644 --- a/apps/kassandra/default.nix +++ b/apps/kassandra/default.nix @@ -1,147 +1,165 @@ -{ obelisk ? import ./.obelisk/impl { - system = builtins.currentSystem; - config.android_sdk.accept_license = true; - } +{ + obelisk ? + import ./.obelisk/impl { + system = builtins.currentSystem; + config.android_sdk.accept_license = true; + }, }: with obelisk; -project ./. ( - { pkgs, ... }: - let - inherit (pkgs.haskell.lib) - markUnbroken dontCheck addBuildDepend doJailbreak - overrideCabal - ; - in - { - android = { - applicationId = "de.maralorn.kassandra"; - displayName = "Kassandra"; - releaseKey = null; - isRelease = true; - version = { - code = import ./code.nix; - name = "0.1.0"; + project ./. ( + {pkgs, ...}: let + inherit + (pkgs.haskell.lib) + markUnbroken + dontCheck + addBuildDepend + doJailbreak + overrideCabal + ; + in { + android = { + applicationId = "de.maralorn.kassandra"; + displayName = "Kassandra"; + releaseKey = null; + isRelease = true; + version = { + code = import ./code.nix; + name = "0.1.0"; + }; }; - }; - overrides = self: super: { - kassandra = overrideCabal super.kassandra { doHaddock = false; }; - backend = addBuildDepend super.backend pkgs.taskwarrior; - clay = markUnbroken (dontCheck super.clay); - haskeline = dontCheck (self.callHackage "haskeline" "0.8.0.1" { }); - repline = doJailbreak (self.callHackage "repline" "0.4.0.0" { }); - dhall = dontCheck (self.callHackage "dhall" "1.35.0" { }); - relude = dontCheck super.relude; - stm-containers = markUnbroken super.stm-containers; - stm-hamt = markUnbroken (doJailbreak super.stm-hamt); - streamly-bytestring = self.callHackageDirect - { - pkg = "streamly-bytestring"; - ver = "0.1.2"; - sha256 = "08xhp8zgf5n1j4v1br1dz9ih8j05vk92swp3nz9in5xajllkc7qv"; - } - { }; - streamly = self.callHackageDirect - { - pkg = "streamly"; - ver = "0.7.0"; - sha256 = "0hr2cz14w6nnbvhnq1fvr8v4rzyqcj3b9khf2rszyji00fmp27l1"; - } - { }; - nonempty-vector = self.callHackageDirect - { - pkg = "nonempty-vector"; - ver = "0.1.0.0"; - sha256 = "06abdmdy9z0w6ishiibir3qfjpqxmb4mrkhgyc4j58hd14s8rj0x"; - } - { }; - nonempty-containers = self.callHackageDirect - { - pkg = "nonempty-containers"; - ver = "0.3.4.1"; - sha256 = "0nbnr0az201lv09dwcxcppkfc9b05kyw4la990z5asn9737pvpr2"; - } - { }; - iCalendar = overrideCabal (doJailbreak (markUnbroken super.iCalendar)) { - preConfigure = ''substituteInPlace iCalendar.cabal --replace "network >=2.6 && <2.7" "network -any"''; + overrides = self: super: { + kassandra = overrideCabal super.kassandra {doHaddock = false;}; + backend = addBuildDepend super.backend pkgs.taskwarrior; + clay = markUnbroken (dontCheck super.clay); + haskeline = dontCheck (self.callHackage "haskeline" "0.8.0.1" {}); + repline = doJailbreak (self.callHackage "repline" "0.4.0.0" {}); + dhall = dontCheck (self.callHackage "dhall" "1.35.0" {}); + relude = dontCheck super.relude; + stm-containers = markUnbroken super.stm-containers; + stm-hamt = markUnbroken (doJailbreak super.stm-hamt); + streamly-bytestring = + self.callHackageDirect + { + pkg = "streamly-bytestring"; + ver = "0.1.2"; + sha256 = "08xhp8zgf5n1j4v1br1dz9ih8j05vk92swp3nz9in5xajllkc7qv"; + } + {}; + streamly = + self.callHackageDirect + { + pkg = "streamly"; + ver = "0.7.0"; + sha256 = "0hr2cz14w6nnbvhnq1fvr8v4rzyqcj3b9khf2rszyji00fmp27l1"; + } + {}; + nonempty-vector = + self.callHackageDirect + { + pkg = "nonempty-vector"; + ver = "0.1.0.0"; + sha256 = "06abdmdy9z0w6ishiibir3qfjpqxmb4mrkhgyc4j58hd14s8rj0x"; + } + {}; + nonempty-containers = + self.callHackageDirect + { + pkg = "nonempty-containers"; + ver = "0.3.4.1"; + sha256 = "0nbnr0az201lv09dwcxcppkfc9b05kyw4la990z5asn9737pvpr2"; + } + {}; + iCalendar = overrideCabal (doJailbreak (markUnbroken super.iCalendar)) { + preConfigure = ''substituteInPlace iCalendar.cabal --replace "network >=2.6 && <2.7" "network -any"''; + }; + prettyprinter = + self.callHackageDirect + { + pkg = "prettyprinter"; + ver = "1.5.1"; + sha256 = "0wx01rvgwnnmg10sh9x2whif5z12058w5djh7m5swz94wvkg5cg3"; + } + {}; + cborg-json = + self.callHackageDirect + { + pkg = "cborg-json"; + ver = "0.2.2.0"; + sha256 = "1s7pv3jz8s1qb0ydcc5nra9f63jp4ay4d0vncv919bakf8snj4vw"; + } + {}; + generic-random = + self.callHackageDirect + { + pkg = "generic-random"; + ver = "1.3.0.0"; + sha256 = "0m7lb40wgmyszv8l6qmarkfgs8r0idgl9agwsi72236hpvp353ad"; + } + {}; + atomic-write = + self.callHackageDirect + { + pkg = "atomic-write"; + ver = "0.2.0.7"; + sha256 = "1r9ckwljdbw3mi8rmzmsnh89z8nhw2qnds9n271gkjgavb6hxxf3"; + } + {}; + taskwarrior = + self.callHackageDirect + { + pkg = "taskwarrior"; + ver = "0.5.0.0"; + sha256 = "sha256-elDUtz0NSG4WHxkyCQ1CunYXWIVRj6EqkKSchPy+c3E="; + } + {}; + base64 = + self.callHackageDirect + { + pkg = "base64"; + ver = "0.4.1"; + sha256 = "1pz9s8bmnkrrr3v5mhkwv8vaf251vmxs87zzc5nsjsa027j9lr22"; + } + {}; + password = + self.callHackageDirect + { + pkg = "password"; + ver = "2.0.1.0"; + sha256 = "1q99v7w6bdfpnw245aa3zaj3x7mhl9i2y7f2rzlc30g066p9jhaz"; + } + {}; + indexed-profunctors = + self.callHackageDirect + { + pkg = "indexed-profunctors"; + ver = "0.1"; + sha256 = "0vpgbymfhnvip90jwvyniqi34lhz5n3ni1f21g81n5rap0q140za"; + } + {}; + generic-lens-core = + self.callHackageDirect + { + pkg = "generic-lens-core"; + ver = "2.0.0.0"; + sha256 = "07parw0frqxxkjbbas9m9xb3pmpqrx9wz63m35wa6xqng9vlcscm"; + } + {}; + generic-optics = + self.callHackageDirect + { + pkg = "generic-optics"; + ver = "2.0.0.0"; + sha256 = "0xy5k5b35w1i1zxy0dv5fk1b3zrd3hx3v5kh593k2la7ri880wmq"; + } + {}; + optics-core = self.callHackage "optics-core" "0.3.0.1" {}; + optics-th = self.callHackage "optics-th" "0.3.0.2" {}; + optics-extra = self.callHackage "optics-extra" "0.3" {}; + optics = self.callHackage "optics" "0.3" {}; }; - prettyprinter = self.callHackageDirect - { - pkg = "prettyprinter"; - ver = "1.5.1"; - sha256 = "0wx01rvgwnnmg10sh9x2whif5z12058w5djh7m5swz94wvkg5cg3"; - } - { }; - cborg-json = self.callHackageDirect - { - pkg = "cborg-json"; - ver = "0.2.2.0"; - sha256 = "1s7pv3jz8s1qb0ydcc5nra9f63jp4ay4d0vncv919bakf8snj4vw"; - } - { }; - generic-random = self.callHackageDirect - { - pkg = "generic-random"; - ver = "1.3.0.0"; - sha256 = "0m7lb40wgmyszv8l6qmarkfgs8r0idgl9agwsi72236hpvp353ad"; - } - { }; - atomic-write = self.callHackageDirect - { - pkg = "atomic-write"; - ver = "0.2.0.7"; - sha256 = "1r9ckwljdbw3mi8rmzmsnh89z8nhw2qnds9n271gkjgavb6hxxf3"; - } - { }; - taskwarrior = self.callHackageDirect - { - pkg = "taskwarrior"; - ver = "0.5.0.0"; - sha256 = "sha256-elDUtz0NSG4WHxkyCQ1CunYXWIVRj6EqkKSchPy+c3E="; - } - { }; - base64 = self.callHackageDirect - { - pkg = "base64"; - ver = "0.4.1"; - sha256 = "1pz9s8bmnkrrr3v5mhkwv8vaf251vmxs87zzc5nsjsa027j9lr22"; - } - { }; - password = self.callHackageDirect - { - pkg = "password"; - ver = "2.0.1.0"; - sha256 = "1q99v7w6bdfpnw245aa3zaj3x7mhl9i2y7f2rzlc30g066p9jhaz"; - } - { }; - indexed-profunctors = self.callHackageDirect - { - pkg = "indexed-profunctors"; - ver = "0.1"; - sha256 = "0vpgbymfhnvip90jwvyniqi34lhz5n3ni1f21g81n5rap0q140za"; - } - { }; - generic-lens-core = self.callHackageDirect - { - pkg = "generic-lens-core"; - ver = "2.0.0.0"; - sha256 = "07parw0frqxxkjbbas9m9xb3pmpqrx9wz63m35wa6xqng9vlcscm"; - } - { }; - generic-optics = self.callHackageDirect - { - pkg = "generic-optics"; - ver = "2.0.0.0"; - sha256 = "0xy5k5b35w1i1zxy0dv5fk1b3zrd3hx3v5kh593k2la7ri880wmq"; - } - { }; - optics-core = self.callHackage "optics-core" "0.3.0.1" { }; - optics-th = self.callHackage "optics-th" "0.3.0.2" { }; - optics-extra = self.callHackage "optics-extra" "0.3" { }; - optics = self.callHackage "optics" "0.3" { }; - }; - packages = { - kassandra = ./kassandra; - standalone = ./standalone; - }; - } -) + packages = { + kassandra = ./kassandra; + standalone = ./standalone; + }; + } + ) diff --git a/apps/kassandra/frontend/src/Frontend.hs b/apps/kassandra/frontend/src/Frontend.hs index 14f3f778..44683a74 100644 --- a/apps/kassandra/frontend/src/Frontend.hs +++ b/apps/kassandra/frontend/src/Frontend.hs @@ -28,8 +28,9 @@ frontend = } frontendBody :: WidgetJSM t m => m () -frontendBody = D.dyn_ . fmap (maybe pass mainWidget) - =<< remoteBackendWidget (wrap D.never) Nothing +frontendBody = + D.dyn_ . fmap (maybe pass mainWidget) + =<< remoteBackendWidget (wrap D.never) Nothing css = cssAsText (static @"MaterialIcons-Regular-Outlined.otf") diff --git a/apps/kassandra/frontend/src/Frontend/Route.hs b/apps/kassandra/frontend/src/Frontend/Route.hs index b0351051..eae3da22 100644 --- a/apps/kassandra/frontend/src/Frontend/Route.hs +++ b/apps/kassandra/frontend/src/Frontend/Route.hs @@ -12,7 +12,7 @@ import Control.Category import qualified Control.Category import Data.Text (Text) ---import Data.Functor.Identity +-- import Data.Functor.Identity import Obelisk.Route import Obelisk.Route.TH @@ -41,7 +41,7 @@ fullRouteEncoder = (FullRoute_Backend BackendRouteMissing :/ ()) ( \case BackendRouteMissing -> PathSegment "missing" $ unitEncoder mempty - BackendRouteSocket -> PathSegment "socket" $ Control.Category.id + BackendRouteSocket -> PathSegment "socket" Control.Category.id ) ( \case FrontendRouteMain -> PathEnd $ unitEncoder mempty diff --git a/apps/kassandra/kassandra/src/Kassandra/Config.hs b/apps/kassandra/kassandra/src/Kassandra/Config.hs index 0c3b5ded..179c8457 100644 --- a/apps/kassandra/kassandra/src/Kassandra/Config.hs +++ b/apps/kassandra/kassandra/src/Kassandra/Config.hs @@ -23,7 +23,7 @@ module Kassandra.Config ( TaskwarriorOption (..), ) where -import Data.Default.Class ( Default(..) ) +import Data.Default.Class (Default (..)) import Data.Password.Argon2 ( Argon2, PasswordHash, @@ -142,22 +142,22 @@ data PasswordConfig = Prompt | Password {plaintext :: Text} | PasswordCommand {c data LocalBackend = TaskwarriorBackend - { -- | Set config file - taskRcPath :: Maybe Text - , -- | Set task data directory - taskDataPath :: Maybe Text - , -- | Override config variables - taskConfig :: Seq TaskwarriorOption - , -- | Path to taskwarrior binary. Nothing => Lookup "task" from PATH - taskBin :: Maybe Text - , -- | Use the first free port from the given range for the taskwarrior hook listener. - hookListenPort :: PortConfig - , -- | Created hooks are called ".on-add.." and ".on-remove.." - hookSuffix :: Text - , -- | Ensure existence of taskwarrior hook on every start - createHooksOnStart :: Bool - , -- | Remove hook on exit. - removeHooksOnExit :: Bool + { taskRcPath :: Maybe Text + -- ^ Set config file + , taskDataPath :: Maybe Text + -- ^ Set task data directory + , taskConfig :: Seq TaskwarriorOption + -- ^ Override config variables + , taskBin :: Maybe Text + -- ^ Path to taskwarrior binary. Nothing => Lookup "task" from PATH + , hookListenPort :: PortConfig + -- ^ Use the first free port from the given range for the taskwarrior hook listener. + , hookSuffix :: Text + -- ^ Created hooks are called ".on-add.." and ".on-remove.." + , createHooksOnStart :: Bool + -- ^ Ensure existence of taskwarrior hook on every start + , removeHooksOnExit :: Bool + -- ^ Remove hook on exit. } | GitBackend { directoryPath :: Text diff --git a/apps/kassandra/kassandra/src/Kassandra/Css.hs b/apps/kassandra/kassandra/src/Kassandra/Css.hs index 300d2f57..a678e911 100644 --- a/apps/kassandra/kassandra/src/Kassandra/Css.hs +++ b/apps/kassandra/kassandra/src/Kassandra/Css.hs @@ -31,10 +31,11 @@ css fontPath = do fontFace $ do fontFamily [fontName] [] fontFaceSrc [FontFaceSrcUrl fontSrc (Just OpenType)] - let --darkBlue = rgb 0 0 33 - lightBlue = rgb 200 200 255 - noMargin = margin (px 0) (px 0) (px 0) (px 0) - noPadding = padding (px 0) (px 0) (px 0) (px 0) + let + -- darkBlue = rgb 0 0 33 + lightBlue = rgb 200 200 255 + noMargin = margin (px 0) (px 0) (px 0) (px 0) + noPadding = padding (px 0) (px 0) (px 0) (px 0) star ? do fontFamily ["B612"] [] noMargin @@ -91,13 +92,13 @@ css fontPath = do color white ".button" ? buttonCss ".selector" ? buttonCss - --".tag" ? ".icon" ? do - --position absolute - --borderRadius tagRadius tagRadius tagRadius tagRadius - --background lightBlue - --marginLeft (em (-1.1)) - --marginTop (em 0.70) - --fontSize (em 0.85) + -- ".tag" ? ".icon" ? do + -- position absolute + -- borderRadius tagRadius tagRadius tagRadius tagRadius + -- background lightBlue + -- marginLeft (em (-1.1)) + -- marginTop (em 0.70) + -- fontSize (em 0.85) ".material-icons" ? do fontFamily [fontName] [] fontWeight normal @@ -141,9 +142,9 @@ css fontPath = do ".children" ? do padding (px 0) (px 0) (px 0) leftBarWidth background black - --".slimButton" ? do - --marginRight (px (-5)) - --marginLeft (px (-5)) + -- ".slimButton" ? do + -- marginRight (px (-5)) + -- marginLeft (px (-5)) let blockSize = do width (em 1) height (em 1) @@ -162,5 +163,6 @@ css fontPath = do ".grey" & color (grayish 160) ".show" & color black ".showable" & display none - active & i ? do - background black + active + & i ? do + background black diff --git a/apps/kassandra/kassandra/src/Kassandra/Debug.hs b/apps/kassandra/kassandra/src/Kassandra/Debug.hs index 9170c587..1f5a7b96 100644 --- a/apps/kassandra/kassandra/src/Kassandra/Debug.hs +++ b/apps/kassandra/kassandra/src/Kassandra/Debug.hs @@ -21,6 +21,9 @@ import Reflex as R import System.IO.Unsafe (unsafePerformIO) import qualified Debug.Trace as Trace +import Relude.Extra.Bifunctor +import Relude.Extra.Enum +import Say import System.Console.ANSI ( Color (..), ColorIntensity (Vivid), @@ -28,9 +31,6 @@ import System.Console.ANSI ( SGR (..), setSGRCode, ) -import Relude.Extra.Bifunctor -import Relude.Extra.Enum -import Say data Severity = Debug | Info | Warning | Error deriving stock (Show, Read, Eq, Ord) @@ -149,7 +149,8 @@ showSeverity = \case where color :: Color -> Text -> Text color c txt = - toText (setSGRCode [SetColor Foreground Vivid c]) <> txt + toText (setSGRCode [SetColor Foreground Vivid c]) + <> txt <> toText (setSGRCode [Reset]) diff --git a/apps/kassandra/kassandra/src/Kassandra/MainWidget.hs b/apps/kassandra/kassandra/src/Kassandra/MainWidget.hs index 0d9a0a96..6a3e3018 100644 --- a/apps/kassandra/kassandra/src/Kassandra/MainWidget.hs +++ b/apps/kassandra/kassandra/src/Kassandra/MainWidget.hs @@ -9,7 +9,7 @@ import qualified Data.Sequence as Seq import qualified Data.Sequence.NonEmpty as NESeq import qualified Data.Set as Set import Kassandra.AgendaWidget (agendaWidget) -import Kassandra.BaseWidgets (button, br) +import Kassandra.BaseWidgets (br, button) import Kassandra.Calendar (CalendarEvent) import Kassandra.Config (DefinitionElement, Widget (DefinitionElementWidget, SearchWidget)) import Kassandra.Debug ( @@ -183,17 +183,20 @@ nextWidget = do <$> getTasks D.dynText $ (\x y -> if length x + length y > 0 then [i|There are #{length x} tasks in the inbox and #{length y} tasks unsorted.|] else "Nothing to do.") - <$> inboxTasks <*> unsortedTasks + <$> inboxTasks + <*> unsortedTasks inboxTaskDyn <- R.maybeDyn $ Seq.lookup 0 <$> inboxTasks let decorateSortTask x = D.el "p" (D.text "Sort this task into the task tree:") *> taskTreeWidget x - decorateInboxTask x = D.el "p" $ do - D.text "Process this task from the inbox:" *> br - D.text "1. Does it need to be done?" *> br - D.text "2. Can you do it in under 2 minutes?" *> br - D.text "3. Should someone else do this?" *> br - D.text "4. Should you split this task into sub tasks?" *> br - D.text "5. On which tag list does it belong or when do you want to do it?" *> br - *> taskTreeWidget x + decorateInboxTask x = + D.el "p" $ + do + D.text "Process this task from the inbox:" *> br + D.text "1. Does it need to be done?" *> br + D.text "2. Can you do it in under 2 minutes?" *> br + D.text "3. Should someone else do this?" *> br + D.text "4. Should you split this task into sub tasks?" *> br + D.text "5. On which tag list does it belong or when do you want to do it?" *> br + *> taskTreeWidget x sortTask = do taskDyn <- R.maybeDyn $ viaNonEmpty head <$> unsortedTasks D.dyn_ (maybe pass decorateSortTask <$> taskDyn) diff --git a/apps/kassandra/kassandra/src/Kassandra/ReflexUtil.hs b/apps/kassandra/kassandra/src/Kassandra/ReflexUtil.hs index 763accc3..da99efa7 100644 --- a/apps/kassandra/kassandra/src/Kassandra/ReflexUtil.hs +++ b/apps/kassandra/kassandra/src/Kassandra/ReflexUtil.hs @@ -10,7 +10,8 @@ module Kassandra.ReflexUtil ( import qualified Data.Map as Map import qualified Data.Patch.Map as Patch ---import qualified Data.Patch.MapWithMove as Patch + +-- import qualified Data.Patch.MapWithMove as Patch import qualified Data.Sequence as Seq import qualified Reflex as R import qualified Reflex.Dom as D @@ -29,27 +30,28 @@ smartSimpleList :: m () smartSimpleList widget listElements = do void $ R.simpleList (toList <$> listElements) \vDyn -> do - u <- R.holdUniqDyn vDyn - D.dyn_ . fmap widget $ u - --postBuild <- R.getPostBuild - --keyMap <- R.holdUniqDyn $ Seq.foldMapWithIndex (curry one) <$> listElements - --let keyMapChange = - --R.attachWith - --((Newtype.under @(Map Int (Patch.NodeInfo Int v)) fixPatchMap .) . Patch.patchThatChangesMap) - --(R.current keyMap) - --(R.updated keyMap) - --initialKeyMap = Patch.patchMapWithMoveInsertAll <$> R.tag (R.current keyMap) postBuild - --keyMapEvents = keyMapChange <> initialKeyMap - --void $ R.mapMapWithAdjustWithMove (const widget) mempty keyMapEvents + u <- R.holdUniqDyn vDyn + D.dyn_ . fmap widget $ u --- | A workaround for a bug in patchThatChangesMap in patch 0.0.3.2. ---fixPatchMap :: Map Int (Patch.NodeInfo Int v) -> Map Int (Patch.NodeInfo Int v) ---fixPatchMap inputMap = appEndo setMoves . fmap (Patch.nodeInfoSetTo Nothing) $ inputMap --- where --- setMoves = Map.foldMapWithKey f inputMap --- f to' (Patch.NodeInfo (Patch.From_Move from) _) = Endo $ Map.adjust (Patch.nodeInfoSetTo (Just to')) from --- f _ _ = mempty +-- postBuild <- R.getPostBuild +-- keyMap <- R.holdUniqDyn $ Seq.foldMapWithIndex (curry one) <$> listElements +-- let keyMapChange = +-- R.attachWith +-- ((Newtype.under @(Map Int (Patch.NodeInfo Int v)) fixPatchMap .) . Patch.patchThatChangesMap) +-- (R.current keyMap) +-- (R.updated keyMap) +-- initialKeyMap = Patch.patchMapWithMoveInsertAll <$> R.tag (R.current keyMap) postBuild +-- keyMapEvents = keyMapChange <> initialKeyMap +-- void $ R.mapMapWithAdjustWithMove (const widget) mempty keyMapEvents +{- | A workaround for a bug in patchThatChangesMap in patch 0.0.3.2. +fixPatchMap :: Map Int (Patch.NodeInfo Int v) -> Map Int (Patch.NodeInfo Int v) +fixPatchMap inputMap = appEndo setMoves . fmap (Patch.nodeInfoSetTo Nothing) $ inputMap + where + setMoves = Map.foldMapWithKey f inputMap + f to' (Patch.NodeInfo (Patch.From_Move from) _) = Endo $ Map.adjust (Patch.nodeInfoSetTo (Just to')) from + f _ _ = mempty +-} listWithGaps :: (R.Adjustable t m, R.PostBuild t m, R.MonadHold t m, MonadFix m, Ord v, D.NotReady t m) => (v -> m ()) -> @@ -62,9 +64,9 @@ listWithGaps widget gapWidget listD = do gapWidget lastElementD where elementWidget currentElement = do - elementPair <- R.holdUniqDyn $ (,Just currentElement) . Map.lookup currentElement <$> prevElementsD - gapWidget elementPair - widget currentElement + elementPair <- R.holdUniqDyn $ (,Just currentElement) . Map.lookup currentElement <$> prevElementsD + gapWidget elementPair + widget currentElement prevElementsD = (\xs -> Map.unions . fmap one $ Seq.zip (Seq.drop 1 xs) xs) <$> listD keyDynamic :: diff --git a/apps/kassandra/kassandra/src/Kassandra/RemoteBackendWidget.hs b/apps/kassandra/kassandra/src/Kassandra/RemoteBackendWidget.hs index 63c793dd..4741edf3 100644 --- a/apps/kassandra/kassandra/src/Kassandra/RemoteBackendWidget.hs +++ b/apps/kassandra/kassandra/src/Kassandra/RemoteBackendWidget.hs @@ -51,7 +51,7 @@ remoteBackendWidget closeEvent mayBackend = D.divClass "remoteBackend" $ do backendDyn <- maybe inputBackend getPassword mayBackend responseEvent <- D.dyn - (withBackend (closeEvent <> wrap (() <$ R.updated backendDyn)) <$> backendDyn) + (withBackend (closeEvent <> wrap (void $ R.updated backendDyn)) <$> backendDyn) D.holdDyn Nothing responseEvent where getPassword :: RemoteBackend PasswordConfig -> m (R.Dynamic t (Maybe (RemoteBackend Text))) @@ -122,9 +122,9 @@ remoteBackendWidget closeEvent mayBackend = D.divClass "remoteBackend" $ do D.inputElement $ D.def & lensVL D.inputElementConfig_initialValue - .~ defaultValue + .~ defaultValue & lensVL (D.inputElementConfig_elementConfig . D.elementConfig_initialAttributes) - .~ if hidden then "type" D.=: "password" else mempty + .~ if hidden then "type" D.=: "password" else mempty inputValue = R.current . D._inputElement_value data WebSocketState = WebSocketError Text | Connecting deriving stock (Show) diff --git a/apps/kassandra/kassandra/src/Kassandra/Sorting.hs b/apps/kassandra/kassandra/src/Kassandra/Sorting.hs index 3cc5e5d2..c9cbfc2d 100644 --- a/apps/kassandra/kassandra/src/Kassandra/Sorting.hs +++ b/apps/kassandra/kassandra/src/Kassandra/Sorting.hs @@ -7,12 +7,12 @@ module Kassandra.Sorting ( import qualified Data.Aeson as Aeson import Data.Scientific (toRealFloat) +import qualified Data.Sequence as Seq import Data.Set (member) import Kassandra.Types (TaskInfos) import qualified Reflex as R import Relude.Extra.Foldable1 (maximum1) import qualified Taskwarrior.Task as Task -import qualified Data.Sequence as Seq data SortMode = SortModePartof UUID | SortModeTag Task.Tag deriving stock (Show, Eq, Ord, Generic) @@ -80,9 +80,9 @@ sortingChanges mode list = | otherwise = assureSort minTouchedDist sortedList getWrite (task, sortState) | has #_WillWrite sortState || not (taskInList mode task) = - Just . setSortOrder mode (newValue sortState) . insertInList mode $ task + Just . setSortOrder mode (newValue sortState) . insertInList mode $ task | otherwise = - Nothing + Nothing in mapMaybe getWrite finalList applyUntil :: (a -> a) -> (a -> Bool) -> a -> a @@ -92,7 +92,7 @@ applyUntil f condition x minOrder, maxOrder, minDist, minTouchedDist :: Double minOrder = -1 -maxOrder = - minOrder +maxOrder = -minOrder minDist = 10 ** (-6) minTouchedDist = 10 ** (-3) @@ -111,9 +111,9 @@ unSetWorstUnsorted unSet delta (IsNonEmpty (x :<|| xs)) Seq.breakl ((worst ==) . snd) (toSeq badnesses) = - fine <> (unSet a <| alsoFine) + fine <> (unSet a <| alsoFine) | otherwise = - error "Assumed wrong invariant in unSetWorstUnsorted" -- The list of badnesses has to contain its maximum + error "Assumed wrong invariant in unSetWorstUnsorted" -- The list of badnesses has to contain its maximum where badnesses = go mempty (x :<|| xs) <&> \(a, _, badness) -> (a, badness) worst = maximum1 $ snd <$> badnesses @@ -146,16 +146,16 @@ addSortState f = go (minOrder, 0) go (iprev, dprev) list | IsEmpty <- list = mempty | IsNonEmpty (x :<|| xs) <- list - , Just int <- f x = - (x, HasSortPos int) <| go (int, 0) xs + , Just int <- f x = + (x, HasSortPos int) <| go (int, 0) xs | IsNonEmpty (x :<|| xs) <- list - , next@(IsNonEmpty ((_, sortStateNext -> (inext, dnext)) :<|| _)) <- - go - (iprev, dprev + 1) - xs = - (x, WillWrite iprev (dprev + 1) inext (dnext + 1)) <| next + , next@(IsNonEmpty ((_, sortStateNext -> (inext, dnext)) :<|| _)) <- + go + (iprev, dprev + 1) + xs = + (x, WillWrite iprev (dprev + 1) inext (dnext + 1)) <| next | IsNonEmpty (x :<|| _) <- list = - one (x, WillWrite iprev (dprev + 1) maxOrder 1) + one (x, WillWrite iprev (dprev + 1) maxOrder 1) insertBefore :: Seq Task -> Seq Task -> Maybe UUID -> Seq Task insertBefore list toInsert = \case diff --git a/apps/kassandra/kassandra/src/Kassandra/TaskWidget.hs b/apps/kassandra/kassandra/src/Kassandra/TaskWidget.hs index 39e20ef5..e2b28079 100644 --- a/apps/kassandra/kassandra/src/Kassandra/TaskWidget.hs +++ b/apps/kassandra/kassandra/src/Kassandra/TaskWidget.hs @@ -10,8 +10,9 @@ import qualified Data.Sequence.NonEmpty as NESeq import qualified Data.Set as Set import qualified Data.Text as Text import Kassandra.BaseWidgets ( + br, button, - icon, br + icon, ) import Kassandra.Config (DefinitionElement) import Kassandra.Debug ( @@ -138,7 +139,8 @@ dependenciesWidget = do revDepends <- filter stillTodo <<$>> lookupTasksM (taskInfos ^. #revDepends) depends <- filter stillTodo <<$>> (lookupTasksM . toList) (taskInfos ^. #depends) D.dyn_ $ - whenNotNull <$> depends + whenNotNull + <$> depends <*> pure ( \ds -> do br @@ -150,7 +152,8 @@ dependenciesWidget = do br ) D.dyn_ $ - whenJust . nonEmptySeq <$> revDepends + whenJust . nonEmptySeq + <$> revDepends <*> pure ( \rds -> do br @@ -186,7 +189,8 @@ dropChildWidget = do childrenD <- getChildren showIcon <- fmap not <$> getIsExpanded (taskInfos ^. #uuid) D.dyn_ $ - when <$> showIcon + when + <$> showIcon <*> pure ( childDropArea ( SortPosition @@ -204,11 +208,11 @@ dropChildWidget = do (icon "dropHere plusOne" "block") $ fmap ( \dependencies -> - one $ - #depends + one + $ #depends %~ Set.union (Set.fromList $ toList $ (^. #uuid) <$> dependencies) - $ taskInfos - ^. #task + $ taskInfos + ^. #task ) taskDropArea (taskInfos ^. #uuid % to (R.constDyn . one)) @@ -245,7 +249,8 @@ childrenWidget taskInfosD = do showOptional :: Bool -> m () showOptional x = when x $ do children <- - R.holdUniqDyn . fmap (filter stillTodo) =<< lookupTasksDynM + R.holdUniqDyn . fmap (filter stillTodo) + =<< lookupTasksDynM =<< R.holdUniqDyn (taskInfosD ^. mapping #children) let sortModeD = SortModePartof <$> taskInfosD ^. mapping #uuid @@ -256,7 +261,6 @@ childrenWidget taskInfosD = do D.divClass "children" $ taskList (sortModeD ^. #current) sortedList blacklist taskWidget - taskList :: StandardWidget t m r e => R.Behavior t SortMode -> @@ -368,7 +372,8 @@ statusWidget = do (el, ()) <- D.elAttr' "div" ("class" =: "checkbox") $ do D.elClass "i" - ( "material-icons " <> showClass + ( "material-icons " + <> showClass <> if isJust handlerMay then " hideable" else "" diff --git a/apps/kassandra/kassandra/src/Prelude.hs b/apps/kassandra/kassandra/src/Prelude.hs index 1891f9bb..f2107e73 100644 --- a/apps/kassandra/kassandra/src/Prelude.hs +++ b/apps/kassandra/kassandra/src/Prelude.hs @@ -53,11 +53,12 @@ module Prelude ( pattern IsNonEmpty, pattern (:<||), pattern (:||>), - (|>),(<|), + (|>), + (<|), toSeq, mapMaybe, filter, - partitionEithersNESeq + partitionEithersNESeq, ) where import Control.Concurrent.Async ( @@ -81,12 +82,11 @@ import Data.Generics.Product.Typed (HasType (typed)) import Data.Generics.Sum.Constructors (AsConstructor' (_Ctor')) import Data.Generics.Sum.Typed (AsType (_Typed)) import Data.List.Extra (firstJust) -import Data.Sequence.NonEmpty hiding (filter, (|>), (<|)) -import Data.Sequence ((|>),(<|)) +import Data.Sequence ((<|), (|>)) +import Data.Sequence.NonEmpty hiding (filter, (<|), (|>)) import Data.String.Interpolate (i) import Data.Text.Optics hiding (text) -import Data.These (partitionEithersNE, These(..)) -import Data.Witherable ( mapMaybe, (<$?>), (<&?>), filter ) +import Data.These (These (..), partitionEithersNE) import Data.Time ( UTCTime, addUTCTime, @@ -105,14 +105,15 @@ import Data.Time.LocalTime ( zonedTimeToLocalTime, ) import Data.UUID (UUID) +import Data.Witherable (filter, mapMaybe, (<$?>), (<&?>)) import Language.Haskell.TH.Syntax ( Dec, Name, Q, ) -import Optics hiding ((|>), (<|)) +import Optics hiding ((<|), (|>)) import Optics.TH -import Relude hiding (uncons, mapMaybe, filter) +import Relude hiding (filter, mapMaybe, uncons) import Relude.Extra.Foldable1 import Taskwarrior.Status (Status) import Taskwarrior.Task (Task) @@ -122,7 +123,7 @@ instance One (NESeq a) where one = singleton instance Foldable1 NESeq where - foldMap1 f = foldMapWithIndex (const f) + foldMap1 f = foldMapWithIndex (const f) -- (lensField .~ noPrefixNamer $ fieldLabelsRules) == noPrefixFieldLabels but only in optics-th 0.2 makeLabels :: Name -> Q [Dec] diff --git a/apps/kassandra/obelisk-shell.nix b/apps/kassandra/obelisk-shell.nix index 9e5bf488..bc17581c 100644 --- a/apps/kassandra/obelisk-shell.nix +++ b/apps/kassandra/obelisk-shell.nix @@ -1 +1 @@ -(import ./. { }).shells.ghc +(import ./. {}).shells.ghc diff --git a/apps/kassandra/release.nix b/apps/kassandra/release.nix index 0249ab1d..ebdbedda 100644 --- a/apps/kassandra/release.nix +++ b/apps/kassandra/release.nix @@ -1,18 +1,16 @@ -{ pkgs ? import (import nix/sources.nix).nixpkgs { } }: -let +{pkgs ? import (import nix/sources.nix).nixpkgs {}}: let haskellPackages = pkgs.haskellPackages.extend ( self: super: { - kassandra = self.callCabal2nix "kassandra" ./kassandra { }; - standalone = self.callCabal2nix "standalone" ./standalone { }; + kassandra = self.callCabal2nix "kassandra" ./kassandra {}; + standalone = self.callCabal2nix "standalone" ./standalone {}; } ); - reflex-platform = import ./. { }; -in -{ + reflex-platform = import ./. {}; +in { lib = haskellPackages.kassandra; app = haskellPackages.standalone; server = reflex-platform.exe; - android = pkgs.runCommand "kassandra-android-apk" { } '' + android = pkgs.runCommand "kassandra-android-apk" {} '' mkdir -p $out cp ${reflex-platform.android.frontend}/android-app-release-unsigned.apk $out/de.maralorn.kassandra_${import ./code.nix}.apk ''; diff --git a/apps/kassandra/standalone/src/Kassandra/Backend/Calendar.hs b/apps/kassandra/standalone/src/Kassandra/Backend/Calendar.hs index 5520c6de..2c7b9693 100644 --- a/apps/kassandra/standalone/src/Kassandra/Backend/Calendar.hs +++ b/apps/kassandra/standalone/src/Kassandra/Backend/Calendar.hs @@ -73,9 +73,9 @@ import Kassandra.Debug (Severity (..), log) import qualified Streamly.Data.Fold as FL import Streamly.External.ByteString (fromArray, toArray) import qualified Streamly.FileSystem.Handle as FS +import Streamly.Internal.Data.Array.Stream.Foreign (splitOn) import qualified Streamly.Internal.FileSystem.File as FSFile import Streamly.Memory.Array as Mem (fromList) -import Streamly.Internal.Data.Array.Stream.Foreign (splitOn) dirName :: FilePath dirName = "/home/maralorn/.calendars/" @@ -121,12 +121,12 @@ saveCache cache = do writeJSONStream :: (IsStream t, MonadIO (t IO), ToJSON k, ToJSON v) => STM.Map k v -> FilePath -> t IO () writeJSONStream stmMap fileName = FSFile.withFile fileName WriteMode \handle -> - liftIO $ - S.fold (FS.writeChunks handle) + liftIO + $ S.fold (FS.writeChunks handle) . asyncly . S.intersperse (Mem.fromList [10]) . fmap (toArray . toStrict . encode) - $ streamSTMMap stmMap + $ streamSTMMap stmMap streamSTMMap :: forall t k v. (MonadIO (t IO), IsStream t) => STM.Map k v -> t IO (k, v) streamSTMMap = join . atomically . UnfoldlM.foldlM' (\x y -> pure $ S.cons y x) S.nil . STM.unfoldlM @@ -145,7 +145,8 @@ data Cache = Cache { icsCache :: ICSCache , tzCache :: TZCache , uidCache :: UIDCache - } deriving (Generic) + } + deriving (Generic) newCache :: IO Cache newCache = atomically $ Cache <$> STM.new <*> STM.new <*> STM.new @@ -284,11 +285,11 @@ translateEvent cache calendarName vEvent = -- Also we are ignoring the timezone delivered with this calendar and taking our own getTimes | Just (DTStartDateTime start _) <- veDTStart vEvent - , Just (Left (DTEndDateTime end _)) <- veDTEndDuration vEvent = - S.yieldM . liftIO $ SimpleEvent <$> datetimeToTZTime cache start <*> datetimeToTZTime cache end + , Just (Left (DTEndDateTime end _)) <- veDTEndDuration vEvent = + S.yieldM . liftIO $ SimpleEvent <$> datetimeToTZTime cache start <*> datetimeToTZTime cache end | Just (dateValue . dtStartDateValue -> start) <- veDTStart vEvent - , Just (Left (dateValue . dtEndDateValue -> end)) <- veDTEndDuration vEvent = - S.yield $ AllDayEvent start (addDays (-1) end) + , Just (Left (dateValue . dtEndDateValue -> end)) <- veDTEndDuration vEvent = + S.yield $ AllDayEvent start (addDays (-1) end) | otherwise = S.nil datetimeToTZTime :: Cache -> DateTime -> IO TZTime diff --git a/apps/kassandra/standalone/src/Kassandra/Standalone/Config.hs b/apps/kassandra/standalone/src/Kassandra/Standalone/Config.hs index df4eaae9..9255049f 100644 --- a/apps/kassandra/standalone/src/Kassandra/Standalone/Config.hs +++ b/apps/kassandra/standalone/src/Kassandra/Standalone/Config.hs @@ -6,14 +6,15 @@ module Kassandra.Standalone.Config ( StandaloneAccount (LocalAccount, RemoteAccount), BackendConfig (..), backends, - dhallTypes + dhallTypes, ) where import Dhall (FromDhall) import Kassandra.Config ( - Dict, AccountConfig, DefinitionElement, + Dict, + ListItem, ListQuery, LocalBackend, NamedBackend, @@ -24,7 +25,7 @@ import Kassandra.Config ( TaskwarriorOption, TreeOption, UserConfig, - Widget, ListItem + Widget, ) import Kassandra.Config.Dhall ( DhallLoadConfig (..), @@ -42,7 +43,7 @@ data StandaloneAccount = RemoteAccount {backend :: Maybe (RemoteBackend Password deriving stock (Show, Eq, Ord, Generic) deriving anyclass (FromDhall) -data BackendConfig = BackendConfig +newtype BackendConfig = BackendConfig { users :: Dict AccountConfig } deriving (Show, Eq, Generic, FromDhall) diff --git a/apps/logfeed/Mail.hs b/apps/logfeed/Mail.hs index 395c9262..79dd6be3 100644 --- a/apps/logfeed/Mail.hs +++ b/apps/logfeed/Mail.hs @@ -1,41 +1,44 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -import Prelude ( ) -import Relude -import qualified Notmuch -import Say -import Data.String.Interpolate -import qualified Data.MIME as MIME -import Data.MIME.Charset -import Control.Lens hiding ( argument ) -import Control.Error ( withExceptT - , throwE - , tryJust, tryRight - ) -import qualified Data.Text as T -import Control.Monad.Catch ( MonadCatch - , handleIOError - ) -import Data.Time -import Relude.Extra.Group -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 +import Control.Error ( + throwE, + tryJust, + tryRight, + withExceptT, + ) +import Control.Lens hiding (argument) +import Control.Monad.Catch ( + MonadCatch, + handleIOError, + ) import Data.Either.Extra (mapLeft) +import Data.MIME qualified as MIME +import Data.MIME.Charset +import Data.Map qualified as Map +import Data.String.Interpolate +import Data.Text qualified as T +import Data.Time +import Notmuch qualified +import Options.Applicative qualified as O +import Relude +import Relude.Extra.Group +import Say +import Text.Atom.Feed +import Text.Atom.Feed.Export (textFeed) +import Text.HTML.TagSoup +import Prelude () data Options = Options { dbPath :: String @@ -43,166 +46,184 @@ data Options = Options } data Thread = Thread - { subject :: Text - , threadid :: ByteString - , authors :: [Text] - , date :: UTCTime + { subject :: Text + , threadid :: ByteString + , authors :: [Text] + , date :: UTCTime , totalCount :: Int - , messages :: [Message] + , messages :: [Message] } type Error = Text data Body = HTMLBody Text | TextBody Text data Message = Message - { date :: UTCTime + { date :: UTCTime , headers :: [(Text, Text)] - , body :: Body + , body :: Body } main :: IO () main = do - Options { dbPath, folder } <- O.execParser $ O.info - ( Options - <$> 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 - ) - O.fullDesc + Options{dbPath, folder} <- + O.execParser $ + O.info + ( Options + <$> 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 + ) + O.fullDesc res <- runExceptT do (thrds, msgs) <- withExceptT - (\(er :: Notmuch.Status) -> - [i|Failed to read notmuch data.\ndb path: #{dbPath}\nquery: Folder #{folder}\nerror: #{er}|] + ( \(er :: Notmuch.Status) -> + [i|Failed to read notmuch data.\ndb path: #{dbPath}\nquery: Folder #{folder}\nerror: #{er}|] ) do db <- Notmuch.databaseOpenReadOnly dbPath - q <- Notmuch.query db (Notmuch.Folder folder) + 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) + 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 <$> sortOn (date :: Thread -> UTCTime) (rights result) - feed = nullFeed [i|read-later-e-mails-#{timestamp now}|] - (TextString "Readlater-E-Mail") - (timestamp now) + 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) -> - sayErr [i|mail2feed failed to export mails to rss.\n#{er}|] + ( \(er :: Text) -> + sayErr [i|mail2feed failed to export mails to rss.\n#{er}|] ) (const pass) res threadToEntry :: Thread -> Entry -threadToEntry Thread { subject, messages, threadid, totalCount, date, authors } - = (nullEntry threadUrl threadTitle (timestamp date)) +threadToEntry Thread{subject, messages, threadid, totalCount, date, authors} = + (nullEntry threadUrl threadTitle (timestamp date)) { entryContent = Just . HTMLContent $ content - , entryAuthors = (\x -> nullPerson { personName = x }) <$> authors + , 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) + content = T.intercalate [i|
\n
\n|] (messageToHtml <$> messages) 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 - } +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" -processThread - :: (MonadIO m, MonadCatch m) - => ( Notmuch.ThreadId - , NonEmpty (Either (Notmuch.Thread a) (Notmuch.Message n a)) - ) - -> ExceptT Error m Thread +processThread :: + (MonadIO m, MonadCatch m) => + ( Notmuch.ThreadId + , NonEmpty (Either (Notmuch.Thread a) (Notmuch.Message n a)) + ) -> + ExceptT Error m Thread 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 + . viaNonEmpty head + . lefts + $ thrdAndMsgs let msgs = rights thrdAndMsgs results <- mapM processMessage msgs let messages = sortOn (date :: Message -> UTCTime) results - subject <- decodeUtf8 <$> Notmuch.threadSubject thread + 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 }) - + authors <- (^. Notmuch.matchedAuthors) <$> Notmuch.threadAuthors thread + date <- Notmuch.threadNewestDate thread + pure (Thread{subject, threadid, messages, totalCount, authors, date}) messageToHtml :: Message -> Text -messageToHtml Message { headers, body } = - T.intercalate "
\n" - $ ((\(name, content) -> [i|#{name}: #{content}|]) <$> headers) - <> one (bodyToHtml body) +messageToHtml Message{headers, body} = + T.intercalate "
\n" $ + ((\(name, content) -> [i|#{name}: #{content}|]) <$> headers) + <> one (bodyToHtml body) bodyToHtml :: Body -> Text bodyToHtml (HTMLBody x) = fromMaybe x onlyBody - where onlyBody = renderTags . takeWhile (not . isTagCloseName "body") <$> (viaNonEmpty tail . dropWhile (not . isTagOpenName "body") . parseTags $ x) + 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 processMessage msg = do - fileName <- Notmuch.messageFilename msg - date <- Notmuch.messageDate msg - subject <- tryHdr "subject" 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 - unsub <- tryHdr "list-unsubscribe" msg - let hdrs = mapMaybe - (\(x, a) -> (x, ) <$> a) - [ ("Subject", subject) - , ("From" , fromField) - , ("To" , toField) - , ("Cc" , cc) - , ("Date" , Just (timestamp date)) - , ("Unsubscribe" , unsub) - ] + toField <- tryHdr "to" msg + cc <- tryHdr "cc" msg + unsub <- tryHdr "list-unsubscribe" msg + let hdrs = + mapMaybe + (\(x, a) -> (x,) <$> a) + [ ("Subject", subject) + , ("From", fromField) + , ("To", toField) + , ("Cc", cc) + , ("Date", Just (timestamp date)) + , ("Unsubscribe", unsub) + ] msgEither <- runExceptT $ withExceptT (\er -> [i|Failed to read msg\nFilename:#{fileName}\nerror: #{er}|]) do - msgContent <- handleIOError (\er -> throwE [i|IOError: #{er}|]) - $ readFileBS fileName - 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 + msgContent <- + handleIOError (\er -> throwE [i|IOError: #{er}|]) $ + readFileBS fileName + 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) - <$> tryRight (mapLeft ("Could not decode message "<> ) $ decode textPart) - pure $ Message { date, headers = hdrs, body = either TextBody id msgEither } + <$> 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) tryHdr h msg = diff --git a/apps/logfeed/Main.hs b/apps/logfeed/Main.hs index 96c18fe0..7b396a95 100644 --- a/apps/logfeed/Main.hs +++ b/apps/logfeed/Main.hs @@ -1,29 +1,41 @@ -{-# LANGUAGE ViewPatterns, ScopedTypeVariables, NamedFieldPuns, OverloadedStrings, NoImplicitPrelude, ExtendedDefaultRules, QuasiQuotes, MultiWayIf #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} + module Main where -import qualified Data.List.Extra as L -import Data.List.NonEmpty ( groupBy - , zip - ) -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 () -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 qualified Data.List.Extra as L +import Data.List.NonEmpty ( + groupBy, + zip, + ) +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 () +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 + -- TODO: use Text instead of linked lists of chars type WeechatLog = [WeechatLine] @@ -31,14 +43,15 @@ data WeechatLine = WeechatLine { wlDate :: Text , wlTime :: Text , wlNick :: Text - , wlMsg :: Text + , wlMsg :: Text } deriving (Show, Eq, Ord) + -- TODO: specific handling of join/part/network messages data LogFile = LogFile - { path :: Text - , server :: Text + { path :: Text + , server :: Text , channel :: Text } deriving (Show, Eq, Ord, Read) @@ -88,8 +101,8 @@ ircParser :: Text -> Parser LogFile ircParser p = do void $ MP.count 4 MP.digitChar void dirSep - prefix <- symbol "irc:" :: Parser Text - server <- folder + prefix <- symbol "irc:" :: Parser Text + server <- folder channel <- folder void parseDate void $ symbol ".weechatlog" @@ -101,23 +114,26 @@ logFolder = "/home/maralorn/logs/" main :: IO () main = do now <- T.getCurrentTime - let getFiles t p = L.groupSortOn (\x -> (channel x, server x)) - . mapMaybe ((\x -> MP.parseMaybe (p x) x) . toText) + let getFiles t p = + L.groupSortOn (\x -> (channel x, server x)) + . mapMaybe ((\x -> MP.parseMaybe (p x) x) . toText) <$> getDirectoryFiles - (toString logFolder) - ( T.formatTime T.defaultTimeLocale t + (toString logFolder) + ( 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 + ircFiles <- getFiles "%Y/irc:*/#*/%Y-%m-%d.weechatlog" ircParser + logs <- mapM readLogFiles $ mapMaybe nonEmpty $ matrixFiles <> ircFiles let entries = logs & mapMaybe (logToFeedEntry now) - feed = nullFeed [i|weechat-logs-#{timestamp now}|] - (TextString "Weechat Logs") - (timestamp now) + feed = + nullFeed + [i|weechat-logs-#{timestamp now}|] + (TextString "Weechat Logs") + (timestamp now) [pathToWrite] <- getArgs - whenJust (textFeed feed { feedEntries = entries }) - $ \file -> writeFileLText pathToWrite file + whenJust (textFeed feed{feedEntries = entries}) $ + \file -> writeFileLText pathToWrite file today :: T.UTCTime -> T.Day today = T.utctDay @@ -129,14 +145,17 @@ 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 } -> + \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 - } + then + Just + ( nullEntry + [i|#{logserver}-#{logchannel}-#{timestamp now}|] + (TextString [i|#{logchannel} - (#{logserver})|]) + (timestamp now) + ) + { entryContent = Just $ HTMLContent $ printHTML messages + } else Nothing where cutoff = @@ -145,8 +164,8 @@ logToFeedEntry now = data Log = Log { logchannel :: Text - , logserver :: Text - , messages :: [WeechatLine] + , logserver :: Text + , messages :: [WeechatLine] } deriving (Show, Eq, Ord) @@ -155,16 +174,16 @@ 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 - } +readLogFile LogFile{channel, server} contents = + Log + { logchannel = channel + , logserver = server + , messages = + L.sortOn (\x -> (wlDate x, wlTime x)) + . concatMap parseWeechatLog + $ contents + } parseWeechatLine :: Parser WeechatLine parseWeechatLine = do @@ -179,34 +198,38 @@ parseWeechatLog :: Text -> [WeechatLine] parseWeechatLog = filter actualMessage . mapMaybe parseLine . lines where actualMessage = not . (`elem` ["-->", "<--", "--"]) . wlNick - parseLine = MP.parseMaybe parseWeechatLine + parseLine = MP.parseMaybe parseWeechatLine printHTML :: [WeechatLine] -> Text printHTML log = intercalate "\n" $ map printDay days 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) = "" <> time <> " " <> printNick <> " " <> message <> "
" where prevTime = Text.take 5 $ wlTime prevRow - curTime = Text.take 5 $ wlTime curRow + curTime = Text.take 5 $ wlTime curRow prevNick = wlNick prevRow - curNick = wlNick curRow - time | prevTime == curTime = "" - | otherwise = curTime - nick | specialNick curNick = curNick - | prevNick == curNick = "" - | otherwise = curNick + curNick = wlNick curRow + time + | prevTime == curTime = "" + | otherwise = curTime + nick + | specialNick curNick = curNick + | prevNick == curNick = "" + | otherwise = curNick printNick = Text.dropWhile (`elem` ['&', '@']) nick - msg = wlMsg curRow + msg = wlMsg curRow message - | not (Text.null msg) && Text.head msg == '>' - = "|" <> escape (Text.tail msg) <> "" - | otherwise - = escape msg + | not (Text.null msg) && Text.head msg == '>' = + "|" <> escape (Text.tail msg) <> "" + | otherwise = + escape msg specialNick = (`elem` ["-->", "<--", "--", "*"]) - escape = replace "<" "<" . replace ">" ">" + escape = replace "<" "<" . replace ">" ">" diff --git a/apps/logfeed/default.nix b/apps/logfeed/default.nix index 7ebbb4d9..f99ff961 100644 --- a/apps/logfeed/default.nix +++ b/apps/logfeed/default.nix @@ -1,3 +1,5 @@ -{ pkgs ? import (import nix/sources.nix).nixpkgs {} }: -with pkgs; with haskell.lib; with haskellPackages; -callCabal2nix "logfeed" ./. { purebred-email = doJailbreak (unmarkBroken (dontCheck purebred-email)); } +{pkgs ? import (import nix/sources.nix).nixpkgs {}}: +with pkgs; +with haskell.lib; +with haskellPackages; + callCabal2nix "logfeed" ./. {purebred-email = doJailbreak (unmarkBroken (dontCheck purebred-email));} diff --git a/apps/logfeed/shell.nix b/apps/logfeed/shell.nix index 72306cfe..c71a56d2 100644 --- a/apps/logfeed/shell.nix +++ b/apps/logfeed/shell.nix @@ -1,12 +1,11 @@ -{ pkgs ? import (import nix/sources.nix).nixpkgs {} }: -let +{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; - }; -} + haskellPackages.shellFor { + withHoogle = true; + packages = p: [(import ./. {inherit pkgs;})]; + buildInputs = builtins.attrValues { + inherit (haskellPackages) hlint cabal-install notmuch hsemail; + inherit (pkgs) coreutils zlib; + }; + } diff --git a/apps/nixpkgs-bot/exe/Main.hs b/apps/nixpkgs-bot/exe/Main.hs index 77457e31..544e887e 100644 --- a/apps/nixpkgs-bot/exe/Main.hs +++ b/apps/nixpkgs-bot/exe/Main.hs @@ -269,8 +269,12 @@ getMissingAuthorSubscriptions pr_key author = do author_subs <- SQL.select $ do author_sub <- SQL.from $ SQL.table @AuthorSubscription SQL.where_ - ( author_sub ^. AuthorSubscriptionGithubLogin ==. SQL.val author - SQL.&&. author_sub ^. AuthorSubscriptionUser `notIn` SQL.subSelectList users_subscribed_to_this_pr + ( author_sub + ^. AuthorSubscriptionGithubLogin + ==. SQL.val author + SQL.&&. author_sub + ^. AuthorSubscriptionUser + `notIn` SQL.subSelectList users_subscribed_to_this_pr ) pure author_sub pure $ fmap (authorSubscriptionUser . Persist.entityVal) author_subs @@ -461,10 +465,12 @@ deleteUnusedQueries :: App () deleteUnusedQueries = SQL.delete do query <- SQL.from $ SQL.table @Query SQL.where_ $ - (query ^. QueryUser) `notIn` SQL.subList_select do - sub <- SQL.from $ SQL.table @Subscription - pure (sub ^. SubscriptionUser) - &&. (query ^. QueryUser) `notIn` SQL.subList_select do + (query ^. QueryUser) + `notIn` SQL.subList_select do + sub <- SQL.from $ SQL.table @Subscription + pure (sub ^. SubscriptionUser) + &&. (query ^. QueryUser) + `notIn` SQL.subList_select do sub <- SQL.from $ SQL.table @AuthorSubscription pure (sub ^. AuthorSubscriptionUser) @@ -565,8 +571,8 @@ setQueries commands = do Just query | queryRoom query == coerce (roomId command) -> pass | otherwise -> do - set_room - sendMessageToUser (author command) $ m "Because you sent your most recent message to this room, I will use this room for direct messages to you from now on." + set_room + sendMessageToUser (author command) $ m "Because you sent your most recent message to this room, I will use this room for direct messages to you from now on." _ -> do putTextLn $ "Setting Query for user " <> author command <> " to " <> coerce (roomId command) set_room @@ -595,32 +601,32 @@ resultHandler syncResult@Matrix.SyncResult{Matrix.srNextBatch, Matrix.srRooms} = (cmd,) <$> catchAll case cmd of MkCommand{command, author, args} | Text.isPrefixOf command "subscribe" - , split_args <- Text.words args - , fromMaybe False (viaNonEmpty (flip Text.isPrefixOf "user" . head) split_args) -> do - case maybeAt 1 split_args of - Nothing -> pure $ m "Please tell me a user to subscribe to." - Just user -> do - notSubbed <- hasAuthorSub author user - if notSubbed - then do - Persist.insert_ $ AuthorSubscription author user - pure $ m $ "I will now track for you all pull requests by " <> user - else pure $ m $ "Okay, but you were already subscribed to pull requests by user " <> user + , split_args <- Text.words args + , fromMaybe False (viaNonEmpty (flip Text.isPrefixOf "user" . head) split_args) -> do + case maybeAt 1 split_args of + Nothing -> pure $ m "Please tell me a user to subscribe to." + Just user -> do + notSubbed <- hasAuthorSub author user + if notSubbed + then do + Persist.insert_ $ AuthorSubscription author user + pure $ m $ "I will now track for you all pull requests by " <> user + else pure $ m $ "Okay, but you were already subscribed to pull requests by user " <> user MkCommand{command, author, args} | Text.isPrefixOf command "unsubscribe" - , split_args <- Text.words args - , fromMaybe False (viaNonEmpty (flip Text.isPrefixOf "user" . head) split_args) -> do - case maybeAt 1 split_args of - Nothing -> pure $ m "Please tell me a user to unsubscribe from." - Just user -> do - notSubbed <- hasAuthorSub author user - if notSubbed - then pure $ m $ "I haven‘t been tracking pull requests by " <> user <> " for you." - else do - SQL.delete $ do - author_sub <- SQL.from $ SQL.table @AuthorSubscription - SQL.where_ (author_sub ^. AuthorSubscriptionUser ==. SQL.val author &&. author_sub ^. AuthorSubscriptionGithubLogin ==. SQL.val user) - pure $ m $ "I will not subscribe you automatically to new pull requests by user " <> user <> " anymore." + , split_args <- Text.words args + , fromMaybe False (viaNonEmpty (flip Text.isPrefixOf "user" . head) split_args) -> do + case maybeAt 1 split_args of + Nothing -> pure $ m "Please tell me a user to unsubscribe from." + Just user -> do + notSubbed <- hasAuthorSub author user + if notSubbed + then pure $ m $ "I haven‘t been tracking pull requests by " <> user <> " for you." + else do + SQL.delete $ do + author_sub <- SQL.from $ SQL.table @AuthorSubscription + SQL.where_ (author_sub ^. AuthorSubscriptionUser ==. SQL.val author &&. author_sub ^. AuthorSubscriptionGithubLogin ==. SQL.val user) + pure $ m $ "I will not subscribe you automatically to new pull requests by user " <> user <> " anymore." MkCommand{command, author, args} | Text.isPrefixOf command "subscribe" -> case parsePRNumber args of Nothing -> pure $ m $ "I could not parse \"" <> args <> "\" as a pull request number. Have you maybe mistyped it?" @@ -644,7 +650,7 @@ resultHandler syncResult@Matrix.SyncResult{Matrix.srNextBatch, Matrix.srRooms} = case pr_msg_may of Just prMsg | notSubbed -> - pure $ m "Well, you were not subscribed to pull request " <> prMsg + pure $ m "Well, you were not subscribed to pull request " <> prMsg Just prMsg -> do Persist.delete $ SubscriptionKey author pr_key pure $ m "Okay, I will not send you updates about pull request " <> prMsg diff --git a/apps/nixpkgs-bot/lib/NixpkgsBot/GraphQL/API.hs b/apps/nixpkgs-bot/lib/NixpkgsBot/GraphQL/API.hs index f9ae6e7e..fb17b64b 100644 --- a/apps/nixpkgs-bot/lib/NixpkgsBot/GraphQL/API.hs +++ b/apps/nixpkgs-bot/lib/NixpkgsBot/GraphQL/API.hs @@ -14,7 +14,7 @@ import Data.GraphQL.Bootstrap import NixpkgsBot.GraphQL.Scalars {----------------------------------------------------------------------------- -* MergingPullRequest +\* MergingPullRequest -- result :: Object MergingPullRequestSchema; throws a GraphQL exception on errors result <- runQuery MergingPullRequestQuery @@ -113,7 +113,7 @@ instance GraphQLQuery MergingPullRequestQuery where ] {----------------------------------------------------------------------------- -* PullRequest +\* PullRequest -- result :: Object PullRequestSchema; throws a GraphQL exception on errors result <- runQuery PullRequestQuery