diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 0.2.0 + +* Add almost all raml-tags for yesod-raml-docs and yesod-raml-mock +* Support multi variables of one-line. (Previous version can not parse "/user/{userid}/{string}:".) + ## 0.1.4 * Add OPTIONS and other http methods. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,16 +1,8 @@ # Yesod-Raml: -[![Hackage version](https://img.shields.io/hackage/v/yesod-raml.svg?style=flat)](https://hackage.haskell.org/package/yesod-raml) [![Build Status](https://travis-ci.org/junjihashimoto/yesod-raml.png?branch=master)](https://travis-ci.org/junjihashimoto/yesod-raml) - Yesod-Raml makes routes definition from [RAML](http://raml.org/spec.html) File. -raml style routes definition is inspired by [sbt-play-raml](https://github.com/scalableminds/sbt-play-raml). - -## Getting started - -Install this from Hackage. - - cabal update && cabal install yesod-raml +RAML style routes definition is inspired by [sbt-play-raml](https://github.com/scalableminds/sbt-play-raml). ## Usage diff --git a/Yesod/Raml/Parser.hs b/Yesod/Raml/Parser.hs --- a/Yesod/Raml/Parser.hs +++ b/Yesod/Raml/Parser.hs @@ -1,47 +1,98 @@ {-#LANGUAGE OverloadedStrings#-} +{-#LANGUAGE TemplateHaskell#-} +{-#LANGUAGE QuasiQuotes#-} +{-#LANGUAGE FlexibleInstances#-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Yesod.Raml.Parser () where +module Yesod.Raml.Parser ( + parseRaml +, parseRamlFile +, applyVersion +, applyTrait +, applyResourceType +, genUriParamDescription +) where import Control.Applicative import Control.Monad import Data.Aeson import Data.Aeson.Types(Parser) -import Data.HashMap.Strict(HashMap) import qualified Data.HashMap.Strict as HM import Data.Text (Text) import qualified Data.Text as T import Data.Map (Map) import qualified Data.Map as M +import qualified Data.Vector as V +import Data.Monoid +import Data.Default + import Yesod.Raml.Type +import qualified Data.ByteString.Char8 as B +import qualified Data.Yaml as Y +import qualified Data.Yaml.Include as YI +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote -toResponseBody :: HashMap Text Value -> Parser (Map Text RamlResponseBody) -toResponseBody hashmap = do - list <- forM (HM.toList hashmap) $ \(k,v) -> do - val <- parseJSON v :: Parser RamlResponseBody - return (k,val) - return $ M.fromList list +--import Yesod.Routes.TH.Types +import Language.Haskell.TH.Lift -toResponse :: HashMap Text Value -> Parser (Map Text RamlResponse) -toResponse hashmap = do - list <- forM (HM.toList hashmap) $ \(k,v) -> do - val <- parseJSON v :: Parser RamlResponse - return (k,val) - return $ M.fromList list +(.::?) :: Object -> Text -> Parser (Maybe Text) +(.::?) obj key = do + mobj <- obj .:? key + case mobj of + Nothing -> return Nothing + Just (String str) -> return $ Just str + Just (Number str) -> return $ Just $ T.pack $ show str + Just (Bool str) -> if str then return ( Just "true" ) else return (Just "false") + _ -> fail $ ".::? : Can not parse :" ++ show mobj +(.::) :: Object -> Text -> Parser Text +(.::) obj key = do + mobj <- obj .:? key + case mobj of + Just (String str) -> return $ str + Just (Number str) -> return $ T.pack $ show str + _ -> fail $ ".::? : Can not parse :" ++ show mobj + +toMap :: FromJSON a => Object -> Text -> Parser (Map Text a) +toMap obj key = do + mobj <- obj .:? key + case mobj of + Nothing -> return M.empty + Just (Object hashmap) -> do + list <- forM (HM.toList hashmap) $ \(k,v) -> do + val <- parseJSON v + return (k,val) + return $ M.fromList list + Just Null -> return M.empty + Just _ -> fail $ "Can not parse Map:" ++ show mobj + +toArray :: FromJSON a => Object -> Text -> Parser [a] +toArray obj key = do + mobj <- obj .:? key + case mobj of + Nothing -> return [] + Just (Array ary) -> do + list <- forM (V.toList ary) $ \v -> do + val <- parseJSON v + return val + return list + Just Null -> return [] + Just _ -> fail $ "Can not parse Array:" ++ show mobj + toMethod :: Object -> Parser (Map Text RamlMethod) toMethod hashmap = do let methods = filter (\(k,_) -> elem k ["get", "GET", - "post", "POST", - "head", "HEAD", - "delete", "DELETE", - "trace", "TRACE", - "connect", "CONNECT", - "put", "PUT", - "options", "OPTIONS", - "patch", "PATCH" + "post", "POST", + "head", "HEAD", + "delete", "DELETE", + "trace", "TRACE", + "connect", "CONNECT", + "put", "PUT", + "options", "OPTIONS", + "patch", "PATCH" ] ) (HM.toList hashmap) list <- forM methods $ \(k,v) -> do @@ -50,7 +101,7 @@ return $ M.fromList list -toResource :: HashMap Text Value -> Parser (Map Text RamlResource) +toResource :: Object -> Parser (Map Text RamlResource) toResource hashmap = do let rs = filter (\(k,_) -> T.isPrefixOf "/" k) (HM.toList hashmap) list <- forM rs $ \(k,v) -> do @@ -61,27 +112,71 @@ instance FromJSON RamlResponseBody where parseJSON (Object obj) = RamlResponseBody <$> obj .:? "schema" - <*> obj .:? "example" - parseJSON m = fail $ "Can not parse:" ++ show m + <*> obj .::? "example" + parseJSON Null = return def + parseJSON m = fail $ "Can not parse RamlResponseBody:" ++ show m instance FromJSON RamlResponse where parseJSON (Object obj) = RamlResponse <$> obj .:? "description" - <*> toResponseBody obj - parseJSON m = fail $ "Can not parse:" ++ show m + <*> toMap obj "headers" + <*> toMap obj "body" + parseJSON Null = return def + parseJSON m = fail $ "Can not parse RamlResponse:" ++ show m +instance FromJSON RamlNamedParameters where + parseJSON (Object obj) = RamlNamedParameters + <$> obj .:? "displayName" + <*> obj .:? "description" + <*> obj .:? "type" + <*> toArray obj "enum" + <*> obj .:? "pattern" + <*> obj .:? "minLength" + <*> obj .:? "maxLength" + <*> obj .:? "minimum" + <*> obj .:? "maximum" + <*> obj .::? "example" + <*> obj .:? "repeat" + <*> obj .:? "required" + <*> obj .::? "default" + parseJSON Null = return def + parseJSON m = fail $ "Can not parse RamlNamedParameters:" ++ show m +instance FromJSON RamlRequestBody where + parseJSON (Object obj) = RamlRequestBody + <$> toMap obj "formParameters" + <*> obj .:? "schema" + <*> obj .::? "example" + parseJSON Null = return def + parseJSON m = fail $ "Can not parse RamlRequestBody:" ++ show m + instance FromJSON RamlMethod where parseJSON (Object obj) = do - mres <- obj .:? "responses" :: Parser (Maybe Value) - res <- case mres of - Nothing -> return $ M.empty - Just (Object obj') -> toResponse obj' - Just m -> fail $ "Can not parse:" ++ show m RamlMethod - <$> return res - parseJSON m = fail $ "Can not parse:" ++ show m + <$> toMap obj "responses" + <*> obj .:? "description" + <*> toMap obj "headers" + <*> toArray obj "securedBy" + <*> toArray obj "protocols" + <*> toMap obj "queryParameters" + <*> toMap obj "body" + <*> toArray obj "is" + parseJSON Null = return def + parseJSON m = fail $ "Can not parse RamlMethod:" ++ show m +instance FromJSON RamlTrait where + parseJSON (Object obj) = RamlTrait + <$> obj .:? "usage" + <*> toMap obj "responses" + <*> obj .:? "description" + <*> toMap obj "headers" + <*> toArray obj "securedBy" + <*> toArray obj "protocols" + <*> toMap obj "queryParameters" + <*> toMap obj "body" + parseJSON Null = return def + parseJSON m = fail $ "Can not parse RamlTrait:" ++ show m + instance FromJSON RamlResource where parseJSON (Object obj) = RamlResource <$> obj .:? "displayName" @@ -89,20 +184,204 @@ <*> obj .:? "handler" <*> toMethod obj <*> toResource obj - parseJSON m = fail $ "Can not parse:" ++ show m + <*> toMap obj "uriParameters" + <*> toMap obj "baseUriParameters" + <*> obj .:? "type" + <*> toArray obj "is" + parseJSON Null = return def + parseJSON m = fail $ "Can not parse RamlResource:" ++ show m + +instance FromJSON RamlResourceType where + parseJSON (Object obj) = RamlResourceType + <$> obj .:? "usage" + <*> obj .:? "displayName" + <*> obj .:? "description" + <*> toMethod obj + <*> toResource obj + <*> toMap obj "uriParameters" + <*> toMap obj "baseUriParameters" + parseJSON m = fail $ "Can not parse RamlResourceType:" ++ show m + instance FromJSON RamlDocumentation where parseJSON (Object obj) = RamlDocumentation <$> obj .: "title" <*> obj .: "content" - parseJSON m = fail $ "Can not parse:" ++ show m + parseJSON m = fail $ "Can not parse RamlDocumentation:" ++ show m +instance FromJSON RamlSecuritySchemes where + parseJSON (Object obj) = RamlSecuritySchemes + <$> obj .: "description" + <*> obj .: "type" + <*> obj .: "describedBy" + <*> obj .: "settings" + parseJSON Null = return def + parseJSON m = fail $ "Can not parse RamlSecuritySchemes:" ++ show m + + instance FromJSON Raml where parseJSON (Object obj) = Raml <$> obj .: "title" - <*> obj .: "version" + <*> obj .:: "version" <*> obj .: "baseUri" - <*> obj .:? "documentation" + <*> toMap obj "baseUriParameters" + <*> toArray obj "Protocol" + <*> obj .:? "mediaType" + <*> toArray obj "schemas" + <*> toMap obj "uriParameters" + <*> toArray obj "documentation" <*> toResource obj - parseJSON m = fail $ "Can not parse:" ++ show m + <*> toArray obj "securitySchemes" + <*> toArray obj "resourceTypes" + <*> toArray obj "traits" + parseJSON m = fail $ "Can not parse Raml:" ++ show m + +parseRaml :: QuasiQuoter +parseRaml = QuasiQuoter + { quoteExp = lift . toRamlFromString + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + where + toRamlFromString :: String -> Raml + toRamlFromString ramlStr = + let eRaml = Y.decodeEither (B.pack ramlStr) :: Either String Raml + raml = case eRaml of + Right v -> v + Left e -> error $ "Invalid raml :" ++ e + in raml + +parseRamlFile :: FilePath -> Q Exp +parseRamlFile file = do + qAddDependentFile file + s <- qRunIO $ toRamlFromFile file + lift s + where + toRamlFromFile :: String -> IO Raml + toRamlFromFile file' = do + eRaml <- YI.decodeFileEither file' + let raml = case eRaml of + Right v -> v + Left e -> error $ "Invalid raml :" ++ show e + return raml + +instance Lift Text where + lift txt = [| T.pack $(lift $ T.unpack txt) |] + +$(deriveLift ''Map) +$(deriveLift ''RamlNamedParameters) +$(deriveLift ''RamlRequestBody) +$(deriveLift ''RamlResource) +$(deriveLift ''RamlResourceType) +$(deriveLift ''RamlTrait) +$(deriveLift ''RamlSecuritySchemes) +$(deriveLift ''RamlResponse) +$(deriveLift ''RamlResponseBody) +$(deriveLift ''RamlDocumentation) +$(deriveLift ''RamlMethod) +$(deriveLift ''Raml) + +applyVersion :: Raml -> Raml +applyVersion raml = raml { baseUri = T.replace "{version}" (version raml) (baseUri raml) } + + +applyTrait :: Raml -> Raml +applyTrait raml = raml { paths = applyTraitForPath (paths raml) } + where + traits' :: Map TraitKey RamlTrait + traits' = foldr (<>) mempty (traits raml) + fromTraitKeys :: [TraitKey] -> RamlTrait + fromTraitKeys keys = foldr (<>) mempty (map (traits' M.!) keys) + applyTraitForPath paths' = M.map applyTraitForResource paths' + applyTraitForResource res = + res { + r_paths = applyTraitForPath (r_paths res) + , r_methods = applyTraitForMethod (r_methods res) + } + where + trait = fromTraitKeys (r_is res) + applyTraitForMethod methods' = M.map (appendTrait' traits' trait) methods' + + appendTrait :: RamlTrait -> RamlMethod -> RamlMethod + appendTrait a b = + b { + m_responses = t_responses a <> m_responses b + , m_description = t_description a <> m_description b + , m_headers = t_headers a <> m_headers b + , m_securedBy = t_securedBy a <> m_securedBy b + , m_protocols = t_protocols a <> m_protocols b + , m_queryParameters = t_queryParameters a <> m_queryParameters b + , m_body = t_body a <> m_body b + } + + appendTrait' :: Map TraitKey RamlTrait -> RamlTrait -> RamlMethod -> RamlMethod + appendTrait' m a b = appendTrait (a <> trait) b + where + trait = foldr (<>) mempty (map (m M.!) (m_is b)) + + +applyResourceType :: Raml -> Raml +applyResourceType raml = raml { paths = applyResourceTypeForPath (paths raml) } + where + types' :: Map ResourceTypeKey RamlResourceType + types' = foldr (<>) mempty (resourceTypes raml) + fromResourceTypeKey :: ResourceTypeKey -> RamlResourceType + fromResourceTypeKey key = types' M.! key + applyResourceTypeForPath paths' = M.map applyResourceTypeForResource paths' + applyResourceTypeForResource res = + let res'' = case r_type res of + Just typ -> appendResourceType (fromResourceTypeKey typ) res + Nothing -> res + in res'' { + r_paths = applyResourceTypeForPath (r_paths res) + } + + appendResourceType :: RamlResourceType -> RamlResource -> RamlResource + appendResourceType a b = + b { + r_methods = rt_methods a <> r_methods b + , r_paths = rt_paths a <> r_paths b + , r_uriParameters = rt_uriParameters a <> r_uriParameters b + , r_baseUriParameters = rt_baseUriParameters a <> r_baseUriParameters b + } + + +genUriParamDescription :: Raml -> Raml +genUriParamDescription raml = raml { paths = applyUri "" (paths raml) } + where + applyUri uri map' = M.fromList $ map (applyUri' uri) $ M.toList map' + applyUri' uri (path,res) = (path, + res{ + r_uriParameters = M.fromList (path2uriParameters (uri<>path)) <> r_uriParameters res + , r_paths = applyUri (uri<>path) (r_paths res) + }) + + routeToParams :: T.Text -> [T.Text] + routeToParams str | T.dropWhile (/= '{') str /= "" && + T.dropWhile (/= '}') str /= "" = [T.takeWhile (/= '}') (T.tail (T.dropWhile (/= '{') str))] ++ + routeToParams (T.tail (T.dropWhile (/= '}') str)) + | otherwise = [] + + + path2uriParameters uri = + flip map (routeToParams uri) $ + \param -> + (param, + RamlNamedParameters { + h_displayName = Nothing + , h_description = Nothing + , h_type = Just "string" + , h_enum = [] + , h_pattern = Nothing + , h_minLength = Nothing + , h_maxLength = Nothing + , h_minimum = Nothing + , h_maximum = Nothing + , h_example = Nothing + , h_repeat = Nothing + , h_required = Just True + , h_default = Nothing + }) + diff --git a/Yesod/Raml/Routes.hs b/Yesod/Raml/Routes.hs --- a/Yesod/Raml/Routes.hs +++ b/Yesod/Raml/Routes.hs @@ -3,6 +3,8 @@ module Yesod.Raml.Routes ( parseRamlRoutes , parseRamlRoutesFile +, routesFromRaml +, toYesodRoutes ) where import Yesod.Raml.Routes.Internal diff --git a/Yesod/Raml/Routes/Internal.hs b/Yesod/Raml/Routes/Internal.hs --- a/Yesod/Raml/Routes/Internal.hs +++ b/Yesod/Raml/Routes/Internal.hs @@ -20,29 +20,50 @@ import Language.Haskell.TH.Quote import Yesod.Routes.TH.Types -import Network.URI +import Network.URI hiding (path) -routesFromRaml :: Raml -> Either String [RamlRoute] +routesFromRaml :: Raml -> Either String [RouteEx] routesFromRaml raml = do let buri = T.replace "{version}" (version raml) (baseUri raml) uripaths <- case parsePath buri of (Just uri) -> return $ fmap ("/" <> ) $ T.split (== '/') $ if T.isPrefixOf "/" uri then T.tail uri else uri Nothing -> Left $ "can not parse: " ++ (T.unpack buri) v <- forM (M.toList (paths raml)) $ \(k,v) -> do - routesFromRamlResource v $ uripaths ++ [k] + routesFromRamlResource v $ uripaths ++ splitPath k return $ concat v where parsePath uri = fmap T.pack $ fmap uriPath $ parseURI (T.unpack uri) -routesFromRamlResource :: RamlResource -> [Path] -> Either String [RamlRoute] +splitPath :: T.Text -> [T.Text] +splitPath path = + case T.split (== '/') path of + (_:xs) -> map (T.append "/") xs + _ -> [path] + + +methodExFromRamlMethod :: (Method,RamlMethod) -> MethodEx +methodExFromRamlMethod (method,val) = + let example = do + response <- M.lookup "200" (m_responses val) + (contentType,body) <- listToMaybe (M.toList (res_body response)) + ex <- res_example body + return (contentType,ex) + in MethodEx (T.unpack (T.toUpper (method))) example + +routesFromRamlResource :: RamlResource -> [Path] -> Either String [RouteEx] routesFromRamlResource raml paths' = do rrlist <- forM (M.toList (r_paths raml)) $ \(k,v) -> do - routesFromRamlResource v (paths' ++ [k]) + routesFromRamlResource v (paths' ++ splitPath k) let rlist = concat rrlist case toHandler Nothing raml of Right handle -> do - let methods = map fst $ M.toList (r_methods raml) - return $ (RamlRoute paths' handle methods):rlist + let methods = flip map (M.toList (r_methods raml)) methodExFromRamlMethod + route = RouteEx { + re_pieces = toPieces paths' + , re_handler = T.unpack handle + , re_methods = methods + } + return $ route : rlist Left err -> do case rrlist of [] -> Left err @@ -74,15 +95,15 @@ Nothing -> Left "Can not find Handler" Just handler -> return handler -toYesodResource :: RamlRoute -> Resource String +toYesodResource :: RouteEx -> Resource String toYesodResource route = Resource { - resourceName = T.unpack (rr_handler route) - , resourcePieces = toPieces (rr_pieces route) + resourceName = re_handler route + , resourcePieces = re_pieces route , resourceDispatch = Methods { methodsMulti = Nothing - , methodsMethods = map (T.unpack.T.toUpper) (rr_methods route) + , methodsMethods = map me_method (re_methods route) } , resourceAttrs = [] , resourceCheck = True @@ -120,8 +141,23 @@ | T.isPrefixOf "/" str = Static $ T.unpack $ T.tail str | otherwise = error "Prefix is not '/'." +fromPiece :: Piece String -> T.Text +fromPiece (Static str) = "/" <> T.pack str +fromPiece (Dynamic str) = "/#" <> T.pack str + toPieces :: [Path] -> [Piece String] toPieces paths' = map toPiece paths' + +fromPieces :: [Piece String] -> [Path] +fromPieces paths' = map fromPiece paths' + +toYesodRoutes :: [RouteEx] -> T.Text +toYesodRoutes routes = foldr (\a b -> toRoute a <> "\n" <> b ) "" routes + where + toRoute :: RouteEx -> T.Text + toRoute r = foldr (<>) "" (fromPieces (re_pieces r)) <> " " <> + T.pack (re_handler r) <> " " <> + T.intercalate " " (map (T.pack.me_method) (re_methods r)) parseRamlRoutes :: QuasiQuoter diff --git a/Yesod/Raml/Type.hs b/Yesod/Raml/Type.hs --- a/Yesod/Raml/Type.hs +++ b/Yesod/Raml/Type.hs @@ -4,6 +4,10 @@ import Data.Text (Text) import Data.Map (Map) +import qualified Data.Map as M +import Data.Monoid +import Yesod.Routes.TH.Types (Piece) +import Data.Default type HandlerHint = Text type Handler = Text @@ -11,6 +15,16 @@ type Method = Text type ResponseCode = Text type ContentType = Text +type Auth = Text +type HeaderKey = Text +type QueryParameter = Text +type UriParameter = Text +type SchemaKey = Text +type Schema = Text +type Protocol = Text +type MediaType = Text +type ResourceTypeKey = Text +type TraitKey = Text data RamlResponseBody = RamlResponseBody { @@ -18,45 +32,241 @@ , res_example :: Maybe Text } deriving (Show,Eq,Ord) +instance Default RamlResponseBody where + def = RamlResponseBody { + res_schema = Nothing + , res_example = Nothing + } + data RamlResponse = RamlResponse { res_description :: Maybe Text + , res_headers :: Map HeaderKey RamlNamedParameters , res_body :: Map ContentType RamlResponseBody } deriving (Show,Eq,Ord) +instance Default RamlResponse where + def = RamlResponse { + res_description = Nothing + , res_headers = M.empty + , res_body = M.empty + } + +data RamlNamedParameters = + RamlNamedParameters { + h_displayName :: Maybe Text + , h_description :: Maybe Text + , h_type :: Maybe Text + , h_enum :: [Text] + , h_pattern :: Maybe Text + , h_minLength :: Maybe Int + , h_maxLength :: Maybe Int + , h_minimum :: Maybe Int + , h_maximum :: Maybe Int + , h_example :: Maybe Text + , h_repeat :: Maybe Bool + , h_required :: Maybe Bool + , h_default :: Maybe Text + } deriving (Show,Eq,Ord) + +instance Default RamlNamedParameters where + def = RamlNamedParameters { + h_displayName = Nothing + , h_description = Nothing + , h_type = Nothing + , h_enum = [] + , h_pattern = Nothing + , h_minLength = Nothing + , h_maxLength = Nothing + , h_minimum = Nothing + , h_maximum = Nothing + , h_example = Nothing + , h_repeat = Nothing + , h_required = Nothing + , h_default = Nothing + } + +data RamlRequestBody = + RamlRequestBody { + req_formParameters :: Map QueryParameter RamlNamedParameters + , req_schema :: Maybe Schema + , req_example :: Maybe Text + } deriving (Show,Eq,Ord) + +instance Default RamlRequestBody where + def = RamlRequestBody { + req_formParameters = M.empty + , req_schema = Nothing + , req_example = Nothing + } + data RamlMethod = RamlMethod { m_responses :: Map ResponseCode RamlResponse + , m_description :: Maybe Text + , m_headers :: Map HeaderKey RamlNamedParameters + , m_securedBy :: [Auth] + , m_protocols :: [Protocol] + , m_queryParameters :: Map QueryParameter RamlNamedParameters + , m_body :: Map MediaType RamlRequestBody + , m_is :: [TraitKey] } deriving (Show,Eq,Ord) +instance Default RamlMethod where + def = RamlMethod { + m_responses = M.empty + , m_description = Nothing + , m_headers = M.empty + , m_securedBy = [] + , m_protocols = [] + , m_queryParameters = M.empty + , m_body = M.empty + , m_is = [] + } + +data RamlResourceType = + RamlResourceType { + rt_usage :: Maybe Text + , rt_displayName :: Maybe Text + , rt_description :: Maybe Text + , rt_methods :: Map Method RamlMethod + , rt_paths :: Map Path RamlResource + , rt_uriParameters :: Map UriParameter RamlNamedParameters + , rt_baseUriParameters :: Map UriParameter RamlNamedParameters + } deriving (Show,Eq,Ord) + +instance Default RamlResourceType where + def = RamlResourceType { + rt_usage = Nothing + , rt_displayName = Nothing + , rt_description = Nothing + , rt_methods = M.empty + , rt_paths = M.empty + , rt_uriParameters = M.empty + , rt_baseUriParameters = M.empty + } + +data RamlTrait = + RamlTrait { + t_usage :: Maybe Text + , t_responses :: Map ResponseCode RamlResponse + , t_description :: Maybe Text + , t_headers :: Map HeaderKey RamlNamedParameters + , t_securedBy :: [Auth] + , t_protocols :: [Protocol] + , t_queryParameters :: Map QueryParameter RamlNamedParameters + , t_body :: Map MediaType RamlRequestBody + } deriving (Show,Eq,Ord) + +instance Default RamlTrait where + def = RamlTrait { + t_usage = Nothing + , t_responses = M.empty + , t_description = Nothing + , t_headers = M.empty + , t_securedBy = [] + , t_protocols = [] + , t_queryParameters = M.empty + , t_body = M.empty + } + data RamlResource = RamlResource { r_displayName :: Maybe Text , r_description :: Maybe Text - , r_handler :: Maybe Handler + , r_handler :: Maybe Handler -- ^ This is used for Yesod Route. , r_methods :: Map Method RamlMethod , r_paths :: Map Path RamlResource + , r_uriParameters :: Map UriParameter RamlNamedParameters + , r_baseUriParameters :: Map UriParameter RamlNamedParameters + , r_type :: Maybe ResourceTypeKey + , r_is :: [TraitKey] } deriving (Show,Eq,Ord) +instance Default RamlResource where + def = RamlResource { + r_displayName = Nothing + , r_description = Nothing + , r_handler = Nothing + , r_methods = M.empty + , r_paths = M.empty + , r_uriParameters = M.empty + , r_baseUriParameters = M.empty + , r_type = Nothing + , r_is = [] + } + data RamlDocumentation = RamlDocumentation { doc_title :: Text , doc_content :: Text } deriving (Show,Eq,Ord) +data RamlSecuritySchemes = + RamlSecuritySchemes { + ss_description :: Maybe Text + , ss_type :: Maybe Text + , ss_describedBy :: Maybe Text + , ss_settings :: Maybe Text + } deriving (Show,Eq,Ord) + +instance Default RamlSecuritySchemes where + def = RamlSecuritySchemes { + ss_description = Nothing + , ss_type = Nothing + , ss_describedBy = Nothing + , ss_settings = Nothing + } + data Raml = Raml { title :: Text , version :: Text , baseUri :: Text - , documentation :: Maybe [RamlDocumentation] + , baseUriParameters :: Map UriParameter RamlNamedParameters + , protocols :: [Protocol] + , mediaType :: Maybe MediaType + , schemas :: [Map SchemaKey Schema] + , uriParameters :: Map UriParameter RamlNamedParameters + , documentation :: [RamlDocumentation] , paths :: Map Path RamlResource + , securitySchemes :: [Map Auth RamlSecuritySchemes] + , resourceTypes :: [Map ResourceTypeKey RamlResourceType] + , traits :: [Map TraitKey RamlTrait] } deriving (Show,Eq,Ord) -data RamlRoute = - RamlRoute { - rr_pieces :: [Path] - , rr_handler :: Text - , rr_methods :: [Method] - } deriving (Show,Eq,Ord) +instance Monoid RamlTrait where + mempty = RamlTrait { + t_usage = Nothing + , t_responses = M.empty + , t_description = Nothing + , t_headers = M.empty + , t_securedBy = [] + , t_protocols = [] + , t_queryParameters = M.empty + , t_body = M.empty + } + mappend a b = RamlTrait { + t_usage = t_usage a <> t_usage b + , t_responses = t_responses a <> t_responses b + , t_description = t_description a <> t_description b + , t_headers = t_headers a <> t_headers b + , t_securedBy = t_securedBy a <> t_securedBy b + , t_protocols = t_protocols a <> t_protocols b + , t_queryParameters = t_queryParameters a <> t_queryParameters b + , t_body = t_body a <> t_body b + } + +data MethodEx = + MethodEx { + me_method :: String -- ^ Uppercase method name + , me_example :: Maybe (ContentType,Text) -- ^ This is used for output of mock. + } deriving (Show) + +data RouteEx = + RouteEx { + re_pieces :: [Piece String] + , re_handler :: String + , re_methods :: [MethodEx] + } deriving (Show) diff --git a/tests/RoutesSpec.hs b/tests/RoutesSpec.hs --- a/tests/RoutesSpec.hs +++ b/tests/RoutesSpec.hs @@ -1,27 +1,17 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns#-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -ddump-splices #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans -ddump-splices #-} + import Test.Hspec -import Data.Text (Text, pack, unpack, singleton) import Yesod.Core -import Language.Haskell.TH.Syntax import Yesod.Raml.Type import Yesod.Raml.Routes.Internal import Yesod.Routes.TH.Types import qualified Data.Map as M -import Control.Applicative deriving instance Eq (Dispatch String) deriving instance Eq (Piece String) @@ -71,17 +61,50 @@ description: hoger |] +routea'' :: [ResourceTree String] +routea'' = [parseRamlRoutes| +#%RAML 0.8 +title: Hoge API +baseUri: 'https://hoge/api/{version}' +version: v1 +protocols: [ HTTPS ] +/user/{userid}/{String}: + description: | + handler:HogeR + get: + description: hoger +|] + +routeb :: [ResourceTree String] routeb = [parseRoutes| /api/v1/user/#String HogeR GET POST /api/v1/user/#String/del Hoge2R POST |] +routeb' :: [ResourceTree String] routeb' = [parseRoutes| /api/v1/user/#Userid HogeR GET /api/v1/user/#Userid/del Hoge2R POST |] +routec :: [ResourceTree String] +routec = [parseRoutes| +/api/v1/user/#Userid/#String HogeR GET +|] +emptyMethod :: RamlMethod +emptyMethod = + RamlMethod { + m_responses = M.empty + , m_description = Nothing + , m_headers = M.empty + , m_securedBy = [] + , m_protocols = [] + , m_queryParameters = M.empty + , m_body = M.empty + , m_is = [] + } + main :: IO () main = hspec $ do describe "handler" $ do @@ -91,8 +114,12 @@ r_displayName = Nothing , r_description = Just "handler: hogehoge\n" , r_handler = Nothing - , r_methods = M.fromList [("GET",RamlMethod M.empty)] + , r_methods = M.fromList [("GET",emptyMethod)] , r_paths = M.empty + , r_uriParameters = M.empty + , r_baseUriParameters = M.empty + , r_type = Nothing + , r_is = [] } ) `shouldBe` Right "hogehoge" it "parse handler from description" $ do toHandler Nothing @@ -100,8 +127,12 @@ r_displayName = Nothing , r_description = Just "burabura\nhandler: hogehoge\n" , r_handler = Nothing - , r_methods = M.fromList [("GET",RamlMethod M.empty)] + , r_methods = M.fromList [("GET",emptyMethod)] , r_paths = M.empty + , r_uriParameters = M.empty + , r_baseUriParameters = M.empty + , r_type = Nothing + , r_is = [] } ) `shouldBe` Right "hogehoge" it "parse handler from handler" $ do toHandler Nothing @@ -109,13 +140,19 @@ r_displayName = Nothing , r_description = Just "handler: hogehoge\n" , r_handler = Just "hoge" - , r_methods = M.fromList [("GET",RamlMethod M.empty)] + , r_methods = M.fromList [("GET",emptyMethod)] , r_paths = M.empty + , r_uriParameters = M.empty + , r_baseUriParameters = M.empty + , r_type = Nothing + , r_is = [] } ) `shouldBe` Right "hoge" describe "resource tree" $ do it "parseRamlRoutes from handler" $ do routea `shouldBe` routeb it "parseRamlRoutes from description" $ do routea' `shouldBe` routeb' + it "check multi value" $ do + routea'' `shouldBe` routec it "parseRamlRoutesFile" $ do $(parseRamlRoutesFile "tests/test.raml") `shouldBe` routeb' diff --git a/utils/raml-utils.hs b/utils/raml-utils.hs deleted file mode 100644 --- a/utils/raml-utils.hs +++ /dev/null @@ -1,27 +0,0 @@ -import Yesod.Raml.Type -import Yesod.Raml.Parser -import qualified Data.Yaml as Y - -import Options.Applicative - -data Command = - Verify FilePath - -verify :: Parser Command -verify = Verify <$> (argument str (metavar "RamlFile")) - -parse :: Parser Command -parse = subparser $ - command "verify" (info verify (progDesc "verify raml-file")) - -runCmd :: Command -> IO () -runCmd (Verify file) = do - v <- Y.decodeFile file :: IO (Maybe Raml) - print v - -opts :: ParserInfo Command -opts = info (parse <**> helper) idm - -main :: IO () -main = execParser opts >>= runCmd - diff --git a/yesod-raml.cabal b/yesod-raml.cabal --- a/yesod-raml.cabal +++ b/yesod-raml.cabal @@ -1,5 +1,5 @@ name: yesod-raml -version: 0.1.4 +version: 0.2.0 synopsis: RAML style route definitions for Yesod description: RAML style route definitions for Yesod license: MIT @@ -20,10 +20,6 @@ location: https://github.com/junjihashimoto/yesod-raml.git -flag utils - description: Build utility programs - default: False - library exposed-modules: Yesod.Raml.Type , Yesod.Raml.Parser @@ -36,41 +32,18 @@ , aeson , unordered-containers , containers + , vector , yaml , yesod-core , template-haskell , network-uri , regex-posix + , th-lift + , data-default -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall -executable raml-utils - if flag(utils) - buildable: True - else - buildable: False - main-is: raml-utils.hs - -- other-modules: - -- other-extensions: - build-depends: base ==4.* - , text - , bytestring - , aeson - , unordered-containers - , containers - , yaml - , yesod-core - , template-haskell - , optparse-applicative - , yesod-raml - , network-uri - , regex-posix - hs-source-dirs: utils - default-language: Haskell2010 - ghc-options: -Wall - - test-suite test-routes type: exitcode-stdio-1.0 main-is: RoutesSpec.hs @@ -88,5 +61,8 @@ , yesod-raml , network-uri , regex-posix + , th-lift + , vector + , data-default default-language: Haskell2010 ghc-options: -Wall