diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +The MIT License (MIT) + +Copyright (c) 2015 Front Row Education, 2014 docmunch + +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,57 @@ +yesod-routes-flow +================= + +Parse the Yesod routes data structure and generate routes that can be used in Flow. + +The routing structure is generated by: + + mkYesodDispatch "App" resourcesApp + +You can generate routes at startup inside the `makeApplication` function + + when development $ + genFlowRoutes resourcesApp "assets/ts/paths-gen.ts" + + +This generates Flow code: + + class PATHS_TYPE_paths { + contacts: PATHS_TYPE_paths_contacts; + admin: PATHS_TYPE_paths_admin; + + constructor(){ + this.contacts = new PATHS_TYPE_paths_contacts(); + this.admin = new PATHS_TYPE_paths_admin(); + } + } + + class PATHS_TYPE_paths_contacts { + get(): string { return '/api/v1/contacts/get'; } + } + + class PATHS_TYPE_paths_admin { + adminDocs: PATHS_TYPE_paths_admin_adminDocs; + + constructor(){ + this.adminDocs = new PATHS_TYPE_paths_admin_adminDocs(); + } + } + + class PATHS_TYPE_paths_admin_adminDocs { + get(): string { return '/api/v1/admin/docs/get'; } + } + + + var PATHS:PATHS_TYPE_paths = new PATHS_TYPE_paths(); + + +In your Flow code you can now do: + + + PATHS.admin.adminDocs.get() + + +Please note that the Haskell code was hastily translated from +Javascript code, then translated from TypeScript to Flow, and is +pretty horrible. There are bugs and edge cases to be addressed, +but this works ok for us. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Yesod/Routes/Flow/Generator.hs b/Yesod/Routes/Flow/Generator.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/Flow/Generator.hs @@ -0,0 +1,148 @@ +module Yesod.Routes.Flow.Generator + ( genFlowRoutesPrefix + , genFlowRoutes + ) where + +import ClassyPrelude +import Data.List (nubBy) +import Data.Function (on) +import Data.Text (dropWhileEnd) +import qualified Data.Text as DT +import Filesystem (createTree) +import qualified Data.Char as DC +import Yesod.Routes.TH.Types + -- ( ResourceTree(..), + -- Piece(Dynamic, Static), + -- FlatResource, + -- Resource(resourceDispatch, resourceName, resourcePieces), + -- Dispatch(Methods, Subsite) ) + + +genFlowRoutes :: [ResourceTree String] -> FilePath -> IO () +genFlowRoutes ra fp = genFlowRoutesPrefix [] [] ra fp "''" + +genFlowRoutesPrefix :: [String] -> [String] -> [ResourceTree String] -> FilePath -> Text -> IO () +genFlowRoutesPrefix routePrefixes elidedPrefixes resourcesApp fp prefix = do + createTree $ directory fp + writeFile fp routesCs + where + routesCs = + let res = (resToCoffeeString Nothing "" $ ResourceParent "paths" False [] hackedTree) + in "/* @flow */\n" <> + either id id (snd res) + <> "\nvar PATHS: PATHS_TYPE_paths = new PATHS_TYPE_paths("<>prefix<>");\n" + + -- route hackery.. + fullTree = resourcesApp :: [ResourceTree String] + landingRoutes = flip filter fullTree $ \case + ResourceParent _ _ _ _ -> False + ResourceLeaf res -> not $ elem (resourceName res) ["AuthR", "StaticR"] + + parentName :: ResourceTree String -> String -> Bool + parentName (ResourceParent n _ _ _) name = n == name + parentName _ _ = False + + parents = + -- if routePrefixes is empty, include all routes + filter (\n -> routePrefixes == [] || any (parentName n) routePrefixes) fullTree + hackedTree = ResourceParent "staticPages" False [] landingRoutes : parents + cleanName = underscorize . uncapitalize . dropWhileEnd DC.isUpper + where uncapitalize t = (toLower $ take 1 t) <> drop 1 t + underscorize = DT.pack . go . DT.unpack + where go (c:cs) | DC.isUpper c = '_' : DC.toLower c : go cs + | otherwise = c : go cs + go [] = [] + + renderRoutePieces pieces = intercalate "/" $ map renderRoutePiece pieces + renderRoutePiece p = case p of + Static st -> pack st :: Text + Dynamic "Text" -> ": string" + Dynamic "Int" -> ": number" + Dynamic d -> ": string" + isVariable r = length r > 1 && DT.head r == ':' + resRoute res = renderRoutePieces $ resourcePieces res + resName res = cleanName . pack $ resourceName res + fullName res = intercalate "_" [pack st :: Text | Static st <- resourcePieces res] + singleSlash = DT.replace "//" "/" + resToCoffeeString :: Maybe Text -> Text -> ResourceTree String -> ([(Text, Text)], Either Text Text) + resToCoffeeString parent routePrefix (ResourceLeaf res) = + let rname = resName res in + -- previously assumed there weren't multiple methods per route path + -- now hacking in support + let jsNames = case resourceDispatch res of + Subsite _ _ -> [] -- silently ignore subsites + Methods _ [] -> error "no methods! (never here, check hasMethods)" + Methods _ methods -> + let resName = DT.replace "." "" $ DT.replace "-" "_" $ fullName res + prefix = if resName == "" then "" else resName <> "_" + -- we basically never will want to refer to OPTIONS + -- routes directly + callableMeths = filter (\a -> a /= "OPTIONS") methods in + if length callableMeths > 1 || resName == "" + then map ((prefix <>) . toLower . pack) callableMeths + else [resName] + in ([], Right $ intercalate "\n" $ map mkLine jsNames) + where + pieces = DT.splitOn "/" routeString + variables = snd $ foldl' (\(i,prev) typ -> (i+1, prev <> [("a" <> tshow i, typ)])) + (0::Int, []) + (filter isVariable pieces) + mkLine jsName = " " <> jsName <> "(" + <> csvArgs variables + <> "): string { " + -- <> presenceChk + <> "return this.root + " <> quote (routeStr variables variablePieces) <> "; }" + routeStr vars ((Left p):rest) | null p = routeStr vars rest + | otherwise = "/" <> p <> routeStr vars rest + routeStr (v:vars) ((Right _):rest) = "/' + " <> fst v <> ".toString() + '" <> routeStr vars rest + routeStr [] [] = "" + routeStr _ [] = error "extra vars!" + routeStr [] _ = error "no more vars!" + + variablePieces = map (\p -> if isVariable p then Right p else Left p) pieces + csvArgs :: [(Text, Text)] -> Text + csvArgs = intercalate "," . map (\(var, typ) -> var <> typ) + quote str = "'" <> str <> "'" + routeString = singleSlash routePrefix <> resRoute res + + -- This is here because in the Flow code, we dont refer to + -- PATHS.api.doc.foo but PATHS.doc.foobar. So we can keep our route + -- organization in place but also leave Flow alone. + resToCoffeeString parent routePrefix (ResourceParent name _ pieces children) | name `elem` elidedPrefixes = + (concatMap fst res, Left $ intercalate "\n" (map (either id id . snd) res)) + where + fxn = resToCoffeeString parent (routePrefix <> "/" <> renderRoutePieces pieces <> "/") + res = map fxn children + + resToCoffeeString parent routePrefix (ResourceParent name _ pieces children) = + ([linkFromParent], Left $ resourceClassDef) + where + parentMembers f = + intercalate "\n " $ map f $ concatMap fst childFlow + memberInitFromParent (slot, klass) = " this." <> slot <> " = new " <> klass <> "(root);" + memberLinkFromParent (slot, klass) = "" <> slot <> ": " <> klass <> ";" + linkFromParent = (pref, resourceClassName) + resourceClassDef = "class " <> resourceClassName <> " {\n" + <> " " <> "root: string;\n" + <> intercalate "\n" childMembers + <> " " <> parentMembers memberLinkFromParent + <> "\n" + <> " constructor(root: string){\n" + <> " this.root = root;\n " + <> parentMembers memberInitFromParent + <> "\n }\n" + <> "}\n\n" + <> intercalate "\n" childClasses + (childClasses, childMembers) = partitionEithers $ map snd childFlow + jsName = maybe "" (<> "_") parent <> pref + childFlow = flip map (filter hasMethods children) $ resToCoffeeString + (Just jsName) + (routePrefix <> "/" <> renderRoutePieces pieces <> "/") + pref = cleanName $ pack name + resourceClassName = "PATHS_TYPE_" <> jsName + -- Silently ignore routes without methods. + hasMethods (ResourceLeaf res) = case resourceDispatch res of { Methods _ [] -> False; _ -> True} + hasMethods _ = True + +deriving instance (Show a) => Show (ResourceTree a) +deriving instance (Show a) => Show (FlatResource a) diff --git a/yesod-routes-flow.cabal b/yesod-routes-flow.cabal new file mode 100644 --- /dev/null +++ b/yesod-routes-flow.cabal @@ -0,0 +1,43 @@ +name: yesod-routes-flow +version: 1.0 +synopsis: Generate Flow routes for Yesod +description: Parse the Yesod routes data structure and generate routes that can be used with Flow. +homepage: https://github.com/frontrowed/yesod-routes-flow +license: MIT +license-file: LICENSE +author: Max Cantor, Felipe Lessa +maintainer: Greg Weber +-- copyright: +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: Yesod.Routes.Flow.Generator + -- other-modules: + -- other-extensions: + default-extensions: + ConstraintKinds, + DeriveDataTypeable, + ExtendedDefaultRules, + FlexibleContexts, + FlexibleInstances, + LambdaCase, + NoImplicitPrelude, + OverloadedStrings, + RecordWildCards, + ScopedTypeVariables, + StandaloneDeriving, + TemplateHaskell, + TupleSections, + TypeSynonymInstances + build-depends: + attoparsec, + base < 5, + classy-prelude >= 0.7, + system-fileio, + text, + yesod-core >= 1.4 && < 2.0 + -- hs-source-dirs: + default-language: Haskell2010