{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}

module RESTng.Resources.ResourceTag where

import Prelude hiding(span, div)
import Database.HDBC (toSql)
import Text.ParserCombinators.Parsec (parse)
import Data.List(intercalate)
import Data.Generics

import Text.CxML hiding(tag)
import Network.HTTP.RedHandler (RequestContext, completeURL, addMethodNewToCollAddr, addHierarchicalCollToResAddr)

import RESTng.Database.SQL
import RESTng.Database.Record
import RESTng.RESTngMonad (RESTng)
import RESTng.System.Resource
import RESTng.System.RelationalResource
import RESTng.System.PersistableResource
import RESTng.System.WebResource
import RESTng.System.Annotation
import RESTng.System.Permission (everybodyCan)
import RESTng.System.CRUD
import RESTng.System.Association
import RESTng.System.FormFields


data ResourceTag = ResourceTag {
       resource_tag_id :: Integer,
       resource_id :: Integer,
       resource_type :: String,
       tag :: String
   } deriving (Data, Typeable)

instance Resource ResourceTag where
  resourceType _ = "ResourceTag"
  key = resource_tag_id
  setKey p k = p{resource_tag_id = k}

  userFields _ = ["resource_id", "resource_type", "tag"]


instance RelationalResource ResourceTag where

  userFieldsToSql r = [ toSql $ resource_id r, toSql $ resource_type r,
                        toSql $ tag r ]

--   sqlUserFieldsParser :: SystemFields -> SqlValueParser a
  sqlUserFieldsParser (k, _) = 
                   do
                     (rid, rtype, ta) <- sqlRecordParser
                     return (ResourceTag k rid rtype ta)

instance PersistableResource ResourceTag where
  persistableFunctions = persistableFromRelational

instance WebResource ResourceTag where
  userFieldValues r = [ showField $ resource_id r, showField $ resource_type r,
                        showField $ tag r ]

  userFieldValuesParser (k, _) =
                   do
                     rid <- parseField "resource_id"
                     rtype <- parseNotEmpty "resource_type"
                     ta <- parseNotEmpty "tag"
                     return (ResourceTag k rid rtype ta)

  listElementHtml resTag = tr /- [td /- [tagLink resTag]]

--------------------------------
-- Pointing to tag resource ---
--------------------------------
tagLink :: ResourceTag -> CxML a
tagLink ta = tagLink' (tag ta) Nothing
--Note that the tag resource must be implemented at application level.
-- FIXME: implement read-only algorithmic resources 
-- When doing this, the key for tags will be a string (pretty key) not an id!!!!

tagLink' :: String -> Maybe Integer -> CxML a
tagLink' name maybeQty = a!("href", "/Tag/" ++ name)
                           /- [t $ name ++ maybeQtyDescription]
                         where maybeQtyDescription = case maybeQty of
                                                       Nothing -> ""
                                                       Just qty -> "(" ++ show qty ++ ")"


instance InGridResource ResourceTag

-- ResourceTag CRUD
instance AnnotatedResource ResourceTag

instance CRUDable ResourceTag where
  canGetCreationForm = everybodyCan
  canCreate   = everybodyCan
  canRetrieve = everybodyCan
  canUpdate   = everybodyCan
  canDelete   = everybodyCan
--FIXME: change permission canGetCreationForm to nobodyCan (after some testing)

-- ResourceTag Annotations
resourceTagProxy :: Proxy ResourceTag
resourceTagProxy = undefined


resourceTags :: AssocOneToMany a ResourceTag => Annotation a
resourceTags = defaultAnnotation {
                             annotationName = "tags",
                             whenShowingElement = showTags,
                             whenEditingElement = showTags,
                             whenListingElement = showTags
                            }

showTags :: AssocOneToMany a ResourceTag => a -> RESTng (CxML RequestContext)
showTags res
               = do resTags <- findReferringTo res resourceTagProxy
                    return (concatCxML (map tagLink resTags ++ [withCtx newTagLink]))

                 where
                    newTagLink rq = a!("href", newTagUrl rq) /- [t "Add tag"]
                    newTagUrl = completeURL . addMethodNewToCollAddr . addHierarchicalCollToResAddr (resourceType resourceTagProxy) restQuery
                    restQuery = referringQuery (proxyOf res) resourceTagProxy (key res)


instance RelationalResource a => RelationalOneToMany a ResourceTag where -- requires FlexibleInstances & MultiParamTypeClasses
  --fkValue :: Proxy a -> ResourceTag -> Integer
  fkValue _ = resource_id
  fkName _ _ = "resource_id"

instance RelationalResource a => AssocOneToMany a ResourceTag where -- requires FlexibleInstances & MultiParamTypeClasses
  polyDiscriminatorName _ _ = "resource_type"
  polyDiscriminator r _ = resource_type r
  oneToManyFunctions = oneToManyFromRelational


-- helper functions to process tagged resources:
restrictByTagQuery :: RelationalResource a => Proxy a -> String -> SqlCommand -> SqlCommand
restrictByTagQuery pr tagname selectQuery = restrictAttrInSubQuery (tableName pr ++ ".id" ,resourceIdsQuery) selectQuery
                                where
                                 resourceIdsQuery :: SqlCommand
                                 resourceIdsQuery = projectJustAttrs ["DISTINCT resource_id"] $
                                                     sqlSelect [("resource_type", resourceType pr),("tag",tagname)] [] resourceTagProxy