{-# 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)