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 "});"