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