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           Data.Time
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           Rakka.Storage
import           Rakka.SystemConfig
import           Rakka.TrackBack
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 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 <- validateTrackBack form
         case tbParamM of
           Nothing
               -> return ()
           Just tbParam
               -> do cited <- liftIO $ checkCitation tbParam name
                     if cited then
                         do pageM <- getPage (envStorage env) name Nothing
                            case pageM of
                              Nothing   -> setStatus NotFound
                              Just page -> addTB tbParam page
                       else
                         outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
    where
      addTB :: TrackBack -> Page -> Resource ()
      addTB tbParam page
          | isRedirect page
              = do BaseURI baseURI <- getSysConf (envSysConf env)
                   redirect TemporaryRedirect (mkPageURI baseURI $ redirName page)
          | otherwise
              = do tbListM <- return . fromMaybe [] =<< getAttachment (envStorage env) (pageName page) "trackbacks" Nothing
                   st      <- putAttachment (envStorage env) Nothing Nothing (pageName page) "trackbacks" (tbParam : tbListM)
                   setStatus st


validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
validateTrackBack 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
                        -> do time <- liftIO getCurrentTime
                              return $ Just TrackBack {
                                           tbTitle    = title
                                         , tbExcerpt  = excerpt
                                         , tbURL      = url
                                         , tbBlogName = blogName
                                         , tbTime     = time
                                         }
    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 :: TrackBack -> 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