Middleware

src/.gitignore

@@ -0,0 +1,2 @@
+dist-newstyle
+.envrc

src/Data/Entry.hs

@@ -0,0 +1,40 @@
+module Data.Entry where
+import Data.ByteString.Lazy (ByteString)
+import Data.Set (Set)
+import Data.Text (Text)
+import Control.Lens
+
+newtype URL = URL String
+  deriving (Show)
+newtype Tag = Tag Text
+  deriving (Show, Eq, Ord)
+
+data Entry = Entry
+  { entryURL :: URL
+  , entryTitle :: Text
+  , entryContent :: ByteString
+  , entryScore :: Int
+  , entryTags :: Set Tag
+  }
+  deriving Show
+
+-- * Lenses for accessing relevant parts of entry
+
+_URL :: Iso' URL String
+_URL = iso (\(URL u) -> u) URL
+
+content :: Lens' Entry ByteString
+content = lens entryContent (\ en bs -> en{entryContent=bs})
+
+title :: Lens' Entry Text
+title = lens entryTitle (\ en txt -> en{entryTitle=txt})
+
+url :: Lens' Entry URL
+url = lens entryURL (\ en u -> en{entryURL = u})
+
+score :: Lens' Entry Int
+score = lens entryScore (\ en n -> en{entryScore=n})
+
+tags :: Lens' Entry (Set Tag)
+tags = lens entryTags (\ en txts -> en{entryTags=txts})
+

src/FeedMonad.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module FeedMonad where
+
+import Data.Tree (Tree(..), Forest)
+import Data.Text (Text)
+import Data.ByteString (ByteString)
+import Data.Entry (URL)
+import Middleware (Middleware)
+import Numeric.Natural (Natural)
+
+newtype Minutes = Minutes Natural
+
+data FeedMonad = FeedMonad
+  { feeds :: Forest URL
+    -- ^ The forest of urls for the feeds. It's a forest because of the categories
+  , filters :: Middleware
+    -- ^ The middleware. Modifies the scoring, tags and content
+  , refreshTime :: Minutes
+    -- ^ How often to refresh the feeds
+  , secretToken :: Text
+    -- ^ Used for authenticating the UI. This is a single user app
+    -- served over http, so we can get around with hardcoded
+    -- authentication token
+  }
+
+defaultMain :: FeedMonad -> IO ()
+defaultMain _ = pure ()

src/Middleware.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Middleware where
+
+import Data.Entry
+import Control.Monad ((<=<))
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.Foldable as F
+import System.IO.Unsafe (unsafeInterleaveIO)
+import Control.Lens
+import Data.Set (Set)
+
+-- I'm brainstorming an interface for tt-rss style interface for rss
+-- feeds. The functionality of tt-rss is surprisingly good, it's the
+-- UX that I'm having problems with. What I'm trying to do is provide
+-- a similar featureset, but identifying the minimal functionality to
+-- provide it.
+
+-- In this file I'm trying out a middleware based solution. And at
+-- least for pure values it seems to work quite well.
+--
+-- @
+-- foo :: Middleware
+-- foo = modifyScoreOnTag "haskell" (+10) .
+--       modifyScoreOnTag "crypto" (\x -> x - 100)
+-- @
+
+-- XXX The IO should probably be restricted?
+type Middleware = (URL -> IO Entry) -> (URL -> IO Entry)
+
+-- * Low-level interface for the middlewares
+
+edit :: (Entry -> Entry) -> Middleware
+edit f g = fmap f . g
+
+editM :: (Entry -> IO Entry) -> Middleware
+editM f g = f <=< g
+
+-- * High-level interface for the middleware
+
+fetch :: URL -> f (Maybe a)
+fetch = error "not defined yet"
+
+-- | A lazy variant of unfolder
+unfoldM :: (b -> IO (Maybe (a, b))) -> b -> IO [a]
+unfoldM f = go
+  where
+    go b = do
+      res <- unsafeInterleaveIO $ f b
+      maybe (pure []) (\ (a,b') -> (a:) <$> go b') res
+
+-- | A multipage middleware
+--
+-- Tries to fetch multiple pages and combine them together
+-- @
+-- multipage (has (url . _URL . prefixed "https://oglaf.com")) parser
+-- @
+multipage :: (Entry -> Bool) -> (ByteString -> Maybe URL) -> Middleware
+multipage p f g u = do
+  entry <- g u
+  if p entry
+    then multi entry
+    else pure entry
+  where
+    multi entry = do
+      pages <- take 10 <$> unfoldM go (Just (entryContent entry))
+      pure $ entry{entryContent = F.fold pages "" }
+    go Nothing = pure Nothing -- no page at all
+    go (Just bs) =
+      maybe
+      (pure (Just ((bs <>), Nothing))) -- no next page
+      (fmap (Just . ((bs <>),)) . fetch) -- next page
+      (f bs)
+
+
+-- | Modify the score
+--
+-- @
+-- modifyScore (has (tags . ix (Tag "haskell"))) (+10) .
+-- modifyScore (has (tags . ix (Tag "cryptocoin"))) (\x -> x - 100)
+-- @
+modifyScore :: (Entry -> Bool) -> (Int -> Int) -> Middleware
+modifyScore p n = edit $
+  over (filtered p . score) n
+
+-- | Modify the tags
+--
+-- @
+-- modifyTags (\e -> view title e =~ ("\\bhaskell\\b" :: String)) (S.insert (Tag "haskell")) .
+-- modifyTags (\e -> view content e =~ ("\\bhaskell\\b" :: String)) (S.insert (Tag "haskell"))
+-- @
+modifyTags :: (Entry -> Bool) -> (Set Tag -> Set Tag) -> Middleware
+modifyTags p t = edit $
+  over (filtered p . tags) t