JSRoutes.hs

{-# LANGUAGE FlexibleInstances #-}
module Handler.JSRoutes where

import Import
import qualified Data.Text as T
import Database.Persist.Sql (toSqlKey)
import Control.Monad.Random

jsRoutes :: (MonadRandom m, Applicative m) => [m Text]
jsRoutes =
    [ makeJSRoute HomeR
    , makeJSRoute RulesR
    , makeJSRoute RuleR
    ]
--     [ renderAsJS $ pure HomeR
--     , renderAsJS $ pure RulesR
--     , renderAsJS $ RuleR <$> fakeId
--     ]


class JSRoute a where
    makeJSRoute :: (Applicative m, MonadRandom m) => a -> m Text

instance JSRoute (Route App) where
    makeJSRoute route = do
        r <- renderAsJS $ pure route
        let name = ripRouteName route
        let t = pack . show $ r
        return $ "jsRoutes." <> name <> " = function(){return " <> t <> ";};"

instance (ToBackendKey SqlBackend r) => JSRoute (Key r -> Route App) where
    makeJSRoute f = do
        i <- getRandomR (111, 999)
        let k = toSqlKey i
        let route = f k
        let name = ripRouteName route
        r <- renderAsJS $ pure route
        let t1 = pack . show $ r
        let t2 = T.replace (T.pack $ show i) "\" + x + \"" t1
        return $ "jsRoutes." <> name <> " = function(x){return " <> t2 <> ";};"

getJSRoutesR :: Handler Html
getJSRoutesR = do
    result <- evalRandT (sequence jsRoutes) =<< lift newStdGen
    let js = initialJS <> concat result
    sendResponseStatus ok200 js

initialJS :: Text
initialJS = "var jsRoutes = jsRoutes || {};"

ripRouteName :: Route App -> Text
ripRouteName = pack . fromMaybe "_error" . listToMaybe . words . show

renderAsJS :: (RenderRoute a, Functor m, Monad m) => m (Route a) -> m Text
renderAsJS route = do
    (pieces, _) <- fmap renderRoute route
    return $ "/" <> intercalate "/" pieces

fakeId :: (MonadRandom f, ToBackendKey SqlBackend record, Functor f) => f (Key record)
fakeId = toSqlKey <$> getRandomR (11111, 99999)