yesod-raml (empty) → 0.1.0
raw patch · 11 files changed
+633/−0 lines, 11 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, hspec, network-uri, optparse-applicative, regex-posix, template-haskell, text, unordered-containers, yaml, yesod-core, yesod-raml
Files
- ChangeLog.md +3/−0
- LICENSE +20/−0
- README.md +66/−0
- Setup.hs +2/−0
- Yesod/Raml/Parser.hs +101/−0
- Yesod/Raml/Routes.hs +8/−0
- Yesod/Raml/Routes/Internal.hs +140/−0
- Yesod/Raml/Type.hs +62/−0
- tests/RoutesSpec.hs +121/−0
- utils/raml-utils.hs +27/−0
- yesod-raml.cabal +83/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+## 0.1.0++* First Release
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Junji Hashimoto++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,66 @@+# Yesod-Raml: ++[](https://hackage.haskell.org/package/yesod-raml) [](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++## Usage++Use parseRamlRoutes or parseRamlRoutesFile in instead of parseRoutes or parseRoutesFile.++Write RAML with ```handler```-tag for Yesod Handler.++```handler```-tag is not a tag of RAML spec but original one.++You can use ```description```-tag with ```handler: <<handler-name>>``` instead of ```handler```-tag.++Bracket variable(PathPiece) like ```{hogehoge}``` is capitalized.+The variable becomes ```#Hogehoge```.+because variable(PathPiece) of yesod-routes is data-type like String or Text.++Examples are below.++```+type Userid = String++mkYesod "App" [parseRamlRoutes|+#%RAML 0.8+title: Hoge API+baseUri: 'https://hoge/api/{version}'+version: v1+protocols: [ HTTPS ]+/user:+ /{userid}:+# handler tag is used.+ handler: HogeR+ get:+ description: Get user list+ /del:+# handler is written in description-tag+ description: |+ handler: Hoge2R+ post:+ description: Delete user+|]+```++This is the same as following codes.++As you can see, ```{userid}``` becomes ```#Userid```.++```+type Userid = String++mkYesod "App" [parseRoutes|+/user/#Userid HogeR GET+/user/#Userid/del Hoge2R POST+|]+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Yesod/Raml/Parser.hs view
@@ -0,0 +1,101 @@+{-#LANGUAGE OverloadedStrings#-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Yesod.Raml.Parser () 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 Yesod.Raml.Type+++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++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+++toMethod :: Object -> Parser (Map Text RamlMethod)+toMethod hashmap = do+ let methods = filter (\(k,_) -> elem k ["get","post","delete","put",+ "GET","POST","DELETE","PUT"+ ]+ ) (HM.toList hashmap)+ list <- forM methods $ \(k,v) -> do+ val <- parseJSON v :: Parser RamlMethod+ return (k,val)+ return $ M.fromList list+++toResource :: HashMap Text Value -> Parser (Map Text RamlResource)+toResource hashmap = do+ let rs = filter (\(k,_) -> T.isPrefixOf "/" k) (HM.toList hashmap)+ list <- forM rs $ \(k,v) -> do+ val <- parseJSON v :: Parser RamlResource+ return (k,val)+ return $ M.fromList list++instance FromJSON RamlResponseBody where+ parseJSON (Object obj) = RamlResponseBody+ <$> obj .:? "schema"+ <*> obj .:? "example"+ parseJSON m = fail $ "Can not parse:" ++ show m++instance FromJSON RamlResponse where+ parseJSON (Object obj) = RamlResponse+ <$> obj .:? "description"+ <*> toResponseBody obj+ parseJSON m = fail $ "Can not parse:" ++ 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++instance FromJSON RamlResource where+ parseJSON (Object obj) = RamlResource+ <$> obj .:? "displayName"+ <*> obj .:? "description"+ <*> obj .:? "handler"+ <*> toMethod obj+ <*> toResource obj+ parseJSON m = fail $ "Can not parse:" ++ show m++instance FromJSON RamlDocumentation where+ parseJSON (Object obj) = RamlDocumentation+ <$> obj .: "title"+ <*> obj .: "content"+ parseJSON m = fail $ "Can not parse:" ++ show m+++instance FromJSON Raml where+ parseJSON (Object obj) = Raml <$> obj .: "title"+ <*> obj .: "version"+ <*> obj .: "baseUri"+ <*> obj .:? "documentation"+ <*> toResource obj+ parseJSON m = fail $ "Can not parse:" ++ show m+
+ Yesod/Raml/Routes.hs view
@@ -0,0 +1,8 @@+{-#LANGUAGE OverloadedStrings#-}++module Yesod.Raml.Routes (+ parseRamlRoutes+, parseRamlRoutesFile+) where++import Yesod.Raml.Routes.Internal
+ Yesod/Raml/Routes/Internal.hs view
@@ -0,0 +1,140 @@+{-#LANGUAGE OverloadedStrings#-}++module Yesod.Raml.Routes.Internal where++import Control.Applicative+import Control.Monad+import qualified Data.Yaml as Y+import qualified Data.Yaml.Include as YI+import qualified Data.ByteString.Char8 as B+import qualified Data.Text as T+import qualified Data.Char as C+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import Yesod.Raml.Type+import Yesod.Raml.Parser()++import Text.Regex.Posix hiding (empty)+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote++import Yesod.Routes.TH.Types+import Network.URI++routesFromRaml :: Raml -> Either String [RamlRoute]+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]+ return $ concat v+ where+ parsePath uri = fmap T.pack $ fmap uriPath $ parseURI (T.unpack uri)++routesFromRamlResource :: RamlResource -> [Path] -> Either String [RamlRoute]+routesFromRamlResource raml paths' = do+ rrlist <- forM (M.toList (r_paths raml)) $ \(k,v) -> do+ routesFromRamlResource v (paths' ++ [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+ Left err -> do+ case rrlist of+ [] -> Left err+ _ -> return rlist+ +toHandler :: Maybe HandlerHint -> RamlResource -> Either String Handler+toHandler mhint ramlMethod =+ (fromHandlerTag ramlMethod) <|>+ (fromDescription (fromMaybe "handler: *(.*)" mhint) ramlMethod)+ where+ fromHandlerTag :: RamlResource -> Either String Handler+ fromHandlerTag ramlMethod' = do+ handler <- case r_handler ramlMethod' of+ Nothing -> Left "handler of method is empty"+ (Just desc') -> return desc'+ return handler+ fromRegex :: T.Text -> T.Text -> Maybe T.Text+ fromRegex pattern str =+ let v = (T.unpack str) =~ (T.unpack pattern) :: (String,String,String,[String])+ in case v of+ (_,_,_,[]) -> Nothing+ (_,_,_,h:_) -> Just $ T.pack h+ fromDescription :: HandlerHint -> RamlResource -> Either String Handler+ fromDescription hint ramlMethod' = do+ desc <- case r_description ramlMethod' of+ Nothing -> Left "Description of method is empty"+ (Just desc') -> return desc'+ case (foldr (<|>) empty $ map (fromRegex hint) $ T.lines $ desc) of+ Nothing -> Left "Can not find Handler"+ Just handler -> return handler++toYesodResource :: RamlRoute -> Resource String+toYesodResource route =+ Resource {+ resourceName = T.unpack (rr_handler route)+ , resourcePieces = toPieces (rr_pieces route)+ , resourceDispatch =+ Methods {+ methodsMulti = Nothing+ , methodsMethods = map (T.unpack.T.toUpper) (rr_methods route)+ }+ , resourceAttrs = []+ , resourceCheck = True+ }++toRoutesFromString :: String -> [ResourceTree String]+toRoutesFromString ramlStr =+ let eRaml = Y.decodeEither (B.pack ramlStr) :: Either String Raml+ raml = case eRaml of+ Right v -> v+ Left e -> error $ "Invalid raml :" ++ e+ routes = case (routesFromRaml raml) of+ Right v -> v+ Left e -> error $ "Invalid resource : " ++ e+ in map ResourceLeaf $ map toYesodResource routes++toRoutesFromFile :: String -> IO [ResourceTree String]+toRoutesFromFile file = do+ eRaml <- YI.decodeFileEither file+ let raml = case eRaml of+ Right v -> v+ Left e -> error $ "Invalid raml :" ++ show e+ routes = case (routesFromRaml raml) of+ Right v -> v+ Left e -> error $ "Invalid resource : " ++ e+ return $ map ResourceLeaf $ map toYesodResource routes+++capitalize :: String -> String+capitalize [] = []+capitalize (h:str) = C.toUpper h:str++toPiece :: T.Text -> Piece String+toPiece str | T.isPrefixOf "/{" str && T.isSuffixOf "}" str= Dynamic $ capitalize $ T.unpack $ T.takeWhile (/= '}') $ T.tail $ T.dropWhile (/= '{') str+ | T.isPrefixOf "/" str = Static $ T.unpack $ T.tail str+ | otherwise = error "Prefix is not '/'."++toPieces :: [Path] -> [Piece String]+toPieces paths' = map toPiece paths'+++parseRamlRoutes :: QuasiQuoter+parseRamlRoutes = QuasiQuoter+ { quoteExp = lift . toRoutesFromString+ , quotePat = undefined+ , quoteType = undefined+ , quoteDec = undefined + }++parseRamlRoutesFile :: FilePath -> Q Exp+parseRamlRoutesFile file = do+ qAddDependentFile file+ s <- qRunIO $ toRoutesFromFile file+ lift s+
+ Yesod/Raml/Type.hs view
@@ -0,0 +1,62 @@+{-#LANGUAGE OverloadedStrings#-}++module Yesod.Raml.Type where++import Data.Text (Text)+import Data.Map (Map)++type HandlerHint = Text+type Handler = Text+type Path = Text+type Method = Text+type ResponseCode = Text+type ContentType = Text++data RamlResponseBody =+ RamlResponseBody {+ res_schema :: Maybe Text+ , res_example :: Maybe Text+ } deriving (Show,Eq,Ord)++data RamlResponse =+ RamlResponse {+ res_description :: Maybe Text+ , res_body :: Map ContentType RamlResponseBody+ } deriving (Show,Eq,Ord)++data RamlMethod =+ RamlMethod {+ m_responses :: Map ResponseCode RamlResponse+ } deriving (Show,Eq,Ord)++data RamlResource =+ RamlResource {+ r_displayName :: Maybe Text+ , r_description :: Maybe Text+ , r_handler :: Maybe Handler+ , r_methods :: Map Method RamlMethod+ , r_paths :: Map Path RamlResource+ } deriving (Show,Eq,Ord)++data RamlDocumentation = + RamlDocumentation {+ doc_title :: Text+ , doc_content :: Text+ } deriving (Show,Eq,Ord)++data Raml =+ Raml {+ title :: Text+ , version :: Text+ , baseUri :: Text+ , documentation :: Maybe [RamlDocumentation]+ , paths :: Map Path RamlResource+ } deriving (Show,Eq,Ord)++data RamlRoute =+ RamlRoute {+ rr_pieces :: [Path]+ , rr_handler :: Text+ , rr_methods :: [Method]+ } deriving (Show,Eq,Ord)+
+ tests/RoutesSpec.hs view
@@ -0,0 +1,121 @@+{-# 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 #-}+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)+deriving instance Eq (Resource String)+deriving instance Eq (ResourceTree String)+deriving instance Show (ResourceTree String)+++routea :: [ResourceTree String]+routea = [parseRamlRoutes|+#%RAML 0.8+title: Hoge API+baseUri: 'https://hoge/api/{version}'+version: v1+protocols: [ HTTPS ]+/user:+ /{String}:+ handler: HogeR+ get:+ description: hoger+ post:+ description: hoger+ /del:+ handler: Hoge2R+ post:+ description: hoger+|]++type Userid = String++routea' :: [ResourceTree String]+routea' = [parseRamlRoutes|+#%RAML 0.8+title: Hoge API+baseUri: 'https://hoge/api/{version}'+version: v1+protocols: [ HTTPS ]+/user:+ /{userid}:+ description: |+ handler:HogeR+ get:+ description: hoger+ /del:+ handler: Hoge2R+ post:+ description: hoger+|]++routeb = [parseRoutes|+/api/v1/user/#String HogeR GET POST+/api/v1/user/#String/del Hoge2R POST+|]++routeb' = [parseRoutes|+/api/v1/user/#Userid HogeR GET+/api/v1/user/#Userid/del Hoge2R POST+|]+++main :: IO ()+main = hspec $ do+ describe "handler" $ do+ it "parse handler from description" $ do+ toHandler Nothing+ (RamlResource {+ r_displayName = Nothing+ , r_description = Just "handler: hogehoge\n"+ , r_handler = Nothing+ , r_methods = M.fromList [("GET",RamlMethod M.empty)]+ , r_paths = M.empty+ } ) `shouldBe` Right "hogehoge"+ it "parse handler from description" $ do+ toHandler Nothing+ (RamlResource {+ r_displayName = Nothing+ , r_description = Just "burabura\nhandler: hogehoge\n"+ , r_handler = Nothing+ , r_methods = M.fromList [("GET",RamlMethod M.empty)]+ , r_paths = M.empty+ } ) `shouldBe` Right "hogehoge"+ it "parse handler from handler" $ do+ toHandler Nothing+ (RamlResource {+ r_displayName = Nothing+ , r_description = Just "handler: hogehoge\n"+ , r_handler = Just "hoge"+ , r_methods = M.fromList [("GET",RamlMethod M.empty)]+ , r_paths = M.empty+ } ) `shouldBe` Right "hoge"+ describe "resource tree" $ do+ it "parseRamlRoutes from handler" $ do+ routea `shouldBe` routeb+ it "parseRamlRoutes from description" $ do+ routea' `shouldBe` routeb'+ it "parseRamlRoutesFile" $ do+ $(parseRamlRoutesFile "tests/test.raml") `shouldBe` routeb'
+ utils/raml-utils.hs view
@@ -0,0 +1,27 @@+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+
+ yesod-raml.cabal view
@@ -0,0 +1,83 @@+name: yesod-raml+version: 0.1.0+synopsis: RAML style route definitions for Yesod+description: RAML style route definitions for Yesod+license: MIT+license-file: LICENSE+author: Junji Hashimoto+maintainer: junji.hashimoto@gmail.com+category: Web, Yesod+build-type: Simple+cabal-version: >=1.10+extra-source-files: ChangeLog.md README.md++flag utils+ description: Build utility programs+ default: False++library+ exposed-modules: Yesod.Raml.Type+ , Yesod.Raml.Parser+ , Yesod.Raml.Routes+ other-modules: Yesod.Raml.Routes.Internal+ -- other-extensions: + build-depends: base ==4.*+ , text+ , bytestring+ , aeson+ , unordered-containers+ , containers+ , yaml+ , yesod-core+ , template-haskell+ , network-uri+ , regex-posix+ -- 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+ hs-source-dirs: tests, .+ build-depends: base ==4.*+ , text+ , bytestring+ , aeson+ , unordered-containers+ , containers+ , yaml+ , yesod-core+ , template-haskell+ , hspec+ , yesod-raml+ , network-uri+ , regex-posix+ default-language: Haskell2010+ ghc-options: -Wall