+ loadPageRedirect :: FileSystem -> Rev Page
+ loadPageRedirect fs
+ = do hist <- getNodeHistory True path
+ content <- getFileContents path
+
+ let pageRev = fst $ head hist
+ dest = T.pack ∘ chomp $ decodeString content
+
+ lastMod <- unsafeIOToFS $
+ liftM (fromJust . W3C.parse . chomp . fromJust)
+ (getRevisionProp' fs pageRev "svn:date")
+
+ isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
+
+ return Redirection {
+ redirName = name
+ , redirDest = dest
+ , redirIsLocked = isLocked
+ , redirRevision = pageRev
+ , redirLastMod = zonedTimeToUTC lastMod
+ , redirUpdateInfo = undefined
+ }
+
+
+putPageIntoRepository ∷ Repository → Maybe String → Page → IO StatusCode
+putPageIntoRepository repos userID page
+ = case pageUpdateInfo page of
+ Just ui
+ → do let oldRev = uiOldRevision ui
+ denied ← case uiOldName ui of
+ Nothing → shouldDeny oldRev name
+ Just oldName → shouldDeny oldRev oldName
+ if denied then
+ pure Forbidden
+ else
+ do rev ← if oldRev ≡ 0 then
+ getRepositoryFS repos ≫= getYoungestRev
+ else
+ return oldRev
+ ret ← doReposTxn repos
+ rev
+ author
+ (Just "Automatic commit by Rakka for page update")
+ $ do case uiOldName ui of
+ Nothing → return ()
+ Just oldName → do exists ← isFile (mkPagePath oldName)
+ when exists
+ ( movePage (uiOldRevision ui) oldName name ≫
+ moveAttachments (uiOldRevision ui) oldName name
+ )
+ exists ← isFile (mkPagePath name)
+ unless exists
+ $ createPage name
+ updatePage name
+ case ret of
+ Left _ → return Conflict
+ Right _ → return Created
+ Nothing
+ → do fs ← getRepositoryFS repos
+ rev ← getYoungestRev fs
+ ret ← doReposTxn repos
+ rev
+ author
+ (Just "Automatic commit by Rakka for page creation")
+ $ (createPage name ≫ updatePage name)
+ case ret of
+ Left _ → return Conflict
+ Right _ → return Created
+ where
+ name ∷ PageName
+ name = pageName page
+
+ author ∷ String
+ author = fromMaybe "[Rakka]" userID
+
+ shouldDeny ∷ RevNum → PageName → IO Bool
+ shouldDeny rev name'
+ = do fs ← getRepositoryFS repos
+ withRevision fs rev
+ $ do exists ← isFile (mkPagePath name')
+ if exists then
+ do prop ← getNodeProp (mkPagePath name') "rakka:isLocked"
+ case prop of
+ Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
+ Nothing -> return False
+ else
+ return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの…
+
+ movePage :: RevNum -> PageName -> PageName -> Txn ()
+ movePage oldRev oldName newName
+ = do let oldPath = mkPagePath oldName
+ newPath = mkPagePath newName
+ createParentDirectories newPath
+ copyEntry oldRev oldPath 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'
+ createParentDirectories path
+ makeFile path
+
+ updatePage ∷ PageName → Txn ()
+ updatePage name'
+ | isRedirect page = updatePageRedirect name'
+ | isEntity page = updatePageEntity name'
+ | otherwise = fail "neither redirection nor page"
+
+ updatePageRedirect :: PageName -> Txn ()
+ updatePageRedirect name'
+ = do let path = mkPagePath name'
+ setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
+ setNodeProp path "rakka:lang" Nothing
+ setNodeProp path "rakka:isTheme" Nothing
+ setNodeProp path "rakka:isFeed" Nothing
+ setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
+ setNodeProp path "rakka:isBinary" Nothing
+ setNodeProp path "rakka:summary" Nothing
+ setNodeProp path "rakka:otherLang" Nothing
+ applyText path Nothing (encodeString (T.unpack $ redirDest page) ⊕ "\n")
+
+ updatePageEntity :: PageName -> Txn ()
+ updatePageEntity name'
+ = do let path = mkPagePath name'
+ setNodeProp path "svn:mime-type" (Just ∘ show $ entityType page)
+ setNodeProp path "rakka:lang" (T.unpack ∘ CI.foldedCase <$> entityLanguage page)
+ setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
+ setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
+ setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
+ setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
+ setNodeProp path "rakka:summary" (encodeString <$> entitySummary page)
+ setNodeProp path "rakka:otherLang" ( if M.null (entityOtherLang page) then
+ Nothing
+ else
+ Just ∘ T.unpack ∘ serializeMap CI.foldedCase id
+ $ entityOtherLang page
+ )
+ applyTextLBS path Nothing (entityContent page)
+
+ encodeFlag :: Bool -> Maybe String
+ encodeFlag True = Just "*"
+ encodeFlag False = Nothing
+
+
+createParentDirectories :: FilePath -> Txn ()
+createParentDirectories path
+ = do let parentPath = takeDirectory path
+ kind <- checkPath parentPath
+ case kind of
+ NoNode -> do createParentDirectories parentPath
+ makeDirectory parentPath
+ FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
+ DirNode -> return ()
+
+
+deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
+deletePageFromRepository repos userID name
+ = do let pagePath = mkPagePath name
+ attachmentPath = mkAttachmentDirPath name
+ fs <- getRepositoryFS repos
+ rev <- getYoungestRev fs
+ status <- withRevision fs rev
+ $ do exists <- isFile pagePath
+ if exists then
+ do prop <- getNodeProp pagePath "rakka:isLocked"
+ return $ case prop of
+ Just _
+ -> if isNothing userID then
+ -- 施錠されてゐるので匿名では駄目
+ Forbidden
+ else
+ NoContent
+ Nothing
+ -> NoContent
+ else
+ return NotFound
+ when (status == NoContent)
+ $ ( (doReposTxn repos
+ rev
+ "[Rakka]"
+ (Just "Automatic commit by Rakka for page deleting")
+ $ do deleteEntry pagePath
+ deleteEmptyParentDirectories pagePath
+
+ attachmentExists <- isDirectory attachmentPath
+ when attachmentExists
+ $ do deleteEntry attachmentPath
+ deleteEmptyParentDirectories attachmentPath)
+ >> return () )
+ return status
+
+
+deleteEmptyParentDirectories :: FilePath -> Txn ()
+deleteEmptyParentDirectories path
+ = do let parentPath = takeDirectory path
+ contents <- getDirEntries parentPath
+ when (null contents)
+ $ do deleteEntry parentPath
+ deleteEmptyParentDirectories parentPath
+
+
+loadAttachmentInRepository ∷ ∀α. Attachment α
+ ⇒ Repository
+ → PageName
+ → String
+ → Maybe RevNum
+ → IO (Maybe α)
+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 α
+ loadAttachment' = (deserializeFromString ∘ decodeString)
+ `liftM` getFileContents path
+
+putAttachmentIntoRepository :: Attachment a =>
+ Repository
+ -> Maybe String
+ -> Maybe RevNum
+ -> PageName
+ -> String
+ -> a
+ -> IO StatusCode
+putAttachmentIntoRepository repos userID oldRev pName aName attachment
+ = 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 (encodeString $ serializeToString attachment)
+ case ret of
+ Left _ -> return Conflict
+ Right _ -> return NoContent