Sketch for a testable, free monad-based HTTP client

http.hs

{-#LANGUAGE DataKinds #-}
{-#LANGUAGE DeriveDataTypeable #-}
{-#LANGUAGE DeriveFoldable #-}
{-#LANGUAGE DeriveFunctor #-}
{-#LANGUAGE DeriveGeneric #-}
{-#LANGUAGE DeriveTraversable #-}
{-#LANGUAGE GADTs #-}
{-#LANGUAGE GeneralizedNewtypeDeriving #-}
{-#LANGUAGE KindSignatures #-}
{-#LANGUAGE TypeFamilies #-}

module Main where

import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Trans.Free
import Data.Foldable (Foldable)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable (Traversable)
import Data.Typeable
import GHC.Generics
import Network.URI
import Prelude hiding (head)

data Method
  -- CONNECT
  = DELETE
  | GET
  | HEAD
  | OPTIONS
  -- PATCH
  | POST
  -- PUT
  | TRACE
  deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show, Typeable)

type family ResponseBody (m :: Method) r
type instance ResponseBody DELETE r = ()
type instance ResponseBody HEAD r = ()
type instance ResponseBody OPTIONS r = (Set Method)
type instance ResponseBody TRACE r = r

data RequestF a where
  Delete :: Resource q => q -> (Response () -> a) -> RequestF a
  Get :: (Resource q, r ~ ResponseBody GET q) => q -> (Response r -> a) -> RequestF a
  Head :: Resource q => q -> (Response () -> a) -> RequestF a
  Options :: Resource q => q -> (Response (Set Method) -> a) -> RequestF a
  Post :: (Resource q, r ~ ResponseBody POST q) => q -> (Response r -> a) -> RequestF a
  Trace :: Resource q => q -> (Response q -> a) -> RequestF a

instance Functor RequestF where
  fmap f (Delete q g) = Delete q (f . g)
  fmap f (Get q g) = Get q (f . g)
  fmap f (Head q g) = Head q (f . g)
  fmap f (Options q g) = Options q (f . g)
  fmap f (Post q g) = Post q (f . g)
  fmap f (Trace q g) = Trace q (f . g)

data Response a = Response
  { status :: !Int
  , body :: !(Maybe a)
  } deriving (Eq, Foldable, Functor, Generic, Ord, Read, Show,
              Traversable, Typeable)

class Resource a where
  uri :: Const URI a

instance Resource [a] where
  uri = undefined

newtype RequestT m a = RequestT { runRequestT :: FreeT RequestF m a }
  deriving (Applicative, Functor, Generic, Monad, MonadIO, Typeable)

delete :: (Resource r, Monad m) => r -> RequestT m (Response ())
delete r = RequestT . liftF $ Delete r id

get :: (Resource r, Monad m) => r -> RequestT m (Response (ResponseBody GET r))
get r = RequestT . liftF $ Get r id

head :: (Resource r, Monad m) => r -> RequestT m (Response ())
head r = RequestT . liftF $ Head r id

options :: (Resource r, Monad m) => r -> RequestT m (Response (Set Method))
options r = RequestT . liftF $ Options r id

post :: (Resource r, Monad m) => r -> RequestT m (Response (ResponseBody POST r))
post r = RequestT . liftF $ Post r id

trace :: (Resource r, Monad m) => r -> RequestT m (Response r)
trace r = RequestT . liftF $ Trace r id

-- | A dummy interpreter.
runRequest :: MonadIO m => RequestT m a -> m a
runRequest (RequestT (FreeT m)) = m >>= runRequest' where
  runRequest' :: MonadIO m => FreeF RequestF a (FreeT RequestF m a) -> m a
  runRequest' (Pure a) = return a
  runRequest' (Free (Delete _ g)) = runRequest . RequestT $ g (Response 200 $ Just ())
  runRequest' (Free (Get q g)) = undefined
  runRequest' (Free (Head _ g)) = runRequest . RequestT $ g (Response 200 $ Just ())
  runRequest' (Free (Options q g)) = runRequest . RequestT $ g (Response 200 . Just $ Set.fromList [DELETE ..TRACE])
  runRequest' (Free (Post q g)) = undefined
  runRequest' (Free (Trace q g)) = runRequest . RequestT $ g (Response 200 $ Just q)

main :: IO ()
main = runRequest $ do
  r <- delete "foo"
  liftIO $ print r
  r <- head "bar"
  liftIO $ print r
  r <- options "baz"
  liftIO $ print r
  r <- trace "quux"
  liftIO $ print r

-- $ runhaskell http.hs
-- Response {status = 200, body = Just ()}
-- Response {status = 200, body = Just ()}
-- Response {status = 200, body = Just (fromList [DELETE,GET,HEAD,OPTIONS,POST,TRACE])}
-- Response {status = 200, body = Just "quux"}