Declarative REST API DSL experimenting

0README.md

Inspectable, type-safe REST API without type-level programming or TH

This approach differs from

• Yesod
• Servant

Instead, the following approach is used:

1. A request can be modelled as an Applicative (a la optparse-applicative): it can generate a parser, and also documentation, and clients, etc. a la servant. That's because Applicative lets you create a tree that produces arguments while being inspectable without providing those arguments.

2. A response can be modelled as a HoleyMonoid (a la formatting): it can generate a printer (writing body, headers), and also documentation, client, etc. a la servant. That's because HoleyMonoid lets you create a tree that consumes arguments while being inspectable without providing those arguments.

In that sense HoleyMonoid is the corresponding opposite concept of Applicative. For a web server to be self-documenting and to generate JS/Haskell clients, you need a way to inspect both sides without providing real arguments.

Hence the two modules:

• Request - modules a parser that is self-describing
• Response - modules a printer that is self-describing

Below is a rough sketch.

RestRequest.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}

{-

> execWriterT $ document api
PathDoc "users" (PathDoc "profile" (MappendDoc [GetCaptureDoc "id",GetParamDoc "private_or_public"]))

-}

module RestRequest where

import Control.Applicative
import Control.Monad.Trans.Writer
import Control.Monad.Trans

data Request a where
  Path :: String -> Request a -> Request a
  GetCapture :: String -> Request String
  GetHeader :: String -> Request String
  GetParam :: String -> Request (Maybe String)
  GetBody :: Request String
  Lift :: m a -> Request a
  Fmap :: (z -> a) -> Request z -> Request a
  LiftA2 :: (y -> z -> a) -> Request y -> Request z -> Request a
  Pure :: a -> Request a

instance Functor Request where
  fmap = Fmap

instance Applicative Request where
  pure = Pure
  liftA2 = LiftA2

data Doc
  = PathDoc String Doc
  | GetHeaderDoc String
  | GetParamDoc String
  | GetCaptureDoc String
  | WriteHeaderDoc String
  | WriteBodyDoc
  | GetBodyDoc
  | MappendDoc [Doc]
  deriving (Show)

instance Monoid Doc where
  mempty = MappendDoc []
  mappend (MappendDoc xs) (MappendDoc ys) = MappendDoc (xs <> ys)
  mappend (MappendDoc xs) (ys) = MappendDoc (xs <> [ys])
  mappend xs (MappendDoc ys) = MappendDoc ([xs] <> ys)
  mappend x y = MappendDoc [x,y]

instance Semigroup Doc where
  (<>) = mappend

document :: Monad m => Request a -> WriterT Doc m a
document =
  \case
    Pure a -> pure a
    Fmap f x -> fmap f (document x)
    LiftA2 f x y -> liftA2 f (document x) (document y)
    Path piece rest -> censor (PathDoc piece) (document rest)
    GetHeader key -> do
      tell (GetHeaderDoc key)
      pure mempty
    GetCapture key -> do
      tell (GetCaptureDoc key)
      pure mempty
    GetParam key -> do
      tell (GetParamDoc key)
      pure mempty
    GetBody -> do
      tell GetBodyDoc
      pure mempty

api :: Request (String, Maybe String)
api =
  Path
    "users"
    (Path "profile" ((,) <$> GetCapture "id" <*> GetParam "private_or_public"))

RestResponse.hs

{-

> :t (header "X-Header" % body)
(header "X-Header" % body) :: Response r2 (String -> String -> r2)

> meta (header "X-Header" % body)
MappendM [HeaderM "X-Header",BodyM]

> run (header "X-Header" % body) "Header Value" "Hello, Body!"
Mappend [Header "X-Header" "Header Value",Body "Hello, Body!"]

-}

module RestResponse
  ( Output(..)
  , Meta(..)
  , (%)
  , header
  , body
  , meta
  , run
  ) where

-- A response generator.
data Response r a = Response { meta :: Meta, runHM :: (Output -> r) -> a }

data Output = Body String | Header String String | Mappend [Output] deriving (Show)

instance Semigroup Output where x <> y = Mappend [x, y]

data Meta = BodyM | HeaderM String | MappendM [Meta] deriving (Show)

instance Semigroup Meta where x <> y = MappendM [x,y]

-- | Combine two responses.
(%) :: Response r1 a -> Response r2 r1 -> Response r2 a
r1 % r2 =
  Response (meta r1 <> meta r2) (\k -> runHM r1 (\output -> runHM r2 (\output2 -> k (output <> output2))))
infixr 9 %

-- | Run the response on arguments.
run :: Response Output a -> a
run m = runHM m id

-- | Declare a header.
header :: String -> Response r (String -> r)
header key = later (HeaderM key) (Header key)

-- | Declare body output.
body :: Response r (String -> r)
body = later BodyM Body

-- Do something later.
later :: Meta -> (a -> Output) -> Response r (a -> r)
later m f = Response m (. f)