Prepare for http

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 =

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

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

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

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)

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

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)

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

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