diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog +## 0.11 + +* Bugfix: Haskell: Resources without a getter now generate identifier arguments for other end points +* Shuffles some internal (but exposed) functions around + #### 0.10.0.4 * Drops `aeson-utils` dependency in favor of `scientific >= 0.3.2` diff --git a/rest-gen.cabal b/rest-gen.cabal --- a/rest-gen.cabal +++ b/rest-gen.cabal @@ -1,5 +1,5 @@ name: rest-gen -version: 0.10.0.4 +version: 0.11 description: Documentation and client generation from rest definition. synopsis: Documentation and client generation from rest definition. maintainer: code@silk.co diff --git a/src/Rest/Gen/Base/ActionInfo.hs b/src/Rest/Gen/Base/ActionInfo.hs --- a/src/Rest/Gen/Base/ActionInfo.hs +++ b/src/Rest/Gen/Base/ActionInfo.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE GADTs, CPP, ScopedTypeVariables #-} +{-# LANGUAGE + CPP + , GADTs + , ScopedTypeVariables + #-} module Rest.Gen.Base.ActionInfo where import Prelude hiding (id, (.)) @@ -14,17 +18,18 @@ #if __GLASGOW_HASKELL__ < 704 import Data.List.Split #endif -import Rest.Gen.Base.ActionInfo.Ident (Ident (Ident)) +import Rest.Gen.Base.ActionInfo.Ident (Ident (Ident), description) import Rest.Info import qualified Data.JSON.Schema as J import qualified Data.Label.Total as L import qualified Rest.Gen.Base.JSON as J import qualified Rest.Gen.Base.XML as X -import Rest.Dictionary (Param (..), Input (..), Output (..), Error (..)) +import Rest.Dictionary (Error (..), Input (..), Output (..), Param (..)) import Rest.Driver.Routing (mkListHandler, mkMultiHandler) +import Rest.Gen.Base.Link import Rest.Handler -import Rest.Resource +import Rest.Resource hiding (description) import Rest.Schema import qualified Rest.Dictionary as Dict @@ -56,6 +61,7 @@ , errors :: [DataDescription] , params :: [String] , https :: Bool + , link :: Link } deriving (Show, Eq) isAccessor :: ActionInfo -> Bool @@ -89,10 +95,37 @@ Schema mTopLevel step -> foldMap (topLevelActionInfo r) mTopLevel ++ stepActionInfo r step ++ foldMap (return . createActionInfo) (Rest.create r) - ++ foldMap (return . removeActionInfo) (Rest.remove r) - ++ map (uncurry selectActionInfo) (Rest.selects r) - ++ map (uncurry actionActionInfo) (Rest.actions r) + ++ foldMap (return . removeActionInfo accLnk) (Rest.remove r) + ++ map (uncurry (selectActionInfo accLnk)) (Rest.selects r) + ++ map (uncurry (actionActionInfo accLnk)) (Rest.actions r) + where + accLnk = accessLink (accessors step) +accessLink :: [Accessor] -> Link +accessLink [] = [] +accessLink xs = [LAccess . map f $ xs] + where + f ("", x) = par x + f (pth, x) = LAction pth : par x + par = maybe [] (return . LParam . description) + +accessors :: Step sid mid aid -> [Accessor] +accessors (Named hs) = mapMaybe (uncurry accessorsNamed) hs + where + accessorsNamed pth (Right (Single g)) = Just (pth, getId g) + accessorsNamed _ _ = Nothing + getId (Singleton _) = Nothing + getId (By id_) = Just . idIdent $ id_ +accessors (Unnamed (Single id_)) = [("", Just . idIdent $ id_)] +accessors (Unnamed (Many _)) = [] + +type Accessor = (String, Maybe Ident) + +resourceToAccessors :: Resource m s sid mid aid -> [Accessor] +resourceToAccessors r = + case schema r of + Schema _ step -> accessors step + topLevelActionInfo :: Resource m s sid mid aid -> Cardinality sid mid -> [ActionInfo] topLevelActionInfo r (Single _ ) = singleActionInfo r Nothing "" topLevelActionInfo r@Resource{} (Many mid) = maybeToList @@ -141,36 +174,36 @@ -- * Smart constructors for ActionInfo. getActionInfo :: Maybe (Id sid) -> String -> Handler m -> ActionInfo -getActionInfo mId pth = handlerActionInfo mId False Retrieve Self pth GET +getActionInfo mId pth = handlerActionInfo mId False Retrieve Self pth GET [] updateActionInfo :: Maybe (Id sid) -> String -> Handler m -> ActionInfo -updateActionInfo mId pth = handlerActionInfo mId False Update Any pth PUT +updateActionInfo mId pth = handlerActionInfo mId False Update Any pth PUT [] multiUpdateActionInfo :: Monad m => Id sid -> String -> Handler m -> Maybe ActionInfo -multiUpdateActionInfo id_ pth h = handlerActionInfo Nothing False UpdateMany Any pth PUT +multiUpdateActionInfo id_ pth h = handlerActionInfo Nothing False UpdateMany Any pth PUT [] <$> mkMultiHandler id_ (const id) h -removeActionInfo :: Handler m -> ActionInfo -removeActionInfo = handlerActionInfo Nothing True Delete Self "" DELETE +removeActionInfo :: Link -> Handler m -> ActionInfo +removeActionInfo lnk = handlerActionInfo Nothing True Delete Self "" DELETE lnk multiRemoveActionInfo :: Monad m => Id sid -> String -> Handler m -> Maybe ActionInfo -multiRemoveActionInfo id_ pth h = handlerActionInfo Nothing False DeleteMany Any pth DELETE +multiRemoveActionInfo id_ pth h = handlerActionInfo Nothing False DeleteMany Any pth DELETE [] <$> mkMultiHandler id_ (const id) h listActionInfo :: Monad m => Maybe (Id mid) -> String -> ListHandler m -> Maybe ActionInfo -listActionInfo mId pth h = handlerActionInfo mId False List Self pth GET <$> mkListHandler h +listActionInfo mId pth h = handlerActionInfo mId False List Self pth GET [] <$> mkListHandler h staticActionInfo :: String -> Handler m -> ActionInfo -staticActionInfo pth = handlerActionInfo Nothing False Modify Any pth POST +staticActionInfo pth = handlerActionInfo Nothing False Modify Any pth POST [] createActionInfo :: Handler m -> ActionInfo -createActionInfo = handlerActionInfo Nothing False Create Self "" POST +createActionInfo = handlerActionInfo Nothing False Create Self "" POST [] -selectActionInfo :: String -> Handler m -> ActionInfo -selectActionInfo pth = handlerActionInfo Nothing True Retrieve Any pth GET +selectActionInfo :: Link -> String -> Handler m -> ActionInfo +selectActionInfo lnk pth = handlerActionInfo Nothing True Retrieve Any pth GET lnk -actionActionInfo :: String -> Handler m -> ActionInfo -actionActionInfo pth = handlerActionInfo Nothing True Modify Any pth POST +actionActionInfo :: Link -> String -> Handler m -> ActionInfo +actionActionInfo lnk pth = handlerActionInfo Nothing True Modify Any pth POST lnk handlerActionInfo :: Maybe (Id id) -> Bool @@ -178,10 +211,11 @@ -> ActionTarget -> String -> RequestMethod + -> Link -> Handler m -> ActionInfo -handlerActionInfo mId postAct actType actTarget pth mth h = ActionInfo - { ident = idIdent <$> mId +handlerActionInfo mId postAct actType actTarget pth mth ac h = ActionInfo + { ident = id_ , postAction = postAct , actionType = actType , actionTarget = actTarget @@ -192,7 +226,19 @@ , errors = handlerErrors h , params = handlerParams h , https = secure h + , link = makeLink } + where + id_ = idIdent <$> mId + makeLink :: Link + makeLink + | postAct = ac ++ dirPart ++ identPart + | otherwise = dirPart ++ identPart + where dirPart = if pth /= "" + then [LAction pth] + else [] + identPart = maybe [] ((:[]) . LParam . description) id_ + -------------------- -- * Utilities for extraction information from Handlers. diff --git a/src/Rest/Gen/Base/ApiTree.hs b/src/Rest/Gen/Base/ApiTree.hs --- a/src/Rest/Gen/Base/ApiTree.hs +++ b/src/Rest/Gen/Base/ApiTree.hs @@ -2,13 +2,12 @@ module Rest.Gen.Base.ApiTree where import Data.Char +import Data.Function import Data.List import Data.Maybe -import Data.Function import Rest.Api (Router (..), Some1 (..)) import Rest.Gen.Base.ActionInfo -import Rest.Gen.Base.ActionInfo.Ident (description) import Rest.Gen.Base.Link import Rest.Gen.Utils import qualified Rest.Resource as Res @@ -26,13 +25,16 @@ , resId :: ResourceId , resParents :: ResourceId , resLink :: Link - , resIdents :: [Link] + , resAccessors :: [Accessor] , resPrivate :: Bool , resItems :: [ApiAction] , resDescription :: String , subResources :: [ApiResource] } deriving (Show, Eq) +resIdents :: ApiResource -> [Link] +resIdents = return . accessLink . resAccessors + apiSubtrees :: Router m s -> ApiResource apiSubtrees (Embed _ routes) = defaultTree { subResources = map (\(Some1 r) -> apiTree r) routes } @@ -41,30 +43,20 @@ apiTree' :: ResourceId -> Link -> Router m s -> ApiResource apiTree' rid lnk (Embed r routes) = - let myId = rid ++ [Res.name r] - myLnk = lnk ++ [LResource (Res.name r)] - accessLinks = [ actionInfoToLink [] ai | ai <- resourceToActionInfo r, isAccessor ai ] + let myId = rid ++ [Res.name r] + myLnk = lnk ++ [LResource (Res.name r)] + as = resourceToAccessors r in TreeItem { resName = Res.name r , resId = myId , resParents = rid , resLink = myLnk - , resIdents = accessLinks + , resAccessors = as , resPrivate = Res.private r - , resItems = [ ApiAction myId (myLnk ++ actionInfoToLink [LAccess accessLinks] ai) ai | ai <- resourceToActionInfo r ] + , resItems = [ ApiAction myId (myLnk ++ link ai) ai | ai <- resourceToActionInfo r ] , resDescription = Res.description r - , subResources = map (\(Some1 chd) -> apiTree' myId (myLnk ++ [LAccess accessLinks]) chd) routes + , subResources = map (\(Some1 chd) -> apiTree' myId (myLnk ++ [LAccess [accessLink as]]) chd) routes } - --- | Create urls from an action -actionInfoToLink :: Link -> ActionInfo -> Link -actionInfoToLink ac ai - | postAction ai = ac ++ dirPart ++ identPart - | otherwise = dirPart ++ identPart - where dirPart = if resDir ai /= "" - then [LAction $ resDir ai] - else [] - identPart = maybe [] ((:[]) . LParam . description) (ident ai) defaultTree :: ApiResource defaultTree = TreeItem "" [] [] [] [] False [] "" [] diff --git a/src/Rest/Gen/Haskell/Generate.hs b/src/Rest/Gen/Haskell/Generate.hs --- a/src/Rest/Gen/Haskell/Generate.hs +++ b/src/Rest/Gen/Haskell/Generate.hs @@ -173,7 +173,7 @@ case lnk of [] -> ac (LResource r : a@(LAccess _) : xs) | not (hasParam a) -> urlParts res xs (rlnk ++ [hsArray [string r]], pars) - | otherwise -> + | otherwise -> urlParts res xs ( rlnk ++ [ hsArray [string r] , (if r == res then noCode else modName r <+> ".") <+> "readId" <++> hsName (cleanName r) @@ -185,28 +185,29 @@ idData :: ApiResource -> Code idData node = - let items = filter isAccessor $ map itemInfo $ resItems node - mkCons = dataName . resDir - in case items of - [] -> noCode - [x] -> maybe noCode - (\i -> mkStack - [ code "type Identifier = " <++> Ident.haskellType i - , function "readId" "Identifier -> [String]" - , hsDecl "readId" ["x"] (hsArray $ if resDir x /= "" then [string $ resDir x, code "showUrl x"] else [code "showUrl x"]) - ] - ) - (ident x) - ls -> mkStack $ - [ hsData "Identifier" $ map (\i -> mkCons i ++ maybe "" (\x -> " (" ++ Ident.haskellType x ++ ")") (ident i)) ls - , function "readId" "Identifier -> [String]" - , mkStack $ - map (\i -> - if isJust (ident i) - then hsDecl "readId" ["(" ++ mkCons i ++ " x" ++ ")"] $ hsArray [string (resDir i), code "showUrl x"] - else hsDecl "readId" [mkCons i] $ hsArray [string (resDir i)] - ) ls - ] + case resAccessors node of + [] -> noCode + [(pth,mi)] -> maybe noCode + (\i -> mkStack + [ code "type Identifier = " <++> Ident.haskellType i + , function "readId" "Identifier -> [String]" + , hsDecl "readId" ["x"] (hsArray $ if pth /= "" + then [string pth, code "showUrl x"] + else [code "showUrl x"] + ) + ] + ) + mi + ls -> mkStack $ + [ hsData "Identifier" $ map (\(pth,mi) -> dataName pth ++ maybe "" (\x -> " (" ++ Ident.haskellType x ++ ")") mi) ls + , function "readId" "Identifier -> [String]" + , mkStack $ + map (\(pth,mi) -> + if isJust mi + then hsDecl "readId" ["(" ++ dataName pth ++ " x" ++ ")"] $ hsArray [string pth, code "showUrl x"] + else hsDecl "readId" [dataName pth] $ hsArray [string pth] + ) ls + ] mkHsName :: ActionInfo -> String mkHsName ai = hsName $ concatMap cleanName parts