1 {-# LANGUAGE OverloadedStrings, GADTs #-}
    2 module Databrary.Web.Routes
    3   ( -- RequestValues(..)
    4   -- , routeActionValues
    5   -- ,
    6     generateRoutesJS
    7   -- , jsRoute
    8   ) where
    9 
   10 -- import Control.Applicative ((<|>))
   11 -- import qualified Data.ByteString as BS
   12 import qualified Data.ByteString.Builder as B
   13 -- import Data.Monoid ((<>))
   14 import System.IO (withBinaryFile, IOMode(WriteMode), hPutStr, hPutStrLn, hFlush)
   15 -- import qualified Web.Route.Invertible as R
   16 -- import qualified Web.Route.Invertible.Internal as R
   17 
   18 -- import Databrary.JSON (quoteByteString)
   19 -- import Databrary.HTTP.Path
   20 -- import Databrary.HTTP.Path.JS
   21 import Databrary.Web.Types
   22 import Databrary.Web.Generate
   23 
   24 -- import {-# SOURCE #-} Databrary.Routes.JS
   25 import Databrary.Routes.JS
   26 
   27 {-
   28 data RequestValues = RequestValues
   29   { requestValuesMethod :: Maybe R.Method
   30   , requestValuesPath :: PathValues
   31   }
   32 
   33 instance Monoid RequestValues where
   34   mempty = RequestValues Nothing []
   35   mappend (RequestValues m1 p1) (RequestValues m2 p2) = RequestValues (m1 <|> m2) (p1 ++ p2)
   36 
   37 routePredicateValues :: R.RoutePredicate a -> a -> RequestValues
   38 routePredicateValues (R.RoutePath p) v = RequestValues Nothing (R.pathValues p v)
   39 routePredicateValues (R.RouteMethod m) () = RequestValues (Just m) []
   40 routePredicateValues _ _ = mempty
   41 
   42 routeActionValues :: R.RouteAction r a -> r -> RequestValues
   43 routeActionValues = R.foldRoute routePredicateValues . R.actionRoute
   44 
   45 jsRoute :: BS.ByteString -> R.RouteAction r a -> r -> B.Builder
   46 jsRoute n r v = B.char8 '\n' <> quoteByteString '"' n
   47   <> B.string8 ":{" <> foldMap (\m' -> "method:\"" <> B.byteString (R.renderParameter m') <> "\",") m
   48   <> B.string8 "route:" <> jsPath p <> B.string8 "},"
   49   where RequestValues m p = routeActionValues r v
   50 -}
   51 
   52 generateRoutesJS :: WebGenerator
   53 generateRoutesJS = staticWebGenerate $ \f ->
   54   withBinaryFile f WriteMode $ \h -> do
   55     hPutStrLn h "'use strict';"
   56     hPutStr h "app.constant('routeData',{"
   57     mapM_ (\r -> do
   58       hFlush h           -- need this
   59       B.hPutBuilder h r) -- or this hangs
   60       jsRoutes
   61     hPutStrLn h "});"