Main-Is:
Main.hs
Other-Modules:
+ Rakka.Attachment
Rakka.Authorization
Rakka.Environment
Rakka.Page
Rakka.Storage.Types
Rakka.Storage.Impl
Rakka.SystemConfig
+ Rakka.TrackBack
Rakka.Utils
Rakka.Validation
Rakka.W3CDateTime
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)
--- /dev/null
+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
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.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.XmlKeywords
-data TBParam
- = TBParam {
- tbTitle :: !(Maybe String)
- , tbExcerpt :: !(Maybe String)
- , tbURL :: !URI
- , tbBlogName :: !(Maybe String)
- }
- deriving (Show, Eq)
-
-
data TBResponse
= NoError
| Error !Int !String
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"
-> 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
) -< ()
-checkCitation :: TBParam -> PageName -> IO Bool
+checkCitation :: TrackBack -> PageName -> IO Bool
checkCitation param name
= do (_, res) <- browse $
do setAllowRedirects True
, putPageA
, deletePageA
+ , getAttachment
+ , putAttachment
+
, getDirContents
, getDirContentsA
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
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
, deletePage'
, getDirContents'
, startIndexManager
+
+ , getAttachment'
+ , putAttachment'
)
where
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
= 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
, loadPageInRepository
, putPageIntoRepository
, deletePageFromRepository
+ , loadAttachmentInRepository
+ , putAttachmentIntoRepository
)
where
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
= "/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
(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
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
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
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
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
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
--- /dev/null
+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)
+
+
+{-
+ <trackbacks>
+ <trackback title="" url="" blogName="" time="">
+ excerpt...
+ </trackback>
+ ...
+ </trackbacks>
+-}
+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
projects / Rakka.git / commitdiff