@@ -17,12 +17,14 @@ import Servant.API.Get
17import Servant.API.Post
17import Servant.API.Post
18import Servant.API.Put
18import Servant.API.Put
19import Servant.API.Delete
19import Servant.API.Delete
20+import Servant.API.RQBody
20import Servant.API.Sub
21import Servant.API.Sub
21import Servant.API.Union
22import Servant.API.Union
23class ExpSYM repr' repr | repr -> repr', repr' -> repr where
24class ExpSYM repr' repr | repr -> repr', repr' -> repr where
24 lit :: String -> repr' -> repr
25 lit :: String -> repr' -> repr
25 capture :: String -> String -> repr -> repr
26 capture :: String -> String -> repr -> repr
27+ rqBody :: String -> repr -> repr
26 conj :: repr' -> repr -> repr
28 conj :: repr' -> repr -> repr
27 get :: String -> repr
29 get :: String -> repr
28 post :: String -> repr
30 post :: String -> repr
@@ -34,34 +36,42 @@ infixr 6 >:
34(>:) :: Type -> Type -> Type
36(>:) :: Type -> Type -> Type
35(>:) = conj
37(>:) = conj
37instance ExpSYM Type Type where
40instance ExpSYM Type Type where
38 lit name r = (LitT (StrTyLit name)) >: r
41 lit name r = (LitT (StrTyLit name)) >: r
39 capture name typ r = (AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
42 capture name typ r = (AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
40 (ConT $ mkName typ)) >: r
43 (ConT $ mkName typ)) >: r
44+ rqBody typ r = (AppT (ConT ''RQBody) (ConT $ mkName typ)) >: r
41 conj x y = AppT (AppT (ConT ''(:>)) x) y
45 conj x y = AppT (AppT (ConT ''(:>)) x) y
42 get typ = AppT (ConT ''Get) (ConT $ mkName typ)
46 get typ = AppT (ConT ''Get) (ConT $ mkName typ)
43 post typ = AppT (ConT ''Post) (ConT $ mkName typ)
47 post typ = AppT (ConT ''Post) (ConT $ mkName typ)
44 put typ = AppT (ConT ''Put) (ConT $ mkName typ)
48 put typ = AppT (ConT ''Put) (ConT $ mkName typ)
45− delete typ = AppT (ConT ''Delete) (ConT $ mkName typ)
49+ delete "()" = ConT ''Delete
50+ delete _ = error "Delete does not return a request body"
47readEntry :: ExpSYM r r => [String] -> Maybe r
52readEntry :: ExpSYM r r => [String] -> Maybe r
48readEntry [] = Nothing
53readEntry [] = Nothing
49−readEntry (met:typ:xs) = case met of
54+readEntry (met:xs:typ) = case met of
50− "GET" -> readEntry' xs $ get typ
55+ "GET" -> rd get
51− "POST" -> readEntry' xs $ post typ
56+ "POST" -> rd post
52− "PUT" -> readEntry' xs $ put typ
57+ "PUT" -> rd put
53− "DELETE" -> readEntry' xs $ delete typ
58+ "DELETE" -> rd delete
54 x -> error $ "Unknown method: " ++ x
59 x -> error $ "Unknown method: " ++ x
60+ where typ' = splitOn "->" $ concat typ
62+ [] -> readEntry' xs $ m "()"
63+ [rsp] -> readEntry' xs $ m rsp
64+ (rqbd:[rsp]) -> readEntry' xs $ rqBody rqbd $ m rsp
65+ _ -> error "Only functions of one argument allowed!"
55readEntry x = error $ "Wrong number of elems in line: " ++ show x
66readEntry x = error $ "Wrong number of elems in line: " ++ show x
57−readEntry' :: ExpSYM r r => [String] -> r -> Maybe r
68+readEntry' :: ExpSYM r r => String -> r -> Maybe r
58readEntry' [] _ = Nothing
69readEntry' [] _ = Nothing
59−readEntry' [xs] r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
70+readEntry' xs r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
61 tRepr y | [x] <- splitOn ":" y = lit x
72 tRepr y | [x] <- splitOn ":" y = lit x
62 | a:[b] <- splitOn ":" y = capture a b
73 | a:[b] <- splitOn ":" y = capture a b
63 | otherwise = error "Only one ':' per section"
74 | otherwise = error "Only one ':' per section"
64−readEntry' _ _ = Nothing
66readAll :: String -> Type
76readAll :: String -> Type
67readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s
77readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s