Middleware

This commit is contained in:
Mats Rauhala 2021-11-11 19:04:48 +02:00
parent 723ce8ef9f
commit 5b4592a496
7 changed files with 187 additions and 9 deletions

View File

@ -23,6 +23,10 @@ extra-source-files: CHANGELOG.md
library library
exposed-modules: MyLib exposed-modules: MyLib
Trace
FeedMonad
Data.Entry
Middleware
-- Modules included in this library but not exported. -- Modules included in this library but not exported.
-- other-modules: -- other-modules:
@ -30,6 +34,17 @@ library
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.14.3.0 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 hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

3
README.md Normal file
View File

@ -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.

View File

@ -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 { mkDerivation {
pname = "reddit-pub"; pname = "FeedMonad";
version = "0.1.0.0"; version = "0.1.0.0";
src = ./.; src = ./.;
isLibrary = true; isLibrary = true;
isExecutable = true; isExecutable = true;
libraryHaskellDepends = [ 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 ]; executableHaskellDepends = [ base ];
testHaskellDepends = [
base bytestring containers hedgehog hspec hspec-hedgehog mtl
];
license = "unknown"; license = "unknown";
hydraPlatforms = lib.platforms.none; hydraPlatforms = lib.platforms.none;
} }

2
src/.gitignore vendored Normal file
View File

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

40
src/Data/Entry.hs Normal file
View File

@ -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})

27
src/FeedMonad.hs Normal file
View File

@ -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 ()

94
src/Middleware.hs Normal file
View File

@ -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