started implementing trackback receiver

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

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