merge branch origin/master

[Rakka.git] / Rakka / Resource / TrackBack.hs

diff --git a/Rakka/Resource/TrackBack.hs b/Rakka/Resource/TrackBack.hs
deleted file mode 100644 (file)
index 1bcdbf9..0000000
--- a/Rakka/Resource/TrackBack.hs
+++ /dev/null
@@ -1,154 +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           Data.Time
-import           Network.Browser
-import           Network.HTTP
-import           Network.HTTP.Lucu
-import           Network.HTTP.Lucu.Response
-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 = UTF8.decodeString . joinPath
-
-
-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)
-                   if isSuccessful st then
-                       outputResponse NoError
-                     else
-                       setStatus st
-
-
-validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
-validateTrackBack form
-    = do let title    = get' "title"
-             excerpt  = get' "excerpt"
-             blogName = get' "blog_name"
-         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 )
-                                                           , (a_output_encoding, utf8)
-                                                           , (a_no_xml_pi      , v_0 ) ]
-                                   )
-         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