1
0
Fork 0

Formatting

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

5
.hlint.yaml Normal file
View file

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

View file

@ -1,18 +1,22 @@
{ obelisk ? import ./.obelisk/impl {
{
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
project ./. (
{pkgs, ...}: let
inherit
(pkgs.haskell.lib)
markUnbroken
dontCheck
addBuildDepend
doJailbreak
overrideCabal
;
in
{
in {
android = {
applicationId = "de.maralorn.kassandra";
displayName = "Kassandra";
@ -24,124 +28,138 @@ project ./. (
};
};
overrides = self: super: {
kassandra = overrideCabal super.kassandra { doHaddock = false; };
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" { });
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
streamly-bytestring =
self.callHackageDirect
{
pkg = "streamly-bytestring";
ver = "0.1.2";
sha256 = "08xhp8zgf5n1j4v1br1dz9ih8j05vk92swp3nz9in5xajllkc7qv";
}
{ };
streamly = self.callHackageDirect
{};
streamly =
self.callHackageDirect
{
pkg = "streamly";
ver = "0.7.0";
sha256 = "0hr2cz14w6nnbvhnq1fvr8v4rzyqcj3b9khf2rszyji00fmp27l1";
}
{ };
nonempty-vector = self.callHackageDirect
{};
nonempty-vector =
self.callHackageDirect
{
pkg = "nonempty-vector";
ver = "0.1.0.0";
sha256 = "06abdmdy9z0w6ishiibir3qfjpqxmb4mrkhgyc4j58hd14s8rj0x";
}
{ };
nonempty-containers = self.callHackageDirect
{};
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
prettyprinter =
self.callHackageDirect
{
pkg = "prettyprinter";
ver = "1.5.1";
sha256 = "0wx01rvgwnnmg10sh9x2whif5z12058w5djh7m5swz94wvkg5cg3";
}
{ };
cborg-json = self.callHackageDirect
{};
cborg-json =
self.callHackageDirect
{
pkg = "cborg-json";
ver = "0.2.2.0";
sha256 = "1s7pv3jz8s1qb0ydcc5nra9f63jp4ay4d0vncv919bakf8snj4vw";
}
{ };
generic-random = self.callHackageDirect
{};
generic-random =
self.callHackageDirect
{
pkg = "generic-random";
ver = "1.3.0.0";
sha256 = "0m7lb40wgmyszv8l6qmarkfgs8r0idgl9agwsi72236hpvp353ad";
}
{ };
atomic-write = self.callHackageDirect
{};
atomic-write =
self.callHackageDirect
{
pkg = "atomic-write";
ver = "0.2.0.7";
sha256 = "1r9ckwljdbw3mi8rmzmsnh89z8nhw2qnds9n271gkjgavb6hxxf3";
}
{ };
taskwarrior = self.callHackageDirect
{};
taskwarrior =
self.callHackageDirect
{
pkg = "taskwarrior";
ver = "0.5.0.0";
sha256 = "sha256-elDUtz0NSG4WHxkyCQ1CunYXWIVRj6EqkKSchPy+c3E=";
}
{ };
base64 = self.callHackageDirect
{};
base64 =
self.callHackageDirect
{
pkg = "base64";
ver = "0.4.1";
sha256 = "1pz9s8bmnkrrr3v5mhkwv8vaf251vmxs87zzc5nsjsa027j9lr22";
}
{ };
password = self.callHackageDirect
{};
password =
self.callHackageDirect
{
pkg = "password";
ver = "2.0.1.0";
sha256 = "1q99v7w6bdfpnw245aa3zaj3x7mhl9i2y7f2rzlc30g066p9jhaz";
}
{ };
indexed-profunctors = self.callHackageDirect
{};
indexed-profunctors =
self.callHackageDirect
{
pkg = "indexed-profunctors";
ver = "0.1";
sha256 = "0vpgbymfhnvip90jwvyniqi34lhz5n3ni1f21g81n5rap0q140za";
}
{ };
generic-lens-core = self.callHackageDirect
{};
generic-lens-core =
self.callHackageDirect
{
pkg = "generic-lens-core";
ver = "2.0.0.0";
sha256 = "07parw0frqxxkjbbas9m9xb3pmpqrx9wz63m35wa6xqng9vlcscm";
}
{ };
generic-optics = self.callHackageDirect
{};
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" { };
{};
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;
};
}
)
)

View file

@ -28,7 +28,8 @@ frontend =
}
frontendBody :: WidgetJSM t m => m ()
frontendBody = D.dyn_ . fmap (maybe pass mainWidget)
frontendBody =
D.dyn_ . fmap (maybe pass mainWidget)
=<< remoteBackendWidget (wrap D.never) Nothing
css = cssAsText (static @"MaterialIcons-Regular-Outlined.otf")

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

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

View file

@ -31,7 +31,8 @@ css fontPath = do
fontFace $ do
fontFamily [fontName] []
fontFaceSrc [FontFaceSrcUrl fontSrc (Just OpenType)]
let --darkBlue = rgb 0 0 33
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)
@ -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
active
& i ? do
background black

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

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,10 +183,13 @@ 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
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

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
@ -31,25 +32,26 @@ 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
-- | 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 ()) ->

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

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

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,8 +208,8 @@ dropChildWidget = do
(icon "dropHere plusOne" "block")
$ fmap
( \dependencies ->
one $
#depends
one
$ #depends
%~ Set.union (Set.fromList $ toList $ (^. #uuid) <$> dependencies)
$ taskInfos
^. #task
@ -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 ""

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)

View file

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

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

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,8 +121,8 @@ 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)
@ -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

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)

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 Control.Error (
throwE,
tryJust,
tryRight,
withExceptT,
)
import qualified Data.Text as T
import Control.Monad.Catch ( MonadCatch
, handleIOError
import Control.Lens hiding (argument)
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 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
@ -62,7 +65,9 @@ data Message = Message
main :: IO ()
main = do
Options { dbPath, folder } <- O.execParser $ O.info
Options{dbPath, folder} <-
O.execParser $
O.info
( Options
<$> O.argument
O.str
@ -77,43 +82,50 @@ main = do
O.fullDesc
res <- runExceptT do
(thrds, msgs) <- withExceptT
(\(er :: Notmuch.Status) ->
( \(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)
(,) <$> Notmuch.threads q <*> Notmuch.messages q
msgsByThread <- forM msgs \msg -> Notmuch.threadId msg <&> (, Right msg)
thrdsByThread <- forM thrds \thrd -> Notmuch.threadId thrd <&> (, Left thrd)
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
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}|]
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 :))
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) ->
( \(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}|]
@ -121,11 +133,14 @@ threadToEntry Thread { subject, messages, threadid, totalCount, date, authors }
content = T.intercalate [i|<br>\n<hr>\n|] (messageToHtml <$> messages)
errorsToEntry :: UTCTime -> [Error] -> Entry
errorsToEntry now er = (nullEntry [i|mailerrors - #{timestamp now}|]
errorsToEntry now er =
( nullEntry
[i|mailerrors - #{timestamp now}|]
(TextString [i|Mail processing Errors|])
(timestamp now)
)
{ entryContent = Just
{ entryContent =
Just
. HTMLContent
. T.intercalate "<br>\n"
. T.splitOn "\n"
@ -136,12 +151,12 @@ errorsToEntry now er = (nullEntry [i|mailerrors - #{timestamp now}|]
timestamp :: UTCTime -> Text
timestamp = toText . formatTime defaultTimeLocale "%Y-%m-%d %H:%M"
processThread
:: (MonadIO m, MonadCatch m)
=> ( Notmuch.ThreadId
processThread ::
(MonadIO m, MonadCatch m) =>
( Notmuch.ThreadId
, NonEmpty (Either (Notmuch.Thread a) (Notmuch.Message n a))
)
-> ExceptT Error m Thread
) ->
ExceptT Error m Thread
processThread (threadid, toList -> thrdAndMsgs) =
handleIOError (\er -> throwE [i|IOError: #{er}|]) $ do
thread <-
@ -156,18 +171,18 @@ processThread (threadid, toList -> thrdAndMsgs) =
totalCount <- Notmuch.threadTotalMessages thread
authors <- (^. Notmuch.matchedAuthors) <$> Notmuch.threadAuthors thread
date <- Notmuch.threadNewestDate thread
pure (Thread { subject, threadid, messages, totalCount, authors, date })
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)
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
@ -179,30 +194,36 @@ processMessage msg = do
toField <- tryHdr "to" msg
cc <- tryHdr "cc" msg
unsub <- tryHdr "list-unsubscribe" msg
let hdrs = mapMaybe
(\(x, a) -> (x, ) <$> a)
let hdrs =
mapMaybe
(\(x, a) -> (x,) <$> a)
[ ("Subject", subject)
, ("From" , fromField)
, ("To" , toField)
, ("Cc" , cc)
, ("Date" , Just (timestamp date))
, ("Unsubscribe" , unsub)
, ("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
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
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 =

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.List.NonEmpty (
groupBy,
zip,
)
import Data.String.Interpolate ( i )
import Data.Text ( intercalate
, replace
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 Relude hiding (
intercalate,
zip,
)
import System.Environment ()
import System.FilePattern.Directory ( getDirectoryFiles )
import System.FilePattern.Directory (getDirectoryFiles)
import Text.Atom.Feed
import Text.Atom.Feed.Export ( textFeed )
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]
@ -34,6 +46,7 @@ data WeechatLine = WeechatLine
, wlMsg :: Text
}
deriving (Show, Eq, Ord)
-- TODO: specific handling of join/part/network messages
data LogFile = LogFile
@ -101,7 +114,8 @@ logFolder = "/home/maralorn/logs/"
main :: IO ()
main = do
now <- T.getCurrentTime
let getFiles t p = L.groupSortOn (\x -> (channel x, server x))
let getFiles t p =
L.groupSortOn (\x -> (channel x, server x))
. mapMaybe ((\x -> MP.parseMaybe (p x) x) . toText)
<$> getDirectoryFiles
(toString logFolder)
@ -112,12 +126,14 @@ main = do
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}|]
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,9 +145,12 @@ 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}|]
then
Just
( nullEntry
[i|#{logserver}-#{logchannel}-#{timestamp now}|]
(TextString [i|#{logchannel} - (#{logserver})|])
(timestamp now)
)
@ -155,15 +174,15 @@ readLogFiles files =
readLogFile (head files)
<$> mapM (readFileText . toString . (logFolder <>) . path) files
readLogFile :: LogFile -> NonEmpty Text -> Log
readLogFile LogFile { channel, server } contents = Log
readLogFile LogFile{channel, server} contents =
Log
{ logchannel = channel
, logserver = server
, messages = L.sortOn (\x -> (wlDate x, wlTime x))
. concat
$ parseWeechatLog
<$> contents
, messages =
L.sortOn (\x -> (wlDate x, wlTime x))
. concatMap parseWeechatLog
$ contents
}
parseWeechatLine :: Parser WeechatLine
@ -186,7 +205,9 @@ printHTML log = intercalate "\n" $ map printDay days
where
days = groupBy ((==) `on` wlDate) log
printDay ls =
intercalate "\n" $ ["<h3>" <> wlDate (head ls) <> "</h3>"] <> toList
intercalate "\n" $
["<h3>" <> wlDate (head ls) <> "</h3>"]
<> toList
(printRow <$> zip (WeechatLine "" "" "" "" :| toList ls) ls)
printRow :: (WeechatLine, WeechatLine) -> Text
printRow (prevRow, curRow) =
@ -196,17 +217,19 @@ printHTML log = intercalate "\n" $ map printDay days
curTime = Text.take 5 $ wlTime curRow
prevNick = wlNick prevRow
curNick = wlNick curRow
time | prevTime == curTime = ""
time
| prevTime == curTime = ""
| otherwise = curTime
nick | specialNick curNick = curNick
nick
| specialNick curNick = curNick
| prevNick == curNick = ""
| otherwise = curNick
printNick = Text.dropWhile (`elem` ['&', '@']) nick
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;"

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

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 {
haskellPackages.shellFor {
withHoogle = true;
packages = p: [ (import ./. { inherit pkgs; }) ];
packages = p: [(import ./. {inherit pkgs;})];
buildInputs = builtins.attrValues {
inherit (haskellPackages) hlint cabal-install notmuch hsemail;
inherit (pkgs) coreutils zlib;
};
}
}

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
(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 @AuthorSubscription
pure (sub ^. AuthorSubscriptionUser)

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