X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FStorage%2FRepos.hs;h=6a90ed6e5365aebd1340cf9a80b11c8e7d0d2582;hp=a6977e67286e2b35d81ce71e710018616f926fc2;hb=42f51754dea02201aececaacbf194d714cd58aaf;hpb=98fd1cb53a837a9bda7145544c34872acb13a634 diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index a6977e6..6a90ed6 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -1,4 +1,10 @@ -- -*- coding: utf-8 -*- +{-# LANGUAGE + DoAndIfThenElse + , RecordWildCards + , ScopedTypeVariables + , UnicodeSyntax + #-} module Rakka.Storage.Repos ( findAllPagesInRevision , getDirContentsInRevision @@ -10,16 +16,21 @@ module Rakka.Storage.Repos , putAttachmentIntoRepository ) where - +import Control.Applicative import Codec.Binary.UTF8.String 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 Network.HTTP.Lucu hiding (redirect) +import Prelude.Unicode import Rakka.Attachment import Rakka.Page import Rakka.SystemConfig @@ -85,7 +96,6 @@ findAllPagesInRevision repos rev decodePath :: FilePath -> PageName decodePath = decodePageName . makeRelative root . dropExtension - getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName) getDirContentsInRevision repos dir rev = do fs <- getRepositoryFS repos @@ -105,9 +115,8 @@ getDirContentsInRevision repos dir rev getDir' :: Rev [PageName] getDir' = liftM (map entToName) (getDirEntries path) - entToName :: DirEntry -> PageName - entToName = (dir ) . decodePageName . dropExtension . entName - + entToName ∷ DirEntry → PageName + entToName = T.pack ∘ (T.unpack dir ) ∘ T.unpack ∘ decodePageName ∘ dropExtension ∘ entName findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName) findChangedPagesAtRevision repos rev @@ -169,7 +178,7 @@ loadPageInRepository repos name rev 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 @@ -181,11 +190,10 @@ loadPageInRepository repos name rev , 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 } @@ -195,7 +203,7 @@ loadPageInRepository repos name rev content <- getFileContents path let pageRev = fst $ head hist - dest = chomp $ decodeString content + dest = T.pack ∘ chomp $ decodeString content lastMod <- unsafeIOToFS $ liftM (fromJust . parseW3CDateTime . chomp . fromJust) @@ -213,63 +221,64 @@ loadPageInRepository repos name rev } -putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode +putPageIntoRepository ∷ Repository → Maybe String → Page → IO StatusCode putPageIntoRepository repos userID page - = 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 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 - $ do 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") - $ 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 exists <- isFile (mkPagePath name) + $ do exists ← isFile (mkPagePath name') if exists then - do prop <- getNodeProp (mkPagePath name) "rakka:isLocked" + do prop ← getNodeProp (mkPagePath name') "rakka:isLocked" case prop of Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目 Nothing -> return False @@ -295,20 +304,20 @@ putPageIntoRepository repos userID page 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 @@ -317,24 +326,24 @@ putPageIntoRepository repos userID page 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 @@ -399,12 +408,12 @@ deleteEmptyParentDirectories path 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 @@ -417,12 +426,12 @@ loadAttachmentInRepository repos pName aName rev else return Nothing where - path :: FilePath + path ∷ FilePath path = mkAttachmentPath pName aName - loadAttachment' :: Rev a - loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path) - + loadAttachment' ∷ Rev α + loadAttachment' = (deserializeFromString ∘ decodeString) + `liftM` getFileContents path putAttachmentIntoRepository :: Attachment a => Repository