14 import Control.Arrow.ArrowIO
15 import Control.Concurrent.STM
16 import Control.Exception
18 import Control.Monad.Trans
21 import Rakka.Storage.DefaultPage
22 import Subversion.Types
23 import System.Directory
24 import System.FilePath
26 import System.Log.Logger
27 import System.Posix.Files
28 import System.Posix.Types
29 import System.Posix.IO
30 import Subversion.FileSystem
31 import Subversion.Repository
32 import Text.HyperEstraier hiding (WriteLock)
34 logger = "Rakka.Storage"
39 stoIndexRevLocked :: !(TVar Bool)
40 , stoIndexRevFile :: !FilePath
41 , stoIndexDB :: !Database
42 , stoRepository :: !Repository
43 , stoMakeDraft :: !(Page -> IO Document)
47 mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage
48 mkStorage lsdir repos mkDraft
49 = do let indexDir = lsdir </> "index"
50 revFile = lsdir </> "indexRev"
52 revLocked <- newTVarIO False
53 indexDB <- openIndex indexDir revFile
56 stoIndexRevLocked = revLocked
57 , stoIndexRevFile = revFile
58 , stoIndexDB = indexDB
59 , stoRepository = repos
60 , stoMakeDraft = mkDraft
67 getPage :: MonadIO m => Storage -> PageName -> m (Maybe Page)
69 = liftIO $ loadDefaultPage name -- FIXME
72 putPage :: MonadIO m => Storage -> Maybe RevNum -> Page -> m ()
73 putPage sto oldRev page
74 = error "FIXME: not implemented"
77 getPageA :: ArrowIO a => Storage -> a PageName (Maybe Page)
78 getPageA = arrIO . getPage
81 putPageA :: ArrowIO a => Storage -> a (Maybe RevNum, Page) ()
82 putPageA = arrIO2 . putPage
85 findAllPages :: Storage -> RevNum -> IO (Set PageName)
86 findAllPages sto revNum
87 = findAllDefaultPages -- FIXME
90 findChangedPages :: Storage -> RevNum -> RevNum -> IO (Set PageName)
91 findChangedPages sto 0 newRev = findAllPages sto newRev
92 findChangedPages sto oldRev newRev
93 = fail "fixme: not impl"
96 getCurrentRevNum :: Storage -> IO RevNum
98 = getRepositoryFS (stoRepository sto) >>= getYoungestRev
101 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
102 -- indexDir と revFile を削除してから casket を R/W モードで開く。
103 openIndex :: FilePath -> FilePath -> IO Database
104 openIndex indexDir revFile
105 = do ret <- openDatabase indexDir (Writer [])
108 -> do debugM logger ("Opened an H.E. database on " ++ indexDir)
112 -> do warningM logger ("Failed to open an H.E. database on "
113 ++ indexDir ++ ": " ++ show err)
115 indexExists <- doesDirectoryExist indexDir
117 $ removeDirectoryRecursive indexDir
119 revFileExists <- doesFileExist revFile
123 Right db <- openDatabase indexDir (Writer [Create []])
124 noticeM logger ("Created an H.E. database on " ++ indexDir)
129 syncIndex :: Storage -> IO ()
131 = updateIndexRev sto $ \ oldRev ->
132 do debugM logger ("The index revision is currently " ++ show oldRev)
134 newRev <- getCurrentRevNum sto
135 debugM logger ("The repository revision is currently " ++ show newRev)
137 when (newRev /= oldRev) (syncIndex' oldRev newRev)
139 return oldRev -- FIXME
142 syncIndex' :: RevNum -> RevNum -> IO ()
143 syncIndex' oldRev newRev
144 = do pages <- findChangedPages sto oldRev newRev
148 updateIndexRev :: Storage -> (RevNum -> IO RevNum) -> IO ()
149 updateIndexRev sto f = bracket acquireLock releaseLock update
153 = do atomically $ do revLocked <- readTVar (stoIndexRevLocked sto)
157 writeTVar (stoIndexRevLocked sto) True
158 fd <- openFd (stoIndexRevFile sto) ReadWrite (Just stdFileMode) defaultFileFlags
159 waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
162 releaseLock :: Fd -> IO ()
164 = do setLock fd (Unlock, AbsoluteSeek, 0, 0)
165 atomically $ writeTVar (stoIndexRevLocked sto) False
167 update :: Fd -> IO ()
169 = do fdSeek fd AbsoluteSeek 0
170 size <- return . fromIntegral . fileSize =<< getFdStatus fd
171 (revStr, gotSize) <- fdRead fd size
172 when (size /= gotSize) $ fail ("read " ++ show gotSize ++
173 " bytes but expected " ++ show size ++ " bytes")
175 let rev = case revStr of
181 let revStr' = show rev' ++ "\n"
182 size' = fromIntegral $ length revStr'
184 fdSeek fd AbsoluteSeek 0
186 wroteSize <- fdWrite fd revStr'
187 when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
188 " bytes but expected " ++ show size' ++ " bytes")