helic (empty) → 0.1.0.0

raw patch · 40 files changed

+2089/−0 lines, 40 filesdep +aesondep +basedep +chronos

Dependencies added: aeson, base, chronos, containers, data-default, either, exon, gi-gdk, gi-gtk, helic, hostname, http-client, http-client-tls, optparse-applicative, path, path-io, polysemy, polysemy-chronos, polysemy-conc, polysemy-http, polysemy-log, polysemy-plugin, polysemy-process, polysemy-resume, polysemy-test, polysemy-time, relude, servant, servant-client, servant-client-core, servant-server, tasty, template-haskell, text, torsor, typed-process, unix, wai, wai-extra, warp, yaml

Files

• LICENSE +34/−0
• app/Main.hs +7/−0
• changelog.md +5/−0
• helic.cabal +325/−0
• lib/Helic.hs +56/−0
• lib/Helic/Cli.hs +132/−0
• lib/Helic/Cli/Options.hs +71/−0
• lib/Helic/Config/File.hs +54/−0
• lib/Helic/Data/AgentId.hs +10/−0
• lib/Helic/Data/Config.hs +18/−0
• lib/Helic/Data/Event.hs +36/−0
• lib/Helic/Data/GtkState.hs +14/−0
• lib/Helic/Data/Host.hs +10/−0
• lib/Helic/Data/InstanceName.hs +10/−0
• lib/Helic/Data/NetConfig.hs +23/−0
• lib/Helic/Data/Selection.hs +11/−0
• lib/Helic/Data/TmuxConfig.hs +15/−0
• lib/Helic/Data/XClipboardEvent.hs +12/−0
• lib/Helic/Data/YankConfig.hs +10/−0
• lib/Helic/Effect/Agent.hs +59/−0
• lib/Helic/Effect/XClipboard.hs +16/−0
• lib/Helic/Gtk.hs +81/−0
• lib/Helic/Interpreter/AgentNet.hs +31/−0
• lib/Helic/Interpreter/AgentTmux.hs +43/−0
• lib/Helic/Interpreter/AgentX.hs +42/−0
• lib/Helic/Interpreter/InstanceName.hs +32/−0
• lib/Helic/Interpreter/XClipboard.hs +81/−0
• lib/Helic/Listen.hs +103/−0
• lib/Helic/Net/Api.hs +56/−0
• lib/Helic/Net/Client.hs +40/−0
• lib/Helic/Net/Server.hs +85/−0
• lib/Helic/Prelude.hs +171/−0
• lib/Helic/Prelude/Debug.hs +103/−0
• lib/Helic/Tmux.hs +24/−0
• lib/Helic/Yank.hs +28/−0
• lib/Prelude.hs +9/−0
• readme.md +151/−0
• test/Helic/Test/ConfigFileTest.hs +27/−0
• test/Helic/Test/InsertEventTest.hs +39/−0
• test/Main.hs +15/−0

@@ -0,0 +1,34 @@+Copyright (c) 2021 Torsten Schmits++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met:++  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+  disclaimer.+  2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following+  disclaimer in the documentation and/or other materials provided with the distribution.++Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:++  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.++Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise.++DISCLAIMER++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,7 @@+module Main where++import Helic.Cli (app)++main :: IO ()+main =+  app

@@ -0,0 +1,5 @@+# Unreleased++# 0.1.0.0++* Initial release

@@ -0,0 +1,325 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           helic+version:        0.1.0.0+synopsis:       Clipboard Manager+description:    See <https://hackage.haskell.org/package/helic/docs/Helic.html>+category:       Clipboard+author:         Torsten Schmits+maintainer:     hackage@tryp.io+copyright:      2021 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    readme.md+    changelog.md++library+  exposed-modules:+      Helic+      Helic.Cli+      Helic.Cli.Options+      Helic.Config.File+      Helic.Data.AgentId+      Helic.Data.Config+      Helic.Data.Event+      Helic.Data.GtkState+      Helic.Data.Host+      Helic.Data.InstanceName+      Helic.Data.NetConfig+      Helic.Data.Selection+      Helic.Data.TmuxConfig+      Helic.Data.XClipboardEvent+      Helic.Data.YankConfig+      Helic.Effect.Agent+      Helic.Effect.XClipboard+      Helic.Gtk+      Helic.Interpreter.AgentNet+      Helic.Interpreter.AgentTmux+      Helic.Interpreter.AgentX+      Helic.Interpreter.InstanceName+      Helic.Interpreter.XClipboard+      Helic.Listen+      Helic.Net.Api+      Helic.Net.Client+      Helic.Net.Server+      Helic.Prelude+      Helic.Prelude.Debug+      Helic.Tmux+      Helic.Yank+  other-modules:+      Prelude+      Paths_helic+  autogen-modules:+      Paths_helic+  hs-source-dirs:+      lib+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      OverloadedLists+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wunused-packages -fplugin=Polysemy.Plugin+  build-depends:+      aeson >=1.4+    , base ==4.*+    , chronos >=1.1.1+    , containers+    , data-default >=0.2+    , either >=5+    , exon >=0.2.0.1+    , gi-gdk >=3+    , gi-gtk >=3+    , hostname >=1+    , http-client >=0.5.14+    , http-client-tls >=0.3.1+    , optparse-applicative >=0.16+    , path+    , path-io+    , polysemy >=1.6+    , polysemy-chronos >=0.2.0.1+    , polysemy-conc >=0.5+    , polysemy-http >=0.5+    , polysemy-log >=0.4+    , polysemy-plugin >=0.4+    , polysemy-process >=0.5+    , polysemy-resume >=0.2+    , polysemy-time >=0.1.4+    , relude >=0.7+    , servant >=0.18+    , servant-client >=0.18+    , servant-client-core >=0.18+    , servant-server >=0.18+    , template-haskell+    , text+    , typed-process >=0.2.6+    , unix+    , wai >=3.2+    , wai-extra >=3.1+    , warp >=3.3+    , yaml >=0.11+  mixins:+      base hiding (Prelude)+  default-language: Haskell2010++executable hel+  main-is: Main.hs+  other-modules:+      Paths_helic+  hs-source-dirs:+      app+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      OverloadedLists+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wunused-packages -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base ==4.*+    , helic+    , polysemy+    , polysemy-plugin+  mixins:+      base hiding (Prelude)+    , helic hiding (Helic.Prelude)+    , helic (Helic.Prelude as Prelude)+  default-language: Haskell2010++test-suite helic-unit+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Helic.Test.ConfigFileTest+      Helic.Test.InsertEventTest+      Paths_helic+  hs-source-dirs:+      test+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      OverloadedLists+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wunused-packages -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base ==4.*+    , chronos+    , containers+    , helic+    , path+    , polysemy+    , polysemy-chronos+    , polysemy-log+    , polysemy-plugin+    , polysemy-test+    , polysemy-time+    , tasty+    , torsor+  mixins:+      base hiding (Prelude)+    , helic hiding (Helic.Prelude)+    , helic (Helic.Prelude as Prelude)+  default-language: Haskell2010

