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