rest-gen refactorings and extensions

rest-core/src/Rest/Driver/Perform.hs

@@ -277,7 +277,6 @@ contentType c = setHeader "Content-Type" $
     XmlFormat  -> "application/xml; charset=UTF-8"
     _          -> "text/plain; charset=UTF-8"
 
-
 validator :: forall v m e. Rest m => Outputs v -> ExceptT (Reason e) m ()
 validator = tryOutputs try
   where

rest-core/tests/Runner.hs

@@ -2,6 +2,7 @@
     OverloadedStrings
   , ScopedTypeVariables
   #-}
+module Main (main) where
 
 import Control.Applicative
 import Control.Monad
@@ -11,7 +12,7 @@ import Test.Framework (defaultMain)
 import Test.Framework.Providers.HUnit (testCase)
 import Test.HUnit (Assertion, assertEqual, assertFailure)
 
-import qualified Data.HashMap.Strict   as H
+import qualified Data.HashMap.Strict as H
 
 import Rest.Api hiding (route)
 import Rest.Dictionary
@@ -43,7 +44,8 @@ main = do
               , testCase "Root router is skipped." testRootRouter
               , testCase "Multi-PUT." testMultiPut
               , testCase "Multi-POST" testMultiPost
-              , testCase "Accept headers." testAcceptHeaders
+              , testCase "application/json accept header" testAppJsonAcceptHeader
+              , testCase "text/json accept header" testTextJsonAcceptHeader
               ]
 
 testListing :: Assertion
@@ -204,7 +206,12 @@ checkRouteSuccess method uri router =
 allMethods :: [Method]
 allMethods = [GET, PUT, POST, DELETE]
 
-testAcceptHeaders :: Assertion
-testAcceptHeaders =
+testAppJsonAcceptHeader :: Assertion
+testAppJsonAcceptHeader =
+  do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "application/json" } accept
+     assertEqual "Accept application/json format." [JsonFormat] fmt
+
+testTextJsonAcceptHeader :: Assertion
+testTextJsonAcceptHeader =
   do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "text/json" } accept
-     assertEqual "Accept json format." [JsonFormat] fmt
+     assertEqual "Accept text/json format." [JsonFormat] fmt

rest-example/generate/Main.hs

@@ -19,3 +19,4 @@ main = do
     -- these are re-exported from an internal module they can be
     -- rewritten to something more stable.
     [(ModuleName "Data.Text.Internal", ModuleName "Data.Text")]
+    (const return)

rest-gen/files/Javascript/base.js

