git.iko.soy/servant
on master help sign in
Merge pull request #34 from alpmestan/jkarni/qq-parser
4f62dceAlp Mestanogullari
servant.cabal+2
compare with master
unifiedsplit
@@ -47,6 +47,7 @@ library
47 , network-uri >= 2.6
47 , network-uri >= 2.6
48 , wai
48 , wai
49 , warp
49 , warp
50+ , parsec
50 , safe
51 , safe
51 , transformers
52 , transformers
52 , template-haskell
53 , template-haskell
@@ -92,6 +93,7 @@ test-suite spec
92 , http-types
93 , http-types
93 , network >= 2.6
94 , network >= 2.6
94 , QuickCheck
95 , QuickCheck
96+ , parsec
95 , servant
97 , servant
96 , string-conversions
98 , string-conversions
97 , text
99 , text
src/Servant/Utils/ApiQuasiQuoting.hs+86−36
@@ -4,14 +4,14 @@
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TemplateHaskell #-}
7+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
7module Servant.Utils.ApiQuasiQuoting where
8module Servant.Utils.ApiQuasiQuoting where
8
9
9−import Control.Applicative
10+import Control.Monad (void)
10−import Data.List.Split (splitOn)
11+import Control.Applicative hiding (many, (<|>), optional)
11−import Data.Maybe (mapMaybe)
12import Language.Haskell.TH.Quote
12import Language.Haskell.TH.Quote
13import Language.Haskell.TH
13import Language.Haskell.TH
14−import Safe (headMay)
14+import Text.ParserCombinators.Parsec
15
15
16import Servant.API.Capture
16import Servant.API.Capture
17import Servant.API.Get
17import Servant.API.Get
@@ -34,6 +34,7 @@ class ExpSYM repr' repr | repr -> repr', repr' -> repr where
34 put :: String -> repr
34 put :: String -> repr
35 delete :: String -> repr
35 delete :: String -> repr
36
36
37+
37infixr 6 >:
38infixr 6 >:
38
39
39(>:) :: Type -> Type -> Type
40(>:) :: Type -> Type -> Type
@@ -54,42 +55,91 @@ instance ExpSYM Type Type where
54 delete "()" = ConT ''Delete
55 delete "()" = ConT ''Delete
55 delete _ = error "Delete does not return a request body"
56 delete _ = error "Delete does not return a request body"
56
57
57−readEntry :: ExpSYM r r => [String] -> Maybe r
58+parseMethod :: ExpSYM repr' repr => Parser (String -> repr)
58−readEntry [] = Nothing
59+parseMethod = try (string "GET" >> return get)
59−readEntry (met:xs:typ) = case met of
60− "GET" -> rd get
61− "POST" -> rd post
60+ <|> try (string "POST" >> return post)
62− "PUT" -> rd put
61+ <|> try (string "PUT" >> return put)
63− "DELETE" -> rd delete
62+ <|> try (string "DELETE" >> return delete)
64− x -> error $ "Unknown method: " ++ x
63+
65− where typ' = splitOn "->" $ concat typ
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
66− rd m = case typ' of
115+ case typ of
67− [] -> readEntry' xs $ m "()"
116+ Val s -> return $ url (met s)
68− [rsp] -> readEntry' xs $ m rsp
117+ ReqArgVal i o -> return $ url $ reqBody i (met o)
69− (rqbd:[rsp]) -> readEntry' xs $ reqBody rqbd $ m rsp
118+
70− _ -> error "Only functions of one argument allowed!"
119+eol :: Parser String
71−readEntry x = error $ "Wrong number of elems in line: " ++ show x
120+eol = try (string "\n\r")
72−
121+ <|> try (string "\r\n")
73−readEntry' :: ExpSYM r r => String -> r -> Maybe r
122+ <|> string "\n"
74−readEntry' [] _ = Nothing
123+ <|> string "\r"
75−readEntry' xs r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
124+ <?> "end of line"
76− where
125+
77− tRepr y | [x] <- splitOn ":" y = lit x
126+eols :: Parser ()
78− | a:[b] <- splitOn ":" y = case headMay a of
127+eols = skipMany $ void eol
79− Just '?' -> queryParam (tail a) b
128+
80− Just _ -> capture a b
129+parseAll :: Parser Type
81− Nothing -> error "Expecting something after '/'"
130+parseAll = do
82− | otherwise = error "Only one ':' per section"
131+ eols
83−
132+ entries <- parseEntry `endBy` eols
84−readAll :: String -> Type
133+ return $ foldr1 union entries
85−readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s
86− where union :: Type -> Type -> Type
134+ where union :: Type -> Type -> Type
87− union a = AppT (AppT (ConT ''(:<|>)) a)
135+ union a = AppT (AppT (ConT ''(:<|>)) a)
88
136
89sitemap :: QuasiQuoter
137sitemap :: QuasiQuoter
90sitemap = QuasiQuoter { quoteExp = undefined
138sitemap = QuasiQuoter { quoteExp = undefined
91 , quotePat = undefined
139 , 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
93 , quoteDec = undefined
143 , quoteDec = undefined
94 }
144 }
95
145