diff --git a/FeedMonad.cabal b/FeedMonad.cabal index f7e7d36..61831e8 100644 --- a/FeedMonad.cabal +++ b/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 diff --git a/README.md b/README.md new file mode 100644 index 0000000..d64cdf8 --- /dev/null +++ b/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. diff --git a/default.nix b/default.nix index ec705ee..78b6d32 100644 --- a/default.nix +++ b/default.nix @@ -1,21 +1,18 @@ -{ mkDerivation, aeson, amqp, base, bytestring, containers, dhall -, hedgehog, hspec, hspec-hedgehog, lens, lens-aeson, lib, mtl -, pipes, sqlite-simple, text, wreq +{ mkDerivation, acid-state, base, bytestring, containers +, http-client, http-client-tls, lens, lib, mtl, safecopy, servant +, 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 - pipes sqlite-simple text wreq + acid-state base bytestring containers http-client http-client-tls + lens mtl safecopy servant servant-server text ]; executableHaskellDepends = [ base ]; - testHaskellDepends = [ - base bytestring containers hedgehog hspec hspec-hedgehog mtl - ]; license = "unknown"; hydraPlatforms = lib.platforms.none; } diff --git a/src/.gitignore b/src/.gitignore new file mode 100644 index 0000000..f7a18e9 --- /dev/null +++ b/src/.gitignore @@ -0,0 +1,2 @@ +dist-newstyle +.envrc \ No newline at end of file diff --git a/src/Data/Entry.hs b/src/Data/Entry.hs new file mode 100644 index 0000000..886608f --- /dev/null +++ b/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}) + diff --git a/src/FeedMonad.hs b/src/FeedMonad.hs new file mode 100644 index 0000000..92b212a --- /dev/null +++ b/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 () diff --git a/src/Middleware.hs b/src/Middleware.hs new file mode 100644 index 0000000..af336c0 --- /dev/null +++ b/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