Rakka/Resource/TrackBack.hs

   1 module Rakka.Resource.TrackBack
   2     ( resTrackBack
   3     )
   4     where
   5
   6 import qualified Codec.Binary.UTF8.String as UTF8
   7 import           Control.Arrow
   8 import           Control.Arrow.ArrowList
   9 import           Control.Monad.Trans
  10 import           Data.List
  11 import           Data.Maybe
  12 import           Network.Browser
  13 import           Network.HTTP
  14 import           Network.HTTP.Lucu
  15 import           Network.HTTP.Lucu.Utils
  16 import           Network.URI
  17 import           Rakka.Environment
  18 import           Rakka.Page
  19 import           Text.XML.HXT.Arrow.WriteDocument
  20 import           Text.XML.HXT.Arrow.XmlArrow
  21 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  22 import           Text.XML.HXT.DOM.TypeDefs
  23 import           Text.XML.HXT.DOM.XmlKeywords
  24
  25
  26 data TBParam
  27     = TBParam {
  28         tbTitle    :: !(Maybe String)
  29       , tbExcerpt  :: !(Maybe String)
  30       , tbURL      :: !URI
  31       , tbBlogName :: !(Maybe String)
  32       }
  33     deriving (Show, Eq)
  34
  35
  36 data TBResponse
  37     = NoError
  38     | Error !Int !String
  39     deriving (Show, Eq)
  40
  41
  42 resTrackBack :: Environment -> ResourceDef
  43 resTrackBack env
  44     = ResourceDef {
  45         resUsesNativeThread = False
  46       , resIsGreedy         = True
  47       , resGet              = Nothing
  48       , resHead             = Nothing
  49       , resPost             = Just $ getPathInfo >>= handlePost env . toPageName
  50       , resPut              = Nothing
  51       , resDelete           = Nothing
  52       }
  53     where
  54       toPageName :: [String] -> PageName
  55       toPageName = decodePageName . joinWith "/"
  56
  57
  58 handlePost :: Environment -> PageName -> Resource ()
  59 handlePost env name
  60     = do form     <- inputForm defaultLimit
  61          tbParamM <- validateTBParam form
  62          case tbParamM of
  63            Nothing
  64                -> return ()
  65            Just tbParam
  66                -> do cited <- liftIO $ checkCitation tbParam name
  67                      if cited then
  68                          fail "not impl"
  69                        else
  70                          outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
  71
  72
  73 validateTBParam :: [(String, String)] -> Resource (Maybe TBParam)
  74 validateTBParam form
  75     = do let title    = get' "title"
  76              excerpt  = get' "excerpt"
  77              blogName = get' "blogName"
  78          case get' "url" of
  79            Nothing
  80                -> do outputResponse (Error 1 "Parameter `url' is missing.")
  81                      return Nothing
  82            Just u
  83                -> case parseURI u of
  84                     Nothing
  85                         -> do outputResponse (Error 1 "Parameter `url' is malformed.")
  86                               return Nothing
  87                     Just url
  88                         -> return $ Just TBParam {
  89                                     tbTitle    = title
  90                                   , tbExcerpt  = excerpt
  91                                   , tbURL      = url
  92                                   , tbBlogName = blogName
  93                                   }
  94     where
  95       get' :: String -> Maybe String
  96       get' = fmap UTF8.decodeString . flip lookup form
  97
  98
  99 outputResponse :: TBResponse -> Resource ()
 100 outputResponse res
 101     = do setContentType $ read "text/xml"
 102          [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
 103                                      >>>
 104                                      mkResponseTree
 105                                      >>>
 106                                      writeDocumentToString [ (a_indent, v_1) ]
 107                                    )
 108          output xmlStr
 109     where
 110       mkResponseTree :: ArrowXml a => a b XmlTree
 111       mkResponseTree
 112           = proc _
 113           -> ( eelem "/"
 114                += ( eelem "response"
 115                     += ( eelem "error"
 116                          += txt (case res of
 117                                    NoError      -> "0"
 118                                    Error code _ -> show code)
 119                        )
 120                     += ( case res of
 121                            NoError     -> none
 122                            Error _ msg -> ( eelem "message"
 123                                             += txt msg
 124                                           )
 125                        )
 126                   )
 127              ) -< ()
 128
 129
 130 checkCitation :: TBParam -> PageName -> IO Bool
 131 checkCitation param name
 132     = do (_, res) <- browse $
 133                      do setAllowRedirects True
 134                         setErrHandler (\ _ -> return ())
 135                         setOutHandler (\ _ -> return ())
 136                         request $ defaultGETRequest $ tbURL param
 137          case rspCode res of
 138            (2, 0, 0)
 139                -> return (encodePageName name `isInfixOf` rspBody res)
 140            _   -> return False