@@ -4,14 +4,14 @@
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE ScopedTypeVariables #-}
66{-# LANGUAGE TemplateHaskell #-}
7+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
78module Servant.Utils.ApiQuasiQuoting where
89
9−import Control.Applicative
10−import Data.List.Split (splitOn)
11−import Data.Maybe (mapMaybe)
10+import Control.Monad (void)
11+import Control.Applicative hiding (many, (<|>), optional)
1212import Language.Haskell.TH.Quote
1313import Language.Haskell.TH
14−import Safe (headMay)
14+import Text.ParserCombinators.Parsec
1515
1616import Servant.API.Capture
1717import Servant.API.Get
@@ -34,6 +34,7 @@ class ExpSYM repr' repr | repr -> repr', repr' -> repr where
3434 put :: String -> repr
3535 delete :: String -> repr
3636
37+
3738infixr 6 >:
3839
3940(>:) :: Type -> Type -> Type
@@ -54,42 +55,91 @@ instance ExpSYM Type Type where
5455 delete "()" = ConT ''Delete
5556 delete _ = error "Delete does not return a request body"
5657
57−readEntry :: ExpSYM r r => [String] -> Maybe r
58−readEntry [] = Nothing
59−readEntry (met:xs:typ) = case met of
60− "GET" -> rd get
61− "POST" -> rd post
62− "PUT" -> rd put
63− "DELETE" -> rd delete
64− x -> error $ "Unknown method: " ++ x
65− where typ' = splitOn "->" $ concat typ
66− rd m = case typ' of
67− [] -> readEntry' xs $ m "()"
68− [rsp] -> readEntry' xs $ m rsp
69− (rqbd:[rsp]) -> readEntry' xs $ reqBody rqbd $ m rsp
70− _ -> error "Only functions of one argument allowed!"
71−readEntry x = error $ "Wrong number of elems in line: " ++ show x
72−
73−readEntry' :: ExpSYM r r => String -> r -> Maybe r
74−readEntry' [] _ = Nothing
75−readEntry' xs r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
76− where
77− tRepr y | [x] <- splitOn ":" y = lit x
78− | a:[b] <- splitOn ":" y = case headMay a of
79− Just '?' -> queryParam (tail a) b
80− Just _ -> capture a b
81− Nothing -> error "Expecting something after '/'"
82− | otherwise = error "Only one ':' per section"
83−
84−readAll :: String -> Type
85−readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s
86− where union :: Type -> Type -> Type
87− union a = AppT (AppT (ConT ''(:<|>)) a)
58+parseMethod :: ExpSYM repr' repr => Parser (String -> repr)
59+parseMethod = try (string "GET" >> return get)
60+ <|> try (string "POST" >> return post)
61+ <|> try (string "PUT" >> return put)
62+ <|> try (string "DELETE" >> return delete)
63+
64+parseUrlSegment :: ExpSYM repr repr => Parser (repr -> repr)
65+parseUrlSegment = try parseCapture
66+ <|> try parseQueryParam
67+ <|> try parseLit
68+ where
69+ parseCapture = do
70+ cname <- many (noneOf " ?/:")
71+ char ':'
72+ ctyp <- many (noneOf " ?/:")
73+ return $ capture cname ctyp
74+ parseQueryParam = do
75+ char '?'
76+ cname <- many (noneOf " ?/:")
77+ char ':'
78+ ctyp <- many (noneOf " ?/:")
79+ return $ queryParam cname ctyp
80+ parseLit = lit <$> many (noneOf " ?/:")
81+
82+parseUrl :: ExpSYM repr repr => Parser (repr -> repr)
83+parseUrl = do
84+ optional $ char '/'
85+ url <- parseUrlSegment `sepBy1` char '/'
86+ return $ foldr1 (.) url
87+
88+data Typ = Val String
89+ | ReqArgVal String String
90+
91+parseTyp :: Parser Typ
92+parseTyp = do
93+ f <- many (noneOf "-#\n\r")
94+ spaces
95+ s <- optionMaybe parseRet
96+ case s of
97+ Nothing -> return $ Val (stripTr f)
98+ Just s' -> return $ ReqArgVal (stripTr f) (stripTr s')
99+ where
100+ parseRet :: Parser String
101+ parseRet = do
102+ string "->"
103+ spaces
104+ many (noneOf "#\n\r")
105+ stripTr = reverse . dropWhile (== ' ') . reverse
106+
107+
108+parseEntry :: ExpSYM repr repr => Parser repr
109+parseEntry = do
110+ met <- parseMethod
111+ spaces
112+ url <- parseUrl
113+ spaces
114+ typ <- parseTyp
115+ case typ of
116+ Val s -> return $ url (met s)
117+ ReqArgVal i o -> return $ url $ reqBody i (met o)
118+
119+eol :: Parser String
120+eol = try (string "\n\r")
121+ <|> try (string "\r\n")
122+ <|> string "\n"
123+ <|> string "\r"
124+ <?> "end of line"
125+
126+eols :: Parser ()
127+eols = skipMany $ void eol
128+
129+parseAll :: Parser Type
130+parseAll = do
131+ eols
132+ entries <- parseEntry `endBy` eols
133+ return $ foldr1 union entries
134+ where union :: Type -> Type -> Type
135+ union a = AppT (AppT (ConT ''(:<|>)) a)
88136
89137sitemap :: QuasiQuoter
90138sitemap = QuasiQuoter { quoteExp = undefined
91139 , quotePat = undefined
92− , quoteType = return . readAll
140+ , quoteType = \x -> case parse parseAll "" x of
141+ Left err -> error $ show err
142+ Right st -> return st
93143 , quoteDec = undefined
94144 }
95145