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          mapM (fromId $ map fst hint) ids
 193     where
 194       fromId :: [String] -> DocumentID -> IO SearchResult
 195       fromId words docId
 196           = do uri     <- getDocURI index docId
 197                rev     <- getDocAttr index docId "rakka:revision"
 198                           >>= return . read . fromJust
 199                snippet <- unsafeInterleaveIO $
 200                           do doc <- getDocument index docId [NoAttributes, NoKeywords]
 201                              sn  <- makeSnippet doc words 300 80 80
 202                              return (trim (== Boundary) $ map toFragment sn)
 203                return SearchResult {
 204                             srPageName = decodePageName $ uriPath uri
 205                           , srPageRev  = rev
 206                           , srSnippet  = snippet
 207                           }
 208
 209       toFragment :: Either String (String, String) -> SnippetFragment
 210       toFragment (Left "")      = Boundary
 211       toFragment (Left t)       = NormalText t
 212       toFragment (Right (w, _)) = HighlightedWord w
 213
 214
 215 updateIndex :: Database
 216             -> Repository
 217             -> (Page -> IO Document)
 218             -> RevNum
 219             -> PageName
 220             -> IO ()
 221 updateIndex index repos mkDraft rev name
 222     = do pageM <- getPage' repos name (Just rev)
 223          case pageM of
 224            -- ページが削除された
 225            Nothing
 226                -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
 227                      case docIdM of
 228                        Nothing    -> return ()
 229                        Just docId -> do removeDocument index docId [CleaningRemove]
 230                                         infoM logger ("Removed page " ++ name ++ " from the index")
 231            Just page
 232                -> do draft <- mkDraft page
 233                      putDocument index draft [CleaningPut]
 234                      infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
 235
 236
 237 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
 238 updateIndexRev revFile f = withFile revFile ReadWriteMode update
 239     where
 240       update :: Handle -> IO ()
 241       update h = do eof  <- hIsEOF h
 242                     rev  <- if eof then
 243                                 return 0
 244                             else
 245                                 hGetLine h >>= return . read
 246                     rev' <- f rev
 247                     hSeek h AbsoluteSeek 0
 248                     hSetFileSize h 0
 249                     hPutStrLn h (show rev')