eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Add new request -> response syntax

Browse source
This commit is contained in:
Julian K. Arni 2014-10-28 17:32:22 +01:00
parent 21c8fcbea2
commit 1f6c3c4009
2 changed files with 22 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
example/greet.hs
View file

@ -56,8 +56,9 @@ type TestApi =
:<|> "delete" :> Capture "greetid" Text :> Delete :<|> "delete" :> Capture "greetid" Text :> Delete
type TestApi2 = [sitemap| type TestApi2 = [sitemap|
GET Bool something/capt:Int GET hello/name:Text/capital:Bool () -> Greet
POST Bool something POST greet Greet -> Greet
DELETE delete/greetid:Text ()
|] |]
testApi :: Proxy TestApi testApi :: Proxy TestApi

28
src/Servant/API/QQ.hs
View file

@ -17,12 +17,14 @@ import Servant.API.Get
import Servant.API.Post import Servant.API.Post
import Servant.API.Put import Servant.API.Put
import Servant.API.Delete import Servant.API.Delete
import Servant.API.RQBody
import Servant.API.Sub import Servant.API.Sub
import Servant.API.Union import Servant.API.Union
class ExpSYM repr' repr | repr -> repr', repr' -> repr where class ExpSYM repr' repr | repr -> repr', repr' -> repr where
lit :: String -> repr' -> repr lit :: String -> repr' -> repr
capture :: String -> String -> repr -> repr capture :: String -> String -> repr -> repr
rqBody :: String -> repr -> repr
conj :: repr' -> repr -> repr conj :: repr' -> repr -> repr
get :: String -> repr get :: String -> repr
post :: String -> repr post :: String -> repr
@ -34,34 +36,42 @@ infixr 6 >:
(>:) :: Type -> Type -> Type (>:) :: Type -> Type -> Type
(>:) = conj (>:) = conj
instance ExpSYM Type Type where instance ExpSYM Type Type where
lit name r = (LitT (StrTyLit name)) >: r lit name r = (LitT (StrTyLit name)) >: r
capture name typ r = (AppT (AppT (ConT ''Capture) (LitT (StrTyLit name))) capture name typ r = (AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
(ConT $ mkName typ)) >: r (ConT $ mkName typ)) >: r
rqBody typ r = (AppT (ConT ''RQBody) (ConT $ mkName typ)) >: r
conj x y = AppT (AppT (ConT ''(:>)) x) y conj x y = AppT (AppT (ConT ''(:>)) x) y
get typ = AppT (ConT ''Get) (ConT $ mkName typ) get typ = AppT (ConT ''Get) (ConT $ mkName typ)
post typ = AppT (ConT ''Post) (ConT $ mkName typ) post typ = AppT (ConT ''Post) (ConT $ mkName typ)
put typ = AppT (ConT ''Put) (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 :: ExpSYM r r => [String] -> Maybe r
readEntry [] = Nothing readEntry [] = Nothing
readEntry (met:typ:xs) = case met of readEntry (met:xs:typ) = case met of
"GET" -> readEntry' xs $ get typ "GET" -> rd get
"POST" -> readEntry' xs $ post typ "POST" -> rd post
"PUT" -> readEntry' xs $ put typ "PUT" -> rd put
"DELETE" -> readEntry' xs $ delete typ "DELETE" -> rd delete
x -> error $ "Unknown method: " ++ x 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 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' [] _ = Nothing
readEntry' [xs] r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r readEntry' xs r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
where where
tRepr y | [x] <- splitOn ":" y = lit x tRepr y | [x] <- splitOn ":" y = lit x
| a:[b] <- splitOn ":" y = capture a b | a:[b] <- splitOn ":" y = capture a b
| otherwise = error "Only one ':' per section" | otherwise = error "Only one ':' per section"
readEntry' _ _ = Nothing
readAll :: String -> Type readAll :: String -> Type
readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s