95 lines
2.7 KiB
Haskell
95 lines
2.7 KiB
Haskell
{-# 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
|