@@ -0,0 +1,56 @@+-- |A clipboard management CLI tool built with Polysemy, Servant and GI.Gtk.+module Helic (+  -- $intro+  --+  -- * Effects+  -- ** Agent+  Agent,+  AgentTag,+  Agents,+  -- ** XClipboard+  XClipboard,++  -- * Interpreters+  interpretAgentNet,+  interpretAgentX,+  interpretAgentTmux,+  interpretXClipboardGtk,++  -- * Data+  Event,++  -- * Utilities+  transformXEvents,+  withMainLoop,+  subscribeToClipboard,+  clipboardEvents,+  listenXClipboard,+  Api,+  serve,+  listen,+  yank,++) where++import Helic.Data.Event (Event)+import Helic.Effect.Agent (Agent, AgentTag, Agents)+import Helic.Effect.XClipboard (XClipboard)+import Helic.Interpreter.AgentNet (interpretAgentNet)+import Helic.Interpreter.AgentTmux (interpretAgentTmux)+import Helic.Interpreter.AgentX (interpretAgentX, transformXEvents)+import Helic.Interpreter.XClipboard (+  clipboardEvents,+  interpretXClipboardGtk,+  listenXClipboard,+  subscribeToClipboard,+  withMainLoop,+  )+import Helic.Listen (listen)+import Helic.Net.Api (Api, serve)+import Helic.Yank (yank)++-- $intro+-- /Helic/ is primarily a CLI tool that listens for clipboard events and broadcasts them to other hosts and tmux.+--+-- The program is built with Polysemy, so its effects and interpreters may be useful for other developers.+-- Some utilities for interfacing with GTK are exposed as well.

