Prepare for http

This commit is contained in:
Mats Rauhala 2021-11-11 22:31:38 +02:00
parent a788a188fe
commit b79fa52b25
9 changed files with 64 additions and 12 deletions

View File

@ -3,7 +3,7 @@ module Main where
import FeedMonad import FeedMonad
import Data.Category import Data.Category
import Data.Entry (URL(URL)) import Data.URL (URL(..))
myFeeds :: [ Category URL ] myFeeds :: [ Category URL ]
myFeeds = myFeeds =

View File

@ -32,6 +32,8 @@ library
Trace Trace
Data.Environment Data.Environment
Control.Monad.App Control.Monad.App
Control.Monad.HTTP
Data.URL
-- Modules included in this library but not exported. -- Modules included in this library but not exported.
-- other-modules: -- other-modules:
@ -51,6 +53,7 @@ library
, acid-state , acid-state
, safecopy , safecopy
, xdg-basedir , xdg-basedir
, free
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View File

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

View File

@ -1,4 +1,6 @@
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
module Data.Category where module Data.Category where
import Data.Text (Text) import Data.Text (Text)
@ -6,7 +8,7 @@ import Data.Text (Text)
data Category a data Category a
= Leaf a = Leaf a
| Category Text [Category a] | Category Text [Category a]
deriving (Show, Functor) deriving (Show, Functor, Foldable, Traversable)
foldCategory :: (a -> b) -> (Text -> [b] -> b) -> Category a -> b foldCategory :: (a -> b) -> (Text -> [b] -> b) -> Category a -> b
foldCategory fab f = go foldCategory fab f = go

View File

@ -1,17 +1,15 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Data.Entry where module Data.Entry where
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import Control.Lens import Control.Lens
import Data.SafeCopy import Data.SafeCopy
import GHC.Generics (Generic) 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 newtype Tag = Tag Text
deriving (Show, Eq, Ord, Generic) deriving (Show, Eq, Ord, Generic)

10
FeedMonad/src/Data/URL.hs Normal file
View File

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

View File

@ -25,6 +25,7 @@ import Data.Acid
import Control.Lens import Control.Lens
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad.Reader (asks) import Control.Monad.Reader (asks)
import Data.URL (URL)
newtype FeedId = FeedId URL newtype FeedId = FeedId URL
deriving (Show, Eq, Ord, Generic) deriving (Show, Eq, Ord, Generic)

View File

@ -3,7 +3,6 @@
module FeedMonad where module FeedMonad where
import Data.Text (Text) import Data.Text (Text)
import Data.Entry (URL)
import Middleware (Middleware) import Middleware (Middleware)
import Numeric.Natural (Natural) import Numeric.Natural (Natural)
import Data.Category (Category) import Data.Category (Category)
@ -14,6 +13,7 @@ import Network.HTTP.Client.TLS (newTlsManager)
import Control.Monad.App (runApp) import Control.Monad.App (runApp)
import Data.Environment import Data.Environment
import Control.Monad.Trans (liftIO) import Control.Monad.Trans (liftIO)
import Data.URL (URL)
newtype Minutes = Minutes Natural newtype Minutes = Minutes Natural

View File

@ -6,9 +6,10 @@ import Data.Entry
import Control.Monad ((<=<)) import Control.Monad ((<=<))
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import qualified Data.Foldable as F import qualified Data.Foldable as F
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Lens import Control.Lens
import Data.Set (Set) 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 -- I'm brainstorming an interface for tt-rss style interface for rss
-- feeds. The functionality of tt-rss is surprisingly good, it's the -- 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? -- 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 -- * Low-level interface for the middlewares
edit :: (Entry -> Entry) -> Middleware edit :: (Entry -> Entry) -> Middleware
edit f g = fmap f . g edit f g = fmap f . g
editM :: (Entry -> IO Entry) -> Middleware editM :: (Entry -> FetchM Entry) -> Middleware
editM f g = f <=< g editM f g = f <=< g
-- * High-level interface for the middleware -- * High-level interface for the middleware
@ -42,11 +43,11 @@ fetch :: URL -> f (Maybe a)
fetch = error "not defined yet" fetch = error "not defined yet"
-- | A lazy variant of unfolder -- | 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 unfoldM f = go
where where
go b = do go b = do
res <- unsafeInterleaveIO $ f b res <- f b
maybe (pure []) (\ (a,b') -> (a:) <$> go b') res maybe (pure []) (\ (a,b') -> (a:) <$> go b') res
-- | A multipage middleware -- | A multipage middleware