X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FTrackBack.hs;h=df1f5c3f4e07a13cc114ca2c991d490ea4639660;hb=45bce2c29948649f74ada71f2fa851bdb812e96c;hp=ca2635738d6216b951aa932428591577bebd723e;hpb=d843e97aa04278677eaede4e50ef680af32867e7;p=Rakka.git

diff --git a/Rakka/Resource/TrackBack.hs b/Rakka/Resource/TrackBack.hs
deleted file mode 100644
index ca26357..0000000
--- a/Rakka/Resource/TrackBack.hs
+++ /dev/null
@@ -1,140 +0,0 @@
-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