diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# 0.1.0.0 + +* First public release +* Add the `MonadRequest` type class +* Add the `RequestT` monad +* Initial documentation diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Tom Hulihan + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,98 @@ +# request-monad + +[Hackage](http://hackage.haskell.org/package/request-monad) + +This library exports a monad that can be used to abstract a request sending/response handling pattern. +It can be used to implement type-transforming middleware, as well as a way to easily implement stubbing. + +## Installation + +From the command line: + +```shell +$ cabal install request-monad +``` + +To use data types and functions export from this library: + +```haskell +import Control.Monad.Request +``` + +## Usage + +Using `RequestT r r' m a` abstracts sending requests of type `r`, and handling responses of `r'`. +Below is an example of using `RequestT` to ask for somebody's name and age. +Note that there is no logic about _how_ to get and return the strings in `getNameAndAge`, that's all handled in `prompt`. + +```haskell +import Control.Monad +import Control.Monad.Request + +getNameAndAge :: Monad m => RequestT String String m (String, Int) +getNameAndAge = do + name <- send "Name: " + age <- liftM read $ send "Age: " + return (name, age) + +prompt :: String -> IO String +prompt str = putStr str >> getLine + +main :: IO () +main = do + (name, age) <- runRequestT getNameAndAge prompt + putStrLn $ name ++ " is " ++ show age ++ " years old." +``` + +Below is an example of an echo server, which just returns the exact input that it was given. + +```haskell +import Control.Monad.Request + +pingPong :: Monad m => RequestT String String m (String, String) +pingPong = do + a <- send "ping" + b <- send "pong" + return (a, b) + +main :: IO () +main = do + let (a, b) = runRequest pingPong id + putStrLn $ "a: " ++ a -- Prints "a: ping" + putStrLn $ "b: " ++ b -- Prints "b: pong" +``` + +Aside from implementation-independant requests, this abstraction also simplifies adding request/response middleware. +The code below adds JSON deserialization to each response. + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad +import Control.Monad.Request +import qualified Data.Aeson as A +import qualified Data.ByteString as B + +deserialize :: (A.FromJSON a, Monad m) => B.ByteString -> m (Maybe a) +deserialize = return . A.decode + +tryTwice :: Monad m => RequestT B.ByteString (Maybe A.Value) m (Maybe A.Value) +tryTwice = mapResponseT deserialize $ do + a <- send "request one" + b <- send "request two" + return $ a `mplus` b + +handleRequest :: Monad m => B.ByteString -> m B.ByteString +handleRequest "request one" = return "not json" +handleRequest x = "15" + +main :: IO () +main = do + let res = runRequest tryTwice handleRequest + print $ res -- Prints "Just (Number 15)" +``` + +## TODO + +* Make `RequestT` an instance of `MonadCont` and `MonadFix` +* Add a strict version of `RequestT` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/request-monad.cabal b/request-monad.cabal new file mode 100644 --- /dev/null +++ b/request-monad.cabal @@ -0,0 +1,31 @@ +name: request-monad +version: 0.1.0.0 +synopsis: A transformer for generic requests +description: + An MTL-style monad that can be used to perform requests. Using RequestT + simplifies writing generic middleware. +homepage: http://github.com/nahiluhmot/request-monad +bug-reports: http://github.com/nahiluhmot/request-monad/issues +license: MIT +license-file: LICENSE +author: Tom Hulihan +maintainer: Tom Hulihan +category: Control +build-type: Simple +extra-source-files: README.md, CHANGELOG.md +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/nahiluhmot/request-monad.git + +library + hs-source-dirs: src + build-depends: base >=4.7 && <4.8, + transformers ==0.4.*, + mtl ==2.2.* + exposed-modules: Control.Monad.Request, + Control.Monad.Request.Class, + Control.Monad.Request.Lazy + ghc-options: -O3 -Wall + default-language: Haskell2010 diff --git a/src/Control/Monad/Request.hs b/src/Control/Monad/Request.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Request.hs @@ -0,0 +1,23 @@ +{- | +Module : Control.Monad.Request.Class +Copyright : (c) Tom Hulihan 2014, +License : MIT + +Maintainer : hulihan.tom159@gmail.com +Stability : experimental +Portability : non-portable (multi-parameter type classes) + +[Computation type:] Compuations that send requests and handle responses + +[Binding strategy:] Response callbacks are composed with the binding function + +[Useful for:] Implementation-agnostic requests (i.e. making real requests versus +mocking), adding middlewares. + +[Example type:] @'Control.Monad.Request.Lazy.Request' String String a@ + +The Request monad +-} +module Control.Monad.Request ( module Control.Monad.Request.Lazy ) where + +import Control.Monad.Request.Lazy diff --git a/src/Control/Monad/Request/Class.hs b/src/Control/Monad/Request/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Request/Class.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- | +Module : Control.Monad.Request.Class +Copyright : (c) Tom Hulihan 2014, +License : MIT + +Maintainer : hulihan.tom159@gmail.com +Stability : experimental +Portability : non-portable (multi-parameter type classes) + +[Computation type:] Compuations that send requests and handle responses + +[Binding strategy:] Response callbacks are composed with the binding function + +[Useful for:] Implementation-agnostic requests (i.e. making real requests versus +mocking), adding middlewares. + +[Example type:] @'Control.Monad.Request.Lazy.Request' String String a@ + +The Request monad +-} +module Control.Monad.Request.Class ( MonadRequest(..) ) where + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Cont as Cont +import Control.Monad.Trans.Identity as Identity +import Control.Monad.Trans.Error as Error +import Control.Monad.Trans.Except as Except +import Control.Monad.Trans.List as List +import Control.Monad.Trans.Maybe as Maybe +import Control.Monad.Trans.RWS.Lazy as RWSL +import Control.Monad.Trans.RWS.Strict as RWSS +import Control.Monad.Trans.Reader as Reader +import Control.Monad.Trans.State.Lazy as StateL +import Control.Monad.Trans.State.Strict as StateS +import Control.Monad.Trans.Writer.Lazy as WriterL +import Control.Monad.Trans.Writer.Strict as WriterS +import Data.Monoid + +-- | This type class generalizes monadic requests. +-- +-- Parameters: +-- +-- * @r@ - The type of request +-- +-- * @r'@ - The type of response +-- +-- * @m@ - The monad through which the requests are sent +-- +class Monad m => MonadRequest r r' m | m -> r r' where + -- | Given a request of type @r@, perform an action in @m@ whose result is + -- @r'@. + send :: r -> m r' + +instance MonadRequest r r' m => MonadRequest r r' (IdentityT m) where + send = IdentityT . send + +instance (MonadRequest r r' m) => MonadRequest r r' (ContT x m) where + send = lift . send + +instance (Error e, MonadRequest r r' m) => MonadRequest r r' (ErrorT e m) where + send = ErrorT . liftM Right . send + +instance MonadRequest r r' m => MonadRequest r r' (ExceptT e m) where + send = ExceptT . liftM Right . send + +instance MonadRequest r r' m => MonadRequest r r' (ListT m) where + send = ListT . liftM (\x -> [x]) . send + +instance MonadRequest r r' m => MonadRequest r r' (MaybeT m) where + send = MaybeT . liftM Just . send + +instance (Monoid w, MonadRequest r r' m) => MonadRequest r r' (RWSL.RWST x w s m) where + send = lift . send + +instance (Monoid w, MonadRequest r r' m) => MonadRequest r r' (RWSS.RWST x w s m) where + send = lift . send + +instance MonadRequest r r' m => MonadRequest r r' (ReaderT x m) where + send = ReaderT . const . send + +instance MonadRequest r r' m => MonadRequest r r' (StateL.StateT x m) where + send r = StateL.StateT $ \s -> send r >>= \a -> return (a, s) + +instance MonadRequest r r' m => MonadRequest r r' (StateS.StateT x m) where + send r = StateS.StateT $ \s -> send r >>= \a -> return (a, s) + +instance (Monoid w, MonadRequest r r' m) => MonadRequest r r' (WriterL.WriterT w m) where + send = WriterL.WriterT . liftM (flip (,) mempty) . send + +instance (Monoid w, MonadRequest r r' m) => MonadRequest r r' (WriterS.WriterT w m) where + send = WriterS.WriterT . liftM (flip (,) mempty) . send diff --git a/src/Control/Monad/Request/Lazy.hs b/src/Control/Monad/Request/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Request/Lazy.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + + +{- | +Module : Control.Monad.Request.Lazy +Copyright : (c) Tom Hulihan 2014, +License : MIT + +Maintainer : hulihan.tom159@gmail.com +Stability : experimental +Portability : non-portable (multi-parameter type classes) + +[Computation type:] Compuations that send requests and handle responses + +[Binding strategy:] Response callbacks are composed with the binding function + +[Useful for:] Implementation-agnostic requests (i.e. making real requests versus +mocking), adding middlewares. + +[Example type:] @'Request' String String a@ + +The Request monad +-} +module Control.Monad.Request.Lazy ( -- * MonadRequest + MonadRequest(..) + -- * Request + , Request + , request + , runRequest + , mapRequest + , mapResponse + -- * RequestT + , RequestT + , requestT + , runRequestT + , mapRequestT + , mapResponseT + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Request.Class +import Control.Monad.Trans.Class +import Control.Monad.Error.Class +import Control.Monad.RWS.Class +import Data.Monoid +import Data.Functor.Identity + +-------------------------------------------------------------------------------- +-- 'Request' and its associated functions + +-- | A Request monad, parameterized by the request type, @r@, and response type, +-- @r'@. +-- together. +type Request r r' = RequestT r r' Identity + +-- | Turn a request and response callback into a monadic computation. +request :: r -- ^ The request + -> (r' -> a) -- ^ The response callback + -> Request r r' a -- ^ The resulting computation +request r g = requestT r (Identity . g) + +-- | Evaluate a @'Request' r r\' a@ action. +runRequest :: Request r r' a -- ^ The computation to run + -> (r -> r') -- ^ A function that turns requests into responses + -> a -- ^ The final result of the computation +runRequest act f = runIdentity $ runRequestT act (Identity . f) + +-- | Given a @x -> r@, transform a computation that sends requests of type @x@ +-- into one that sends requests of type @r@. +mapRequest :: (x -> r) -- ^ The middleware function + -> Request x r' a -- ^ The computation which sends @x@ + -> Request r r' a -- ^ The computation which sends @r@ +mapRequest f = mapRequestT (Identity . f) + +-- | Given a mapping from @r\' -> x@, transform a computation handles responses +-- of type @x@ to one that handles responses of type @r'@. +mapResponse :: (r' -> x) -- ^ The middleware function + -> Request r x a -- ^ The computation which handles @x@ + -> Request r r' a -- ^ The computation which handles @r'@ +mapResponse f = mapResponseT (Identity . f) + +-------------------------------------------------------------------------------- +-- 'RequestT' and its associated functions + +-- | A request monad, parameterized by the request type, @r@, response type, +-- @r'@, and inner monad, @m@. +data RequestT r r' m a + = Pure a + | Request r (r' -> RequestT r r' m a) + | Lift (m (RequestT r r' m a)) + +-- | This function takes a request and monadic response handler to produce a +-- @'RequestT' r r\' m a@. +requestT :: Monad m => r -- ^ The request + -> (r' -> m a) -- ^ The response callback + -> RequestT r r' m a -- ^ The resulting computation +requestT r g = Request r (Lift . liftM Pure . g) + +-- | Given a @'RequestT' r r\' m a@ and a mapping from requests to responses, +-- return a monadic computation which produces @a@. +runRequestT :: Monad m => RequestT r r' m a -- ^ The computation to run + -> (r -> m r') -- ^ The request function + -> m a -- ^ The resulting computation +runRequestT m req = + let go (Pure a) = return a + go (Request r g) = req r >>= go . g + go (Lift act) = act >>= go + in go m + +-- | Turn a computation that requests @x@ into a computation that requests @r@. +mapRequestT :: Monad m => (x -> m r) -- ^ The middleware function + -> RequestT x r' m a -- ^ The @x@-requesting computation + -> RequestT r r' m a -- ^ The @r@-requesting computation +mapRequestT f = + let go (Pure a) = Pure a + go (Request x g) = lift (f x) >>= flip Request (go . g) + go (Lift act) = Lift (liftM go act) + in go + +-- | Turn a computation that handles @x@ into a computation that handles @r'@. +mapResponseT :: Monad m => (r' -> m x) -- ^ The middleware function + -> RequestT r x m a -- ^ The @x@-handling computation + -> RequestT r r' m a -- ^ The @r'@-handling computation +mapResponseT f = + let go (Pure a) = Pure a + go (Request r g) = Request r (go . g <=< lift . f) + go (Lift act) = Lift (liftM go act) + in go + +-------------------------------------------------------------------------------- +-- Type class instances from base. + +instance Alternative m => Alternative (RequestT r r' m) where + empty = Lift empty + (<|>) = + let go (Pure a) _ = Pure a + go (Request r g) x = Request r (flip go x . g) + go (Lift act) x = Lift (fmap (flip go x) act) + in go + +instance Applicative m => Applicative (RequestT r r' m) where + pure = Pure + (<*>) = + let go (Pure f) (Pure a) = Pure (f a) + go (Request r g) x = Request r (flip go x . g) + go (Lift act) x = Lift (fmap (flip go x) act) + go x (Request r g) = Request r (go x . g) + go x (Lift act) = Lift (fmap (go x) act) + in go + +instance Functor m => Functor (RequestT r r' m) where + fmap f = + let go (Pure a) = Pure (f a) + go (Request r g) = Request r (go . g) + go (Lift act) = Lift (fmap go act) + in go + +instance Monad m => Monad (RequestT r r' m) where + return = Pure + fail = Lift . fail + (>>=) m f = + let go (Pure a) = f a + go (Request r g) = Request r (go . g) + go (Lift act) = Lift (liftM go act) + in go m + +instance MonadPlus m => MonadPlus (RequestT r r' m) where + mzero = Lift mzero + mplus = + let go (Pure a) _ = Pure a + go (Request r g) x = Request r (flip go x . g) + go (Lift act) x = Lift (liftM (flip go x) act) + in go + +-------------------------------------------------------------------------------- +-- Type class instances from this library. + +instance Monad m => MonadRequest r r' (RequestT r r' m) where + send = flip Request Pure + +-------------------------------------------------------------------------------- +-- Type class instances from transformers. + +instance MonadIO m => MonadIO (RequestT r r' m) where + liftIO = lift . liftIO + +instance MonadTrans (RequestT r r') where + lift = Lift . liftM Pure + +-------------------------------------------------------------------------------- +-- Type class instances from mtl. + +instance MonadError e m => MonadError e (RequestT r r' m) where + throwError = Lift . throwError + catchError m h = + let go (Pure a) = Pure a + go (Request r g) = Request r (go . g) + go (Lift act) = Lift (catchError act (return . h)) + in go m + + +instance MonadReader x m => MonadReader x (RequestT r r' m) where + ask = lift ask + local f = + let go (Pure a) = Pure a + go (Request r g) = Request r (go . g) + go (Lift act) = Lift (liftM go (local f act)) + in go + +instance (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) => MonadRWS r w s (RequestT r r' m) + +instance MonadState s m => MonadState s (RequestT r r' m) where + get = lift get + put = lift . put + +instance (Monoid w, MonadWriter w m) => MonadWriter w (RequestT r r' m) where + writer = lift . writer + tell = lift . tell + listen = + let go acc (Pure a) = Pure (a, acc) + go acc (Request r g) = Request r (go acc . g) + go acc (Lift act) = Lift $ do + ~(m, w) <- listen act + return (go (acc `mappend` w) m) + in go mempty + pass m = listen m >>= \ ~(~(a, f), w) -> writer (a, f w)