@@ -0,0 +1,132 @@+{-# options_haddock prune #-}+-- |CLI, Internal+module Helic.Cli where++import Options.Applicative (customExecParser, fullDesc, header, helper, info, prefs, showHelpOnEmpty, showHelpOnError)+import Polysemy.Chronos (ChronosTime, interpretTimeChronos)+import qualified Polysemy.Conc as Conc+import Polysemy.Conc (+  Critical,+  Interrupt,+  interpretAtomic,+  interpretCritical,+  interpretEventsChan,+  interpretInterrupt,+  interpretRace,+  )+import Polysemy.Error (errorToIOFinal)+import Polysemy.Http.Interpreter.Manager (interpretManager)+import qualified Polysemy.Log as Log+import Polysemy.Log (Log, Severity (Info), interpretLogStdoutLevelConc)+import Polysemy.Reader (runReader)+import Polysemy.Time (MilliSeconds (MilliSeconds))+import System.IO (hLookAhead)++import Helic.Cli.Options (Command (Listen, Yank), Conf (Conf), parser)+import Helic.Config.File (findFileConfig)+import Helic.Data.Config (Config (Config))+import Helic.Data.Event (Event)+import Helic.Data.XClipboardEvent (XClipboardEvent)+import Helic.Data.YankConfig (YankConfig (YankConfig))+import Helic.Interpreter.AgentNet (interpretAgentNet)+import Helic.Interpreter.AgentTmux (interpretAgentTmux)+import Helic.Interpreter.AgentX (interpretAgentX)+import Helic.Interpreter.InstanceName (interpretInstanceName)+import Helic.Interpreter.XClipboard (interpretXClipboardGtk, listenXClipboard)+import Helic.Listen (listen)+import Helic.Yank (yank)++logError ::+  Members [Log, Final IO] r =>+  Sem (Error Text : r) () ->+  Sem r ()+logError sem =+  errorToIOFinal sem >>= \case+    Right () -> unit+    Left err -> Log.error err++type IOStack =+  [+    Error Text,+    Interrupt,+    Critical,+    Log,+    ChronosTime,+    Race,+    Async,+    Resource,+    Embed IO,+    Final IO+  ]++runIO ::+  Bool ->+  Sem IOStack () ->+  IO ()+runIO verbose =+  runFinal .+  embedToFinal .+  resourceToIOFinal .+  asyncToIOFinal .+  interpretRace .+  interpretTimeChronos .+  interpretLogStdoutLevelConc (if verbose then Nothing else Just Info) .+  interpretCritical .+  interpretInterrupt .+  logError++listenApp ::+  Config ->+  Sem IOStack ()+listenApp (Config name tmux net maxHistory) =+  runReader (fromMaybe def tmux) $+  runReader (fromMaybe def net) $+  interpretEventsChan @XClipboardEvent $+  interpretEventsChan @Event $+  interpretAtomic mempty $+  interpretInstanceName name $+  interpretManager $+  listenXClipboard $+  interpretXClipboardGtk $+  interpretAgentX $+  interpretAgentNet $+  interpretAgentTmux $+  listen maxHistory++yankApp ::+  Config ->+  YankConfig ->+  Sem IOStack ()+yankApp (Config name _ net _) yankConf =+  interpretManager $+  interpretInstanceName name $+  yank (fromMaybe def net) yankConf++runCommand :: Config -> Command -> Sem IOStack ()+runCommand config = \case+  Listen ->+    listenApp config+  Yank yankConf ->+    yankApp config yankConf++defaultCommand :: Sem IOStack Command+defaultCommand = do+  Conc.timeout_ (pure Nothing) (MilliSeconds 100) (Just <$> tryAny (hLookAhead stdin)) <&> \case+    Just (Right _) -> Yank (YankConfig (Just "cli"))+    _ -> Listen++withCliOptions :: Conf -> Maybe Command -> IO ()+withCliOptions (Conf verbose file) cmd =+  runIO verbose do+    config <- findFileConfig file+    runCommand config =<< maybe defaultCommand pure cmd++app :: IO ()+app = do+  (conf, cmd) <- customExecParser parserPrefs (info (parser <**> helper) desc)+  withCliOptions conf cmd+  where+    parserPrefs =+      prefs (showHelpOnEmpty <> showHelpOnError)+    desc =+      fullDesc <> header "Helic is a clipboard synchronization tool."

@@ -0,0 +1,71 @@+{-# options_haddock prune #-}+-- |CLI Options, Internal+module Helic.Cli.Options where++import Options.Applicative (+  CommandFields,+  Mod,+  Parser,+  ReadM,+  command,+  help,+  hsubparser,+  info,+  long,+  option,+  progDesc,+  readerError,+  strOption,+  switch,+  )+import Options.Applicative.Types (readerAsk)+import Path (Abs, File, Path, parseAbsFile)++import Helic.Data.YankConfig (YankConfig (YankConfig))++data Conf =+  Conf {+    verbose :: Bool,+    configFile :: Maybe (Path Abs File)+  }+  deriving stock (Eq, Show)++data Command =+  Listen+  |+  Yank YankConfig+  deriving stock (Eq, Show)++filePathOption :: ReadM (Path Abs File)+filePathOption = do+  raw <- readerAsk+  either (const (readerError [exon|not an absolute file path: #{show raw}|])) pure (parseAbsFile raw)++confParser :: Parser Conf+confParser = do+  verbose <- switch (long "verbose")+  configFile <- optional (option filePathOption (long "config-file"))+  pure (Conf verbose configFile)++listenCommand :: Mod CommandFields Command+listenCommand =+  command "listen" (info (pure Listen) (progDesc "Run the daemon"))++yankParser :: Parser YankConfig+yankParser =+  YankConfig <$> optional (strOption (long "agent" <> help "Source of the yank"))++yankCommand :: Mod CommandFields Command+yankCommand =+  command "yank" (Yank <$> info yankParser (progDesc "Send stdin to the daemon"))++commands :: [Mod CommandFields Command]+commands =+  [+    listenCommand,+    yankCommand+  ]++parser :: Parser (Conf, Maybe Command)+parser =+  (,) <$> confParser <*> optional (hsubparser (mconcat commands))

@@ -0,0 +1,54 @@+{-# options_haddock prune #-}+-- |Config File Parsing, Internal+module Helic.Config.File where++import Data.Yaml (decodeFileEither, prettyPrintParseException)+import Path (Abs, File, Path, Rel, absfile, relfile, toFilePath, (</>))+import Path.IO (XdgDirectory (XdgConfig), doesFileExist, getXdgDir)+import qualified Polysemy.Log as Log+import Polysemy.Log (Log)++import Helic.Data.Config (Config)++parseFileConfig ::+  Members [Log, Error Text, Embed IO] r =>+  Path Abs File ->+  Sem r Config+parseFileConfig (toFilePath -> path) = do+  Log.info [exon|Reading config file #{toText path}|]+  fromEither =<< mapLeft formatError <$> embed (decodeFileEither path)+  where+    formatError exc =+      toText [exon|invalid config file: #{prettyPrintParseException exc}|]++findConfigPath ::+  Members [Log, Error Text, Embed IO] r =>+  Maybe (Path Abs File) ->+  Sem r (Maybe (Path Abs File))+findConfigPath = \case+  Just f ->+    doesFileExist f >>= \case+      True -> pure (Just f)+      False -> throw [exon|config file doesn't exist: #{toText (toFilePath f)}|]+  Nothing -> do+    xdgConf <- getXdgDir XdgConfig Nothing+    let+      xdgFile =+        xdgConf </> [relfile|helic.yaml|]+      etcFile =+        [absfile|/etc/helic.yaml|]+    doesFileExist xdgFile >>= \case+      True ->+        pure (Just xdgFile)+      False ->+        doesFileExist etcFile <&> \case+          True -> Just etcFile+          False -> Nothing++findFileConfig ::+  Members [Log, Error Text, Embed IO] r =>+  Maybe (Path Abs File) ->+  Sem r Config+findFileConfig cliFile = do+  f <- findConfigPath cliFile+  maybe (pure def) parseFileConfig f

@@ -0,0 +1,10 @@+{-# options_haddock prune #-}+-- |AgentId Data Type, Internal+module Helic.Data.AgentId where++newtype AgentId =+  AgentId { unAgentId :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString)++defaultJson ''AgentId

@@ -0,0 +1,18 @@+{-# options_haddock prune #-}+-- |Config Data Type, Internal+module Helic.Data.Config where++import Helic.Data.NetConfig (NetConfig)+import Helic.Data.TmuxConfig (TmuxConfig)++data Config =+  Config {+    name :: Maybe Text,+    tmux :: Maybe TmuxConfig,+    net :: Maybe NetConfig,+    maxHistory :: Maybe Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Default)++defaultJson ''Config

@@ -0,0 +1,36 @@+-- |Event Data Type+module Helic.Data.Event where++import qualified Chronos+import Polysemy.Chronos (ChronosTime)+import qualified Polysemy.Time as Time++import Helic.Data.AgentId (AgentId)+import Helic.Data.InstanceName (InstanceName)++-- |The central data type representing a clipboard event.+data Event =+  Event {+    -- |The host from which the event originated.+    sender :: InstanceName,+    -- |The entity that caused the event.+    source :: AgentId,+    -- |Timestamp.+    time :: Chronos.Time,+    -- |Payload.+    content :: Text+  }+  deriving stock (Eq, Show)++defaultJson ''Event++-- |Construct an event for the current host and time.+now ::+  Members [ChronosTime, Reader InstanceName] r =>+  AgentId ->+  Text ->+  Sem r Event+now source content = do+  sender <- ask+  time <- Time.now+  pure Event {..}

@@ -0,0 +1,14 @@+{-# options_haddock prune #-}+-- |GtkState Data Type, Internal+module Helic.Data.GtkState where++import GI.Gdk (Display)+import GI.Gtk (Clipboard)++data GtkState =+  GtkState {+    clipboard :: Clipboard,+    primary :: Clipboard,+    secondary :: Clipboard,+    display :: Display+  }

@@ -0,0 +1,10 @@+{-# options_haddock prune #-}+-- |Host Data Type, Internal+module Helic.Data.Host where++newtype Host =+  Host { unHost :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString)++defaultJson ''Host

@@ -0,0 +1,10 @@+{-# options_haddock prune #-}+-- |InstanceName Data Type, Internal+module Helic.Data.InstanceName where++newtype InstanceName =+  InstanceName { unInstanceName :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString)++defaultJson ''InstanceName

@@ -0,0 +1,23 @@+{-# options_haddock prune #-}+-- |NetConfig Data Type, Internal+module Helic.Data.NetConfig where++import Helic.Data.Host (Host)++newtype Timeout =+  Timeout { unTimeout :: Int }+  deriving stock (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord)++defaultJson ''Timeout++data NetConfig =+  NetConfig {+    port :: Maybe Int,+    timeout :: Maybe Timeout,+    hosts :: Maybe [Host]+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Default)++defaultJson ''NetConfig

@@ -0,0 +1,11 @@+{-# options_haddock prune #-}+-- |Selection Data Type, Internal+module Helic.Data.Selection where++data Selection =+  Clipboard+  |+  Primary+  |+  Secondary+  deriving stock (Eq, Show)

@@ -0,0 +1,15 @@+{-# options_haddock prune #-}+-- |TmuxConfig Data Type, Internal+module Helic.Data.TmuxConfig where++import Path (Abs, File, Path)++data TmuxConfig =+  TmuxConfig {+    enable :: Maybe Bool,+    exe :: Maybe (Path Abs File)+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Default)++defaultJson ''TmuxConfig

@@ -0,0 +1,12 @@+{-# options_haddock prune #-}+-- |XClipboardEvent Data Type, Internal+module Helic.Data.XClipboardEvent where++import Helic.Data.Selection (Selection)++data XClipboardEvent =+  XClipboardEvent {+    text :: Text,+    selection :: Selection+  }+  deriving stock (Eq, Show)

@@ -0,0 +1,10 @@+{-# options_haddock prune #-}+-- |YankConfig Data Type, Internal+module Helic.Data.YankConfig where++data YankConfig =+  YankConfig {+    agent :: Maybe Text+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Default)

@@ -0,0 +1,59 @@+{-# options_haddock prune #-}+-- |The Agent Effect+module Helic.Effect.Agent where++import GHC.TypeLits (KnownSymbol, symbolVal)+import Polysemy.Tagged (Tagged)++import Helic.Data.AgentId (AgentId (AgentId))+import Helic.Data.Event (Event)++-- |Used to disambiguate 'Agent's via 'Tagged'.+data AgentTag =+  AgentTag Symbol++-- |An agent is an interface to an external entity that can receive clipboard events.+-- The Helic CLI uses agents for remote hosts over network, tmux, and X11.+data Agent :: Effect where+  -- |Send an event to an agent.+  Update :: Event -> Agent m ()++makeSem ''Agent++type AgentTmux =+  'AgentTag "tmux"++type AgentX =+  'AgentTag "x"++type AgentNet =+  'AgentTag "net"++-- |The default agents for the Helic CLI.+type Agents =+  [+    Tagged AgentTmux Agent,+    Tagged AgentX Agent,+    Tagged AgentNet Agent+  ]++class AgentName (tag :: AgentTag) where+  agentName :: Text++instance (+    KnownSymbol s+  ) => AgentName ('AgentTag s) where+  agentName =+    toText (symbolVal (Proxy @s))++agentIdTmux :: AgentId+agentIdTmux =+  AgentId "tmux"++agentIdX :: AgentId+agentIdX =+  AgentId "x"++agentIdNet :: AgentId+agentIdNet =+  AgentId "net"

@@ -0,0 +1,16 @@+{-# options_haddock prune #-}+-- |The XClipboard Effect+module Helic.Effect.XClipboard where++import Helic.Data.Selection (Selection)++-- |Communicate with the X11 clipboard.+data XClipboard :: Effect where+  -- |Get the current clipboard contents, if available.+  Current :: XClipboard m (Maybe Text)+  -- |Set the clipboard contents.+  Set :: Text -> XClipboard m ()+  -- |Copy the content of the specified selection to the clipboard selection.+  Sync :: Text -> Selection -> XClipboard m ()++makeSem ''XClipboard

@@ -0,0 +1,81 @@+{-# options_haddock prune #-}+-- |GTK Helpers, Internal+module Helic.Gtk where++import qualified GI.Gdk as Gdk+import GI.Gdk (Display)+import qualified GI.Gtk as GI++import qualified Helic.Data.GtkState as GtkState+import Helic.Data.GtkState (GtkState)+import Helic.Data.Selection (Selection (Clipboard, Primary, Secondary))++gtkClipboard ::+  MonadIO m =>+  Display ->+  Text ->+  m GI.Clipboard+gtkClipboard display name = do+  selection <- Gdk.atomIntern name False+  GI.clipboardGetForDisplay display selection++subscribe ::+  MonadIO m =>+  GI.Clipboard ->+  (Text -> IO ()) ->+  m ()+subscribe clipboard handle =+  void $ GI.onClipboardOwnerChange clipboard \ _ ->+    GI.clipboardRequestText clipboard (const (traverse_ handle))++clipboardFor ::+  Member (Reader GtkState) r =>+  Selection ->+  Sem r GI.Clipboard+clipboardFor = \case+  Clipboard -> asks GtkState.clipboard+  Primary -> asks GtkState.primary+  Secondary -> asks GtkState.secondary++getClipboard ::+  MonadIO m =>+  GI.Clipboard ->+  m (Maybe Text)+getClipboard clipboard =+  GI.clipboardWaitForText clipboard++getClipboardFor ::+  Members [Reader GtkState, Embed IO] r =>+  Selection ->+  Sem r (Maybe Text)+getClipboardFor sel = do+  cb <- clipboardFor sel+  getClipboard cb++setClipboard ::+  MonadIO m =>+  GI.Clipboard ->+  Text ->+  m ()+setClipboard clipboard text =+  GI.clipboardSetText clipboard text (-1)++setClipboardFor ::+  Members [Reader GtkState, Embed IO] r =>+  Selection ->+  Text ->+  Sem r ()+setClipboardFor sel text = do+  cb <- clipboardFor sel+  setClipboard cb text++syncXClipboard ::+  Members [Reader GtkState, Embed IO] r =>+  Text ->+  Selection ->+  Sem r ()+syncXClipboard text = \case+  Clipboard -> unit+  _ -> do+    cb <- asks GtkState.clipboard+    setClipboard cb text

@@ -0,0 +1,31 @@+-- |Agent Interpreter for Network, Internal+module Helic.Interpreter.AgentNet where++import Polysemy.Conc (Events, Interrupt, interpretSync, withAsync_)+import Polysemy.Http (Manager)+import qualified Polysemy.Log as Log+import Polysemy.Log (Log)+import Polysemy.Tagged (Tagged, untag)++import Helic.Data.Event (Event (source))+import Helic.Data.InstanceName (InstanceName)+import Helic.Data.NetConfig (NetConfig (NetConfig))+import Helic.Effect.Agent (Agent (Update), AgentNet, agentIdNet)+import Helic.Net.Api (serve)+import Helic.Net.Client (sendTo)++-- |Interpret 'Agent' using remote hosts as targets.+-- This also starts the HTTP server that listens to network events, which are used both for remote hosts and CLI+-- events.+interpretAgentNet ::+  Members [Manager, Events resource Event, Reader InstanceName, Reader NetConfig] r =>+  Members [AtomicState (Seq Event), Log, Interrupt, Race, Resource, Async, Embed IO, Final IO] r =>+  InterpreterFor (Tagged AgentNet Agent) r+interpretAgentNet sem =+  interpretSync $+  withAsync_ serve $+  interpreting (raiseUnder (untag sem)) \case+    Update e -> do+      NetConfig _ timeout hosts <- ask+      for_ (fold hosts) \ host ->+        traverseLeft Log.debug =<< runError (sendTo timeout host e { source = agentIdNet })

@@ -0,0 +1,43 @@+-- |Agent Interpreter for Tmux, Internal+module Helic.Interpreter.AgentTmux where++import Path (Abs, File, Path, toFilePath)+import Polysemy.Log (Log)+import Polysemy.Process.Interpreter.ProcessIOE (interpretProcessIOE)+import Polysemy.Tagged (Tagged, untag)+import qualified System.Process.Typed as Process+import System.Process.Typed (ProcessConfig)++import qualified Helic.Data.TmuxConfig as TmuxConfig+import Helic.Data.TmuxConfig (TmuxConfig)+import Helic.Effect.Agent (Agent (Update), AgentTmux)+import Helic.Tmux (sendToTmux)++-- |Process definition for running `tmux load-buffer -`.+tmuxProc ::+  Maybe (Path Abs File) ->+  ProcessConfig () () ()+tmuxProc exe =+  Process.proc cmd ["load-buffer", "-"]+  where+    cmd =+      maybe "tmux" toFilePath exe++-- |Consult the config as to whether tmux should be used, defaulting to true.+enableTmux ::+  Member (Reader TmuxConfig) r =>+  Sem r Bool+enableTmux =+  fromMaybe True <$> asks TmuxConfig.enable++-- |Interpret 'Agent' using a tmux server as the target.+interpretAgentTmux ::+  Members [Reader TmuxConfig, Log, Async, Race, Resource, Embed IO] r =>+  InterpreterFor (Tagged AgentTmux Agent) r+interpretAgentTmux sem = do+  exe <- asks TmuxConfig.exe+  interpretProcessIOE True 64 (tmuxProc exe) $+    interpreting (raiseUnder (untag sem)) \case+      Update e ->+        whenM enableTmux do+          sendToTmux e

@@ -0,0 +1,42 @@+-- |Agent Interpreter for X11, Internal+module Helic.Interpreter.AgentX where++import Polysemy.Chronos (ChronosTime)+import qualified Polysemy.Conc as Conc+import Polysemy.Conc (EventConsumer, Events, withAsync_)+import Polysemy.Tagged (Tagged, untag)++import qualified Helic.Data.Event as Event+import Helic.Data.Event (Event (Event))+import Helic.Data.InstanceName (InstanceName)+import Helic.Data.XClipboardEvent (XClipboardEvent (XClipboardEvent))+import Helic.Effect.Agent (Agent (Update), AgentX, agentIdX)+import qualified Helic.Effect.XClipboard as XClipboard+import Helic.Effect.XClipboard (XClipboard)++-- |Listen for 'XClipboardEvent's and publish them as 'Event's.+transformXEvents ::+  Member (Reader InstanceName) r =>+  Members [EventConsumer xr XClipboardEvent, Events er Event, XClipboard, ChronosTime, Resource, Race, Async] r =>+  Sem r a ->+  Sem r a+transformXEvents =+  withAsync_ do+    Conc.subscribeLoop \case+      XClipboardEvent text selection -> do+        XClipboard.sync text selection+        ev <- Event.now agentIdX text+        Conc.publish ev++-- |Interpret 'Agent' using the X11 clipboard as target.+-- This interpreter also runs a thread that converts events generated by the 'XClipboard' interpreter+-- ('XClipboardEvent') to the main 'Event' type.+interpretAgentX ::+  Members [EventConsumer xr XClipboardEvent, Events er Event, Reader InstanceName, XClipboard, ChronosTime] r =>+  Members [Events xr XClipboardEvent, Error Text, Race, Resource, Async, Embed IO, Final IO] r =>+  InterpreterFor (Tagged AgentX Agent) r+interpretAgentX sem =+  transformXEvents $+  interpreting (untag sem) \case+    Update Event {..} ->+      XClipboard.set content

@@ -0,0 +1,32 @@+-- |Reader Interpreter for InstanceName, Internal+module Helic.Interpreter.InstanceName where++import Network.HostName (getHostName)+import qualified Polysemy.Error as Polysemy+import Polysemy.Reader (runReader)++import Helic.Data.InstanceName (InstanceName (InstanceName))++-- |If no instance name was given in the config file, query the system's host name.+determineName ::+  Members [Error Text, Embed IO] r =>+  Maybe Text ->+  Sem r InstanceName+determineName = \case+  Just name ->+    pure (InstanceName name)+  _ ->+    Polysemy.fromExceptionVia err (fromString <$> getHostName)+  where+    err (e :: SomeException) =+      [exon|no name in conig and unable to determine hostname: #{show e}|]++-- |Interpret @'Reader' 'InstanceName'@ using the name specified in the config file, falling back to the system's host+-- name if it wasn't given.+interpretInstanceName ::+  Members [Error Text, Embed IO] r =>+  Maybe Text ->+  InterpreterFor (Reader InstanceName) r+interpretInstanceName configName sem = do+  name <- determineName configName+  runReader name sem

@@ -0,0 +1,81 @@+-- |XClipboard Interpreter, Internal+module Helic.Interpreter.XClipboard where++import qualified GI.Gdk as Gdk+import qualified GI.Gtk as GI+import qualified Polysemy.Conc as Conc+import Polysemy.Conc (Events, withAsync_)+import Polysemy.Final (withWeavingToFinal)+import Polysemy.Reader (runReader)+import Polysemy.Resource (bracket)++import qualified Helic.Data.GtkState as GtkState+import Helic.Data.GtkState (GtkState (GtkState))+import Helic.Data.Selection (Selection (Clipboard, Primary, Secondary))+import Helic.Data.XClipboardEvent (XClipboardEvent (XClipboardEvent))+import Helic.Effect.XClipboard (XClipboard (Current, Set, Sync))+import qualified Helic.Gtk as Gtk+import Helic.Gtk (getClipboardFor, gtkClipboard, setClipboardFor, syncXClipboard)++-- |Execute a GTK main loop in a baackground thread and interpret @'Reader' 'GtkState'@.+-- The clipboards stored in the state need the main loop running to work properly.+-- The main loop is killed after the interpreted program terminates.+withMainLoop ::+  Members [Resource, Error Text, Race, Async, Embed IO] r =>+  InterpreterFor (Reader GtkState) r+withMainLoop prog = do+  bracket acquire release \ display -> do+    clipboard <- gtkClipboard display "CLIPBOARD"+    primary <- gtkClipboard display "PRIMARY"+    secondary <- gtkClipboard display "SECONDARY"+    runReader (GtkState clipboard primary secondary display) (withAsync_ GI.main prog)+  where+    acquire = do+      _ <- embed (GI.init Nothing)+      note "couldn't get a GTK display" =<< Gdk.displayGetDefault+    release display = do+      Gdk.displayFlush display+      Gdk.displayClose display+      GI.mainQuit++-- |Listen to clipboard events for a specific source, like "primary selection", and publish them via 'Events'.+subscribeToClipboard ::+  Members [Events resource XClipboardEvent, Reader GtkState, Embed IO, Final IO] r =>+  GI.Clipboard ->+  Selection ->+  Sem r ()+subscribeToClipboard clipboard selection =+  withWeavingToFinal \ s wv _ -> do+    s <$ Gtk.subscribe clipboard \ t ->+      void (wv (Conc.publish (XClipboardEvent t selection) <$ s))++-- |Listen to clipboard events and publish them via 'Events'.+clipboardEvents ::+  Members [Events resource XClipboardEvent, Reader GtkState, Embed IO, Final IO] r =>+  Sem r ()+clipboardEvents = do+  GtkState {..} <- ask+  subscribeToClipboard clipboard Clipboard+  subscribeToClipboard primary Primary+  subscribeToClipboard secondary Secondary++-- |Run a GTK main loop and listen to clipboard events, publishing them via 'Events'.+listenXClipboard ::+  Members [Events resource XClipboardEvent, Error Text, Race, Resource, Async, Embed IO, Final IO] r =>+  InterpreterFor (Reader GtkState) r+listenXClipboard =+  withMainLoop . withAsync_ clipboardEvents++-- |Interpret 'XClipboard' using a GTK backend.+-- This uses the @gi-gtk@ library to access the X11 clipboard.+interpretXClipboardGtk ::+  Members [Reader GtkState, Embed IO] r =>+  InterpreterFor XClipboard r+interpretXClipboardGtk = do+  interpret \case+    Current ->+      getClipboardFor Clipboard+    Set text ->+      setClipboardFor Clipboard text+    Sync text selection ->+      syncXClipboard text selection

@@ -0,0 +1,103 @@+{-# options_haddock prune #-}+-- |Daemon Logic, Internal+module Helic.Listen where++import qualified Chronos+import qualified Data.Sequence as Seq+import Data.Sequence (Seq ((:|>)), (|>))+import Polysemy.AtomicState (atomicState')+import Polysemy.Chronos (ChronosTime)+import qualified Polysemy.Conc as Conc+import Polysemy.Conc (EventConsumer)+import qualified Polysemy.Log as Log+import Polysemy.Log (Log)+import Polysemy.Tagged (Tagged, tag)+import qualified Polysemy.Time as Time+import Polysemy.Time (Seconds (Seconds), convert)+import Polysemy.Time.Diff (diff)++import Helic.Data.AgentId (AgentId (AgentId))+import qualified Helic.Data.Event as Event+import Helic.Data.Event (Event (Event))+import qualified Helic.Effect.Agent as Agent+import Helic.Effect.Agent (Agent, AgentName, AgentNet, AgentTag, AgentTmux, AgentX, Agents, agentName)++runAgent ::+  ∀ (tag :: AgentTag) r .+  AgentName tag =>+  Member (Tagged tag Agent) r =>+  Event ->+  Sem r ()+runAgent (Event _ (AgentId eId) _ _) | eId == agentName @tag =+  unit+runAgent e =+  tag (Agent.update e)++broadcast ::+  Members Agents r =>+  Member Log r =>+  Event ->+  Sem r ()+broadcast event@(Event _ (AgentId ag) _ text) = do+  Log.debug [exon|broadcasting from #{ag}: #{show text}|]+  runAgent @AgentTmux event+  runAgent @AgentNet event+  runAgent @AgentX event++inRecent ::+  Chronos.Time ->+  Event ->+  Seq Event ->+  Bool+inRecent now (Event _ _ _ c) =+  any ((c ==) . Event.content) . Seq.takeWhileR newer+  where+    newer (Event _ _ t _) =+      diff now t <= convert (Seconds 1)++appendIfValid ::+  Chronos.Time ->+  Event ->+  Seq Event ->+  Maybe (Seq Event)+appendIfValid now e = \case+  Seq.Empty ->+    Just (Seq.singleton e)+  _ :|> Event _ _ _ newest | newest == Event.content e ->+    Nothing+  hist | inRecent now e hist ->+    Nothing+  hist ->+    Just (hist |> e)++insertEvent ::+  Members [AtomicState (Seq Event), ChronosTime] r =>+  Event ->+  Sem r Bool+insertEvent e = do+  now <- Time.now+  atomicState' \ s -> result s (appendIfValid now e s)+  where+    result s = \case+      Just new -> (new, True)+      Nothing -> (s, False)++truncateLog ::+  Member (AtomicState (Seq Event)) r =>+  Int ->+  Sem r ()+truncateLog maxHistory =+  atomicModify' \ evs ->+    if length evs > maxHistory+    then Seq.drop 1 evs+    else evs++-- |Listen for 'Event' via 'Polysemy.Conc.Events', broadcasting them to agents.+listen ::+  Members Agents r =>+  Members [EventConsumer token Event, AtomicState (Seq Event), ChronosTime, Log] r =>+  Maybe Int ->+  Sem r ()+listen maxHistory =+  Conc.subscribeLoop \ e ->+    whenM (insertEvent e) (broadcast e *> truncateLog (fromMaybe 100 maxHistory))

@@ -0,0 +1,56 @@+-- |HTTP API of the Daemon, Internal+module Helic.Net.Api where++import qualified Polysemy.Conc as Conc+import Polysemy.Conc (Events, Interrupt, Sync)+import Polysemy.Log (Log)+import Servant (Get, JSON, PostCreated, ReqBody, type (:<|>) ((:<|>)), type (:>))+import Servant.Server (Context (EmptyContext), ServerT)++import Helic.Data.Event (Event (Event, sender, source))+import Helic.Data.InstanceName (InstanceName)+import qualified Helic.Data.NetConfig as NetConfig+import Helic.Data.NetConfig (NetConfig)+import Helic.Effect.Agent (agentIdNet)+import Helic.Net.Server (ServerReady, runServerWithContext)++-- |The Servant API of the daemon, providing endpoints for getting all events and creating one.+type Api =+  "event" :> (+    Get '[JSON] (Seq Event)+    :<|>+    ReqBody '[JSON] Event :> PostCreated '[JSON] ()+  )++-- |Publish a received event unless it was sent by the network agent of this instance.+receiveEvent ::+  Members [Events resource Event, Reader InstanceName] r =>+  Event ->+  Sem r ()+receiveEvent e@Event {sender, source} = do+  name <- ask+  unless (name == sender && source == agentIdNet) do+    Conc.publish e++-- |The server implementation.+server ::+  Members [Events resource Event, AtomicState (Seq Event), Reader InstanceName] r =>+  ServerT Api (Sem r)+server =+  atomicGet+  :<|>+  receiveEvent++-- |The default port, 9500.+defaultPort :: Int+defaultPort =+  9500++-- |Run the daemon API.+serve ::+  Members [Events resource Event, Reader NetConfig] r =>+  Members [AtomicState (Seq Event), Reader InstanceName, Sync ServerReady, Log, Interrupt, Final IO] r =>+  Sem r ()+serve = do+  port <- asks NetConfig.port+  runServerWithContext @Api server EmptyContext (fromMaybe defaultPort port)

@@ -0,0 +1,40 @@+{-# options_haddock prune #-}+-- |HTTP Client, Internal+module Helic.Net.Client where++import qualified Polysemy.Conc as Conc+import Polysemy.Http (Manager)+import qualified Polysemy.Http.Effect.Manager as Manager+import qualified Polysemy.Log as Log+import Polysemy.Log (Log)+import Polysemy.Time (MilliSeconds (MilliSeconds))+import Servant (type (:<|>) ((:<|>)))+import Servant.Client (ClientM, client, mkClientEnv, parseBaseUrl, runClientM)++import Helic.Data.Event (Event)+import Helic.Data.Host (Host (Host))+import Helic.Data.NetConfig (Timeout)+import Helic.Net.Api (Api)++get :: ClientM (Seq Event)+yank :: Event -> ClientM ()+get :<|> yank = client (Proxy @Api)++sendTo ::+  Members [Manager, Log, Race, Error Text, Embed IO] r =>+  Maybe Timeout ->+  Host ->+  Event ->+  Sem r ()+sendTo configTimeout (Host addr) event = do+  Log.debug [exon|sending to #{addr}|]+  url <- note "bad url" (parseBaseUrl (toString addr))+  mgr <- Manager.get+  let+    timeout =+      MilliSeconds (fromIntegral (fromMaybe 300 configTimeout))+    env =+      mkClientEnv mgr url+    req =+      mapLeft show <$> runClientM (yank event) env+  fromEither =<< Conc.timeoutAs_ (Left "timed out") timeout (embed req)

@@ -0,0 +1,85 @@+{-# options_haddock prune #-}+-- |HTTP Server Plumbing, Internal+module Helic.Net.Server where++import qualified Network.Wai.Handler.Warp as Warp+import Network.Wai.Handler.Warp (+  defaultSettings,+  setBeforeMainLoop,+  setGracefulShutdownTimeout,+  setHost,+  setInstallShutdownHandler,+  setPort,+  )+import Network.Wai.Middleware.RequestLogger (logStdout)+import Polysemy.Conc (Interrupt, Sync)+import qualified Polysemy.Conc.Effect.Interrupt as Interrupt+import qualified Polysemy.Conc.Effect.Sync as Sync+import Polysemy.Final (withWeavingToFinal)+import qualified Polysemy.Log as Log+import Polysemy.Log (Log)+import Servant (+  Context,+  DefaultErrorFormatters,+  ErrorFormatters,+  Handler (Handler),+  HasContextEntry,+  HasServer,+  ServerError,+  ServerT,+  err500,+  hoistServerWithContext,+  serveWithContext,+  type (.++),+  )++newtype ApiError =+  ApiError { unApiError :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString)++data ServerReady =+  ServerReady+  deriving (Eq, Show)++logErrors ::+  Member Log r =>+  Sem r (Either ServerError a) ->+  Sem r (Either ServerError a)+logErrors ma =+  ma >>= \case+    Right a -> pure (Right a)+    Left err -> Left err <$ Log.error (show err)++toHandler :: IO (Maybe a) -> Handler a+toHandler =+  Handler . ExceptT . fmap (maybe (Left err500) Right)++runServerWithContext ::+  ∀ (api :: Type) context r .+  HasServer api context =>+  HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters =>+  Members [Sync ServerReady, Log, Interrupt, Final IO] r =>+  ServerT api (Sem r) ->+  Context context ->+  Int ->+  Sem r ()+runServerWithContext srv context port = do+  Log.info [exon|server port: #{show port}|]+  withWeavingToFinal \ s wv ins -> do+    let+      app =+        serveWithContext (Proxy @api) context (hoistServerWithContext (Proxy @api) (Proxy @context) hoist srv)+      hoist :: Sem r a -> Handler a+      hoist =+        toHandler . fmap ins . wv . (<$ s)+      shut h =+        void (wv (Interrupt.register "api" h <$ s))+      settings =+        setHost "*6" $+        setPort port $+        setBeforeMainLoop (void (wv (Sync.putBlock ServerReady <$ s))) $+        setInstallShutdownHandler shut $+        setGracefulShutdownTimeout (Just 0) $+        defaultSettings+    (<$ s) <$> Warp.runSettings settings (logStdout app)

@@ -0,0 +1,171 @@+{-# language NoImplicitPrelude #-}+{-# options_haddock prune, hide #-}+-- |Prelude, Internal++module Helic.Prelude (+  module Data.Aeson,+  module Data.Aeson.TH,+  module Data.Default,+  module Data.Either.Combinators,+  module Data.Foldable,+  module Data.Kind,+  module Exon,+  module GHC.Err,+  module GHC.TypeLits,+  module Helic.Prelude,+  module Helic.Prelude.Debug,+  module Polysemy,+  module Polysemy.Async,+  module Polysemy.AtomicState,+  module Polysemy.Conc,+  module Polysemy.Error,+  module Polysemy.Internal.Tactics,+  module Polysemy.Reader,+  module Polysemy.Resource,+  module Polysemy.State,+  module Relude,+) where++import Control.Exception (try)+import qualified Data.Aeson as Aeson+import Data.Aeson (FromJSON (parseJSON), SumEncoding (UntaggedValue), ToJSON (toJSON), Value, camelTo2)+import Data.Aeson.TH (deriveFromJSON, deriveJSON)+import Data.Default (Default (def))+import Data.Either.Combinators (mapLeft)+import Data.Foldable (foldl, traverse_)+import Data.Kind (Type)+import Exon (exon)+import GHC.Err (undefined)+import GHC.TypeLits (Symbol)+import qualified Language.Haskell.TH.Syntax as TH+import Polysemy (+  Effect,+  EffectRow,+  Embed,+  Final,+  InterpreterFor,+  InterpretersFor,+  Member,+  Members,+  Sem,+  WithTactics,+  bindT,+  embed,+  embedToFinal,+  interpret,+  interpretH,+  makeSem,+  pureT,+  raise,+  raise2Under,+  raise3Under,+  raiseUnder,+  raiseUnder2,+  raiseUnder3,+  reinterpret,+  runFinal,+  runT,+  )+import Polysemy.Async (Async, async, asyncToIOFinal, await, sequenceConcurrently)+import Polysemy.AtomicState (AtomicState, atomicGet, atomicGets, atomicModify', atomicPut, runAtomicStateTVar)+import Polysemy.Conc (Race)+import Polysemy.Error (Error, fromEither, fromExceptionVia, mapError, note, runError, throw)+import Polysemy.Internal.CustomErrors (FirstOrder)+import Polysemy.Internal.Kind (Append)+import Polysemy.Internal.Tactics (liftT)+import Polysemy.Reader (Reader, ask, asks)+import Polysemy.Resource (Resource, resourceToIOFinal, runResource)+import Polysemy.State (State, evalState, get, gets, modify, modify', put, runState)+import Relude hiding (+  Reader,+  State,+  Type,+  ask,+  asks,+  evalState,+  filterM,+  get,+  gets,+  hoistEither,+  modify,+  modify',+  put,+  readFile,+  runReader,+  runState,+  state,+  trace,+  traceShow,+  undefined,+  )++import Helic.Prelude.Debug (dbg, dbgs, dbgsWith, dbgs_, tr, trs, trs')++unit ::+  Applicative f =>+  f ()+unit =+  pure ()+{-# inline unit #-}++tryAny ::+  Member (Embed IO) r =>+  IO a ->+  Sem r (Either Text a)+tryAny =+  embed . fmap (mapLeft show) . try @SomeException+{-# inline tryAny #-}++basicOptions :: Aeson.Options+basicOptions =+  Aeson.defaultOptions {+    Aeson.fieldLabelModifier = dropWhile ('_' ==)+  }++jsonOptions :: Aeson.Options+jsonOptions =+  basicOptions {+    Aeson.unwrapUnaryRecords = True+  }++untaggedOptions :: Aeson.Options+untaggedOptions =+  jsonOptions {+    Aeson.sumEncoding = UntaggedValue+  }++defaultJson :: TH.Name -> TH.Q [TH.Dec]+defaultJson =+  deriveJSON jsonOptions++lowerMinusJson :: TH.Name -> TH.Q [TH.Dec]+lowerMinusJson =+  deriveJSON jsonOptions {+    Aeson.constructorTagModifier = camelTo2 '-'+  }++unaryRecordJson :: TH.Name -> TH.Q [TH.Dec]+unaryRecordJson =+  deriveJSON basicOptions++type a ++ b =+  Append a b++traverseLeft ::+  Applicative m =>+  (a -> m b) ->+  Either a b ->+  m b+traverseLeft f =+  either f pure+{-# inline traverseLeft #-}++interpreting ::+  ∀ e r a .+  FirstOrder e "interpret" =>+  Sem (e : r) a ->+  (∀ r0 x . e (Sem r0) x -> Sem r x) ->+  Sem r a+interpreting s h =+  interpret h s+{-# inline interpreting #-}

@@ -0,0 +1,103 @@+{-# language NoImplicitPrelude #-}+{-# options_haddock prune #-}+-- |Debug Printing, Internal++module Helic.Prelude.Debug where++import qualified Data.Text as Text+import Exon (exon)+import GHC.Stack (SrcLoc (..))+import Relude+import System.IO.Unsafe (unsafePerformIO)++srcLoc :: CallStack -> SrcLoc+srcLoc = \case+  (getCallStack -> (_, loc) : _) -> loc+  _ -> error "Debug.srcLoc: empty CallStack"++debugPrint ::+  SrcLoc ->+  Text ->+  IO ()+debugPrint SrcLoc{ srcLocModule = (toText -> slm), ..} msg =+  putStrLn [exon|#{toString moduleName}:#{show srcLocStartLine} #{toString msg}|]+  where+    moduleName =+      fromMaybe slm $ listToMaybe $ reverse $ Text.splitOn "." slm++debugPrintWithLoc ::+  Monad m =>+  SrcLoc ->+  Text ->+  m ()+debugPrintWithLoc loc msg = do+  () <- return (unsafePerformIO (debugPrint loc msg))+  pure ()++dbg ::+  HasCallStack =>+  Monad m =>+  Text ->+  m ()+dbg =+  debugPrintWithLoc (srcLoc callStack)+{-# inline dbg #-}++dbgsWith ::+  HasCallStack =>+  Monad m =>+  Show a =>+  Text ->+  a ->+  m ()+dbgsWith prefix a =+  debugPrintWithLoc (srcLoc callStack) [exon|#{prefix}: #{show @Text a}|]+{-# inline dbgsWith #-}++dbgs ::+  HasCallStack =>+  Monad m =>+  Show a =>+  a ->+  m ()+dbgs a =+  debugPrintWithLoc (srcLoc callStack) (show a)+{-# inline dbgs_ #-}++dbgs_ ::+  HasCallStack =>+  Monad m =>+  Show a =>+  a ->+  m a+dbgs_ a =+  a <$ debugPrintWithLoc (srcLoc callStack) (show a)+{-# inline dbgs #-}++tr ::+  HasCallStack =>+  Text ->+  a ->+  a+tr msg a =+  unsafePerformIO (a <$ debugPrint (srcLoc callStack) msg)+{-# INLINE tr #-}++trs ::+  Show a =>+  HasCallStack =>+  a ->+  a+trs a =+  unsafePerformIO (a <$ debugPrint (srcLoc callStack) (show a))+{-# INLINE trs #-}++trs' ::+  Show b =>+  HasCallStack =>+  b ->+  a ->+  a+trs' b a =+  unsafePerformIO (a <$ debugPrint (srcLoc callStack) (show b))+{-# INLINE trs' #-}

@@ -0,0 +1,24 @@+{-# options_haddock prune #-}+-- |Tmux Helpers, Internal+module Helic.Tmux where++import Polysemy.Conc (Scoped)+import qualified Polysemy.Log as Log+import Polysemy.Log (Log)+import qualified Polysemy.Process as Process+import Polysemy.Process (Process)+import Polysemy.Process.Effect.Process (withProcess)+import Polysemy.Resume (type (!!), (!!))++import Helic.Data.Event (Event (Event))++sendToTmux ::+  ∀ err o e resource r .+  Show err =>+  Members [Scoped resource (Process ByteString o e !! err), Log] r =>+  Event ->+  Sem r ()+sendToTmux (Event _ _ _ text) =+  withProcess do+    Process.send (encodeUtf8 text) !! \ e ->+      Log.error [exon|failed to send data to tmux: #{show e}|]

@@ -0,0 +1,28 @@+{-# options_haddock prune #-}+-- |Yank Logic, Internal+module Helic.Yank where++import qualified Data.Text.IO as Text+import Polysemy.Chronos.Time (ChronosTime)+import Polysemy.Http (Manager)+import Polysemy.Log (Log)++import Helic.Data.AgentId (AgentId (AgentId))+import qualified Helic.Data.Event as Event+import Helic.Data.Host (Host (Host))+import Helic.Data.InstanceName (InstanceName)+import Helic.Data.NetConfig (NetConfig (NetConfig))+import Helic.Data.YankConfig (YankConfig (YankConfig))+import Helic.Net.Api (defaultPort)+import Helic.Net.Client (sendTo)++-- |Send an event to the server.+yank ::+  Members [Reader InstanceName, ChronosTime, Manager, Log, Race, Error Text, Embed IO] r =>+  NetConfig ->+  YankConfig ->+  Sem r ()+yank (NetConfig port timeout _) (YankConfig agent) = do+  text <- embed (Text.hGetContents stdin)+  event <- Event.now (AgentId (fromMaybe "cli" agent)) text+  sendTo timeout (Host [exon|localhost:#{show (fromMaybe defaultPort port)}|]) event

@@ -0,0 +1,9 @@+{-# language NoImplicitPrelude #-}+{-# options_haddock prune #-}+-- |Prelude, Internal++module Prelude (+  module Helic.Prelude,+) where++import Helic.Prelude

@@ -0,0 +1,151 @@+# About++*Helic* is a tool for synchronizing clipboard contents across *X11*, *tmux* and network, consisting of a daemon+listening for changes and a CLI client for use in programs like *Neovim*.++When some text is copied or selected in *X11*, the daemon receives an event that it proceeds to broadcast to the+configured targets.+If the source was a selection, the *X11* clipboard is updated as well.+The CLI program `hel` can be used to manually send text to the daemon, for example from *tmux* or *Neovim*.+If remote hosts are configured, each yank event is sent over the network to update their clipboards.++Several yank events are stored in memory in order to avoid duplicates and cycles.++# Installing and Running Helic++## Nix++The project uses a [Nix] [flake] to configure its build, and it is recommended to install or run it using *Nix* as well.+If *Nix* is installed and configured for use with *flakes*, the app can be run like this:++```shell+$ nix run github:tek/helic -- listen+$ echo 'yank me' | nix run github:tek/helic -- yank+```++## NixOS++The flake provides a *NixOS* module that can be used by adding it to `/etc/nixos/configuration.nix`:++```nix+{+  inputs.helic.url = github:/tek/helic;+  outputs = { nixpkgs, helic, ... }: {+    nixosConfigurations.myhost = nixpkgs.lib.nixosSystem {+      modules = [helic.nixosModule];+      services.helic.enable = true;+    };+  };+}+```++With this, a *systemd* user service will be started on login and the client will be in `$PATH`:++```shell+$ echo 'yank me' | hel yank+```++## Without Nix++Alternatively, the app can be installed using a *Haskell* package manager, like [Cabal]:++```shell+$ cabal install helic+$ hel listen+```++## CLI++If neither of the commands `listen` and `yank` have been specified explicitly, *Helic* decides which one to start by the+presence of stdin data:++```shell+$ hel # start daemon+$ echo 'yank me' | hel # yank+```++Global CLI options are specified *before* the command name, command-specific ones after it.++|Command|Name|Description|+|Global|`--verbose`|Increase the log level.|+|Global|`--config-file FILE`|Use the specified file path instead of the default locations.|+|`listen`|`--agent NAME`|Used to avoid sending yanks back to the application that sent them.|++# Configuring Helic++The app reads the first existing one of these three configuration files:++* The file specified with `--config-file`+* `$XDG_CONFIG_DIR/helic.yaml` (most likely `~/.config/helic.yaml`)+* `/etc/helic.yaml`++An example config file looks like this:++```yaml+name: myhost+maxHistory: 1000+net:+  port: 10001+  hosts:+    - "remote1:1000"+    - "remote2:2000"+  timeout: 5+tmux:+  enable: true+  exe: /bin/tmux+```++For *NixOS*, the file `/etc/helic.yaml` is generated from module options:++```nix+services.helic = {+  enable = true;+  name = "myhost";+  maxHistory = 1000;+  net = {+    port = 10001;+    hosts = ["remote1:1000" "remote2:2000"];+    timeout = 5;+  };+  tmux = {+    enable = true;+    package = old.tmux;+  };+};+```++The meaning of these options is:++|Key|Default|Description|+|`name`|Host name|An identifier for the host, used for filtering duplicates.|+|`maxHistory`|100|The number of yanks that should be kept.|+|`net.port`|`9500`|The HTTP port the daemon listens to for both remote sync and `hel yank`.|+|`net.hosts`|`[]`|The addresses (with port) of the hosts to which this instance should broadcast yank events.|+|`net.timeout`|`300`|The timeout in milliseconds for requests to remote hosts.|+|`tmux.enable`|`true`|Whether to send events to *tmux*.|+|`tmux.package`|`pkgs.tmux`|Only for *NixOS*: The `nixpkgs` package used for the *tmux* executable.|+|`tmux.exe`|`tmux`|Only for YAML file: The path to the *tmux* executable|++# Neovim++*Neovim*'s clipboard requires configuration with a tool in any case, so changing it to use `hel` is simple:++```vim+let g:clipboard = {+  \   'name': 'helic',+  \   'copy': {+  \      '+': 'hel yank --agent nvim',+  \      '+': 'hel yank --agent nvim',+  \    },+  \   'paste': {+  \      '+': 'xsel -bo',+  \      '*': 'xsel -bo',+  \   },+  \ }+```++Since *Helic* updates the *X11* clipboard, a custom `paste` command is not necessary.++[Nix]: https://nixos.org/learn.html+[flake]: https://nixos.org/manual/nix/unstable/command-ref/new-cli/nix3-flake.html+[Cabal]: https://cabal.readthedocs.io

@@ -0,0 +1,27 @@+module Helic.Test.ConfigFileTest where++import Path (Abs, File, Rel, absfile, relfile)+import Polysemy.Log (interpretLogNull)+import Polysemy.Test (UnitTest, assertRight, runTestAuto)+import qualified Polysemy.Test.Data.Test as Test++import Helic.Config.File (parseFileConfig)+import Helic.Data.Config (Config (Config))+import Helic.Data.NetConfig (NetConfig (NetConfig))+import Helic.Data.TmuxConfig (TmuxConfig (TmuxConfig))++target :: Config+target =+  Config (Just "name") (Just tmux) (Just net) (Just 1000)+  where+    tmux =+      TmuxConfig (Just True) (Just [absfile|/bin/tmux|])+    net =+      NetConfig (Just 10001) (Just 5) (Just ["remote:1000"])++test_readConfigFile :: UnitTest+test_readConfigFile = do+  runTestAuto $ interpretLogNull do+    assertRight target =<< do+      file <- Test.fixturePath [relfile|config.yaml|]+      runError (parseFileConfig file)

@@ -0,0 +1,39 @@+module Helic.Test.InsertEventTest where++import qualified Chronos+import Chronos (datetimeToTime)+import Data.Sequence ((|>))+import Polysemy.Chronos (interpretTimeChronos)+import Polysemy.Test (UnitTest, assertJust, runTestAuto, (===))+import qualified Polysemy.Time as Time+import Polysemy.Time (MilliSeconds (MilliSeconds), convert, mkDatetime)+import Torsor (add)++import Helic.Data.Event (Event (Event))+import Helic.Listen (appendIfValid)++old :: Chronos.Time+old =+  datetimeToTime (mkDatetime 2000 1 1 0 0 0)++event1 :: Event+event1 =+  Event "me" "test" old "event1"++event2 :: Event+event2 =+  Event "me" "test" old "event2"++historyLatest :: Seq Event+historyLatest =+  [event2, event1]++test_insertEvent :: UnitTest+test_insertEvent =+  runTestAuto $ interpretTimeChronos do+    now <- Time.now+    assertJust [Event "me" "test" now "string"] (appendIfValid now (Event "me" "test" now "string") mempty)+    Nothing === appendIfValid now event1 historyLatest+    assertJust (historyLatest |> event2) (appendIfValid now event2 historyLatest)+    Nothing === appendIfValid (add (convert (MilliSeconds 100)) old) event2 historyLatest+    assertJust (historyLatest |> event2) (appendIfValid (add (convert (MilliSeconds 1100)) old) event2 historyLatest)

@@ -0,0 +1,15 @@+module Main where++import Helic.Test.InsertEventTest (test_insertEvent)+import Polysemy.Test (unitTest)+import Test.Tasty (TestTree, defaultMain, testGroup)++tests :: TestTree+tests =+  testGroup "all" [+    unitTest "insert an event" test_insertEvent+  ]++main :: IO ()+main =+  defaultMain tests