From d843e97aa04278677eaede4e50ef680af32867e7 Mon Sep 17 00:00:00 2001 From: pho Date: Fri, 25 Jan 2008 19:12:21 +0900 Subject: [PATCH] started implementing trackback receiver darcs-hash:20080125101221-62b54-269cc3584759be8daaf13c996622a345f3966a96.gz --- Main.hs | 2 + Makefile | 5 +- Rakka.cabal | 25 +++++-- Rakka/Page.hs | 6 +- Rakka/Resource/TrackBack.hs | 140 ++++++++++++++++++++++++++++++++++++ schemas/rakka-page-1.0.rng | 26 ------- 6 files changed, 170 insertions(+), 34 deletions(-) create mode 100644 Rakka/Resource/TrackBack.hs diff --git a/Main.hs b/Main.hs index 77c17a1..4328e70 100644 --- 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 05b96a1..8bb305a 100644 --- 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 fa0bbe4..ee1f885 100644 --- 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 ec43df8..00406c2 100644 --- 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 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 812e1e1..c9dd03b 100644 --- a/schemas/rakka-page-1.0.rng +++ b/schemas/rakka-page-1.0.rng @@ -126,32 +126,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - -- 2.40.0