yesod-routes-flow (empty) → 1.0
raw patch · 5 files changed
+270/−0 lines, 5 filesdep +attoparsecdep +basedep +classy-preludesetup-changed
Dependencies added: attoparsec, base, classy-prelude, system-fileio, text, yesod-core
Files
- LICENSE +20/−0
- README.md +57/−0
- Setup.hs +2/−0
- Yesod/Routes/Flow/Generator.hs +148/−0
- yesod-routes-flow.cabal +43/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Yesod/Routes/Flow/Generator.hs view
@@ -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)
+ yesod-routes-flow.cabal view
@@ -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 <greg@frontrowed.com>+-- 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