yesod-raml 0.1.4 → 0.2.0

raw patch · 9 files changed

+651/−141 lines, 9 filesdep +data-defaultdep +th-liftdep +vectordep −optparse-applicativePVP ok

version bump matches the API change (PVP)

Dependencies added: data-default, th-lift, vector

Dependencies removed: optparse-applicative

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• README.md +1/−9
• Yesod/Raml/Parser.hs +318/−39
• Yesod/Raml/Routes.hs +2/−0
• Yesod/Raml/Routes/Internal.hs +47/−11
• Yesod/Raml/Type.hs +218/−8
• tests/RoutesSpec.hs +53/−16
• utils/raml-utils.hs +0/−27
• yesod-raml.cabal +7/−31

@@ -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.

@@ -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 

@@ -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+          })+ 

@@ -3,6 +3,8 @@ module Yesod.Raml.Routes (   parseRamlRoutes , parseRamlRoutesFile+, routesFromRaml+, toYesodRoutes ) where  import Yesod.Raml.Routes.Internal

@@ -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

@@ -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) 

@@ -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'

@@ -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-  

@@ -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