From e85b652169f502cffe1f6f7f927d8990e9c11499 Mon Sep 17 00:00:00 2001 From: pho Date: Mon, 28 Jan 2008 19:19:02 +0900 Subject: [PATCH] implemented things related to attachment darcs-hash:20080128101902-62b54-cd5f4c334200167f7770e0def9584cd8c5b8cfe0.gz --- Rakka.cabal | 10 ++-- Rakka/Attachment.hs | 46 ++++++++++++++++ Rakka/Resource/TrackBack.hs | 51 ++++++++++-------- Rakka/Storage.hs | 23 ++++++++ Rakka/Storage/Impl.hs | 24 +++++++++ Rakka/Storage/Repos.hs | 102 ++++++++++++++++++++++++++++++++--- Rakka/TrackBack.hs | 103 ++++++++++++++++++++++++++++++++++++ 7 files changed, 326 insertions(+), 33 deletions(-) create mode 100644 Rakka/Attachment.hs create mode 100644 Rakka/TrackBack.hs diff --git a/Rakka.cabal b/Rakka.cabal index ee1f885..d16fd38 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -59,6 +59,7 @@ Executable rakka Main-Is: Main.hs Other-Modules: + Rakka.Attachment Rakka.Authorization Rakka.Environment Rakka.Page @@ -76,6 +77,7 @@ Executable rakka Rakka.Storage.Types Rakka.Storage.Impl Rakka.SystemConfig + Rakka.TrackBack Rakka.Utils Rakka.Validation Rakka.W3CDateTime @@ -90,17 +92,17 @@ Executable rakka Rakka.Wiki.Formatter Rakka.Wiki.Parser Extensions: - Arrows, ExistentialQuantification, ScopedTypeVariables + Arrows, ExistentialQuantification, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances if flag(enable-profiling) GHC-Options: - -Wall -XDeriveDataTypeable -O2 -fvia-C -prof -auto-all + -Wall -O2 -fvia-C -prof -auto-all else if flag(hardest-optimization) GHC-Options: - -Wall -XDeriveDataTypeable -O2 -fvia-C -funbox-strict-fields + -Wall -O2 -fvia-C -funbox-strict-fields else GHC-Options: - -Wall -XDeriveDataTypeable + -Wall Executable RakkaUnitTest if flag(build-test-suite) diff --git a/Rakka/Attachment.hs b/Rakka/Attachment.hs new file mode 100644 index 0000000..06a9476 --- /dev/null +++ b/Rakka/Attachment.hs @@ -0,0 +1,46 @@ +module Rakka.Attachment + ( Attachment(..) + ) + where + +import Control.Arrow +import Control.Arrow.ArrowList +import System.IO.Unsafe +import Text.XML.HXT.Arrow.ReadDocument +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 + + +class Attachment t where + serializeToXmlTree :: (ArrowChoice a, ArrowXml a) => a t XmlTree + deserializeFromXmlTree :: (ArrowChoice a, ArrowXml a) => a XmlTree t + + serializeToString :: t -> String + serializeToString attachment + = unsafePerformIO $ + do [xmlStr] <- runX ( setErrorMsgHandler False fail + >>> + constA attachment + >>> + serializeToXmlTree + >>> + writeDocumentToString [ (a_indent, v_1) ] + ) + return xmlStr + + deserializeFromString :: String -> t + deserializeFromString source + = unsafePerformIO $ + do [ret] <- runX ( setErrorMsgHandler False fail + >>> + readString [ (a_validate , v_0) + , (a_check_namespaces , v_1) + , (a_remove_whitespace, v_0) + ] source + >>> + deserializeFromXmlTree + ) + return ret diff --git a/Rakka/Resource/TrackBack.hs b/Rakka/Resource/TrackBack.hs index ca26357..ad367cd 100644 --- a/Rakka/Resource/TrackBack.hs +++ b/Rakka/Resource/TrackBack.hs @@ -9,6 +9,7 @@ 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 @@ -16,6 +17,9 @@ import Network.HTTP.Lucu.Utils 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 @@ -23,16 +27,6 @@ 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 @@ -58,20 +52,33 @@ resTrackBack env handlePost :: Environment -> PageName -> Resource () handlePost env name = do form <- inputForm defaultLimit - tbParamM <- validateTBParam form + tbParamM <- validateTrackBack form case tbParamM of Nothing -> return () Just tbParam -> do cited <- liftIO $ checkCitation tbParam name if cited then - fail "not impl" + 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) + setStatus st -validateTBParam :: [(String, String)] -> Resource (Maybe TBParam) -validateTBParam form +validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack) +validateTrackBack form = do let title = get' "title" excerpt = get' "excerpt" blogName = get' "blogName" @@ -85,12 +92,14 @@ validateTBParam form -> do outputResponse (Error 1 "Parameter `url' is malformed.") return Nothing Just url - -> return $ Just TBParam { - tbTitle = title - , tbExcerpt = excerpt - , tbURL = url - , tbBlogName = blogName - } + -> 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 @@ -127,7 +136,7 @@ outputResponse res ) -< () -checkCitation :: TBParam -> PageName -> IO Bool +checkCitation :: TrackBack -> PageName -> IO Bool checkCitation param name = do (_, res) <- browse $ do setAllowRedirects True diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 9ab15be..d26f713 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -11,6 +11,9 @@ module Rakka.Storage , putPageA , deletePageA + , getAttachment + , putAttachment + , getDirContents , getDirContentsA @@ -26,6 +29,7 @@ import Control.Monad import Control.Monad.Trans import Data.Maybe import Network.HTTP.Lucu +import Rakka.Attachment import Rakka.Page import Rakka.Storage.Impl import Rakka.Storage.Types @@ -101,3 +105,22 @@ syncIndex :: Storage -> IO () syncIndex sto = atomically $ writeTChan (stoIndexChan sto) SyncIndex + +getAttachment :: (Attachment a, MonadIO m) => + Storage + -> PageName + -> String + -> Maybe RevNum + -> m (Maybe a) +getAttachment = (((liftIO .) .) .) . getAttachment' . stoRepository + + +putAttachment :: (Attachment a, MonadIO m) => + Storage + -> Maybe String + -> Maybe RevNum + -> PageName + -> String + -> a + -> m StatusCode +putAttachment = (((((liftIO .) .) .) .) .) . putAttachment' . stoRepository diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs index 7910892..fed687f 100644 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@ -4,6 +4,9 @@ module Rakka.Storage.Impl , deletePage' , getDirContents' , startIndexManager + + , getAttachment' + , putAttachment' ) where @@ -15,6 +18,7 @@ import Data.Set (Set) import qualified Data.Set as S import Network.HTTP.Lucu import Network.URI +import Rakka.Attachment import Rakka.Page import Rakka.Storage.DefaultPage import Rakka.Storage.Repos @@ -76,6 +80,26 @@ getCurrentRevNum repos = getRepositoryFS repos >>= getYoungestRev +getAttachment' :: Attachment a => + Repository + -> PageName + -> String + -> Maybe RevNum + -> IO (Maybe a) +getAttachment' = loadAttachmentInRepository + + +putAttachment' :: Attachment a => + Repository + -> Maybe String + -> Maybe RevNum + -> PageName + -> String + -> a + -> IO StatusCode +putAttachment' = putAttachmentIntoRepository + + startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq) startIndexManager lsdir repos mkDraft = do chan <- newTChanIO diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index 01f64c7..76889d7 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -5,6 +5,8 @@ module Rakka.Storage.Repos , loadPageInRepository , putPageIntoRepository , deletePageFromRepository + , loadAttachmentInRepository + , putAttachmentIntoRepository ) where @@ -18,6 +20,7 @@ import Data.Set (Set) import qualified Data.Set as S hiding (Set) import Data.Time import Network.HTTP.Lucu hiding (redirect) +import Rakka.Attachment import Rakka.Page import Rakka.SystemConfig import Rakka.Utils @@ -43,6 +46,16 @@ mkDirPath dir = "/pages" encodePageName dir +mkAttachmentPath :: PageName -> String -> FilePath +mkAttachmentPath pName aName + = "/attachments" encodePageName pName <.> "page" aName + + +mkAttachmentDirPath :: PageName -> FilePath +mkAttachmentDirPath pName + = "/attachments" encodePageName pName <.> "page" + + findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName) findAllPagesInRevision repos rev = do fs <- getRepositoryFS repos @@ -220,7 +233,9 @@ putPageIntoRepository repos userID page (Just "Automatic commit by Rakka for page update") $ do case uiOldName ui of Nothing -> return () - Just oldName -> renamePage (uiOldRevision ui) oldName name + Just oldName -> movePage (uiOldRevision ui) oldName name + >> + moveAttachments (uiOldRevision ui) oldName name updatePage name case ret of Left _ -> return Conflict @@ -248,8 +263,8 @@ putPageIntoRepository repos userID page Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目 Nothing -> return False - renamePage :: RevNum -> PageName -> PageName -> Txn () - renamePage oldRev oldName newName + movePage :: RevNum -> PageName -> PageName -> Txn () + movePage oldRev oldName newName = do let oldPath = mkPagePath oldName newPath = mkPagePath newName createParentDirectories newPath @@ -257,6 +272,15 @@ putPageIntoRepository repos userID page deleteEntry oldPath deleteEmptyParentDirectories oldPath + moveAttachments :: RevNum -> PageName -> PageName -> Txn () + moveAttachments oldRev oldName newName + = do let oldPath = mkAttachmentDirPath oldName + newPath = mkAttachmentDirPath newName + createParentDirectories newPath + copyEntry oldRev oldPath newPath + deleteEntry oldPath + deleteEmptyParentDirectories oldPath + createPage :: PageName -> Txn () createPage name = do let path = mkPagePath name @@ -319,13 +343,14 @@ createParentDirectories path deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode deletePageFromRepository repos userID name = filterSvnError $ - do let path = mkPagePath name + do let pagePath = mkPagePath name + attachmentPath = mkAttachmentDirPath name fs <- getRepositoryFS repos rev <- getYoungestRev fs status <- withRevision fs rev - $ do exists <- isFile path + $ do exists <- isFile pagePath if exists then - do prop <- getNodeProp path "rakka:isLocked" + do prop <- getNodeProp pagePath "rakka:isLocked" return $ case prop of Just _ -> if isNothing userID then @@ -342,8 +367,13 @@ deletePageFromRepository repos userID name rev "[Rakka]" (Just "Automatic commit by Rakka for page deleting") - $ do deleteEntry path - deleteEmptyParentDirectories path + $ do deleteEntry pagePath + deleteEmptyParentDirectories pagePath + + attachmentExists <- isDirectory attachmentPath + when attachmentExists + $ do deleteEntry attachmentPath + deleteEmptyParentDirectories attachmentPath return () return status @@ -357,6 +387,62 @@ deleteEmptyParentDirectories path deleteEmptyParentDirectories parentPath +loadAttachmentInRepository :: forall a. Attachment a => + Repository + -> PageName + -> String + -> Maybe RevNum + -> IO (Maybe a) +loadAttachmentInRepository repos pName aName rev + = do fs <- getRepositoryFS repos + rev' <- case rev of + Nothing -> getYoungestRev fs + Just r -> return r + withRevision fs rev' + $ do exists <- isFile path + if exists then + return . Just =<< loadAttachment' + else + return Nothing + where + path :: FilePath + path = mkAttachmentPath pName aName + + loadAttachment' :: Rev a + loadAttachment' = getFileContents path >>= return . deserializeFromString + + +putAttachmentIntoRepository :: Attachment a => + Repository + -> Maybe String + -> Maybe RevNum + -> PageName + -> String + -> a + -> IO StatusCode +putAttachmentIntoRepository repos userID oldRev pName aName attachment + = filterSvnError $ + do let author = fromMaybe "[Rakka]" userID + path = mkAttachmentPath pName aName + fs <- getRepositoryFS repos + oldRev' <- case oldRev of + Nothing -> getYoungestRev fs + Just r -> return r + ret <- doReposTxn + repos + oldRev' + author + (Just "Automatic commit by Rakka for putting attachment") + $ do exists <- isFile path + unless exists + $ do createParentDirectories path + makeFile path + applyText path Nothing (serializeToString attachment) + case ret of + Left _ -> return Conflict + Right _ -> return NoContent + + filterSvnError :: IO a -> IO a filterSvnError f = catchDyn f rethrow where diff --git a/Rakka/TrackBack.hs b/Rakka/TrackBack.hs new file mode 100644 index 0000000..2ea34cd --- /dev/null +++ b/Rakka/TrackBack.hs @@ -0,0 +1,103 @@ +module Rakka.TrackBack + ( TrackBack(..) + ) + where + +import Control.Arrow +import Control.Arrow.ArrowList +import Control.Arrow.ArrowTree +import Data.Maybe +import Data.Time +import Network.URI +import Rakka.Attachment +import Rakka.Utils +import Rakka.W3CDateTime +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlNodeSet +import Text.XML.HXT.DOM.TypeDefs + + +data TrackBack + = TrackBack { + tbTitle :: !(Maybe String) + , tbExcerpt :: !(Maybe String) + , tbURL :: !URI + , tbBlogName :: !(Maybe String) + , tbTime :: !UTCTime + } + deriving (Show, Eq) + + +{- + + + excerpt... + + ... + +-} +instance Attachment [TrackBack] where + serializeToXmlTree + = proc trackbacks + -> ( eelem "/" + += ( eelem "trackbacks" + += ( arrL id + >>> + tbToTree + ) + ) + ) -< trackbacks + where + tbToTree :: ArrowXml a => a TrackBack XmlTree + tbToTree + = proc tb + -> let title = case tbTitle tb of + Nothing -> none + Just t -> sattr "title" t + excerpt = case tbExcerpt tb of + Nothing -> none + Just e -> txt e + url = sattr "url" (uriToString id (tbURL tb) "") + blogName = case tbBlogName tb of + Nothing -> none + Just n -> sattr "blogName" n + time = sattr "time" (formatW3CDateTime $ utcToZonedTime utc (tbTime tb)) + in + ( eelem "trackback" + += title + += url + += blogName + += time + += excerpt + ) -<< () + + deserializeFromXmlTree + = proc doc + -> do tree <- getXPathTreesInDoc "/trackbacks/trackback" -< doc + tb <- treeToTb -< tree + listA this -< tb + where + treeToTb :: (ArrowChoice a, ArrowXml a) => a XmlTree TrackBack + treeToTb + = proc tree + -> do title <- maybeA (getAttrValue0 "title") -< tree + url <- ( getAttrValue0 "url" + >>> + arr (fromJust . parseURI) + ) -< tree + time <- ( getAttrValue0 "time" + >>> + arr (zonedTimeToUTC . fromJust . parseW3CDateTime) + ) -< tree + blogName <- maybeA (getAttrValue0 "blogName") -< tree + excerpt <- maybeA ( getChildren + >>> + getText + ) -< tree + returnA -< TrackBack { + tbTitle = title + , tbExcerpt = excerpt + , tbURL = url + , tbBlogName = blogName + , tbTime = time + } \ No newline at end of file -- 2.40.0