Rakka/Storage/Impl.hs

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