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]