Rakka/Storage/Impl.hs

   1 module Rakka.Storage.Impl
   2     ( getPage'
   3     , putPage'
   4     , deletePage'
   5     , getDirContents'
   6     , startIndexManager
   7
   8     , getAttachment'
   9     , putAttachment'
  10     )
  11     where
  12
  13 import           Control.Concurrent
  14 import           Control.Concurrent.STM
  15 import           Control.Monad
  16 import           Data.Maybe
  17 import           Data.Set (Set)
  18 import qualified Data.Set as S
  19 import           Network.HTTP.Lucu
  20 import           Network.HTTP.Lucu.Utils
  21 import           Network.URI
  22 import           Prelude hiding (words)
  23 import           Rakka.Attachment
  24 import           Rakka.Page
  25 import           Rakka.Storage.DefaultPage
  26 import           Rakka.Storage.Repos
  27 import           Rakka.Storage.Types
  28 import           Subversion.Types
  29 import           Subversion.FileSystem
  30 import           Subversion.Repository
  31 import           System.Directory
  32 import           System.FilePath
  33 import           System.IO
  34 import           System.IO.Unsafe
  35 import           System.Log.Logger
  36 import           Text.HyperEstraier hiding (WriteLock)
  37
  38
  39 logger :: String
  40 logger = "Rakka.Storage"
  41
  42
  43 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
  44 getPage' repos name rev
  45     = do page <- loadPageInRepository repos name rev
  46          case page of
  47            Nothing -> loadDefaultPage name
  48            p       -> return p
  49
  50
  51 putPage' :: Repository -> Maybe String -> Page -> IO StatusCode
  52 putPage' = putPageIntoRepository
  53
  54
  55 deletePage' :: Repository -> Maybe String -> PageName -> IO StatusCode
  56 deletePage' = deletePageFromRepository
  57
  58
  59 findAllPages :: Repository -> RevNum -> IO (Set PageName)
  60 findAllPages _     0   = findAllDefaultPages
  61 findAllPages repos rev = do reposPages   <- findAllPagesInRevision repos rev
  62                             defaultPages <- findAllDefaultPages
  63                             return (reposPages `S.union` defaultPages)
  64
  65
  66 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
  67 findChangedPages repos 0      newRev = findAllPages repos newRev
  68 findChangedPages repos oldRev newRev
  69     = mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev]
  70       >>=
  71       return . S.unions
  72
  73
  74 getDirContents' :: Repository -> PageName -> Maybe RevNum -> IO [PageName]
  75 getDirContents' repos name rev
  76     = do reposPages   <- getDirContentsInRevision repos name rev
  77          defaultPages <- getDefaultDirContents name
  78          return $ S.toList (reposPages `S.union` defaultPages)
  79
  80
  81 getCurrentRevNum :: Repository -> IO RevNum
  82 getCurrentRevNum repos
  83     = getRepositoryFS repos >>= getYoungestRev
  84
  85
  86 getAttachment' :: Attachment a =>
  87                   Repository
  88                -> PageName
  89                -> String
  90                -> Maybe RevNum
  91                -> IO (Maybe a)
  92 getAttachment' = loadAttachmentInRepository
  93
  94
  95 putAttachment' :: Attachment a =>
  96                   Repository
  97                -> Maybe String
  98                -> Maybe RevNum
  99                -> PageName
 100                -> String
 101                -> a
 102                -> IO StatusCode
 103 putAttachment' = putAttachmentIntoRepository
 104
 105
 106 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
 107 startIndexManager lsdir repos mkDraft
 108     = do chan  <- newTChanIO
 109          index <- openIndex indexDir revFile
 110          forkIO (loop chan index)
 111          return chan
 112     where
 113       indexDir = lsdir </> "index"
 114       revFile  = lsdir </> "indexRev"
 115
 116       loop :: TChan IndexReq -> Database -> IO ()
 117       loop chan index
 118           = do req <- atomically $ readTChan chan
 119                case req of
 120                  RebuildIndex
 121                      -> do noticeM logger "Rebuilding the H.E. index..."
 122                            closeDatabase index
 123                            removeDirectoryRecursive indexDir
 124                            index' <- openIndex indexDir revFile
 125                            syncIndex' index' revFile repos mkDraft
 126                            loop chan index'
 127
 128                  SyncIndex
 129                      -> do syncIndex' index revFile repos mkDraft
 130                            loop chan index
 131
 132                  SearchIndex cond var
 133                      -> do result <- searchIndex index cond
 134                            atomically $ putTMVar var result
 135                            loop chan index
 136
 137
 138 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
 139 -- indexDir と revFile を削除してから casket を R/W モードで開く。
 140 openIndex :: FilePath -> FilePath -> IO Database
 141 openIndex indexDir revFile
 142     = do ret <- openDatabase indexDir (Writer [])
 143          case ret of
 144            Right index
 145                -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
 146                      return index
 147
 148            Left err
 149                -> do noticeM logger ("Failed to open an H.E. index on "
 150                                      ++ indexDir ++ ": " ++ show err)
 151
 152                      indexExists <- doesDirectoryExist indexDir
 153                      when indexExists
 154                               $ removeDirectoryRecursive indexDir
 155
 156                      revFileExists <- doesFileExist revFile
 157                      when revFileExists
 158                               $ removeFile revFile
 159
 160                      Right index <- openDatabase indexDir (Writer [Create []])
 161                      addAttrIndex index "@type"          StrIndex
 162                      addAttrIndex index "@uri"           SeqIndex
 163                      addAttrIndex index "rakka:revision" SeqIndex
 164                      addAttrIndex index "rakka:isTheme"  StrIndex
 165                      addAttrIndex index "rakka:isFeed"   StrIndex
 166                      noticeM logger ("Created an H.E. index on " ++ indexDir)
 167
 168                      return index
 169
 170
 171 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
 172 syncIndex' index revFile repos mkDraft
 173     = updateIndexRev revFile $ \ oldRev ->
 174       do debugM logger ("The index revision is currently " ++ show oldRev)
 175
 176          newRev <- getCurrentRevNum repos
 177          debugM logger ("The repository revision is currently " ++ show newRev)
 178
 179          when (oldRev == 0 || newRev /= oldRev)
 180               $ syncIndex'' oldRev newRev
 181          return newRev
 182     where
 183       syncIndex'' :: RevNum -> RevNum -> IO ()
 184       syncIndex'' oldRev newRev
 185           = do pages <- findChangedPages repos oldRev newRev
 186                mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
 187
 188
 189 searchIndex :: Database -> Condition -> IO SearchResult
 190 searchIndex index cond
 191     = do (ids, hint) <- searchDatabase' index cond
 192          let (total, words) = parseHint hint
 193          pages <- mapM (fromId words) ids
 194          return SearchResult {
 195                       srTotal = total
 196                     , srPages = pages
 197                     }
 198     where
 199       parseHint :: [(String, Int)] -> (Int, [String])
 200       parseHint xs
 201           = let total = fromJust $ lookup "" xs
 202                 words = filter (/= "") $ map fst xs
 203             in
 204               (total, words)
 205
 206       fromId :: [String] -> DocumentID -> IO HitPage
 207       fromId words docId
 208           = do uri     <- getDocURI index docId
 209                rev     <- getDocAttr index docId "rakka:revision"
 210                           >>= return . read . fromJust
 211                snippet <- unsafeInterleaveIO $
 212                           do doc <- getDocument index docId [NoAttributes, NoKeywords]
 213                              sn  <- makeSnippet doc words 300 80 80
 214                              return (trim (== Boundary) $ map toFragment sn)
 215                return HitPage {
 216                             hpPageName = decodePageName $ uriPath uri
 217                           , hpPageRev  = rev
 218                           , hpSnippet  = snippet
 219                           }
 220
 221       toFragment :: Either String (String, String) -> SnippetFragment
 222       toFragment (Left "")      = Boundary
 223       toFragment (Left t)       = NormalText t
 224       toFragment (Right (w, _)) = HighlightedWord w
 225
 226
 227 updateIndex :: Database
 228             -> Repository
 229             -> (Page -> IO Document)
 230             -> RevNum
 231             -> PageName
 232             -> IO ()
 233 updateIndex index repos mkDraft rev name
 234     = do pageM <- getPage' repos name (Just rev)
 235          case pageM of
 236            -- ページが削除された
 237            Nothing
 238                -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
 239                      case docIdM of
 240                        Nothing    -> return ()
 241                        Just docId -> do removeDocument index docId [CleaningRemove]
 242                                         infoM logger ("Removed page " ++ name ++ " from the index")
 243            Just page
 244                -> do draft <- mkDraft page
 245                      putDocument index draft [CleaningPut]
 246                      infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
 247
 248
 249 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
 250 updateIndexRev revFile f = withFile revFile ReadWriteMode update
 251     where
 252       update :: Handle -> IO ()
 253       update h = do eof  <- hIsEOF h
 254                     rev  <- if eof then
 255                                 return 0
 256                             else
 257                                 hGetLine h >>= return . read
 258                     rev' <- f rev
 259                     hSeek h AbsoluteSeek 0
 260                     hSetFileSize h 0
 261                     hPutStrLn h (show rev')