module Rakka.Resource.TrackBack
    ( resTrackBack
    )
    where

import qualified Codec.Binary.UTF8.String as UTF8
import           Control.Arrow
import           Control.Arrow.ArrowList
import           Control.Monad.Trans
import           Data.List
import           Data.Maybe
import           Network.Browser
import           Network.HTTP
import           Network.HTTP.Lucu
import           Network.HTTP.Lucu.Utils
import           Network.URI
import           Rakka.Environment
import           Rakka.Page
import           Text.XML.HXT.Arrow.WriteDocument
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.Arrow.XmlIOStateArrow
import           Text.XML.HXT.DOM.TypeDefs
import           Text.XML.HXT.DOM.XmlKeywords


data TBParam
    = TBParam {
        tbTitle    :: !(Maybe String)
      , tbExcerpt  :: !(Maybe String)
      , tbURL      :: !URI
      , tbBlogName :: !(Maybe String)
      }
    deriving (Show, Eq)


data TBResponse
    = NoError
    | Error !Int !String
    deriving (Show, Eq)


resTrackBack :: Environment -> ResourceDef
resTrackBack env
    = ResourceDef {
        resUsesNativeThread = False
      , resIsGreedy         = True
      , resGet              = Nothing
      , resHead             = Nothing
      , resPost             = Just $ getPathInfo >>= handlePost env . toPageName
      , resPut              = Nothing
      , resDelete           = Nothing
      }
    where
      toPageName :: [String] -> PageName
      toPageName = decodePageName . joinWith "/"


handlePost :: Environment -> PageName -> Resource ()
handlePost env name
    = do form     <- inputForm defaultLimit
         tbParamM <- validateTBParam form
         case tbParamM of
           Nothing
               -> return ()
           Just tbParam
               -> do cited <- liftIO $ checkCitation tbParam name
                     if cited then
                         fail "not impl"
                       else
                         outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")


validateTBParam :: [(String, String)] -> Resource (Maybe TBParam)
validateTBParam form
    = do let title    = get' "title"
             excerpt  = get' "excerpt"
             blogName = get' "blogName"
         case get' "url" of
           Nothing
               -> do outputResponse (Error 1 "Parameter `url' is missing.")
                     return Nothing
           Just u
               -> case parseURI u of
                    Nothing
                        -> do outputResponse (Error 1 "Parameter `url' is malformed.")
                              return Nothing
                    Just url
                        -> return $ Just TBParam {
                                    tbTitle    = title
                                  , tbExcerpt  = excerpt
                                  , tbURL      = url
                                  , tbBlogName = blogName
                                  }
    where
      get' :: String -> Maybe String
      get' = fmap UTF8.decodeString . flip lookup form


outputResponse :: TBResponse -> Resource ()
outputResponse res
    = do setContentType $ read "text/xml"
         [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
                                     >>>
                                     mkResponseTree
                                     >>>
                                     writeDocumentToString [ (a_indent, v_1) ]
                                   )
         output xmlStr
    where
      mkResponseTree :: ArrowXml a => a b XmlTree
      mkResponseTree 
          = proc _
          -> ( eelem "/"
               += ( eelem "response"
                    += ( eelem "error"
                         += txt (case res of
                                   NoError      -> "0"
                                   Error code _ -> show code)
                       )
                    += ( case res of
                           NoError     -> none
                           Error _ msg -> ( eelem "message"
                                            += txt msg
                                          )
                       )
                  )
             ) -< ()


checkCitation :: TBParam -> PageName -> IO Bool
checkCitation param name
    = do (_, res) <- browse $
                     do setAllowRedirects True
                        setErrHandler (\ _ -> return ())
                        setOutHandler (\ _ -> return ())
                        request $ defaultGETRequest $ tbURL param
         case rspCode res of
           (2, 0, 0)
               -> return (encodePageName name `isInfixOf` rspBody res)
           _   -> return False