module Rest.Gen.Base.ApiTree where
import Data.Char
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
data ApiAction =
ApiAction
{ itemResource :: ResourceId
, itemLink :: Link
, itemInfo :: ActionInfo
} deriving (Show, Eq)
data ApiResource =
TreeItem
{ resName :: String
, resId :: ResourceId
, resParents :: ResourceId
, resLink :: Link
, resIdents :: [Link]
, resPrivate :: Bool
, resItems :: [ApiAction]
, resDescription :: String
, subResources :: [ApiResource]
} deriving (Show, Eq)
apiSubtrees :: Router m s -> ApiResource
apiSubtrees (Embed _ routes) = defaultTree { subResources = map (\(Some1 r) -> apiTree r) routes }
apiTree :: Router m s -> ApiResource
apiTree = apiTree' [] []
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 ]
in TreeItem
{ resName = Res.name r
, resId = myId
, resParents = rid
, resLink = myLnk
, resIdents = accessLinks
, resPrivate = Res.private r
, resItems = [ ApiAction myId (myLnk ++ actionInfoToLink [LAccess accessLinks] ai) ai | ai <- resourceToActionInfo r ]
, resDescription = Res.description r
, subResources = map (\(Some1 chd) -> apiTree' myId (myLnk ++ [LAccess accessLinks]) chd) routes
}
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 [] "" []
foldTree :: (ApiResource -> [a] -> a) -> ApiResource -> a
foldTree f tr = f tr (map (foldTree f) (subResources tr))
foldTreeChildren :: ([a] -> a) -> (ApiResource -> [a] -> a) -> ApiResource -> a
foldTreeChildren f1 f2 = f1 . map (foldTree f2) . subResources
noPrivate :: ApiResource -> ApiResource
noPrivate = foldTree $ \it subs -> it { subResources = filter (not . resPrivate) subs }
sortTree :: ApiResource -> ApiResource
sortTree = foldTree $ \it subs -> it { subResources = sortBy (compare `on` resName) subs }
allTrees :: ApiResource -> [ApiResource]
allTrees = foldTree $ \it subs -> it : concat subs
allSubTrees :: ApiResource -> [ApiResource]
allSubTrees = foldTreeChildren concat $ \it subs -> it : concat subs
apiResources :: ApiResource -> [ResourceId]
apiResources = foldTree $ \it subs -> map (resName it:) ([] : concat subs)
allResources :: ApiResource -> [ApiResource]
allResources = foldTree $ \it -> (it:) . concat
allSubResources :: ApiResource -> [ApiResource]
allSubResources = foldTreeChildren concat $ \it -> (it:) . concat
allResourceIds :: ApiResource -> [ResourceId]
allResourceIds = map resId . allResources
allSubResourceIds :: ApiResource -> [ResourceId]
allSubResourceIds = map resId . allSubResources
subResourceNames :: ApiResource -> [String]
subResourceNames = map resName . subResources
subResourceIds :: ApiResource -> [ResourceId]
subResourceIds = map resId . subResources
hasAccessor :: ApiResource -> Bool
hasAccessor = not . null . resIdents
mkFuncParts :: ApiAction -> [String]
mkFuncParts (ApiAction _ _ ai) = concatMap cleanName parts
where
parts = case actionType ai of
Retrieve -> let nm = get ++ by ++ target
in if null nm then ["access"] else nm
Create -> ["create"] ++ by ++ target
Delete -> ["remove"] ++ by ++ target
List -> ["list"] ++ by ++ target
Update -> ["save"] ++ by ++ target
UpdateMany -> ["saveMany"] ++ by ++ target
Modify -> if resDir ai == "" then ["do"] else [resDir ai]
target = if resDir ai == "" then [] else [resDir ai]
by = if null target
|| isNothing (ident ai)
&& actionType ai /= UpdateMany then [] else ["by"]
get = if isAccessor ai then [] else ["get"]
cleanName :: String -> [String]
cleanName "" = [""]
cleanName ('-':v:rs) = [] : mapHead (mapHead toUpper) (cleanName (v: rs))
cleanName (x : xs) | isAlphaNum x = mapHead (x:) $ cleanName xs
| otherwise = cleanName xs