started implementing trackback receiver

darcs-hash:20080125101221-62b54-269cc3584759be8daaf13c996622a345f3966a96.gz

diff --git a/Main.hs b/Main.hs
index 77c17a16a4b5c212b9268e22a827baf456f2d8a4..4328e707b21c01614d0d7189c0c030a5a3665342 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -11,6 +11,7 @@ import           Rakka.Resource.JavaScript
 import           Rakka.Resource.PageEntity
 import           Rakka.Resource.Object
 import           Rakka.Resource.Render
+import           Rakka.Resource.TrackBack
 import           Rakka.Storage
 import           Subversion
 import           System.Console.GetOpt
@@ -142,6 +143,7 @@ resTree env
                 , (["js"       ], javaScript      )
                 , (["object"   ], resObject    env)
                 , (["render"   ], resRender    env)
+                , (["trackback"], resTrackBack env)
                 ]
 
 

diff --git a/Makefile b/Makefile
index 05b96a16cd13f597ae30aea1f69a368b6b05b227..8bb305a19adcc4a1e9e99063f99d277d1a224bab 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,8 @@
 CABAL_FILE = Rakka.cabal
 GHC        = ghc
 EXECUTABLE = sudo ./dist/build/rakka/rakka -p 8989 -l DEBUG
+#EXECUTABLE = sudo ./dist/build/rakka/rakka -p 8989 -l DEBUG +RTS -S -A60M -RTS
+#EXECUTABLE = sudo ./dist/build/rakka/rakka -p 8989 -l DEBUG +RTS -p -RTS
 
 build: dist/setup-config Setup
        $(MAKE) -C js $@
@@ -14,7 +16,8 @@ rebuild-index: build
 
 dist/setup-config: $(CABAL_FILE) configure Setup Rakka.buildinfo.in
        ./Setup configure --disable-optimization -fbuild-test-suite
-#      ./Setup configure -O
+#      ./Setup configure -fhardest-optimization
+#      ./Setup configure -fenable-profiling
 
 configure: configure.ac
        autoconf

diff --git a/Rakka.cabal b/Rakka.cabal
index fa0bbe4eac2fadf8f556ea2c38366af09ee196aa..ee1f885acc5b000666e1ccea83261c3299367a8e 100644 (file)
--- a/Rakka.cabal
+++ b/Rakka.cabal
@@ -42,10 +42,18 @@ Flag build-test-suite
     Description: Build the test suite.
     Default:     False
 
+Flag enable-profiling
+    Description: Enable profiling of the executable
+    Default:     False
+
+Flag hardest-optimization
+    Description: Make the executable as fast as possible
+    Default:     False
+
 Executable rakka
     Build-Depends:
-        Crypto, FileManip, HUnit, HsHyperEstraier, HsSVN, Lucu, base,
-        bytestring, containers, dataenc, directory, utf8-string,
+        Crypto, FileManip, HTTP, HUnit, HsHyperEstraier, HsSVN, Lucu,
+        base, bytestring, containers, dataenc, directory, utf8-string,
         filepath, hslogger, hxt, magic, mtl, network, parsec, stm,
         time, unix, zlib
     Main-Is:
@@ -61,6 +69,7 @@ Executable rakka
         Rakka.Resource.Object
         Rakka.Resource.PageEntity
         Rakka.Resource.Render
+        Rakka.Resource.TrackBack
         Rakka.Storage
         Rakka.Storage.DefaultPage
         Rakka.Storage.Repos
@@ -82,8 +91,16 @@ Executable rakka
         Rakka.Wiki.Parser
     Extensions:
         Arrows, ExistentialQuantification, ScopedTypeVariables
-    GHC-Options:
-        -Wall -XDeriveDataTypeable
+    if flag(enable-profiling)
+        GHC-Options:
+            -Wall -XDeriveDataTypeable -O2 -fvia-C -prof -auto-all
+    else
+        if flag(hardest-optimization)
+            GHC-Options:
+                -Wall -XDeriveDataTypeable -O2 -fvia-C -funbox-strict-fields
+        else
+            GHC-Options:
+                -Wall -XDeriveDataTypeable
 
 Executable RakkaUnitTest
     if flag(build-test-suite)

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index ec43df852c2d252ab758bfffe0e0e22ecf981c9d..00406c26fed53d30433c2b2a6c23fecb5817d224 100644 (file)
--- a/Rakka/Page.hs
+++ b/Rakka/Page.hs
@@ -151,14 +151,14 @@ encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
 mkPageURI :: URI -> PageName -> URI
 mkPageURI baseURI name
     = baseURI {
-        uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
+        uriPath = "/" </> uriPath baseURI </> encodePageName name <.> "html"
       }
 
 
 mkPageFragmentURI :: URI -> PageName -> String -> URI
 mkPageFragmentURI baseURI name fragment
     = baseURI {
-        uriPath     = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
+        uriPath     = "/" </> uriPath baseURI </> encodePageName name <.> "html"
       , uriFragment = ('#' : encodeFragment fragment)
       }
 
@@ -185,7 +185,7 @@ mkAuxiliaryURI baseURI basePath name
 mkFeedURI :: URI -> PageName -> URI
 mkFeedURI baseURI name
     = baseURI {
-        uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".rdf"]
+        uriPath = "/" </> uriPath baseURI </> encodePageName name <.> "rdf"
       }
 
 

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

diff --git a/schemas/rakka-page-1.0.rng b/schemas/rakka-page-1.0.rng
index 812e1e16700cccbf520e22b3ae0dd19c4a039707..c9dd03b280d18ed1f5ebb799e7ac46af39830d3b 100644 (file)
--- a/schemas/rakka-page-1.0.rng
+++ b/schemas/rakka-page-1.0.rng
@@ -126,32 +126,6 @@
           <text />
         </element>
       </choice>
-
-      <optional>
-        <element name="attachment">
-          <zeroOrMore>
-            <element name="entry">
-              <attribute name="name" />
-              <ref name="anyElement" />
-            </element>
-          </zeroOrMore>
-        </element>
-      </optional>
     </group>
   </define>
-
-  <define name="anyElement">
-    <element>
-      <anyName />
-      <zeroOrMore>
-        <choice>
-          <attribute>
-            <anyName />
-          </attribute>
-          <text />
-          <ref name="anyElement" />
-        </choice>
-      </zeroOrMore>
-    </element>
-  </define>
 </grammar>