diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -34,16 +34,9 @@ Callbacks are configured through the `$XDG_CONFIG_HOME/imm/callbacks.dhall` file. A commented template file is bundled with the project. -`imm` will call each callback once per feed element, and will fill its standard input (`stdin`) with a [MessagePack][4]-encoded object structured as follows: - -``` -{ - "feed": "RSS document or Atom feed (XML)", - "element": "RSS item or Atom entry (XML)" -} -``` +*imm* will call each callback once per feed element, and will fill its standard input (`stdin`) with [Avro][4]-encoded binary data, which schema is described in file [`idl/callback.json`](idl/callback.json). -`imm` expects callbacks to return `0` in case of success, or any other exit code in case of failure, in which case the standard error output (`stderr`) will be displayed. +Callback process is expected to return `0` in case of success, or any other exit code in case of failure, in which case the standard error output (`stderr`) will be displayed. ## Example use cases @@ -136,4 +129,4 @@ [1]: http://hackage.haskell.org/package/imm [2]: https://www.haskell.org [3]: https://dhall-lang.org/ -[4]: https://msgpack.org/ +[4]: https://avro.apache.org/ diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -3,12 +3,23 @@ let hlib = nixpkgs.haskell.lib; - thisPackage = - addRuntimeDependencies (myHaskellPackages.callCabal2nix "imm" ./. { }) [ + source = nixpkgs.nix-gitignore.gitignoreSource [ ] ./.; + packageWithoutRuntimeDependencies = + myHaskellPackages.callCabal2nix "imm" source { }; + packageWithRuntimeDependencies = + addRuntimeDependencies packageWithoutRuntimeDependencies [ nixpkgs.httpie nixpkgs.pup ]; + exe = hlib.justStaticExecutables packageWithRuntimeDependencies; + + my-avro = { + pkg = "avro"; + ver = "0.5.2.0"; + sha256 = "0inznspd7lwrc4z7bz12zrdh75zmyibidyb5yblxd3vmni68dx5c"; + }; + my-atom-conduit = { pkg = "atom-conduit"; ver = "0.8.0.0"; @@ -28,16 +39,17 @@ }; myHaskellPackages = nixpkgs.haskellPackages.override { - overrides = hself: hsuper: { - imm = thisPackage; - atom-conduit = hlib.dontCheck - (hlib.dontHaddock (hsuper.callHackageDirect my-atom-conduit { })); - opml-conduit = hlib.dontCheck - (hlib.dontHaddock (hsuper.callHackageDirect my-opml-conduit { })); - rss-conduit = hlib.dontCheck - (hlib.dontHaddock (hsuper.callHackageDirect my-rss-conduit { })); - msgpack = hlib.doJailbreak hsuper.msgpack; - }; + overrides = hself: hsuper: + let + fromHackage = x: + hlib.dontCheck (hlib.dontHaddock (hsuper.callHackageDirect x { })); + in { + imm = packageWithRuntimeDependencies; + avro = fromHackage my-avro; + atom-conduit = fromHackage my-atom-conduit; + opml-conduit = fromHackage my-opml-conduit; + rss-conduit = fromHackage my-rss-conduit; + }; }; addRuntimeDependencies = drv: xs: @@ -64,8 +76,6 @@ withHoogle = false; }; - - exe = hlib.justStaticExecutables (myHaskellPackages.imm); in { inherit shell; diff --git a/idl/callback.json b/idl/callback.json new file mode 100644 --- /dev/null +++ b/idl/callback.json @@ -0,0 +1,14 @@ +{ + "type": "record", + "name": "message", + "fields": [ + { + "name": "feed", + "type": "string" + }, + { + "name": "element", + "type": "string" + } + ] +} diff --git a/imm.cabal b/imm.cabal --- a/imm.cabal +++ b/imm.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: imm -version: 1.9.0.0 +version: 1.10.0.0 synopsis: Execute arbitrary callbacks for each element of RSS/Atom feeds description: Cf README file homepage: https://github.com/k0ral/imm @@ -11,7 +11,7 @@ category: Web build-type: Simple data-files: data/*.dhall -extra-source-files: README.md, *.nix +extra-source-files: README.md, *.nix, idl/*.json tested-with: GHC <8.10 && >=8.4.2 source-repository head @@ -40,6 +40,7 @@ build-depends: aeson, async, + avro, atom-conduit >= 0.7, binary, conduit, @@ -48,7 +49,6 @@ directory >= 1.2.3.0, filepath, hashable, - msgpack, microlens, monad-time, pipes, @@ -70,7 +70,7 @@ executable imm import: common - build-depends: imm, aeson, async, atom-conduit >=0.7, bytestring, conduit, containers, dhall >= 1.27, directory, fast-logger, filepath, msgpack, opml-conduit >=0.7, optparse-applicative, prettyprinter-ansi-terminal, pipes, pipes-bytestring, refined >=0.4.1, rss-conduit >=0.4.1, safe, safe-exceptions, stm, stm-chans, text, typed-process, uri-bytestring, xml-conduit >=1.5, xml-types + build-depends: imm, aeson, async, atom-conduit >=0.7, avro >=0.5, bytestring, conduit, containers, dhall >= 1.27, directory, fast-logger, filepath, opml-conduit >=0.7, optparse-applicative, prettyprinter-ansi-terminal, pipes, pipes-bytestring, refined >=0.4.1, rss-conduit >=0.4.1, safe, safe-exceptions, stm, stm-chans, text, typed-process, uri-bytestring, xml-conduit >=1.5, xml-types main-is: Main.hs other-modules: Alternate, Core, Database, HTTP, Logger, Options, Paths_imm, XML autogen-modules: Paths_imm @@ -79,14 +79,14 @@ executable imm-writefile import: common - build-depends: imm, atom-conduit, blaze-html, blaze-markup, bytestring, directory, filepath, msgpack, optparse-applicative, prettyprinter, rss-conduit, streaming-bytestring, streaming-with, text, time, uri-bytestring + build-depends: imm, atom-conduit, blaze-html, blaze-markup, bytestring, directory, filepath, optparse-applicative, prettyprinter, rss-conduit, text, time, uri-bytestring main-is: Main.hs hs-source-dirs: src/write-file ghc-options: -Wall -fno-warn-unused-do-bind -threaded executable imm-sendmail import: common - build-depends: imm, atom-conduit, blaze-html, blaze-markup, bytestring, dhall >= 1.27, directory, filepath, msgpack, mime-mail, optparse-applicative, prettyprinter, refined, rss-conduit, text, time, typed-process, uri-bytestring + build-depends: imm, atom-conduit, blaze-html, blaze-markup, bytestring, dhall >= 1.27, directory, filepath, mime-mail, optparse-applicative, prettyprinter, refined, rss-conduit, text, time, typed-process, uri-bytestring main-is: Main.hs hs-source-dirs: src/send-mail ghc-options: -Wall -fno-warn-unused-do-bind -threaded diff --git a/src/lib/Imm/Callback.hs b/src/lib/Imm/Callback.hs --- a/src/lib/Imm/Callback.hs +++ b/src/lib/Imm/Callback.hs @@ -1,20 +1,21 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -module Imm.Callback where +module Imm.Callback (Callback(..), serializeMessage, deserializeMessage) where -- {{{ Imports import Imm.Feed -import qualified Data.Map as Map -import Data.MessagePack.Object +import qualified Data.Avro as Avro +import Data.Avro.Deriving import Data.Text.Prettyprint.Doc import Dhall hiding (maybe) -- }}} -- | External program run for each feed element. -- --- A `Message` is passed to this program through stdin, serialized in JSON. +-- Data is passed to that program through standard input (@stdin@), using Avro () serialization format. The data schema is described in file @ids/callback.json@, provided with this library. data Callback = Callback { _executable :: FilePath , _arguments :: [Text] @@ -26,16 +27,16 @@ pretty (Callback executable arguments) = pretty executable <+> sep (pretty <$> arguments) --- | All information passed to external programs about a new feed item, are stored in this structure. -data Message = Message Feed FeedElement deriving(Eq, Generic, Ord, Show) +deriveAvroWithOptions defaultDeriveOptions "idl/callback.json" -instance MessagePack Message where - toObject (Message feed element) = toObject @(Map Text Text) - $ Map.insert "feed" (renderFeed feed) - $ Map.insert "element" (renderFeedElement element) mempty +-- | Meant to be called by the main @imm@ process. +serializeMessage :: Feed -> FeedElement -> LByteString +serializeMessage feed element = Avro.encodeValue $ Message (renderFeed feed) (renderFeedElement element) - fromObject object = fromObject object >>= \m -> Message - <$> (lookup @(Map Text Text) "feed" m >>= eitherToMaybe . parseFeed) - <*> (lookup @(Map Text Text) "element" m >>= eitherToMaybe . parseFeedElement) - where eitherToMaybe (Right a) = Just a - eitherToMaybe _ = Nothing +-- | Meant to be called by callback process. +deserializeMessage :: MonadFail m => LByteString -> m (Feed, FeedElement) +deserializeMessage bytestring = do + Message feedText elementText <- Avro.decodeValue bytestring & either fail pure + feed <- parseFeed feedText & either (fail . displayException) pure + element <- parseFeedElement elementText & either (fail . displayException) pure + return (feed, element) diff --git a/src/lib/Prelude.hs b/src/lib/Prelude.hs --- a/src/lib/Prelude.hs +++ b/src/lib/Prelude.hs @@ -1,6 +1,6 @@ module Prelude (io, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, force) +import Relude hiding (Handle, appendFile, force, readFile, writeFile) import Relude.Extra.Map (lookup) io :: MonadIO m => IO a -> m a diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -6,6 +6,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- {{{ Imports import Alternate import qualified Core @@ -19,9 +20,9 @@ import Control.Concurrent.STM.TMChan import Control.Exception.Safe import Data.Conduit.Combinators as Conduit (stdin) -import qualified Data.MessagePack as MsgPack import Dhall import Imm +import qualified Imm.Callback as Callback import Imm.Database.Feed as Database import qualified Imm.HTTP as HTTP import Imm.Pretty @@ -117,7 +118,7 @@ -- New items events => execute callback => processed/error events let runnerF (entryKey, feed, element) = do results <- forM callbacks $ \callback@(Callback executable arguments) -> do - let processInput = byteStringInput $ MsgPack.pack $ Message feed element + let processInput = byteStringInput $ Callback.serializeMessage feed element processConfig = proc executable (toString <$> arguments) & setStdin processInput log logger Debug $ "Running" <+> cyan (pretty executable) <+> "on" <+> magenta (pretty entryKey) <+> "/" <+> yellow (pretty $ getTitle element) @@ -202,7 +203,9 @@ bold ("Fetch error for" <+> prettyURI uri) <++> indent 2 (pretty $ displayException e) -printCallbackError :: Logger.Handle m -> ((EntryKey, FeedElement), _) -> m () +printCallbackError :: i ~ (EntryKey, FeedElement) + => e ~ (Callback, Int, LByteString, LByteString) + => Logger.Handle m -> (i, [e]) -> m () printCallbackError logger ((entryKey, element), e) = log logger Error $ bold ("Callback error for" <+> pretty entryKey <+> "/" <+> pretty (getTitle element)) <++> indent 2 prettyErrors diff --git a/src/main/Prelude.hs b/src/main/Prelude.hs --- a/src/main/Prelude.hs +++ b/src/main/Prelude.hs @@ -1,6 +1,6 @@ module Prelude (io, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, force) +import Relude hiding (Handle, appendFile, force, readFile, writeFile) import Relude.Extra.Map (lookup) io :: MonadIO m => IO a -> m a diff --git a/src/send-mail/Main.hs b/src/send-mail/Main.hs --- a/src/send-mail/Main.hs +++ b/src/send-mail/Main.hs @@ -3,12 +3,11 @@ {-# LANGUAGE OverloadedStrings #-} -- | 'Callback' for @imm@ that sends a mail via a SMTP server the input RSS/Atom item. -- {{{ Imports -import Imm.Callback +import qualified Imm.Callback as Callback import Imm.Feed import Imm.Pretty -import Data.ByteString (getContents) -import qualified Data.MessagePack as MsgPack +import Data.ByteString.Lazy (getContents) import Data.Text as Text (intercalate) import Data.Time import Dhall hiding (map, maybe) @@ -71,9 +70,9 @@ CliOptions configFile recipients dryRun <- parseOptions Command executable arguments <- input auto $ fromString configFile - message <- getContents <&> fromStrict <&> MsgPack.unpack + message <- getContents <&> Callback.deserializeMessage case message of - Just (Message feed element) -> do + Right (feed, element) -> do timezone <- io getCurrentTimeZone currentTime <- io getCurrentTime let formatMail = FormatMail defaultFormatFrom defaultFormatSubject defaultFormatBody (const $ const recipients) @@ -88,7 +87,7 @@ ExitSuccess -> exitSuccess ExitFailure _ -> putStrLn (decodeUtf8 errors) >> exitFailure - _ -> putStrLn "Invalid input" >> exitFailure + Left e -> putStrLn ("Invalid input: " <> e) >> exitFailure return () diff --git a/src/send-mail/Prelude.hs b/src/send-mail/Prelude.hs --- a/src/send-mail/Prelude.hs +++ b/src/send-mail/Prelude.hs @@ -1,6 +1,6 @@ module Prelude (io, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, force) +import Relude hiding (Handle, appendFile, force, readFile, writeFile) import Relude.Extra.Map (lookup) io :: MonadIO m => IO a -> m a diff --git a/src/write-file/Main.hs b/src/write-file/Main.hs --- a/src/write-file/Main.hs +++ b/src/write-file/Main.hs @@ -4,24 +4,20 @@ -- -- Meant to be use as a callback for imm. -- {{{ Imports -import Imm.Callback +import Imm.Callback as Callback import Imm.Feed import Imm.Pretty -import Data.ByteString (getContents) import Data.ByteString.Builder -import Data.ByteString.Streaming (toStreamingByteString) -import qualified Data.MessagePack as MsgPack +import Data.ByteString.Lazy (getContents, writeFile) import qualified Data.Text as Text (null, replace) import Data.Time import Options.Applicative -import Streaming.With import System.Directory (createDirectoryIfMissing) import System.FilePath import Text.Atom.Types import Text.Blaze.Html.Renderer.Utf8 -import Text.Blaze.Html5 (Html, docTypeHtml, - preEscapedToHtml, (!)) +import Text.Blaze.Html5 (Html, docTypeHtml, preEscapedToHtml, (!)) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as H (charset, href) import Text.RSS.Types @@ -46,16 +42,17 @@ main :: IO () main = do CliOptions directory dryRun <- parseOptions - message <- getContents <&> fromStrict <&> MsgPack.unpack - case message of - Just (Message feed element) -> do + input <- getContents <&> Callback.deserializeMessage + + case input :: Either String (Feed, FeedElement) of + Right (feed, element) -> do let content = defaultFileContent feed element filePath = defaultFilePath directory feed element putStrLn filePath unless dryRun $ do createDirectoryIfMissing True $ takeDirectory filePath - writeBinaryFile filePath $ toStreamingByteString content - _ -> putStrLn "Invalid input" >> exitFailure + writeFile filePath $ toLazyByteString content + Left e -> putStrLn ("Invalid input: " <> e) >> exitFailure return () -- * Default behavior diff --git a/src/write-file/Prelude.hs b/src/write-file/Prelude.hs --- a/src/write-file/Prelude.hs +++ b/src/write-file/Prelude.hs @@ -1,6 +1,6 @@ module Prelude (io, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, force) +import Relude hiding (Handle, appendFile, force, readFile, writeFile) import Relude.Extra.Map (lookup) io :: MonadIO m => IO a -> m a