FeedMonad/default.nix

@@ -1,6 +1,6 @@
 { mkDerivation, acid-state, base, bytestring, containers, feed
 , free, http-client, http-client-tls, lens, lib, mtl, safecopy
-, servant, servant-server, text, time, xdg-basedir, xml-conduit
+, servant, servant-server, text, xdg-basedir
 }:
 mkDerivation {
   pname = "FeedMonad";
@@ -8,8 +8,8 @@ mkDerivation {
   src = ./.;
   libraryHaskellDepends = [
     acid-state base bytestring containers feed free http-client
-    http-client-tls lens mtl safecopy servant servant-server text time
+    http-client-tls lens mtl safecopy servant servant-server text
-    xdg-basedir xml-conduit
+    xdg-basedir
   ];
   license = "unknown";
   hydraPlatforms = lib.platforms.none;

FeedMonad/src/Feed/Parser.hs

@@ -5,6 +5,7 @@ import Control.Lens (from, lazy, re, view, _Just)
 import Data.ByteString.Lazy (ByteString)
 import Data.Entry (Entry(..), Tag(Tag))
 import Data.Foldable (toList)
+import Data.Maybe (mapMaybe)
 import qualified Data.Set as S
 import Data.Text.Strict.Lens (unpacked, utf8)
 import Data.URL (URL(URL), _URL)
@@ -22,20 +23,18 @@ import Text.XML
        , renderLBS
        )
 import Data.Time (parseTimeM, rfc822DateFormat, defaultTimeLocale, iso8601DateFormat)
-import Data.Text (Text)
-import qualified Data.Text as T
 
-parseAtom :: Atom.Feed -> [Either Text Entry]
+parseAtom :: Atom.Feed -> [Entry]
-parseAtom Atom.Feed{Atom.feedEntries=es} = map parseEntry es
+parseAtom Atom.Feed{Atom.feedEntries=es} = mapMaybe parseEntry es
   where
-    parseEntry :: Atom.Entry -> Either Text Entry
+    parseEntry :: Atom.Entry -> Maybe Entry
     parseEntry atomEntry = Entry
-      <$> note "Missing entry id" (view (unpacked . from _URL . re _Just) entryId)
+      <$> view (unpacked . from _URL . re _Just) entryId
-      <*> note "Missing title" title
+      <*> title
-      <*> note "Missing content" content
+      <*> content
       <*> pure 0
       <*> pure mempty
-      <*> note ("Missing time: " <> T.pack (show entryUpdated)) (parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S%Q%EZ")) . view unpacked $ entryUpdated)
+      <*> (parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S%Q%EZ")) . view unpacked =<< entryPublished)
       where
         content =
           case entryContent of
@@ -50,7 +49,7 @@ parseAtom Atom.Feed{Atom.feedEntries=es} = map parseEntry es
         Atom.Entry{ Atom.entryId
                   , Atom.entryTitle
                   , Atom.entryContent
-                  , Atom.entryUpdated } = atomEntry
+                  , Atom.entryPublished } = atomEntry
 
 renderElement :: [Element] -> ByteString
 renderElement els = renderLBS def doc
@@ -59,23 +58,18 @@ renderElement els = renderLBS def doc
     doc = Document {documentPrologue = prologue, documentRoot = el, documentEpilogue = []}
     prologue = Prologue {prologueBefore = [], prologueDoctype = Nothing, prologueAfter = []}
 
--- | Add context to a Maybe by converting it into an Either
+parseRSS :: RSS.RSS -> [Entry]
-note :: e -> Maybe a -> Either e a
-note e Nothing = Left e
-note _ (Just a) = Right a
-
-parseRSS :: RSS.RSS -> [Either Text Entry]
 parseRSS RSS.RSS{RSS.rssChannel=RSS.RSSChannel{RSS.rssItems = items}} =
-  map parseItem items
+  mapMaybe parseItem items
   where
-    parseItem :: RSS.RSSItem -> Either Text Entry
+    parseItem :: RSS.RSSItem -> Maybe Entry
     parseItem item = Entry
-      <$> note "Missing entry url" (URL . view unpacked <$> rssItemLink)
+      <$> (URL . view unpacked <$> rssItemLink)
-      <*> note "Missing title" rssItemTitle
+      <*> rssItemTitle
-      <*> note "Missing content" (regularContent <> Just otherContent)
+      <*> (regularContent <> Just otherContent)
       <*> pure 0
       <*> pure (foldMap (S.singleton . Tag . RSS.rssCategoryValue) rssItemCategories)
-      <*> note ("Missing time: " <> T.pack (show rssItemPubDate)) (parseTimeM True defaultTimeLocale rfc822DateFormat . view unpacked =<< rssItemPubDate)
+      <*> (parseTimeM True defaultTimeLocale rfc822DateFormat . view unpacked =<< rssItemPubDate)
       where
         regularContent = view (re utf8 . lazy) <$> rssItemContent
         otherContent = renderElement (concatMap (toList . fromXMLElement) rssItemOther)
@@ -87,7 +81,7 @@ parseRSS RSS.RSS{RSS.rssChannel=RSS.RSSChannel{RSS.rssItems = items}} =
                     , RSS.rssItemPubDate
                     } = item
 
-parseEntries :: Feed -> [Either Text Entry]
+parseEntries :: Feed -> [Entry]
 parseEntries (AtomFeed atom) = parseAtom atom
 parseEntries (RSSFeed rss) = parseRSS rss
 parseEntries (RSS1Feed _rss1) = trace "rss1" []

FeedMonad/src/FeedMonad.hs

@@ -2,18 +2,17 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE LambdaCase #-}
 module FeedMonad where
 
 import Control.Exception (bracket)
 import Control.Monad.App (App, runApp)
 import Control.Monad.HTTP (execute, fetch)
 import Control.Monad.Reader (asks)
-import Control.Monad.Trans (liftIO, MonadIO)
+import Control.Monad.Trans (liftIO)
 import Data.Acid (AcidState(closeAcidState), openLocalState, query, update)
 import Data.Category (Category)
 import Data.Environment
-import Data.Foldable (for_, toList, traverse_)
+import Data.Foldable (for_, toList)
 import Data.Text (Text)
 import Database
        ( CountEntries(CountEntries)
@@ -28,12 +27,6 @@ import Numeric.Natural (Natural)
 import Text.Feed.Import (parseFeedSource)
 import Data.Entry (Entry(entryURL))
 import qualified Data.Map.Strict as M
-import qualified Data.Text.IO as TI
-import Trace
-import qualified Data.Text as T
-import Data.Functor.Contravariant ((>$<))
-import Text.Printf (printf)
-import Data.Either (partitionEithers)
 
 
 newtype Minutes = Minutes Natural
@@ -59,45 +52,17 @@ defaultConfig = FeedMonad
   , secretToken = "i am a secret"
   }
 
-data TraceMsg
-  = UpdateFeed FeedId UpdateMsg
-  | UpdateFeeds
 
-data UpdateMsg
+updateFeeds :: FeedMonad -> App ()
-  = Start
+updateFeeds f = do
-  | NewEntries Int
-  | Failures [Text]
-
-formatTraceMsg :: TraceMsg -> Maybe Text
-formatTraceMsg (UpdateFeed fi Start) = Just $ T.pack $ printf "Updating feed %s" (show fi)
-formatTraceMsg (UpdateFeed fi (NewEntries n)) = Just $ T.pack $ printf "Feed (%s) has %d new entries" (show fi) n
-formatTraceMsg (UpdateFeed _ (Failures [])) = Nothing
-formatTraceMsg (UpdateFeed fi (Failures failures)) = Just $ T.pack $ printf "Feed (%s) has %d failures: %s" (show fi) (length failures) (show failures)
-formatTraceMsg UpdateFeeds = Just $ T.pack $ printf "Updating feeds"
-
-logTrace :: MonadIO m => Trace m (Maybe Text)
-logTrace = Trace $ \case
-  Nothing -> pure ()
-  Just msg -> liftIO . TI.putStrLn $ msg
-
-updateFeeds :: Trace App TraceMsg -> FeedMonad -> App ()
-updateFeeds trace f = do
-  runTrace trace UpdateFeeds
-  for_ (feeds f) $
-    traverse_ (\fid -> updateFeed (UpdateFeed fid >$< trace) fid)
-  where
-    updateFeed :: Trace App UpdateMsg -> FeedId -> App ()
-    updateFeed t fid = do
-      let FeedId u = fid
   mgr <- asks environmentManager
   st <- asks environmentAcidState
-      runTrace t Start
+  for_ (feeds f) $ \c -> for_ c $ \fid -> liftIO $ do
-      (failures, entries) <- liftIO (partitionEithers . maybe [] parseEntries . parseFeedSource <$> liftIO (execute mgr (fetch u)))
+    let FeedId u = fid
-      runTrace t (Failures failures)
+    entries <- maybe [] parseEntries . parseFeedSource <$> liftIO (execute mgr (fetch u))
-      finalEntries <- liftIO (foldMap (\e -> M.singleton (EntryId $ entryURL e) e) <$> traverse (execute mgr . filters f pure) entries)
+    finalEntries <- foldMap (\e -> M.singleton (EntryId $ entryURL e) e) <$> traverse (execute mgr . filters f pure) entries
-      newEntries <- liftIO (query st (UnseenEntries fid (M.keysSet finalEntries)))
+    newEntries <- query st (UnseenEntries fid (M.keysSet finalEntries))
-      runTrace t (NewEntries (length newEntries))
+    update st (SaveEntries fid (foldMap (\eid -> toList $ M.lookup eid finalEntries) newEntries))
-      liftIO (update st (SaveEntries fid (foldMap (\eid -> toList $ M.lookup eid finalEntries) newEntries)))
 
 queryCategory :: FeedMonad -> App [Category (FeedId, Int)]
 queryCategory = traverse (traverse q) . feeds
@@ -108,11 +73,10 @@ queryCategory = traverse (traverse q) . feeds
       (fid, ) <$> liftIO (query st (CountEntries fid))
 
 defaultMain :: FeedMonad -> IO ()
-defaultMain f = do
+defaultMain f =
-  let trace = formatTraceMsg >$< logTrace
   bracket (openLocalState emptyFeedMonadState) closeAcidState $ \st -> do
     mgr <- newTlsManager
     runApp (Environment mgr st) $ do
-      updateFeeds trace f
+      updateFeeds f
       cat <- queryCategory f
       liftIO $ print cat

FeedMonad/src/Trace.hs

@@ -4,6 +4,6 @@ module Trace where
 import Data.Functor.Contravariant (Op(..), Contravariant)
 import Data.Monoid (Ap(..))
 
-newtype Trace m a = Trace { runTrace :: a -> m () }
+newtype Trace m a = Trace { trace :: a -> m () }
   deriving Contravariant via Op (m ())
   deriving (Semigroup, Monoid) via Op (Ap m ()) a

flake.lock

@@ -1,75 +0,0 @@
-{
-  "nodes": {
-    "easy-hls-src": {
-      "inputs": {
-        "nixpkgs": "nixpkgs"
-      },
-      "locked": {
-        "lastModified": 1636606878,
-        "narHash": "sha256-rLxYl7iYP9vQhSvVlV2uRCdgrqKDz/vN1Z8ZmA8itkM=",
-        "owner": "jkachmar",
-        "repo": "easy-hls-nix",
-        "rev": "edd5710946d46ea40810ef9a708b084d7e05a118",
-        "type": "github"
-      },
-      "original": {
-        "owner": "jkachmar",
-        "repo": "easy-hls-nix",
-        "type": "github"
-      }
-    },
-    "flake-utils": {
-      "locked": {
-        "lastModified": 1634851050,
-        "narHash": "sha256-N83GlSGPJJdcqhUxSCS/WwW5pksYf3VP1M13cDRTSVA=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "c91f3de5adaf1de973b797ef7485e441a65b8935",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
-    "nixpkgs": {
-      "locked": {
-        "lastModified": 1636983198,
-        "narHash": "sha256-ductPDqewBTMB0ZWSJo3wc99RaR6MzbRf6wjWsMjqoM=",
-        "owner": "nixos",
-        "repo": "nixpkgs",
-        "rev": "d04b41c582c69405f1fb1272711967f777cca883",
-        "type": "github"
-      },
-      "original": {
-        "owner": "nixos",
-        "repo": "nixpkgs",
-        "type": "github"
-      }
-    },
-    "nixpkgs_2": {
-      "locked": {
-        "lastModified": 1636979576,
-        "narHash": "sha256-Iy2J3T7xyHk43cVj4gGv74MKvVOCOqoqzffO3k5mbpU=",
-        "owner": "NixOS",
-        "repo": "nixpkgs",
-        "rev": "4ea0167baf7126e424edb7ed2be27c0f6008dafb",
-        "type": "github"
-      },
-      "original": {
-        "id": "nixpkgs",
-        "type": "indirect"
-      }
-    },
-    "root": {
-      "inputs": {
-        "easy-hls-src": "easy-hls-src",
-        "flake-utils": "flake-utils",
-        "nixpkgs": "nixpkgs_2"
-      }
-    }
-  },
-  "root": "root",
-  "version": 7
-}

flake.nix

@@ -1,46 +0,0 @@
-{
-  description = "FeedMonad";
-
-  inputs = {
-    easy-hls-src = { url = "github:jkachmar/easy-hls-nix"; };
-    flake-utils = { url = "github:numtide/flake-utils"; };
-  };
-
-  outputs = { self, nixpkgs, flake-utils, easy-hls-src }:
-    flake-utils.lib.eachSystem ["x86_64-linux" "x86_64-darwin"] ( system:
-      let
-        pkgs = nixpkgs.legacyPackages.${system};
-        hp = pkgs.haskellPackages.extend (self: super: {
-            FeedMonad = self.callPackage ./FeedMonad {};
-            FeedMonad-demo = self.callPackage ./FeedMonad-demo {};
-          });
-        easy-hls = pkgs.callPackage easy-hls-src { ghcVersions = [ hp.ghc.version ]; };
-      in
-      rec {
-
-        packages = { inherit (hp) FeedMonad FeedMonad-demo; };
-
-        defaultPackage = packages.FeedMonad;
-        apps.FeedMonad-demo = {
-          type = "app";
-          program = "${hp.FeedMonad-demo}/bin/FeedMonad-demo";
-        };
-        devShell = hp.shellFor {
-          packages = h: [h.FeedMonad h.FeedMonad-demo];
-          withHoogle = true;
-          buildInputs = with pkgs; [
-            entr
-            cabal-install
-            hp.hlint
-            stylish-haskell
-            ghcid
-            easy-hls
-
-            sqlite-interactive
-
-            hp.graphmod
-          ];
-        };
-      }
-    );
-}

shell.nix

@@ -1,8 +1,35 @@
-# https://nixos.wiki/wiki/Flakes#Using_flakes_project_from_a_legacy_Nix
+{ nixpkgs ? import <nixpkgs> {} }:
-(import (
+
-  fetchTarball {
+with nixpkgs;
-    url = "https://github.com/edolstra/flake-compat/archive/99f1c2157fba4bfe6211a321fd0ee43199025dbf.tar.gz";
+
-    sha256 = "0x2jn3vrawwv9xp15674wjz9pixwjyj3j771izayl962zziivbx2"; }
+let
-) {
+  easy-hls-src = fetchFromGitHub {
-  src =  ./.;
+    owner = "ssbothwell";
-}).defaultNix
+    repo = "easy-hls-nix";
+    inherit (builtins.fromJSON (builtins.readFile ./easy-hls-nix.json)) rev sha256;
+  };
+  easy-hls = callPackage easy-hls-src { ghcVersions = [ hp.ghc.version ]; };
+  hp = haskellPackages.extend (self: super: {
+    FeedMonad = self.callPackage ./FeedMonad {};
+    FeedMonad-demo = self.callPackage ./FeedMonad-demo {};
+  });
+
+in
+
+hp.shellFor {
+  packages = h: [h.FeedMonad h.FeedMonad-demo];
+  withHoogle = true;
+  buildInputs = [
+    entr
+    cabal-install
+    haskellPackages.hlint
+    stylish-haskell
+    ghcid
+    easy-hls
+
+    sqlite-interactive
+
+    haskellPackages.graphmod
+  ];
+}
+