diff --git a/FeedMonad-demo/app/Main.hs b/FeedMonad-demo/app/Main.hs index 96d8579..36cc4b0 100644 --- a/FeedMonad-demo/app/Main.hs +++ b/FeedMonad-demo/app/Main.hs @@ -3,7 +3,7 @@ module Main where import FeedMonad import Data.Category -import Data.Entry (URL(URL)) +import Data.URL (URL(..)) myFeeds :: [ Category URL ] myFeeds = diff --git a/FeedMonad/FeedMonad.cabal b/FeedMonad/FeedMonad.cabal index b57c925..b7a5c47 100644 --- a/FeedMonad/FeedMonad.cabal +++ b/FeedMonad/FeedMonad.cabal @@ -32,6 +32,8 @@ library Trace Data.Environment Control.Monad.App + Control.Monad.HTTP + Data.URL -- Modules included in this library but not exported. -- other-modules: @@ -51,6 +53,7 @@ library , acid-state , safecopy , xdg-basedir + , free hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/FeedMonad/src/Control/Monad/HTTP.hs b/FeedMonad/src/Control/Monad/HTTP.hs new file mode 100644 index 0000000..a885b44 --- /dev/null +++ b/FeedMonad/src/Control/Monad/HTTP.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +module Control.Monad.HTTP where +import Data.ByteString.Lazy (ByteString) +import Data.URL (URL (URL)) +import Control.Monad.Free.Church (F, liftF, foldF) +import Network.HTTP.Client (Manager, httpLbs, parseRequest, responseBody) +import System.IO.Unsafe (unsafeInterleaveIO) + +data OpsF f = Fetch URL (ByteString -> f) + deriving Functor + +-- | A restricted HTTP monad +-- +-- While the "regular" code could access http whenever and it would be +-- fine, the middleware functions shouldn't probably have full IO +-- access. So restricting the access and providing manager and user +-- agents should prove useful +type FetchM = F OpsF + +-- | Execute a http request and return the bytestring +-- +-- Possible HTTP exceptions are thrown (how?) +fetch :: URL -> FetchM ByteString +fetch u = liftF (Fetch u id) + +-- Run the http monad +-- +-- The requests are executed lazily, both as an atomic request and as +-- a lazy bytestring. Be careful. +execute :: Manager -> FetchM a -> IO a +execute manager = foldF $ \case + Fetch (URL u) k -> k <$> unsafeInterleaveIO (fetchR u) + where + fetchR u = do + req <- parseRequest u + responseBody <$> httpLbs req manager diff --git a/FeedMonad/src/Data/Category.hs b/FeedMonad/src/Data/Category.hs index ec5ba49..85a8f3e 100644 --- a/FeedMonad/src/Data/Category.hs +++ b/FeedMonad/src/Data/Category.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} module Data.Category where import Data.Text (Text) @@ -6,7 +8,7 @@ import Data.Text (Text) data Category a = Leaf a | Category Text [Category a] - deriving (Show, Functor) + deriving (Show, Functor, Foldable, Traversable) foldCategory :: (a -> b) -> (Text -> [b] -> b) -> Category a -> b foldCategory fab f = go diff --git a/FeedMonad/src/Data/Entry.hs b/FeedMonad/src/Data/Entry.hs index dc304e9..7ac32a5 100644 --- a/FeedMonad/src/Data/Entry.hs +++ b/FeedMonad/src/Data/Entry.hs @@ -1,17 +1,15 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} module Data.Entry where + import Data.ByteString.Lazy (ByteString) import Data.Set (Set) import Data.Text (Text) import Control.Lens import Data.SafeCopy import GHC.Generics (Generic) +import Data.URL (URL (URL)) -newtype URL = URL String - deriving (Show, Eq, Ord, Generic) - -instance SafeCopy URL newtype Tag = Tag Text deriving (Show, Eq, Ord, Generic) diff --git a/FeedMonad/src/Data/URL.hs b/FeedMonad/src/Data/URL.hs new file mode 100644 index 0000000..80e57b2 --- /dev/null +++ b/FeedMonad/src/Data/URL.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DeriveGeneric #-} +module Data.URL where + +import GHC.Generics (Generic) +import Data.SafeCopy (SafeCopy) + +newtype URL = URL String + deriving (Show, Eq, Ord, Generic) + +instance SafeCopy URL diff --git a/FeedMonad/src/Database.hs b/FeedMonad/src/Database.hs index 1774bb4..b91f6b1 100644 --- a/FeedMonad/src/Database.hs +++ b/FeedMonad/src/Database.hs @@ -25,6 +25,7 @@ import Data.Acid import Control.Lens import Control.Applicative ((<|>)) import Control.Monad.Reader (asks) +import Data.URL (URL) newtype FeedId = FeedId URL deriving (Show, Eq, Ord, Generic) diff --git a/FeedMonad/src/FeedMonad.hs b/FeedMonad/src/FeedMonad.hs index bdd0d39..faef478 100644 --- a/FeedMonad/src/FeedMonad.hs +++ b/FeedMonad/src/FeedMonad.hs @@ -3,7 +3,6 @@ module FeedMonad where import Data.Text (Text) -import Data.Entry (URL) import Middleware (Middleware) import Numeric.Natural (Natural) import Data.Category (Category) @@ -14,6 +13,7 @@ import Network.HTTP.Client.TLS (newTlsManager) import Control.Monad.App (runApp) import Data.Environment import Control.Monad.Trans (liftIO) +import Data.URL (URL) newtype Minutes = Minutes Natural diff --git a/FeedMonad/src/Middleware.hs b/FeedMonad/src/Middleware.hs index af336c0..ea793c4 100644 --- a/FeedMonad/src/Middleware.hs +++ b/FeedMonad/src/Middleware.hs @@ -6,9 +6,10 @@ 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) +import Data.URL (URL) +import Control.Monad.HTTP (FetchM) -- I'm brainstorming an interface for tt-rss style interface for rss -- feeds. The functionality of tt-rss is surprisingly good, it's the @@ -26,14 +27,14 @@ import Data.Set (Set) -- @ -- XXX The IO should probably be restricted? -type Middleware = (URL -> IO Entry) -> (URL -> IO Entry) +type Middleware = (URL -> FetchM Entry) -> (URL -> FetchM Entry) -- * Low-level interface for the middlewares edit :: (Entry -> Entry) -> Middleware edit f g = fmap f . g -editM :: (Entry -> IO Entry) -> Middleware +editM :: (Entry -> FetchM Entry) -> Middleware editM f g = f <=< g -- * High-level interface for the middleware @@ -42,11 +43,11 @@ 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 :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] unfoldM f = go where go b = do - res <- unsafeInterleaveIO $ f b + res <- f b maybe (pure []) (\ (a,b') -> (a:) <$> go b') res -- | A multipage middleware