From 1f6c3c4009a5a61758bfc0fadf0cf255c64835e5 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Tue, 28 Oct 2014 17:32:22 +0100
Subject: [PATCH] Add new request -> response syntax

---
 example/greet.hs      |  5 +++--
 src/Servant/API/QQ.hs | 28 +++++++++++++++++++---------
 2 files changed, 22 insertions(+), 11 deletions(-)

diff --git a/example/greet.hs b/example/greet.hs
index 394a4111..10674072 100644
--- a/example/greet.hs
+++ b/example/greet.hs
@@ -56,8 +56,9 @@ type TestApi =
   :<|> "delete" :> Capture "greetid" Text :> Delete
 
 type TestApi2 = [sitemap|
-GET   Bool  something/capt:Int
-POST  Bool  something
+GET     hello/name:Text/capital:Bool    () -> Greet
+POST    greet                           Greet -> Greet
+DELETE  delete/greetid:Text             ()
 |]
 
 testApi :: Proxy TestApi
diff --git a/src/Servant/API/QQ.hs b/src/Servant/API/QQ.hs
index 930a9365..18315532 100644
--- a/src/Servant/API/QQ.hs
+++ b/src/Servant/API/QQ.hs
@@ -17,12 +17,14 @@ import Servant.API.Get
 import Servant.API.Post
 import Servant.API.Put
 import Servant.API.Delete
+import Servant.API.RQBody
 import Servant.API.Sub
 import Servant.API.Union
 
 class ExpSYM repr' repr | repr -> repr', repr' -> repr where
     lit        :: String -> repr' -> repr
     capture    :: String -> String -> repr -> repr
+    rqBody     :: String -> repr -> repr
     conj       :: repr' -> repr -> repr
     get        :: String -> repr
     post       :: String -> repr
@@ -34,34 +36,42 @@ infixr 6 >:
 (>:) :: Type -> Type -> Type
 (>:) = conj
 
+
 instance ExpSYM Type Type where
     lit name r         = (LitT (StrTyLit name)) >: r
     capture name typ r = (AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
                                (ConT $ mkName typ)) >: r
+    rqBody typ r     = (AppT (ConT ''RQBody) (ConT $ mkName typ)) >: r
     conj x y         = AppT (AppT (ConT ''(:>)) x) y
     get  typ         = AppT (ConT ''Get) (ConT $ mkName typ)
     post typ         = AppT (ConT ''Post) (ConT $ mkName typ)
     put typ          = AppT (ConT ''Put) (ConT $ mkName typ)
-    delete typ       = AppT (ConT ''Delete) (ConT $ mkName typ)
+    delete "()"      = ConT ''Delete
+    delete _         = error "Delete does not return a request body"
 
 readEntry :: ExpSYM r r => [String] -> Maybe r
 readEntry []     = Nothing
-readEntry (met:typ:xs) = case met of
-    "GET"    -> readEntry' xs $ get typ
-    "POST"   -> readEntry' xs $ post typ
-    "PUT"    -> readEntry' xs $ put typ
-    "DELETE" -> readEntry' xs $ delete typ
+readEntry (met:xs:typ) = case met of
+    "GET"    -> rd get
+    "POST"   -> rd post
+    "PUT"    -> rd put
+    "DELETE" -> rd delete
     x        -> error $ "Unknown method: " ++ x
+  where typ' = splitOn "->" $ concat typ
+        rd m = case typ' of
+            []           -> readEntry' xs $ m "()"
+            [rsp]        -> readEntry' xs $ m rsp
+            (rqbd:[rsp]) -> readEntry' xs $ rqBody rqbd $ m rsp
+            _            -> error "Only functions of one argument allowed!"
 readEntry x    = error $ "Wrong number of elems in line: " ++ show x
 
-readEntry' :: ExpSYM r r => [String] -> r -> Maybe r
+readEntry' :: ExpSYM r r => String -> r -> Maybe r
 readEntry' []   _ = Nothing
-readEntry' [xs] r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
+readEntry' xs r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
     where
           tRepr y | [x] <- splitOn ":" y   = lit x
                   | a:[b] <- splitOn ":" y = capture a b
                   | otherwise              = error "Only one ':' per section"
-readEntry' _  _   = Nothing
 
 readAll :: String -> Type
 readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s