diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,16 +5,16 @@ *imm* is written in [Haskell][2], configured in [Dhall][3]. The project includes: - a main executable `imm` that users run directly -- secondary executables (`imm-writefile`, `imm-sendmail`) which can be used as callbacks triggered by `imm` +- secondary executables (`imm-writefile`, `imm-sendmail`, `imm-monolith`) meant to be used as callbacks triggered by `imm` - a [Haskell][2] library, that exports functions useful to both the main executable and callbacks; the API is documented [in Hackage][1]. ## Installation ### Using nix -This repository includes a *nix* package that can be installed by running the following command at the root folder: +This repository is notably a [Nix flake][flakes] that can be installed by running the following command at the root folder: ```bash -nix-build --attr exe +nix build ``` ### Without nix @@ -25,6 +25,7 @@ ``` Then, the following runtime dependencies must be installed separately and provided in `PATH`: +- [monolith](https://github.com/Y2Z/monolith) (if using `imm-monolith`) - [pup](https://github.com/ericchiang/pup) ## Configuration @@ -66,23 +67,41 @@ ### Offline read-it-later -*imm* is able to store a local copy of unread elements, to read them later while offline for example. External links won't work offline though. +*imm* is able to store a local copy of unread elements, to read them later while offline for example. -```dhall -let Callback : Type = - { _executable : Text - , _arguments : List Text - } +There are 2 alternate ways of achieving this: +- using `imm-writefile` will produce a light HTML file with no stylesheets, no scripts and with links to online resources (images, fonts, ...) that won't be available offline: + ```dhall + let Callback : Type = + { _executable : Text + , _arguments : List Text + } -let writeFile = - { _executable = "imm-writefile" - , _arguments = [ "-d", "/path/to/folder" ] - } + let writeFile = + { _executable = "imm-writefile" + , _arguments = [ "-d", "/path/to/folder" ] + } -let config : List Callback = [ writeFile ] -in config -``` + let config : List Callback = [ writeFile ] + in config + ``` +- using `imm-monolith` will produce a heavy, self-contained HTML file, with embedded stylesheets, scripts, images and fonts; links to external web pages will still require an internet connection: + ```dhall + let Callback : Type = + { _executable : Text + , _arguments : List Text + } + let downloadPage = + { _executable = "imm-monolith" + , _arguments = [ "-d", "/path/to/folder" ] + } + + let config : List Callback = [ downloadPage ] + in config + ``` + + ## Example usage - Subscribe to a feed through direct URL: @@ -123,3 +142,4 @@ [1]: http://hackage.haskell.org/package/imm [2]: https://www.haskell.org [3]: https://dhall-lang.org/ +[flakes]: https://nixos.wiki/wiki/Flakes diff --git a/data/callbacks.dhall b/data/callbacks.dhall --- a/data/callbacks.dhall +++ b/data/callbacks.dhall @@ -5,8 +5,13 @@ , _arguments : List Text } --- Below are 2 basic callbacks bundled with imm. --- +-- Below are 3 basic callbacks bundled with imm. +-- Check out `imm-monolith --help` +let downloadPage = + { _executable = "imm-monolith" + , _arguments = [ "-d", "/path/to/folder" ] + } + -- Check out `imm-writefile --help` let writeFile = { _executable = "imm-writefile" @@ -19,5 +24,5 @@ , _arguments = ["--login", "-u", "user@domain.com", "-P", "password", "-s", "smtp.domain.com", "-p", "587", "--to", "foo.bar@domain.com"] } -let config : List Callback = [ writeFile ] +let config : List Callback = [ downloadPage ] in config diff --git a/default.nix b/default.nix deleted file mode 100644 --- a/default.nix +++ /dev/null @@ -1,80 +0,0 @@ -{ nixpkgs ? import { } }: - -let - hlib = nixpkgs.haskell.lib; - - source = nixpkgs.nix-gitignore.gitignoreSource [ ] ./.; - packageWithoutRuntimeDependencies = - myHaskellPackages.callCabal2nix "imm" source { }; - packageWithRuntimeDependencies = with nixpkgs; - addRuntimeDependencies packageWithoutRuntimeDependencies [ - pup - sqliteInteractive - ]; - - exe = hlib.justStaticExecutables packageWithRuntimeDependencies; - - my-atom-conduit = { - pkg = "atom-conduit"; - ver = "0.9.0.0"; - sha256 = "11x41fxj0g93kg46z06i1kxfms84wqbad41i7fnm7ixpw4n464pp"; - }; - - my-beam = nixpkgs.fetchFromGitHub { - owner = "haskell-beam"; - repo = "beam"; - rev = "3bde0615b6eccfe5ca44ed907b79a3cd74eee33f"; - sha256 = "0fy8p70pxhrllr2njwxa8lijf35hlds2zkhh7fkkv5b3i34jqx29"; - }; - - my-rss-conduit = { - pkg = "rss-conduit"; - ver = "0.6.0.0"; - sha256 = "1gdq1bv1ayx9qx9ppwld8b5qjfsq1pgkqd29qni3jcldw9w4wfb8"; - }; - - myHaskellPackages = nixpkgs.haskellPackages.override { - overrides = hself: hsuper: - let - fromHackage = x: - hlib.dontCheck (hlib.dontHaddock (hsuper.callHackageDirect x { })); - in { - imm = packageWithRuntimeDependencies; - atom-conduit = fromHackage my-atom-conduit; - beam-core = hself.callCabal2nix "beam-core" "${my-beam}/beam-core" {}; - beam-migrate = hself.callCabal2nix "beam-core" "${my-beam}/beam-migrate" {}; - beam-sqlite = hself.callCabal2nix "beam-core" "${my-beam}/beam-sqlite" {}; - rss-conduit = fromHackage my-rss-conduit; - }; - }; - - addRuntimeDependencies = drv: xs: - hlib.overrideCabal drv (drv: { - buildDepends = (drv.buildDepends or [ ]) ++ [ nixpkgs.makeWrapper ]; - postInstall = '' - ${drv.postInstall or ""} - for exe in "$out/bin/"* ; do - wrapProgram "$exe" --prefix PATH ":" \ - ${nixpkgs.lib.makeBinPath xs} - done - ''; - }); - - shell = myHaskellPackages.shellFor { - packages = p: [ p.imm ]; - - buildInputs = with nixpkgs; [ - haskellPackages.cabal-install - haskellPackages.haskell-ci - haskellPackages.hlint - haskellPackages.ghcid - sqliteInteractive - ]; - - withHoogle = false; - }; - -in { - inherit shell; - inherit exe; -} diff --git a/flake.nix b/flake.nix new file mode 100644 --- /dev/null +++ b/flake.nix @@ -0,0 +1,76 @@ +{ + description = "imm flake"; + + inputs = { + nixpkgs.url = "github:NixOS/nixpkgs/e9158eca70ae59e73fae23be5d13d3fa0cfc78b4"; + beam.url = "github:haskell-beam/beam/efd464b079755a781c2bb7a2fc030d6c141bbb8a"; + beam.flake = false; + atom-conduit.url = "github:k0ral/atom-conduit/da353afcbf19a8cfebefa34bc5c4b81ee80322b3"; + atom-conduit.flake = false; + rss-conduit.url = "github:k0ral/rss-conduit/c1fec73d715fd1c9a95a155e87ba469887b8e543"; + rss-conduit.flake = false; + timerep.url = "github:HugoDaniel/timerep/aeb792b7ec701634016021b188e01091e9bd10df"; + timerep.flake = false; + }; + + outputs = { self, nixpkgs, beam, atom-conduit, rss-conduit, timerep }: + let + pkgs = import nixpkgs { system = "x86_64-linux"; }; + hlib = pkgs.haskell.lib; + + source = pkgs.nix-gitignore.gitignoreSource [ ] ./.; + package = with pkgs; + add-runtime-dependencies (my-haskell-packages.callCabal2nix "imm" source { }) [ + monolith + pup + sqliteInteractive + ]; + executable = hlib.justStaticExecutables package; + + my-haskell-packages = pkgs.haskellPackages.override { + overrides = hself: hsuper: + let from-hackage = x: hlib.doJailbreak (hlib.dontCheck (hlib.dontHaddock (hsuper.callHackageDirect x { }))); + in { + imm = package; + atom-conduit = hself.callCabal2nix "atom-conduit" atom-conduit { }; + beam-core = hlib.doJailbreak (hself.callCabal2nix "beam-core" "${beam}/beam-core" { }); + beam-migrate = hlib.doJailbreak (hself.callCabal2nix "beam-core" "${beam}/beam-migrate" { }); + beam-sqlite = hlib.doJailbreak (hself.callCabal2nix "beam-core" "${beam}/beam-sqlite" { }); + rss-conduit = hself.callCabal2nix "rss-conduit" rss-conduit { }; + chronos = from-hackage { + pkg = "chronos"; + ver = "1.1.1"; + sha256 = "gOHjPrDXgyZjfC/4qp7UwCj9FOopO5vGQaAKkRoCdRg="; + }; + co-log = from-hackage { + pkg = "co-log"; + ver = "0.4.0.1"; + sha256 = "r/thdqWagfWFFVntgxytOWIrERUj2WCFqZXyGTA9wxU="; + }; + timerep = hself.callCabal2nix "timerep" timerep { }; + }; + }; + + add-runtime-dependencies = drv: xs: + hlib.overrideCabal drv (drv: { + buildDepends = (drv.buildDepends or [ ]) ++ [ pkgs.makeWrapper ]; + postInstall = '' + ${drv.postInstall or ""} + for exe in "$out/bin/"* ; do + wrapProgram "$exe" --prefix PATH ":" \ + ${nixpkgs.lib.makeBinPath xs} + done + ''; + }); + in { + defaultPackage.x86_64-linux = executable; + devShell = my-haskell-packages.shellFor { + packages = p: [ p.imm ]; + + buildInputs = [ my-haskell-packages.cabal-install my-haskell-packages.hlint pkgs.sqliteInteractive ]; + + withHoogle = false; + }; + }; + +} 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: 2.0.0.0 +version: 2.1.0.0 synopsis: Execute arbitrary actions for each item from RSS/Atom feeds description: Cf README file homepage: https://github.com/k0ral/imm @@ -19,8 +19,9 @@ location: git://github.com/k0ral/imm.git common common - build-depends: base-noprelude >=4.7 && <5, relude + build-depends: base >=4.7 && <5, relude default-language: Haskell2010 + mixins: base hiding (Prelude) other-modules: Prelude @@ -71,7 +72,7 @@ executable imm import: common - build-depends: imm, aeson, async, beam-core, beam-sqlite, bytestring, chronos, co-log, conduit, containers, dhall >= 1.27, directory, filepath, http-types, microlens, monad-time, optparse-applicative, prettyprinter-ansi-terminal, pipes, pipes-bytestring, pipes-http, safe, safe-exceptions, sqlite-simple, stm, stm-chans, streamly, text, time, typed-process, typerep-map, uri-bytestring, xml-conduit >=1.5, xml-types + build-depends: imm, aeson, async, beam-core, beam-sqlite, bytestring, chronos, co-log, conduit, containers, dhall >= 1.27, directory, filepath, http-types, microlens, monad-time, optparse-applicative, prettyprinter-ansi-terminal, pipes, pipes-bytestring, pipes-http, safe, safe-exceptions, sqlite-simple, stm, stm-chans, streamly >=0.7, text, time, typed-process, typerep-map, uri-bytestring, xml-conduit >=1.5, xml-types main-is: Main.hs other-modules: Alternate @@ -89,6 +90,13 @@ XML autogen-modules: Paths_imm hs-source-dirs: src/main + ghc-options: -Wall -fno-warn-unused-do-bind -threaded + +executable imm-monolith + import: common + build-depends: imm, aeson, bytestring, directory, filepath, optparse-applicative, prettyprinter, safe-exceptions, text, time, typed-process, uri-bytestring + main-is: Main.hs + hs-source-dirs: src/monolith ghc-options: -Wall -fno-warn-unused-do-bind -threaded executable imm-writefile diff --git a/shell.nix b/shell.nix deleted file mode 100644 --- a/shell.nix +++ /dev/null @@ -1,1 +0,0 @@ -(import ./default.nix { }).shell diff --git a/src/lib/Imm/Pretty.hs b/src/lib/Imm/Pretty.hs --- a/src/lib/Imm/Pretty.hs +++ b/src/lib/Imm/Pretty.hs @@ -6,10 +6,10 @@ -- {{{ Imports import qualified Data.Text as Text -import Data.Text.Prettyprint.Doc as X hiding (list, width) import Data.Text.Prettyprint.Doc (list) -import Data.Text.Prettyprint.Doc.Render.Terminal as X (AnsiStyle) +import Data.Text.Prettyprint.Doc as X hiding (list, width) import Data.Text.Prettyprint.Doc.Render.Terminal +import Data.Text.Prettyprint.Doc.Render.Terminal as X (AnsiStyle) import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty import Data.Time import Data.Tree diff --git a/src/lib/Prelude.hs b/src/lib/Prelude.hs --- a/src/lib/Prelude.hs +++ b/src/lib/Prelude.hs @@ -1,8 +1,8 @@ module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) -import Relude.Extra.Map (lookup) import Control.Exception.Safe +import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) +import Relude.Extra.Map (lookup) io :: MonadIO m => IO a -> m a io = liftIO @@ -12,8 +12,8 @@ headThrow :: MonadThrow m => Exception e => e -> [a] -> m a headThrow _ (a:_) = return a -headThrow e _ = throwM e +headThrow e _ = throwM e headFail :: MonadFail m => String -> [a] -> m a headFail _ (a:_) = return a -headFail e _ = fail e +headFail e _ = fail e diff --git a/src/main/Alternate.hs b/src/main/Alternate.hs --- a/src/main/Alternate.hs +++ b/src/main/Alternate.hs @@ -39,8 +39,10 @@ ] instance FromJSON AlternateLink where - parseJSON (Object v) = AlternateLink <$> v .: "title" <*> v .: "type" <*> v .: "href" - parseJSON _ = mzero + parseJSON = withObject "AlternateLink" $ \v -> AlternateLink + <$> (v .: "title" <|> pure mempty) + <*> v .: "type" + <*> v .: "href" asFeedURI :: MonadFail m => URI -> Text -> m URI diff --git a/src/main/Core.hs b/src/main/Core.hs --- a/src/main/Core.hs +++ b/src/main/Core.hs @@ -16,9 +16,8 @@ -- {{{ Imports import Alternate -import Database.Record --- (FeedItemRecord (..), FeedItemStatus (..), FeedRecord (..), Inserted) import qualified Database.Handle as Database +import Database.Record import Output (putDocLn) import qualified Output diff --git a/src/main/Database/Async.hs b/src/main/Database/Async.hs --- a/src/main/Database/Async.hs +++ b/src/main/Database/Async.hs @@ -3,7 +3,7 @@ module Database.Async (withAsyncHandle) where import Database.Handle -import Output (putDocLn) +import Output (putDocLn) import qualified Output import Control.Concurrent.Async diff --git a/src/main/Database/Handle.hs b/src/main/Database/Handle.hs --- a/src/main/Database/Handle.hs +++ b/src/main/Database/Handle.hs @@ -173,7 +173,7 @@ markAllFeedsAsUnprocessed :: MonadThrow m => Logger.Handle m -> Handle m -> m () markAllFeedsAsUnprocessed logger database = do - log logger Debug $ "Marking all feeds as unprocessed..." + log logger Debug "Marking all feeds as unprocessed..." feeds <- _fetchAllFeeds database items <- _fetchAllItems database forM_ items $ \item -> _updateItemStatus database $ item { _itemStatus = markItemAsUnprocessed $ _itemStatus item } diff --git a/src/main/Logger.hs b/src/main/Logger.hs --- a/src/main/Logger.hs +++ b/src/main/Logger.hs @@ -12,7 +12,7 @@ import Chronos import Colog hiding (Severity (..)) -import qualified Colog as Colog +import qualified Colog import Data.Text.Prettyprint.Doc.Render.Terminal import qualified Data.TypeRepMap as TypeRepMap import System.Directory @@ -56,4 +56,4 @@ <> " " <> text where showTime posixTime = "[" <> encode_YmdHMS (SubsecondPrecisionFixed 0) hyphen (timeToDatetime posixTime) <> "]" showThread (Just tid) = "[" <> show tid <> "]" - showThread _ = mempty + showThread _ = mempty diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -43,7 +43,7 @@ Subscribe u c -> Core.subscribe logger stdout database u c Unsubscribe query -> Core.unsubscribe logger database query Describe query -> Core.describeFeeds stdout database query - Reset query -> Core.markAsUnprocessed logger database query + Reset query -> Core.markAsUnprocessed logger database query Run f c -> main2 logger stdout database f =<< resolveCallbacks c (inputCallbacksFile programInput) Database.commit logger database diff --git a/src/main/Prelude.hs b/src/main/Prelude.hs --- a/src/main/Prelude.hs +++ b/src/main/Prelude.hs @@ -1,8 +1,8 @@ module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) -import Relude.Extra.Map (lookup) import Control.Exception.Safe +import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) +import Relude.Extra.Map (lookup) io :: MonadIO m => IO a -> m a io = liftIO @@ -12,8 +12,8 @@ headThrow :: MonadThrow m => Exception e => e -> [a] -> m a headThrow _ (a:_) = return a -headThrow e _ = throwM e +headThrow e _ = throwM e headFail :: MonadFail m => String -> [a] -> m a headFail _ (a:_) = return a -headFail e _ = fail e +headFail e _ = fail e diff --git a/src/monolith/Main.hs b/src/monolith/Main.hs new file mode 100644 --- /dev/null +++ b/src/monolith/Main.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Download a self-contained HTML file, using monolith, related to the input RSS/Atom item. +-- +-- Meant to be use as a callback for imm. +-- {{{ Imports +import Imm.Callback +import Imm.Feed +import Imm.Link +import Imm.Pretty + +import Data.Aeson +import Data.ByteString.Lazy (getContents) +import qualified Data.Text as Text (replace) +import Data.Time +import Options.Applicative +import System.Directory (createDirectoryIfMissing) +import System.Exit (ExitCode) +import System.FilePath +import System.Process.Typed +import URI.ByteString.Extended +-- }}} + +data CliOptions = CliOptions + { _directory :: FilePath + , _dryRun :: Bool + } deriving (Eq, Ord, Read, Show) + +parseOptions :: MonadIO m => m CliOptions +parseOptions = io $ customExecParser defaultPrefs (info cliOptions $ progDesc "Download a self-contained HTML file, using monolith, for each new RSS/Atom item. An intermediate folder will be created for each feed.") + +cliOptions :: Parser CliOptions +cliOptions = CliOptions + <$> strOption (long "directory" <> short 'd' <> metavar "PATH" <> help "Root directory where files will be created.") + <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.") + + +main :: IO () +main = do + CliOptions directory dryRun <- parseOptions + input <- getContents <&> eitherDecode + + case input :: Either String CallbackMessage of + Right (CallbackMessage feedDefinition item) -> do + let filePath = defaultFilePath directory feedDefinition item + putStrLn filePath + unless dryRun $ do + createDirectoryIfMissing True $ takeDirectory filePath + case getMainLink item of + Just link -> downloadPage filePath (_linkURI link) >>= exitWith + _ -> putStrLn ("No main link in item " <> show (prettyName item)) >> exitFailure + Left e -> putStrLn ("Invalid input: " <> e) >> exitFailure + return () + +-- * Default behavior + +downloadPage :: FilePath -> AnyURI -> IO ExitCode +downloadPage filePath uri = runProcess $ proc "monolith" ["-o", filePath, show $ pretty uri] + & setStdin nullStream + & setStdout inherit + & setStderr inherit + +-- | Generate a path @//-.html@, where @@ is the first argument +defaultFilePath :: FilePath -> FeedDefinition -> FeedItem -> FilePath +defaultFilePath root feedDefinition element = makeValid $ root toString title fileName <.> "html" where + date = maybe "" (formatTime defaultTimeLocale "%F-") $ _itemDate element + fileName = date <> toString (sanitize $ _itemTitle element) + title = sanitize $ _feedTitle feedDefinition + sanitize = appEndo (mconcat [Endo $ Text.replace (toText [s]) "_" | s <- pathSeparators]) + >>> Text.replace "." "_" + >>> Text.replace "?" "_" + >>> Text.replace "!" "_" + >>> Text.replace "#" "_" diff --git a/src/monolith/Prelude.hs b/src/monolith/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/monolith/Prelude.hs @@ -0,0 +1,19 @@ +module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where + +import Control.Exception.Safe +import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) +import Relude.Extra.Map (lookup) + +io :: MonadIO m => IO a -> m a +io = liftIO + +for :: [a] -> (a -> b) -> [b] +for = flip map + +headThrow :: MonadThrow m => Exception e => e -> [a] -> m a +headThrow _ (a:_) = return a +headThrow e _ = throwM e + +headFail :: MonadFail m => String -> [a] -> m a +headFail _ (a:_) = return a +headFail e _ = fail e 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,8 +1,8 @@ module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) -import Relude.Extra.Map (lookup) import Control.Exception.Safe +import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) +import Relude.Extra.Map (lookup) io :: MonadIO m => IO a -> m a io = liftIO @@ -12,8 +12,8 @@ headThrow :: MonadThrow m => Exception e => e -> [a] -> m a headThrow _ (a:_) = return a -headThrow e _ = throwM e +headThrow e _ = throwM e headFail :: MonadFail m => String -> [a] -> m a headFail _ (a:_) = return a -headFail e _ = fail e +headFail e _ = fail e 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,8 +1,8 @@ module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) -import Relude.Extra.Map (lookup) import Control.Exception.Safe +import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) +import Relude.Extra.Map (lookup) io :: MonadIO m => IO a -> m a io = liftIO @@ -12,8 +12,8 @@ headThrow :: MonadThrow m => Exception e => e -> [a] -> m a headThrow _ (a:_) = return a -headThrow e _ = throwM e +headThrow e _ = throwM e headFail :: MonadFail m => String -> [a] -> m a headFail _ (a:_) = return a -headFail e _ = fail e +headFail e _ = fail e