RESTng-0.1: RESTng/System/CRUD.hs
{-# LANGUAGE ExistentialQuantification, FlexibleInstances #-}
{-# OPTIONS_GHC -fglasgow-exts #-}
module RESTng.System.CRUD where
import Prelude hiding (div)
import Control.Monad (filterM)
import Control.Monad.Reader (ask)
import Text.CxML
import Text.YuiGrid (GridElement, toBox, toContainer)
import Control.Monad.Trans (lift)
import RESTng.Utils(low, lookupByFun, mapSnd)
import RESTng.RESTngMonad (RESTng, getAuthUser)
import RESTng.Database.SQL (OrderDirection)
import RESTng.RqHandlers
import RESTng.System.Resource
import RESTng.System.PersistableResource
import RESTng.System.WebResource
import RESTng.System.FormFields
import RESTng.System.Permission (Permission, checkPermissions, ownerOrAdminCan, everybodyCan, authdCan, allowedForUser)
import RESTng.System.Authentication (afterSettingAuthUser)
import RESTng.System.Annotation
import RESTng.System.Association
import RESTng.Resources.User(user_id, User)
-- this data type is to be used by the user.
--data CRUDableOneToManyBox = forall a. (CRUDable a) => C1toNB (Proxy a) (CRUDableChildOf a)
-- the CRUDableResBox is used by the handlers. A list of CRUDableResBox is created from a list of CRUDableOneToManyBox
data CRUDableChildOf a = forall b. (CRUDable b, AssocOneToMany a b) => CCB (Proxy b)
data CRUDableResBox = forall a. (CRUDable a) => CB
(Proxy a) -- proxy
[CRUDableChildOf a] -- childrenOf
lookupAssocByResType :: String -> [CRUDableResBox] -> Maybe CRUDableResBox
lookupAssocByResType resTypeName resList = lookupByFun boxResourceType resTypeName resList
where
boxResourceType :: CRUDableResBox -> String
boxResourceType (CB p children) = low $ resourceType p
lookupChildByResType :: CRUDable a => String -> [CRUDableChildOf a] -> Maybe (CRUDableChildOf a)
lookupChildByResType resTypeName resList = lookupByFun childResourceType resTypeName resList
where
childResourceType :: CRUDableChildOf a -> String
childResourceType (CCB pb) = low $ resourceType pb
class (InGridResource a, PersistableResource a, AnnotatedResource a) => CRUDable a where
canGetCreationForm :: Permission a -- should not depend on the resource (since is undefined)
canCreate :: Permission a
canRetrieve :: Permission a
canUpdate :: Permission a
canDelete :: Permission a
canGetCreationForm = authdCan
canCreate = ownerOrAdminCan
canRetrieve = everybodyCan
canUpdate = ownerOrAdminCan
canDelete = ownerOrAdminCan
-- Handlers for CRUDs
resourcesHandler :: [CRUDableResBox] -> RqHandlerT RESTng RESTngResp
resourcesHandler resList = underString (\resTypeName -> resourcesHandler' resTypeName resList)
resourcesHandler' :: String -> [CRUDableResBox] -> RqHandlerT RESTng RESTngResp
resourcesHandler' resTypeName resList =
case maybeProxyAndAssoc of
Nothing -> notMe
Just (CB p children) ->
anyOf [
resHandler' p,
maybeChildHandler resList p children
]
where
maybeProxyAndAssoc = lookupAssocByResType resTypeName resList
maybeChildHandler :: CRUDable a => [CRUDableResBox] -> Proxy a -> [CRUDableChildOf a] -> RqHandlerT RESTng RESTngResp
maybeChildHandler resList parentProxy children =
underInteger (\ix-> underString (\childName -> maybeChildHandler' resList parentProxy children ix childName ))
maybeChildHandler' :: CRUDable a => [CRUDableResBox] -> Proxy a -> [CRUDableChildOf a] -> Integer -> String -> RqHandlerT RESTng RESTngResp
maybeChildHandler' resList pa children i childName =
case maybeChild of
-- Nothing -> sendStr (resourceType pa ++ " is NOT associated to " ++ childrenName)
-- Just (CCB pb) -> sendStr (resourceType pa ++ " is associated to " ++ resourceType pb)
Nothing -> notMe
Just (CCB pb) -> childHandler resList pa pb i
where
--maybeChild :: CRUDable a => Maybe (CRUDableChildOf a)
maybeChild = lookupChildByResType childName children
childHandler :: (CRUDable a, CRUDable b, AssocOneToMany a b) => [CRUDableResBox] -> Proxy a -> Proxy b -> Integer -> RqHandlerT RESTng RESTngResp
childHandler resList pa pb ix
= modReq setQueriesForChild $ resourcesHandler' (low $ resourceType pb) resList
where
setQueriesForChild :: RequestContext -> RequestContext
setQueriesForChild = upgradeQueriesForHierarchy (referringQuery pa pb ix)
resHandler :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp
resHandler pa = under (resourceType pa) $ resHandler' pa
resHandler' :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp
resHandler' pa = withTitle (resourceType pa) $ afterSettingAuthUser $
anyOf [
ifGet $ anyOf [resHandlerList pa, resHandlerShow pa, resHandlerEdit pa, resHandlerNew pa],
ifPost $ anyOf [resHandlerUpdate pa, resHandlerInsert pa, resHandlerDelete pa]
]
-- handlers for specific methods on a resource or resource collection
resHandlerList :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp
resHandlerShow :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp
resHandlerEdit :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp
resHandlerNew :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp
resHandlerUpdate :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp
resHandlerInsert :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp
resHandlerDelete :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp
----------------------------------------------
--------- GET REQUEST HANDLERS ---------------
----------------------------------------------
resHandlerList pa = withDocName "index" $ withQuery $ resHandlerList' pa
-- They assume that we are ready for the db transaction/query
-- (i.e. the objects used as argument (maybe) have been built)
resHandlerList' :: CRUDable a => Proxy a -> [(String,String)] -> RqHandlerT RESTng RESTngResp
resHandlerList' pa queryPairs =
do rs <- lift (select (filterFields queryPairs) [] pa)
u <- lift getAuthUser
allowed <- lift $ filterM (\r-> allowedForUser r canRetrieve) rs
rAndAnnsList <- lift $ (sequence $ map rAndAnnsPair allowed)
okBoxes (listView rAndAnnsList)
where filterFields = filter (\(key,_) -> elem key (userFieldsWithKey pa))
rAndAnnsPair :: AnnotatedResource a => a -> RESTng (a,[(String, GridElement RequestContext)])
rAndAnnsPair r = do anns <- sequence $ map (listingAnnotation r) annotations
return (r,anns)
listingAnnotation :: Resource a => a -> Annotation a -> RESTng (String, GridElement RequestContext)
listingAnnotation r ann = do cxml <- whenListingElement ann r >>= return . (inElementCtx r)
return (annotationName ann, whenListingElementLayout ann cxml)
inElementCtx r = modCx (addResourceIdToCollAddr (show $ key r))
--Should the filterFields protection go in the persistable or relational resource files?
-- would be safer, but could impose double traversing if the query list needs to be traversed here in the future
--FIXME:: filter the list like in GridCRUD?
resHandlerShow pa = withDocNameInteger (\ix-> resHandlerShow' ix pa)
resHandlerShow' :: CRUDable a => Integer -> Proxy a -> RqHandlerT RESTng RESTngResp
resHandlerShow' k pa =
do maybeRecord <- lift $ find k pa
case maybeRecord of
Nothing -> notMe
Just res -> (checkPermissions [canRetrieve] res $ resHandlerShowWithAnn res)
resHandlerShowWithAnn :: CRUDable a => a -> RqHandlerT RESTng RESTngResp
resHandlerShowWithAnn res =
do anns <- lift $ resShowingAnnotations res
-- catResps showReq (showingResourceAndHtmls res anns)
-- the line was put for debugging but did not work. maybe caResps is buggy.
okBoxes (showView res anns)
resHandlerEdit pa = underInteger (\ix-> withDocName "edit" $ resHandlerEdit' ix pa Nothing)
resHandlerEdit' :: CRUDable a => Integer -> Proxy a -> Maybe ([(String,String)], [(String,ValidationError)]) -> RqHandlerT RESTng RESTngResp
resHandlerEdit' k pa maybeErrs =
do maybeRecord <- lift $ find k pa
case maybeRecord of
Nothing -> notMe
Just res -> (checkPermissions [canRetrieve, canUpdate] res $ resHandlerEditWithAnn res maybeErrs)
resHandlerEditWithAnn :: CRUDable a => a -> Maybe ([(String,String)], [(String,ValidationError)]) -> RqHandlerT RESTng RESTngResp
resHandlerEditWithAnn res maybeErrs =
do anns <- lift $ resEditionAnnotations res
okBoxes (editLayout (proxyOf res) renderedForm (maybeValErrsBox ++ anns))
where
(renderedForm,maybeValErrsBox)
= case maybeErrs of
Nothing -> (formEditHtml res,[])
Just (fields, valErrs) -> mapSnd ( (:[]) . (,) "valErrors" . toBox) $
formAndErrorsCxMLs (proxyOf res) fields valErrs
resHandlerNew pa = withDocName "new" $ (resHandlerNew' pa Nothing)
resHandlerNew' :: CRUDable a => Proxy a -> Maybe ([(String,String)], [(String,ValidationError)]) -> RqHandlerT RESTng RESTngResp
resHandlerNew' pres maybeErrs = (checkPermissions permissions res $ resHandlerNewWithAnn pres maybeErrs)
where
res = fromProxy pres
fromProxy :: Proxy a -> a
fromProxy _ = undefined
--FIXME: can this trick with types be avoid?
permissions = -- check if ownerId has to be enforced for this resource type and require authentication
if (ownable pres) then [authdCan, canGetCreationForm]
else [canGetCreationForm]
resHandlerNewWithAnn :: CRUDable a => Proxy a -> Maybe ([(String,String)], [(String,ValidationError)]) -> RqHandlerT RESTng RESTngResp
resHandlerNewWithAnn pres maybeErrs =
do anns <- lift $ resCreationAnnotations pres
okBoxes (createLayout pres renderedForm (maybeValErrsBox ++ anns))
where
(renderedForm,maybeValErrsBox)
= case maybeErrs of
Nothing -> (formCreateHtml pres,[])
Just (fields, valErrs) -> mapSnd ( (:[]) . (,) "valErrors" . toBox) $
formAndErrorsCxMLs pres fields valErrs
----------------------------------------------
--------- POST REQUEST HANDLERS --------------
----------------------------------------------
resHandlerUpdate pr = underInteger (\ix-> withDocName "edit" $ withPostFields (resHandlerUpdate' pr ix))
resHandlerUpdate' :: CRUDable a => Proxy a -> Integer -> AssocList -> RqHandlerT RESTng RESTngResp
resHandlerUpdate' pr ix fs
= processValidationOutput (runWebParserAndValidator pr (systemFieldsForUpdate ix) fs)
where
processValidationOutput :: CRUDable a => Either [(String, ValidationError)] a -> RqHandlerT RESTng RESTngResp
processValidationOutput (Right res) = updateIfAllowed res
processValidationOutput (Left valErrs) = resHandlerEdit' ix pr (Just (fs,valErrs))
updateIfAllowed :: CRUDable a => a -> RqHandlerT RESTng RESTngResp
updateIfAllowed res = checkPermissions [canUpdate] res (update' res)
where
update' :: CRUDable a => a -> RqHandlerT RESTng RESTngResp
update' res = lift (update res) >> showingResource res
systemFieldsForUpdate :: Integer -> SystemFields
systemFieldsForUpdate ix = (ix, Just 0)
-- FIXME: this is not the correct owner. Should we read the record from the db to check permissions?.
-- Logged in https://www.bugwiki.com/showBug.php?bug=1701
resHandlerInsert pr = withDocName "new" $ withPostFields (resHandlerInsert' pr)
resHandlerInsert' :: CRUDable a => Proxy a -> AssocList -> RqHandlerT RESTng RESTngResp
resHandlerInsert' pr fs = do u <- lift getAuthUser
processValidationOutput (runWebParserAndValidator pr (systemFieldsForInsert pr u) fs)
where
processValidationOutput :: CRUDable a => Either [(String,ValidationError)] a -> RqHandlerT RESTng RESTngResp
processValidationOutput (Right res) = insertIfAllowed res
processValidationOutput (Left valErrs) = resHandlerNew' pr (Just (fs,valErrs))
insertIfAllowed :: CRUDable a => a -> RqHandlerT RESTng RESTngResp
insertIfAllowed res = -- check if ownerId has to be enforced for this resource type
if (ownable $ proxyOf res)
then checkPermissions [authdCan, canCreate] res (insert' res)
else checkPermissions [canCreate] res (insert' res)
where
insert' :: CRUDable a => a -> RqHandlerT RESTng RESTngResp
insert' res = do resWithKey <- lift $ insert res
showingResource resWithKey
systemFieldsForInsert :: Resource a => Proxy a -> Maybe User -> SystemFields
systemFieldsForInsert pr u = (0, maybeOwnerId)
where
maybeOwnerId = if ownable pr
then fmap user_id u -- map user_id in the Maybe Monad
else Nothing
resHandlerDelete pa = underInteger (\ix-> withDocName "delete" $ resHandlerDelete' ix pa)
resHandlerDelete' :: CRUDable a => Integer -> Proxy a -> RqHandlerT RESTng RESTngResp
resHandlerDelete' k pa =
do maybeRecord <- lift $ find k pa
case maybeRecord of
Nothing -> fmap (okNonCxMLRsp . htmlToCxML . showReq) ask
Just res -> checkPermissions [canDelete] res delete'
where
delete' :: RqHandlerT RESTng RESTngResp
delete' = lift (delete k pa) >> listFilteredByQuery
listFilteredByQuery = withQuery $ resHandlerList' pa
----------------------------------------------
---- other utility request handlers ----------
----------------------------------------------
resListingAnnotations :: AnnotatedResource a => a -> RESTng [(String, GridElement RequestContext)]
resListingAnnotations res = sequence $ map (`whenListingElementAnn` res) annotations
-- TODO: look how the context must be set for this one.
-- After done, refactor code in listingResource and change to reuse this.
resShowingAnnotations :: AnnotatedResource a => a -> RESTng [(String, GridElement RequestContext)]
resShowingAnnotations res = sequence $ map (`whenShowingElementAnn` res) annotations
resEditionAnnotations :: AnnotatedResource a => a -> RESTng [(String, GridElement RequestContext)]
resEditionAnnotations res = sequence $ map (`whenEditingElementAnn` res) annotations
resCreationAnnotations :: AnnotatedResource a => Proxy a -> RESTng [(String, GridElement RequestContext)]
resCreationAnnotations pr = sequence $ map (`whenCreatingElementAnn` pr) annotations
showingResource :: (PersistableResource a, WebResource a) => a -> RqHandlerT RESTng RESTngResp
showingResource res = okCxML $ showHtml res --without annotations
listingResource :: CRUDable a => Proxy a -> [(String,String)] -> [(String,OrderDirection)]
-> RESTng (GridElement RequestContext)
listingResource pres queryPairs ordBy
= do
rs <- select (filterFields queryPairs) ordBy pres
rAndAnnsList <- sequence $ map rAndAnnsPair rs
return $ (fmap inResourceContext . toContainer . listView ) rAndAnnsList
where
filterFields = filter (\(key,_) -> elem key (userFieldsWithKey pres))
rAndAnnsPair :: AnnotatedResource a => a -> RESTng (a,[(String, GridElement RequestContext)])
rAndAnnsPair r = do anns <- sequence $ map (listingAnnotation r) annotations
return (r,anns)
listingAnnotation :: Resource a => a -> Annotation a -> RESTng (String, GridElement RequestContext)
listingAnnotation r ann = do cxml <- whenListingElement ann r >>= return . (inElementCtx r)
return (annotationName ann, whenListingElementLayout ann cxml)
inElementCtx r = modCx (addResourceIdToCollAddr (show $ key r))
inResourceContext = modCx (setCollectionFromRootAddr $ resourceType pres)