Enable flakes support

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, xdg-basedir
+, servant, servant-server, text, time, xdg-basedir, xml-conduit
 }:
 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
+    http-client-tls lens mtl safecopy servant servant-server text time
-    xdg-basedir
+    xdg-basedir xml-conduit
   ];
   license = "unknown";
   hydraPlatforms = lib.platforms.none;

FeedMonad/src/Feed/Parser.hs

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

FeedMonad/src/FeedMonad.hs

@@ -2,17 +2,18 @@
 {-# 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)
+import Control.Monad.Trans (liftIO, MonadIO)
 import Data.Acid (AcidState(closeAcidState), openLocalState, query, update)
 import Data.Category (Category)
 import Data.Environment
-import Data.Foldable (for_, toList)
+import Data.Foldable (for_, toList, traverse_)
 import Data.Text (Text)
 import Database
        ( CountEntries(CountEntries)
@@ -27,6 +28,12 @@ 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
@@ -52,17 +59,45 @@ defaultConfig = FeedMonad
   , secretToken = "i am a secret"
   }
 
+data TraceMsg
+  = UpdateFeed FeedId UpdateMsg
+  | UpdateFeeds
 
-updateFeeds :: FeedMonad -> App ()
+data UpdateMsg
-updateFeeds f = do
+  = Start
+  | 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
-  for_ (feeds f) $ \c -> for_ c $ \fid -> liftIO $ do
+      runTrace t Start
-    let FeedId u = fid
+      (failures, entries) <- liftIO (partitionEithers . maybe [] parseEntries . parseFeedSource <$> liftIO (execute mgr (fetch u)))
-    entries <- maybe [] parseEntries . parseFeedSource <$> liftIO (execute mgr (fetch u))
+      runTrace t (Failures failures)
-    finalEntries <- foldMap (\e -> M.singleton (EntryId $ entryURL e) e) <$> traverse (execute mgr . filters f pure) entries
+      finalEntries <- liftIO (foldMap (\e -> M.singleton (EntryId $ entryURL e) e) <$> traverse (execute mgr . filters f pure) entries)
-    newEntries <- query st (UnseenEntries fid (M.keysSet finalEntries))
+      newEntries <- liftIO (query st (UnseenEntries fid (M.keysSet finalEntries)))
-    update st (SaveEntries fid (foldMap (\eid -> toList $ M.lookup eid finalEntries) newEntries))
+      runTrace t (NewEntries (length 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
@@ -73,10 +108,11 @@ queryCategory = traverse (traverse q) . feeds
       (fid, ) <$> liftIO (query st (CountEntries fid))
 
 defaultMain :: FeedMonad -> IO ()
-defaultMain f =
+defaultMain f = do
+  let trace = formatTraceMsg >$< logTrace
   bracket (openLocalState emptyFeedMonadState) closeAcidState $ \st -> do
     mgr <- newTlsManager
     runApp (Environment mgr st) $ do
-      updateFeeds f
+      updateFeeds trace 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 { trace :: a -> m () }
+newtype Trace m a = Trace { runTrace :: a -> m () }
   deriving Contravariant via Op (m ())
   deriving (Semigroup, Monoid) via Op (Ap m ()) a

flake.lock

@@ -0,0 +1,75 @@
+{
+  "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

@@ -0,0 +1,46 @@
+{
+  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,35 +1,8 @@
-{ nixpkgs ? import <nixpkgs> {} }:
+# https://nixos.wiki/wiki/Flakes#Using_flakes_project_from_a_legacy_Nix
-
+(import (
-with nixpkgs;
+  fetchTarball {
-
+    url = "https://github.com/edolstra/flake-compat/archive/99f1c2157fba4bfe6211a321fd0ee43199025dbf.tar.gz";
-let
+    sha256 = "0x2jn3vrawwv9xp15674wjz9pixwjyj3j771izayl962zziivbx2"; }
-  easy-hls-src = fetchFromGitHub {
+) {
-    owner = "ssbothwell";
+  src =  ./.;
-    repo = "easy-hls-nix";
+}).defaultNix
-    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
-  ];
-}
-