module RESTng.System.WebResource where import Prelude hiding(span, div) import Data.List (groupBy, intercalate) import Data.Char (isUpper, toUpper) import Data.Maybe (fromJust) import Text.CxML import Text.YuiGrid import Network.HTTP.RedHandler (RequestContext, completeURL, query, addMethodEditToResAddr, addMethodDeleteToResAddr, addResourceIdToCollAddr, addMethodNewToCollAddr) import RESTng.Utils (mapSnd) import RESTng.System.FormFields import RESTng.System.Resource data FormFieldType = HiddenField | TextField | PasswordField | FileField deriving Eq data FormFieldSpec = FFS { fieldType :: FormFieldType, fieldName :: String, fieldLabel :: String, fieldValue :: String, fieldWithError :: Bool } renderFormField :: FormFieldSpec -> CxML a renderFormField (FFS HiddenField name _ val _) = hidden name val --renderFormField (FFS TextField name label val ferr) = (span /- [t $ label]) +++ (maybeError ferr (textfield name !("value",val))) +++ br --renderFormField (FFS FileField name label _ ferr) = (span /- [t $ label]) +++ (maybeError ferr (afile name)) +++ br renderFormField (FFS TextField name label val ferr) = (span /- [maybeError ferr (t label)]) +++ (textfield name !("value",val)) +++ br renderFormField (FFS FileField name label _ ferr) = (span /- [maybeError ferr (t label)]) +++ afile name +++ br --maybeError True _tag = div!("background-color","red")!("display","table")!("padding","2px") /- [_tag] --maybeError False _tag = _tag maybeError True t = font!("color","red") /- [t] maybeError False t = t class Resource a => WebResource a where userFieldValues :: a -> [String] --does not have the key in the list userFieldValuesParser :: SystemFields -> AssocListValidator a showHtml :: a -> CxML RequestContext showShortHtml :: a -> CxML RequestContext listElementHtml :: a -> CxML RequestContext formFieldsSpec :: Proxy a -> [(String {-label-}, FormFieldType)] showHtml res = withCtx $ showHtml' (reflectResourceData res) showShortHtml res = withCtx $ showHtml' (reflectResourceData res) listElementHtml res = withCtx $ listElementHtml' resname idVal fields where fields = reflectResourceData res resname = resourceType pres idVal = show $ key res pres = proxyOf res formFieldsSpec pr = zip (map renderFieldName $ userFields pr) (repeat TextField) formEditHtml :: WebResource a => a -> CxML RequestContext formEditHtml res = withCtx $ (\cxt -> buildForm (proxyOf res) cxt fields) where fields = zip3 ufields uvalues (repeat False) (ufields, uvalues) = unzip (reflectResourceData res) formCreateHtml :: WebResource a => Proxy a -> CxML RequestContext formCreateHtml pres = withCtx $ (\cxt -> buildForm pres cxt fields) where fields = zip3 (userFields pres) blankValues (repeat False) blankValues = repeat "" formWithErrorsHtml :: WebResource a => Proxy a -> [(String, String, Bool)] -> CxML RequestContext formWithErrorsHtml pres fields = withCtx $ (\cxt -> buildForm pres cxt fields) formAndErrorsCxMLs :: WebResource a => Proxy a -> [(String,String)] -> [(String,ValidationError)] -> (CxML RequestContext, CxML RequestContext) formAndErrorsCxMLs pr fields valErrs = (formWithErrorsHtml pr (map addErrFlag fields), renderValidationErrs valErrs) where addErrFlag (name,val) = (name,val, name `elem` attrsWithError) attrsWithError = map fst valErrs renderValidationErrs :: [(String,ValidationError)] -> CxML a renderValidationErrs valErrs = concatCxML $ map ( (p/-) . (:[]) . t . snd) valErrs userFieldValuesWithKey :: WebResource a => a -> [String] userFieldValuesWithKey r = show (key r) : userFieldValues r reflectResourceData :: WebResource a => a -> [(String, String)] reflectResourceData a = zip (userFields pa) (userFieldValues a) where pa = proxyOf a reflectResourceDataWithKey :: WebResource a => a -> [(String, String)] reflectResourceDataWithKey a = zip (userFieldsWithKey pa) (userFieldValuesWithKey a) where pa = proxyOf a runWebParserAndValidator :: WebResource a => Proxy a -> SystemFields -> AssocList -> Either [(String,ValidationError)] a runWebParserAndValidator _ = runParserAndValidator . userFieldValuesParser showShortURLHtml :: WebResource a => a -> CxML RequestContext showShortURLHtml res = a!("href", ("/" ++ resname ++ "/" ++ idVal)) /- [showShortHtml res] where resname = resourceType pres idVal = show $ key res pres = proxyOf res showHtml' :: [(String, String)] -> RequestContext -> CxML a showHtml' fs rqctx = concatCxML $ renderFields fs where renderFields :: [(String, String)] -> [CxML b] renderFields = concat . (map renderField) . (filter shouldShowField) shouldShowField :: (String, String) -> Bool shouldShowField (name, _) = (not . elem name . fst . unzip . query) rqctx renderField :: (String, String) -> [CxML b] renderField (name, val) = [span /- [t $ renderFieldName (name ++ ":")], span /- [t val], br] -- | rececives a list of triples of data conforming the resource (or blank data if new) and telling if the data is valid -- and receives the request context with information to prefill the form (overriding and hiding some data fields). The information to build the actionURL is also in the requestContext. buildForm :: WebResource a => Proxy a -> RequestContext -> [(String, String, Bool)] -> CxML b buildForm pr rqctx = buildForm' (completeURL rqctx) . map (hideFieldIfFixed . buildFieldSpec) . zip (formFieldsSpec pr) where buildFieldSpec ((lbl,fType),(name,val, withErrorFlag)) = FFS fType name lbl val withErrorFlag hideFieldIfFixed fieldSpec = case lookup (fieldName fieldSpec) q of Nothing -> fieldSpec Just val' -> fieldSpec { fieldValue = val', fieldType = HiddenField } q = query rqctx --TODO? a possible improvement is to allow scaffolding some fields, (not all or nothing). This would be done by naming each field specification, so some repetition of names is required. If a field is not named, then the defauld field label and type is used. buildForm' :: String -> [FormFieldSpec] -> CxML a buildForm' actionUrl fss = formTagAndAttrs /- (map renderFormField fss ++ [br, buttonTagAndAttrs]) where formTagAndAttrs = if FileField `elem` (map fieldType fss) then formTagAndAttrs'!("enctype", "multipart/form-data") else formTagAndAttrs' formTagAndAttrs' = form!("method","post")!("action", actionUrl) buttonTagAndAttrs = button!("name","action")!("value","submit") /- [t "Submit"] listElementHtml' :: String -> String -> [(String, String)] -> RequestContext -> CxML a listElementHtml' aname idVal fs rqctx = tr /- ((renderIdField : map renderField fs) ++ [editField, deleteField]) where renderField :: (String, String) -> CxML a renderField (_, val) = td /- [t val] renderIdField = td /- [a!("href", showURL) /- [t idVal] ] editField, deleteField :: CxML a editField = td /- [ a!("href", editURL) /- [t "edit"] ] deleteField = td /- [ a!("href", deleteURL)!("onclick", onclickScript) /- [t "delete"] ] showURL = completeURL resAddressCtx editURL = completeURL $ addMethodEditToResAddr resAddressCtx deleteURL = completeURL $ addMethodDeleteToResAddr resAddressCtx onclickScript = "if (confirm('Are you sure?')) { var f = document.createElement('form'); f.style.display = 'none'; this.parentNode.appendChild(f); f.method = 'POST'; f.action = this.href;f.submit(); };return false;" resAddressCtx = addResourceIdToCollAddr idVal rqctx -- Some utility functions renderFieldName :: String -> String renderFieldName = capitalize . unwords . groupBy (\_->not . isUpper) where capitalize (x:xs) = toUpper x : xs class WebResource a => InGridResource a where -- the InGridResource methods allow to specify the layout of the result of the WebResource methods and the -- annotations showLayout :: Proxy a -> CxML RequestContext -> [(String, GridElement RequestContext)] -> [GridElement RequestContext] editLayout :: Proxy a -> CxML RequestContext -> [(String, GridElement RequestContext)] -> [GridElement RequestContext] createLayout :: Proxy a -> CxML RequestContext -> [(String, GridElement RequestContext)] -> [GridElement RequestContext] listView :: [(a, [(String, GridElement RequestContext)])] -> [GridElement RequestContext] showLayout = showLayoutDefault editLayout = editLayoutDefault createLayout = createLayoutDefault listView = listInTableView showLayoutDefault, editLayoutDefault, createLayoutDefault :: InGridResource a => Proxy a -> CxML b -> [(String, GridElement b)] -> [GridElement b] showLayoutDefault pres cxml anns = (smallMarginBottomCSS . giveBorderCSS . boxInMain) cxml : map snd anns editLayoutDefault pres cxml anns = boxInMain cxml : map snd anns createLayoutDefault pres cxml anns = boxInMain cxml : map snd anns -- these are the methods aimed to be used in the crud showView :: InGridResource a => a -> [(String, GridElement RequestContext)] -> [GridElement RequestContext] showView res anns = showLayout (proxyOf res) (showHtml res) anns listInBoxesView :: InGridResource a => [(a, [(String, GridElement RequestContext)])] -> [GridElement RequestContext] listInBoxesView resAndAnns = listInBoxesLayout resProxy (map (\(res,anns)->(showHtml res, anns)) resAndAnns) where resProxy = (proxyOf . fst . head) resAndAnns listInBoxesLayout :: InGridResource a => Proxy a -> [(CxML RequestContext,[(String, GridElement RequestContext)])] -> [GridElement RequestContext] listInBoxesLayout pres = map (inMain . toContainer . uncurry (showLayout pres)) listInTableView :: InGridResource a => [(a, [(String, GridElement RequestContext)])] -> [GridElement RequestContext] listInTableView resAndAnns = listInTableLayout resProxy (map (\(res,anns)->(listElementHtml res, anns)) resAndAnns) where resProxy = (proxyOf . fst . head) resAndAnns listInTableLayout :: InGridResource a => Proxy a -> [(CxML RequestContext,[(String, GridElement RequestContext)])] -> [GridElement RequestContext] listInTableLayout pres = (:[]) . boxInMain . listInTableHtml pres . map (stripLayoutFromAnns) where stripLayoutFromAnns :: (CxML RequestContext,[(String, GridElement RequestContext)]) -> (CxML RequestContext,[(String, CxML RequestContext)]) stripLayoutFromAnns cxmlAndAnnsList = mapSnd (map (mapSnd fromGridNode)) cxmlAndAnnsList --TODO: make stripLayout safe? listInTableHtml :: Resource a => Proxy a -> [(CxML RequestContext,[(String, CxML RequestContext)])] -> CxML RequestContext listInTableHtml pres cxmlAndAnnsList = withCtx $ listInTableHtml' pres cxmlAndAnnsList listInTableHtml' :: Resource a => Proxy a -> [(CxML b,[(String, CxML b)])] -> RequestContext -> CxML b listInTableHtml' pres htmlAndAnns rqctx = concatCxML [table /- rowlist htmlAndAnns, a!("href", newURL) /- [t "new"], br ] where newURL = completeURL $ addMethodNewToCollAddr rqctx rowlist :: [(CxML b,[(String, CxML b)])] -> [CxML b] rowlist [] = [tr/-[] ] -- add one row in this case since nested tables without rows are not rendered ok in mozilla. rowlist htmlAndAnns = map listElementInTableHtml htmlAndAnns listElementInTableHtml :: (CxML b,[(String, CxML b)]) -> CxML b listElementInTableHtml (cxml, anns) = cxml /- (map renderAnnotation anns) where renderAnnotation (_,ann) = td /- [ann]