@@ -157,7 +157,8 @@ function nodeRequest (method, url, params, onSuccess, onError, contentType, acce
 
   function parse (response)
   {
-    if (acceptHeader.split(";").indexOf('text/json') >= 0)
+    var acceptHeaders = acceptHeader.split(";");
+    if (acceptHeaders.indexOf('text/json') >= 0 || acceptHeaders.indexOf('application/json') >= 0)
     {
       var r = response;
       try

rest-gen/src/Rest/Gen.hs

@@ -1,17 +1,21 @@
 module Rest.Gen
   ( generate
+  , runGenerate
+  , generateDocs
+  , generateHaskell
+  , generateJavaScript
+  , generateRuby
+  , GenerateError (..)
+  , Result (..)
   ) where
 
 import Data.Char
-import Data.Foldable
 import Data.Label
 import Data.Maybe
-import System.Directory
 import System.Exit
-import System.Process
-import qualified Language.Haskell.Exts.Syntax as H
+import System.IO (hPutStrLn, stderr)
 
-import Rest.Api (Api, Some1 (..), withVersion)
+import Rest.Api (Api, Router, Some1 (..), Version, withVersion)
 
 import Rest.Gen.Config
 import Rest.Gen.Docs (DocsContext (DocsContext), writeDocs)
@@ -20,51 +24,106 @@ import Rest.Gen.JavaScript (mkJsApi)
 import Rest.Gen.Ruby (mkRbApi)
 import Rest.Gen.Types
 import Rest.Gen.Utils
+import qualified Rest.Gen.Docs    as DCtx (DocsContext (..))
+import qualified Rest.Gen.Haskell as HCtx (HaskellContext (..))
 
-generate :: Config -> String -> Api m -> [H.ModuleName] -> [H.ImportDecl] -> [(H.ModuleName, H.ModuleName)] -> IO ()
-generate config name api sources imports rewrites =
-  withVersion (get apiVersion config) api (putStrLn "Could not find api version" >> exitFailure) $ \ver (Some1 r) ->
-     case get action config of
-       Just (MakeDocs root) ->
-         do loc <- getTargetDir config "./docs"
-            setupTargetDir config loc
-            let context = DocsContext root ver (fromMaybe "./templates" (getSourceLocation config))
-            writeDocs context r loc
-            exitSuccess
-       Just MakeJS          -> mkJsApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r >>= toTarget config
-       Just MakeRb          -> mkRbApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r >>= toTarget config
-       Just MakeHS          ->
-         do loc <- getTargetDir config "./client"
-            setupTargetDir config loc
-            let context = HaskellContext ver loc (packageName ++ "-client") (get apiPrivate config) sources imports rewrites [unModuleName moduleName, "Client"]
-            mkHsApi context r
-            exitSuccess
-       Nothing              -> return ()
+data GenerateError
+  = CouldNotFindApiVersion
+  | NoOp
+  deriving (Eq, Show)
+
+data Result
+  = Error GenerateError
+  | StdOut String
+  | FileOut FilePath
+  deriving (Eq, Show)
+
+data FileType
+  = HaskellFile
+  | JavaScriptFile
+  | RubyFile
+  | HtmlFile
+
+generate :: Config -> String -> Api m -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> (FileType -> String -> IO String) -> IO ()
+generate config name api sources imports rewrites postProc = do
+  res <- runGenerate config name api sources imports rewrites postProc
+  case res of
+    Error err -> do
+      case err of
+        CouldNotFindApiVersion -> hPutStrLn stderr "Could not find specified API version"
+        NoOp                   -> hPutStrLn stderr "Nothing to do"
+      exitFailure
+    _          -> exitSuccess
+
+runGenerate :: Config -> String -> Api m -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> (FileType -> String -> IO String) -> IO Result
+runGenerate config name api sources imports rewrites postProc =
+  withVersion (get apiVersion config) api (return $ Error CouldNotFindApiVersion) m
   where
+    m :: Version -> Some1 (Router m) -> IO Result
+    m ver (Some1 r) = case get action config of
+      Just (MakeDocs root) -> generateDocs       config ver r (postProc HtmlFile      ) root
+      Just MakeJS          -> generateJavaScript config ver r (postProc JavaScriptFile) moduleName
+      Just MakeRb          -> generateRuby       config ver r (postProc RubyFile      ) moduleName
+      Just MakeHS          -> generateHaskell    config ver r (postProc HaskellFile   ) moduleName packageName sources imports rewrites
+      Nothing              -> return $ Error NoOp
     packageName = map toLower name
-    moduleName  = H.ModuleName $ upFirst packageName
+    moduleName  = ModuleName $ upFirst packageName
+
+generateJavaScript :: Config -> Version -> Router m s -> (String -> IO String) -> ModuleName -> IO Result
+generateJavaScript config ver r postProc moduleName = do
+  file <- postProc =<< mkJsApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
+  toTarget config file
+
+generateRuby ::  Config -> Version -> Router m s -> (String -> IO String) -> ModuleName -> IO Result
+generateRuby config ver r postProc moduleName = do
+  file <- postProc =<< mkRbApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
+  toTarget config file
+
+generateDocs :: Config -> Version -> Router m s -> (String -> IO String) -> String -> IO Result
+generateDocs config ver r postProc rootUrl = do
+  targetDir <- getTargetDir config "./docs"
+  writeDocs (getSourceLocation config) targetDir context postProc r
+  return $ FileOut targetDir
+    where
+      context = DocsContext
+        { DCtx.rootUrl        = rootUrl
+        , DCtx.contextVersion = ver
+        , DCtx.templates      = "./templates" `fromMaybe` getSourceLocation config
+        }
+
+generateHaskell :: Config -> Version -> Router m s -> (String -> IO String) -> ModuleName -> String -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO Result
+generateHaskell config ver r postProc moduleName packageName sources imports rewrites = do
+  targetPath <- getTargetDir config "./client"
+  mkHsApi (context targetPath (getSourceLocation config)) postProc r
+  return $ FileOut targetPath
+  where
+    context tp sourceDir = HaskellContext
+      { HCtx.apiVersion     = ver
+      , HCtx.targetPath     = tp
+      , HCtx.wrapperName    = packageName ++ "-client"
+      , HCtx.includePrivate = get apiPrivate config
+      , HCtx.sources        = sources
+      , HCtx.imports        = imports
+      , HCtx.rewrites       = rewrites
+      , HCtx.namespace      = [unModuleName moduleName, "Client"]
+      , HCtx.sourceDir      = sourceDir
+      }
 
 getTargetDir :: Config -> String -> IO String
 getTargetDir config str =
   case get target config of
-    Stream     -> putStrLn ("Cannot generate documentation to stdOut, generating to " ++ str) >> return str
-    Default    -> putStrLn ("Generating to " ++ str) >> return str
-    Location d -> putStrLn ("Generating to " ++ d) >> return d
+    Stream     -> putStrLn ("Cannot generate file tree to stdOut, generating to " ++ str) >> return str
+    Default    -> putStrLn ("Generating to " ++ str)                                      >> return str
+    Location d -> putStrLn ("Generating to " ++ d)                                        >> return d
 
-setupTargetDir :: Config -> String -> IO ()
-setupTargetDir config t =
-  do createDirectoryIfMissing True t
-     forM_ (getSourceLocation config) $ \s -> system $ "cp -rf " ++ s ++ " " ++ t
-
-toTarget :: Config -> String -> IO ()
-toTarget config code =
-  do let outf =
-           case get target config of
-             Stream     -> putStrLn
-             Default    -> putStrLn
-             Location l -> writeFile l
-     outf code
-     exitSuccess
+toTarget :: Config -> String -> IO Result
+toTarget config code = do
+  outf code
+  where
+    outf cd = case get target config of
+      Stream     -> putStrLn cd    >> return (StdOut cd)
+      Default    -> putStrLn cd    >> return (StdOut cd)
+      Location l -> writeFile l cd >> return (FileOut l)
 
 getSourceLocation :: Config -> Maybe String
 getSourceLocation config =

rest-gen/src/Rest/Gen/Base/ActionInfo.hs

@@ -12,7 +12,12 @@ module Rest.Gen.Base.ActionInfo
   , ActionInfo (..)
   , ActionType (..)
   , ActionTarget (..)
+
   , DataType (..)
+  , dataTypesToAcceptHeader
+  , dataTypeToAcceptHeader
+  , dataTypeString
+
   , ResourceId
   , accessLink
   , accessors
@@ -34,7 +39,6 @@ module Rest.Gen.Base.ActionInfo
 
   , ResponseType (..)
   , responseAcceptType
-  , dataTypesToAcceptHeader
   , chooseResponseType
 
   , isAccessor
@@ -98,7 +102,34 @@ data ActionType = Retrieve | Create | Delete | DeleteMany | List | Update | Upda
 
 data ActionTarget = Self | Any deriving (Show, Eq)
 
-data DataType = String | XML | JSON | File | Other deriving (Show, Eq)
+data DataType = String | XML | JSON | File | Other
+  deriving (Show, Eq)
+
+dataTypeString :: DataType -> String
+dataTypeString = \case
+    String -> "text"
+    XML    -> "xml"
+    JSON   -> "json"
+    File   -> "file"
+    Other  -> "text"
+
+-- | First argument is the default accept header to use if there is no
+-- output or errors, must be XML or JSON.
+dataTypesToAcceptHeader :: DataType -> [DataType] -> String
+dataTypesToAcceptHeader def = \case
+  [] -> dataTypeToAcceptHeader def
+  xs -> intercalate "," . map dataTypeToAcceptHeader . (xs ++) $
+          if null (intersect xs [XML,JSON])
+            then [def]
+            else []
+
+dataTypeToAcceptHeader :: DataType -> String
+dataTypeToAcceptHeader = \case
+  String -> "text/plain"
+  XML    -> "text/xml"
+  JSON   -> "application/json"
+  File   -> "application/octet-stream"
+  Other  -> "text/plain"
 
 -- | Core information about the type of the input/output
 data DataDesc = DataDesc
@@ -176,24 +207,6 @@ responseAcceptType (ResponseType e o) = typs
         f :: Maybe DataDesc -> [DataType]
         f = maybeToList . fmap (L.get dataType)
 
--- | First argument is the default accept header to use if there is no
--- output or errors, must be XML or JSON.
-dataTypesToAcceptHeader :: DataType -> [DataType] -> String
-dataTypesToAcceptHeader def = \case
-  [] -> dataTypeToAcceptHeader def
-  xs -> intercalate "," . map dataTypeToAcceptHeader . (xs ++) $
-          if null (intersect xs [XML,JSON])
-            then [def]
-            else []
-
-dataTypeToAcceptHeader :: DataType -> String
-dataTypeToAcceptHeader = \case
-  String -> "text/plain"
-  XML    -> "text/xml"
-  JSON   -> "text/json"
-  File   -> "application/octet-stream"
-  Other  -> "text/plain"
-
 chooseResponseType :: ActionInfo -> ResponseType
 chooseResponseType ai = case (NList.nonEmpty $ outputs ai, NList.nonEmpty $ errors ai) of
   -- No outputs or errors defined

rest-gen/src/Rest/Gen/Docs.hs

@@ -31,9 +31,8 @@ import Data.List hiding (head, span)
 import Data.String
 import System.Directory
 import System.FilePath
-import Text.Blaze.Html
-import Text.Blaze.Html5 hiding (map, meta, style)
-import Text.Blaze.Html5.Attributes hiding (method, span, title)
+import Text.Blaze.Html5 hiding (contents, map, meta, style)
+import Text.Blaze.Html5.Attributes hiding (dir, method, span, title)
 import Text.Blaze.Html.Renderer.String
 import Text.StringTemplate
 import qualified Data.Label.Total as L
@@ -49,18 +48,22 @@ data DocsContext = DocsContext
   , templates      :: String
   } deriving (Eq, Show)
 
-writeDocs :: DocsContext -> Router m s -> String -> IO ()
-writeDocs context router loc =
-  do createDirectoryIfMissing True loc
-     let tree = apiSubtrees router
-     mkAllResources context tree >>= writeFile (loc </> "index.html")
-     mapM_ (writeSingleResource context loc) $ allSubResources tree
-
-writeSingleResource :: DocsContext -> String -> ApiResource -> IO ()
-writeSingleResource ctx loc r =
-  do let dr = loc </> intercalate "/" (resId r)
-     createDirectoryIfMissing True dr
-     mkSingleResource ctx r >>= writeFile (dr </> "index.html")
+writeDocs :: Maybe FilePath -> FilePath -> DocsContext -> (String -> IO String) -> Router m s -> IO ()
+writeDocs sourceDir targetDir ctx postProc router = do
+  setupTargetDir sourceDir targetDir
+  let tree = apiSubtrees router
+  mkAllResources ctx tree >>= postProc >>= writeIndex targetDir
+  forM_ (allSubResources tree) $ writeSingleResource targetDir ctx postProc
+
+writeSingleResource :: FilePath -> DocsContext -> (String -> IO String) -> ApiResource -> IO ()
+writeSingleResource targetDir ctx postProc r = do
+  let dir = targetDir </> intercalate "/" (resId r)
+  mkSingleResource ctx r >>= postProc >>= writeIndex dir
+
+writeIndex :: FilePath -> String -> IO ()
+writeIndex dir contents = do
+  createDirectoryIfMissing True dir
+  writeFile (dir </> "index.html") contents
 
 mkAllResources :: DocsContext -> ApiResource -> IO String
 mkAllResources ctx tree =