+-- -*- coding: utf-8 -*-
+{-# LANGUAGE
+ DoAndIfThenElse
+ , RecordWildCards
+ , ScopedTypeVariables
+ , UnicodeSyntax
+ #-}
module Rakka.Storage.Repos
( findAllPagesInRevision
, getDirContentsInRevision
, putAttachmentIntoRepository
)
where
-
+import Control.Applicative
import Codec.Binary.UTF8.String
-import Control.Exception
import Control.Monad
+import Control.Monad.Unicode
+import qualified Data.CaseInsensitive as CI
import Data.List
import qualified Data.Map as M
import Data.Maybe
+import Data.Monoid.Unicode
import Data.Set (Set)
import qualified Data.Set as S hiding (Set)
+import qualified Data.Text as T
import Data.Time
+import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu hiding (redirect)
+import Prelude.Unicode
import Rakka.Attachment
import Rakka.Page
import Rakka.SystemConfig
import Rakka.Utils
-import Rakka.W3CDateTime
-import Subversion.Error
import Subversion.FileSystem
import Subversion.FileSystem.DirEntry
import Subversion.FileSystem.Revision
traverse :: FilePath -> Rev (Set PageName)
traverse dir
- = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
+ = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir))
traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
traverse' dir entry
decodePath :: FilePath -> PageName
decodePath = decodePageName . makeRelative root . dropExtension
-
getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
getDirContentsInRevision repos dir rev
= do fs <- getRepositoryFS repos
path = mkDirPath dir
getDir' :: Rev [PageName]
- getDir' = getDirEntries path >>= return . map entToName
-
- entToName :: DirEntry -> PageName
- entToName = (dir </>) . decodePageName . dropExtension . entName
+ getDir' = liftM (map entToName) (getDirEntries path)
+ entToName ∷ DirEntry → PageName
+ entToName = T.pack ∘ (T.unpack dir </>) ∘ T.unpack ∘ decodePageName ∘ dropExtension ∘ entName
findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
findChangedPagesAtRevision repos rev
= do fs <- getRepositoryFS repos
withRevision fs rev
- $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
+ $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged
where
accumulatePages :: Set PageName -> FilePath -> Set PageName
accumulatePages s path
withRevision fs rev'
$ do exists <- isFile path
if exists then
- return . Just =<< loadPage'
+ return . Just =<< loadPage' fs
else
return Nothing
where
path :: FilePath
path = mkPagePath name
- loadPage' :: Rev Page
- loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
- case mType of
- Just (MIMEType "application" "x-rakka-redirection" _)
- -> loadPageRedirect
- _
- -> loadPageEntity
-
- loadPageEntity :: Rev Page
- loadPageEntity
+ loadPage' :: FileSystem -> Rev Page
+ loadPage' fs
+ = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
+ case mType of
+ Just (MIMEType "application" "x-rakka-redirection" _)
+ -> loadPageRedirect fs
+ _
+ -> loadPageEntity fs
+
+ loadPageEntity :: FileSystem -> Rev Page
+ loadPageEntity fs
= do props <- getNodePropList path
hist <- getNodeHistory True path
content <- getFileContentsLBS path
$ fromMaybe "text/x-rakka"
$ fmap chomp (lookup "svn:mime-type" props)
- lastMod <- getRevisionProp "svn:date"
- >>= return . fromJust . parseW3CDateTime . chomp . fromJust
+ lastMod <- unsafeIOToFS $
+ liftM (fromJust . W3C.parse . chomp . fromJust)
+ (getRevisionProp' fs pageRev "svn:date")
return Entity {
entityName = name
, entityType = mimeType
- , entityLanguage = fmap chomp (lookup "rakka:lang" props)
+ , entityLanguage = CI.mk ∘ T.pack ∘ chomp <$> lookup "rakka:lang" props
, entityIsTheme = any ((== "rakka:isTheme") . fst) props
, entityIsFeed = any ((== "rakka:isFeed") . fst) props
, entityIsLocked = any ((== "rakka:isLocked") . fst) props
, entityRevision = pageRev
, entityLastMod = zonedTimeToUTC lastMod
, entitySummary = fmap decodeString (lookup "rakka:summary" props)
- , entityOtherLang = fromMaybe M.empty
- $ fmap
- (M.fromList . fromJust . deserializeStringPairs . decodeString)
- (lookup "rakka:otherLang" props)
- , entityContent = content
+ , entityOtherLang = maybe (∅)
+ (fromJust ∘ deserializeMap CI.mk id ∘ T.pack ∘ decodeString)
+ (lookup "rakka:otherLang" props)
+ , entityContent = content
, entityUpdateInfo = undefined
}
- loadPageRedirect :: Rev Page
- loadPageRedirect
+ loadPageRedirect :: FileSystem -> Rev Page
+ loadPageRedirect fs
= do hist <- getNodeHistory True path
content <- getFileContents path
let pageRev = fst $ head hist
- dest = chomp $ decodeString content
+ dest = T.pack ∘ chomp $ decodeString content
- lastMod <- getRevisionProp "svn:date"
- >>= return . fromJust . parseW3CDateTime . chomp . fromJust
+ lastMod <- unsafeIOToFS $
+ liftM (fromJust . W3C.parse . chomp . fromJust)
+ (getRevisionProp' fs pageRev "svn:date")
- isLocked <- getRevisionProp "rakka:isLocked"
- >>= return . isJust
+ isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
return Redirection {
redirName = name
}
-putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
+putPageIntoRepository ∷ Repository → Maybe String → Page → IO StatusCode
putPageIntoRepository repos userID page
- = filterSvnError $
- do let name = pageName page
- author = fromMaybe "[Rakka]" userID
- case pageUpdateInfo page of
- Just ui
- -> do let oldRev = uiOldRevision ui
- denied <- case uiOldName ui of
- Nothing -> checkDenial oldRev name
- Just oldName -> checkDenial oldRev oldName
- if denied then
- return Forbidden
- else
- do ret <- doReposTxn
- repos
- (uiOldRevision ui)
- author
- (Just "Automatic commit by Rakka for page update")
- $ do case uiOldName ui of
- Nothing -> return ()
- Just oldName -> movePage (uiOldRevision ui) oldName name
- >>
- moveAttachments (uiOldRevision ui) oldName 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")
- $ do createPage name
- updatePage name
- case ret of
- Left _ -> return Conflict
- Right _ -> return Created
+ = 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
- checkDenial :: RevNum -> PageName -> IO Bool
- checkDenial rev name
- = do fs <- getRepositoryFS repos
+ 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 prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
- case prop of
- Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
- Nothing -> return False
+ $ 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
deleteEmptyParentDirectories oldPath
createPage :: PageName -> Txn ()
- createPage name
- = do let path = mkPagePath name
+ createPage name'
+ = do let path = mkPagePath name'
createParentDirectories path
makeFile path
- updatePage :: PageName -> Txn ()
- updatePage name
- | isRedirect page = updatePageRedirect name
- | isEntity page = updatePageEntity name
+ 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
+ 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:isBinary" Nothing
setNodeProp path "rakka:summary" Nothing
setNodeProp path "rakka:otherLang" Nothing
- applyText path Nothing (encodeString (redirDest page) ++ "\n")
+ 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" (entityLanguage page)
- setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
- setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
+ 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" (fmap encodeString $ entitySummary page)
- setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
- in
- if M.null otherLang then
- Nothing
- else
- Just (encodeString $ serializeStringPairs $ M.toList otherLang))
+ 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
deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
deletePageFromRepository repos userID name
- = filterSvnError $
- do let pagePath = mkPagePath name
+ = do let pagePath = mkPagePath name
attachmentPath = mkAttachmentDirPath name
fs <- getRepositoryFS repos
rev <- getYoungestRev fs
else
return NotFound
when (status == NoContent)
- $ do doReposTxn repos
+ $ ( (doReposTxn repos
rev
"[Rakka]"
(Just "Automatic commit by Rakka for page deleting")
attachmentExists <- isDirectory attachmentPath
when attachmentExists
$ do deleteEntry attachmentPath
- deleteEmptyParentDirectories attachmentPath
- return ()
+ deleteEmptyParentDirectories attachmentPath)
+ >> return () )
return status
deleteEmptyParentDirectories parentPath
-loadAttachmentInRepository :: forall a. Attachment a =>
- Repository
- -> PageName
- -> String
- -> Maybe RevNum
- -> IO (Maybe a)
+loadAttachmentInRepository ∷ ∀α. Attachment α
+ ⇒ Repository
+ → PageName
+ → String
+ → Maybe RevNum
+ → IO (Maybe α)
loadAttachmentInRepository repos pName aName rev
= do fs <- getRepositoryFS repos
rev' <- case rev of
else
return Nothing
where
- path :: FilePath
+ path ∷ FilePath
path = mkAttachmentPath pName aName
- loadAttachment' :: Rev a
- loadAttachment' = getFileContents path >>= return . deserializeFromString . decodeString
-
+ loadAttachment' ∷ Rev α
+ loadAttachment' = (deserializeFromString ∘ decodeString)
+ `liftM` getFileContents path
putAttachmentIntoRepository :: Attachment a =>
Repository
-> a
-> IO StatusCode
putAttachmentIntoRepository repos userID oldRev pName aName attachment
- = filterSvnError $
- do let author = fromMaybe "[Rakka]" userID
+ = do let author = fromMaybe "[Rakka]" userID
path = mkAttachmentPath pName aName
fs <- getRepositoryFS repos
oldRev' <- case oldRev of
unless exists
$ do createParentDirectories path
makeFile path
- applyText path Nothing (serializeToString attachment)
+ applyText path Nothing (encodeString $ serializeToString attachment)
case ret of
Left _ -> return Conflict
Right _ -> return NoContent
-
-
-filterSvnError :: IO a -> IO a
-filterSvnError f = catchDyn f rethrow
- where
- rethrow :: SvnError -> IO a
- rethrow err
- = let code = svnErrCode err
- msg = svnErrMsg err
- in
- fail $ "SvnError: " ++ (show code) ++ ": " ++ msg