Rakka/Storage/Impl.hs

   1 module Rakka.Storage.Impl
   2     ( getPage'
   3     , startIndexManager
   4     )
   5     where
   6
   7 import           Control.Concurrent
   8 import           Control.Concurrent.STM
   9 import           Control.Exception
  10 import           Control.Monad
  11 import           Data.Maybe
  12 import           Data.Set (Set)
  13 import qualified Data.Set as S
  14 import           Network.URI
  15 import           Rakka.Page
  16 import           Rakka.Storage.DefaultPage
  17 import           Rakka.Storage.Repos
  18 import           Rakka.Storage.Types
  19 import           Subversion.Types
  20 import           Subversion.FileSystem
  21 import           Subversion.Repository
  22 import           System.Directory
  23 import           System.FilePath
  24 import           System.IO
  25 import           System.Log.Logger
  26 import           System.Posix.Files
  27 import           System.Posix.Types
  28 import           System.Posix.IO
  29 import           Text.HyperEstraier hiding (WriteLock)
  30
  31
  32 logger :: String
  33 logger = "Rakka.Storage"
  34
  35
  36 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
  37 getPage' repos name rev
  38     = do page <- loadPageInRepository repos name rev
  39          case page of
  40            Nothing -> loadDefaultPage name
  41            p       -> return p
  42
  43
  44 findAllPages :: Repository -> RevNum -> IO (Set PageName)
  45 findAllPages _     0   = findAllDefaultPages
  46 findAllPages repos rev = do reposPages   <- findAllPagesInRevision repos rev
  47                             defaultPages <- findAllDefaultPages
  48                             return (reposPages `S.union` defaultPages)
  49
  50
  51 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
  52 findChangedPages repos 0      newRev = findAllPages repos newRev
  53 findChangedPages repos oldRev newRev
  54     = findAllPages repos newRev -- FIXME
  55
  56
  57 getCurrentRevNum :: Repository -> IO RevNum
  58 getCurrentRevNum repos
  59     = getRepositoryFS repos >>= getYoungestRev
  60
  61
  62 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
  63 startIndexManager lsdir repos mkDraft
  64     = do chan  <- newTChanIO
  65          index <- openIndex indexDir revFile
  66          forkIO (loop chan index)
  67          return chan
  68     where
  69       indexDir = lsdir </> "index"
  70       revFile  = lsdir </> "indexRev"
  71
  72       loop :: TChan IndexReq -> Database -> IO ()
  73       loop chan index
  74           = do req <- atomically $ readTChan chan
  75                case req of
  76                  RebuildIndex
  77                      -> do noticeM logger "Rebuilding the H.E. index..."
  78                            closeDatabase index
  79                            removeDirectoryRecursive indexDir
  80                            index' <- openIndex indexDir revFile
  81                            syncIndex' index' revFile repos mkDraft
  82                            loop chan index'
  83
  84                  SyncIndex
  85                      -> do syncIndex' index revFile repos mkDraft
  86                            loop chan index
  87
  88                  SearchIndex cond var
  89                      -> do result <- searchIndex index cond
  90                            atomically $ putTMVar var result
  91                            loop chan index
  92
  93
  94 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
  95 -- indexDir と revFile を削除してから casket を R/W モードで開く。
  96 openIndex :: FilePath -> FilePath -> IO Database
  97 openIndex indexDir revFile
  98     = do ret <- openDatabase indexDir (Writer [])
  99          case ret of
 100            Right index
 101                -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
 102                      return index
 103
 104            Left err
 105                -> do noticeM logger ("Failed to open an H.E. index on "
 106                                      ++ indexDir ++ ": " ++ show err)
 107
 108                      indexExists <- doesDirectoryExist indexDir
 109                      when indexExists
 110                               $ removeDirectoryRecursive indexDir
 111
 112                      revFileExists <- doesFileExist revFile
 113                      when revFileExists
 114                               $ removeFile revFile
 115
 116                      Right index <- openDatabase indexDir (Writer [Create []])
 117                      addAttrIndex index "@uri"           SeqIndex
 118                      addAttrIndex index "rakka:revision" SeqIndex
 119                      noticeM logger ("Created an H.E. index on " ++ indexDir)
 120
 121                      return index
 122
 123
 124 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
 125 syncIndex' index revFile repos mkDraft
 126     = updateIndexRev revFile $ \ oldRev ->
 127       do debugM logger ("The index revision is currently " ++ show oldRev)
 128
 129          newRev <- getCurrentRevNum repos
 130          debugM logger ("The repository revision is currently " ++ show newRev)
 131
 132          when (oldRev == 0 || newRev /= oldRev)
 133               $ syncIndex'' oldRev newRev
 134          return newRev
 135     where
 136       syncIndex'' :: RevNum -> RevNum -> IO ()
 137       syncIndex'' oldRev newRev
 138           = do pages <- findChangedPages repos oldRev newRev
 139                mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
 140
 141
 142 searchIndex :: Database -> Condition -> IO [(PageName, RevNum)]
 143 searchIndex index cond
 144     = searchDatabase index cond >>= mapM fromId
 145     where
 146       fromId :: DocumentID -> IO (PageName, RevNum)
 147       fromId docId
 148           = do uri <- getDocURI index docId
 149                rev <- getDocAttr index docId "rakka:revision"
 150                       >>= return . read . fromJust
 151                return (decodePageName $ uriPath uri, rev)
 152
 153
 154 updateIndex :: Database
 155             -> Repository
 156             -> (Page -> IO Document)
 157             -> RevNum
 158             -> PageName
 159             -> IO ()
 160 updateIndex index repos mkDraft rev name
 161     = do pageM <- getPage' repos name (Just rev)
 162          case pageM of
 163            -- ページが削除された
 164            Nothing
 165                -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
 166                      case docIdM of
 167                        Nothing    -> return ()
 168                        Just docId -> do removeDocument index docId [CleaningRemove]
 169                                         infoM logger ("Removed page " ++ name ++ " from the index")
 170            Just page
 171                -> do draft <- mkDraft page
 172                      putDocument index draft [CleaningPut]
 173                      infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
 174
 175
 176 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
 177 updateIndexRev revFile f = bracket acquireLock releaseLock update
 178     where
 179       acquireLock :: IO Fd
 180       acquireLock
 181           = do fd <- openFd revFile ReadWrite (Just stdFileMode) defaultFileFlags
 182                waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
 183                return fd
 184
 185       releaseLock :: Fd -> IO ()
 186       releaseLock fd
 187           = setLock fd (Unlock, AbsoluteSeek, 0, 0)
 188
 189       update :: Fd -> IO ()
 190       update fd
 191           = do fdSeek fd AbsoluteSeek 0
 192                size <- return . fromIntegral . fileSize =<< getFdStatus fd
 193                (revStr, gotSize) <- fdRead fd size
 194                when (size /= gotSize) $ fail ("read " ++ show gotSize ++
 195                                               " bytes but expected " ++ show size ++ " bytes")
 196
 197                let rev = case revStr of
 198                            "" -> 0
 199                            _  -> read revStr
 200
 201                rev' <- f rev
 202
 203                let revStr' = show rev' ++ "\n"
 204                    size'   = fromIntegral $ length revStr'
 205
 206                fdSeek fd AbsoluteSeek 0
 207                setFdSize fd 0
 208                wroteSize <- fdWrite fd revStr'
 209                when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
 210                                                  " bytes but expected " ++ show size' ++ " bytes")