Prepare for http
This commit is contained in:
parent
a788a188fe
commit
b79fa52b25
@ -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 =
|
||||||
|
@ -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
|
||||||
|
37
FeedMonad/src/Control/Monad/HTTP.hs
Normal file
37
FeedMonad/src/Control/Monad/HTTP.hs
Normal 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
|
@ -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
|
||||||
|
@ -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
10
FeedMonad/src/Data/URL.hs
Normal 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
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user