Middleware

FeedMonad.cabal

@@ -23,6 +23,10 @@ extra-source-files: CHANGELOG.md
 
 library
     exposed-modules:  MyLib
+                      Trace
+                      FeedMonad
+                      Data.Entry
+                      Middleware
 
     -- Modules included in this library but not exported.
     -- other-modules:
@@ -30,6 +34,17 @@ library
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
     build-depends:    base ^>=4.14.3.0
+                    , mtl
+                    , text
+                    , bytestring
+                    , http-client
+                    , http-client-tls
+                    , containers
+                    , lens
+                    , servant
+                    , servant-server
+                    , acid-state
+                    , safecopy
     hs-source-dirs:   src
     default-language: Haskell2010
 

README.md

@@ -0,0 +1,3 @@
+Planning / designing for a personal feed aggregator along the lines of tt-rss +
+some plugins. I like tt-rss but the web UI is terrible, I want something
+declarative instead.

default.nix

@@ -1,21 +1,18 @@
-{ mkDerivation, aeson, amqp, base, bytestring, containers, dhall
+{ mkDerivation, acid-state, base, bytestring, containers
-, hedgehog, hspec, hspec-hedgehog, lens, lens-aeson, lib, mtl
+, http-client, http-client-tls, lens, lib, mtl, safecopy, servant
-, pipes, sqlite-simple, text, wreq
+, servant-server, text
 }:
 mkDerivation {
-  pname = "reddit-pub";
+  pname = "FeedMonad";
   version = "0.1.0.0";
   src = ./.;
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    aeson amqp base bytestring containers dhall lens lens-aeson mtl
+    acid-state base bytestring containers http-client http-client-tls
-    pipes sqlite-simple text wreq
+    lens mtl safecopy servant servant-server text
   ];
   executableHaskellDepends = [ base ];
-  testHaskellDepends = [
-    base bytestring containers hedgehog hspec hspec-hedgehog mtl
-  ];
   license = "unknown";
   hydraPlatforms = lib.platforms.none;
 }

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