maralorn/nixos-config
1
0
Fork 0
Code Wiki Activity

Formatting

Browse source
This commit is contained in:
Malte 2023-01-16 02:18:18 +01:00
parent bd3186e144
commit 0108f1ee7f
24 changed files with 626 additions and 537 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
.hlint.yaml Normal file
View file

@ -0,0 +1,5 @@
- arguments:
- -XRecursiveDo
- -XQuasiQuotes
- ignore:
name: Eta reduce

10
apps/kassandra/backend/src/Backend.hs
View file

@ -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."

304
apps/kassandra/default.nix
View file

@ -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;
};
}
)

5
apps/kassandra/frontend/src/Frontend.hs
View file

@ -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")

4
apps/kassandra/frontend/src/Frontend/Route.hs
View file

@ -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

34
apps/kassandra/kassandra/src/Kassandra/Config.hs
View file

@ -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

34
apps/kassandra/kassandra/src/Kassandra/Css.hs
View file

@ -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

9
apps/kassandra/kassandra/src/Kassandra/Debug.hs
View file

@ -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])

23
apps/kassandra/kassandra/src/Kassandra/MainWidget.hs
View file

@ -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)

48
apps/kassandra/kassandra/src/Kassandra/ReflexUtil.hs
View file

@ -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 ::

6
apps/kassandra/kassandra/src/Kassandra/RemoteBackendWidget.hs
View file

@ -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)

28
apps/kassandra/kassandra/src/Kassandra/Sorting.hs
View file

@ -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

27
apps/kassandra/kassandra/src/Kassandra/TaskWidget.hs
View file

@ -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 ""

19
apps/kassandra/kassandra/src/Prelude.hs
View file

@ -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]

2
apps/kassandra/obelisk-shell.nix
View file

@ -1 +1 @@
(import ./. { }).shells.ghc
(import ./. {}).shells.ghc

14
apps/kassandra/release.nix
View file

@ -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
'';

19
apps/kassandra/standalone/src/Kassandra/Backend/Calendar.hs
View file

@ -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

9
apps/kassandra/standalone/src/Kassandra/Standalone/Config.hs
View file

@ -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)

287
apps/logfeed/Mail.hs
View file

@ -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 =

173
apps/logfeed/Main.hs
View file

@ -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 "<" "&lt;" . replace ">" "&gt;"
escape = replace "<" "&lt;" . replace ">" "&gt;"

8
apps/logfeed/default.nix
View file

@ -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));}

19
apps/logfeed/shell.nix
View file

@ -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;
};
}

72
apps/nixpkgs-bot/exe/Main.hs
View file

@ -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

4
apps/nixpkgs-bot/lib/NixpkgsBot/GraphQL/API.hs
View file

@ -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