Formatting
This commit is contained in:
parent
bd3186e144
commit
0108f1ee7f
5
.hlint.yaml
Normal file
5
.hlint.yaml
Normal file
|
@ -0,0 +1,5 @@
|
|||
- arguments:
|
||||
- -XRecursiveDo
|
||||
- -XQuasiQuotes
|
||||
- ignore:
|
||||
name: Eta reduce
|
|
@ -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."
|
||||
|
|
|
@ -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;
|
||||
};
|
||||
}
|
||||
)
|
||||
|
|
|
@ -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")
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.<suffix>.<port>" and ".on-remove.<suffix>.<port>"
|
||||
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.<suffix>.<port>" and ".on-remove.<suffix>.<port>"
|
||||
, createHooksOnStart :: Bool
|
||||
-- ^ Ensure existence of taskwarrior hook on every start
|
||||
, removeHooksOnExit :: Bool
|
||||
-- ^ Remove hook on exit.
|
||||
}
|
||||
| GitBackend
|
||||
{ directoryPath :: Text
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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])
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 ::
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ""
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -1 +1 @@
|
|||
(import ./. { }).shells.ghc
|
||||
(import ./. {}).shells.ghc
|
||||
|
|
|
@ -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
|
||||
'';
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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|<br>\n<hr>\n|] (messageToHtml <$> messages)
|
||||
content = T.intercalate [i|<br>\n<hr>\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 "<br>\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 "<br>\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 "<br>\n"
|
||||
$ ((\(name, content) -> [i|<b>#{name}:</b> #{content}|]) <$> headers)
|
||||
<> one (bodyToHtml body)
|
||||
messageToHtml Message{headers, body} =
|
||||
T.intercalate "<br>\n" $
|
||||
((\(name, content) -> [i|<b>#{name}:</b> #{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 "<br>\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 =
|
||||
|
|
|
@ -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" $ ["<h3>" <> wlDate (head ls) <> "</h3>"] <> toList
|
||||
(printRow <$> zip (WeechatLine "" "" "" "" :| toList ls) ls)
|
||||
intercalate "\n" $
|
||||
["<h3>" <> wlDate (head ls) <> "</h3>"]
|
||||
<> toList
|
||||
(printRow <$> zip (WeechatLine "" "" "" "" :| toList ls) ls)
|
||||
printRow :: (WeechatLine, WeechatLine) -> Text
|
||||
printRow (prevRow, curRow) =
|
||||
"<i>" <> time <> "</i> <b>" <> printNick <> "</b> " <> message <> "<br>"
|
||||
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 == '>'
|
||||
= "|<i style='color: grey'>" <> escape (Text.tail msg) <> "</i>"
|
||||
| otherwise
|
||||
= escape msg
|
||||
| not (Text.null msg) && Text.head msg == '>' =
|
||||
"|<i style='color: grey'>" <> escape (Text.tail msg) <> "</i>"
|
||||
| otherwise =
|
||||
escape msg
|
||||
specialNick = (`elem` ["-->", "<--", "--", "*"])
|
||||
escape = replace "<" "<" . replace ">" ">"
|
||||
escape = replace "<" "<" . replace ">" ">"
|
||||
|
|
|
@ -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));}
|
||||
|
|
|
@ -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;
|
||||
};
|
||||
}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue