Generate JavaScript routes for Yesod.

JSRoutes.hs

{-
    To use this module, import it in Foundation and make your App an instance of JSRoutable -

        instance JSRoutable App where
            jsRoutes = jsRoutesBuilder resourcesApp

    You will want to add the following line to your routes file -

        /jsRoutes JSRoutesR GET

    Then add JSRoutesR to the default layout in Foundation -

        instance Yesod App where
            ...
            defaultLayout widget = do
                ...
                pc <- widgetToPageContent $ do
                    ...
                    addScript JSRoutesR

    You will also need to import this module in Application since it defines getJSRoutesR for you.
-}
module Handler.JSRoutes where

import ClassyPrelude.Yesod hiding (Static)
import Yesod.Routes.TH.Types

class JSRoutable a where
    jsRoutes :: a -> Text

getJSRoutesR :: JSRoutable a => HandlerT a IO TypedContent
getJSRoutesR = fmap (TypedContent "text/javascript" . toContent . jsRoutes) ask

jsRoutesBuilder :: [ResourceTree String] -> b -> Text
jsRoutesBuilder = const . buildJSRoutes

buildJSRoutes :: [ResourceTree String] -> Text
buildJSRoutes resourcesApp = sep <> var <> sep <> intercalate sep resources <> sep
  where
    prefix = "jsRoutes"
    resources = map (buildResource prefix) resourcesApp
    var = "var " <> prefix <> "={}"
    sep = ";"

buildResource :: Text -> ResourceTree String -> Text
buildResource prefix (ResourceLeaf (Resource{resourceDispatch=Methods{..}, ..})) =
    prefix <> "." <> pack resourceName <> "={" <> resource <> "}"
  where
    sep = ","
    resource = intercalate sep (map (buildMethod resourcePieces) methodsMethods)

-- TODO: Handle subsites and parents, possibly with Yesod.Routes.TH.Types.flatten?
buildResource _ (ResourceLeaf (Resource{resourceDispatch=Subsite{..}, ..})) = "/* Subsite not supported */"
buildResource _ ResourceParent{} = "/* ResourceParent not supported */"

buildMethod :: [Piece String] -> String -> Text
buildMethod pieces methodName = method <> ":function(){return {method:\"" <> method <> "\",url:\"" <> buildUrl pieces <> "\"};}"
  where
    method = pack . toLower $ methodName

buildUrl :: [Piece String] -> Text
buildUrl = snd . foldl' action (0 :: Int, "")
  where
    sep = "/"
    action (counter, t) piece = case piece of
        Static s -> (counter, t <> sep <> pack s)
        Dynamic _ -> (counter + 1, t <> sep <> "\"+arguments[" <> (pack . show) counter <> "]+\"")