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           Data.Time
  20 import           Network.HTTP.Lucu
  21 import           Network.HTTP.Lucu.Utils
  22 import           Network.URI
  23 import           Prelude hiding (words)
  24 import           Rakka.Attachment
  25 import           Rakka.Page
  26 import           Rakka.Storage.DefaultPage
  27 import           Rakka.Storage.Repos
  28 import           Rakka.Storage.Types
  29 import           Rakka.W3CDateTime
  30 import           Subversion.Types
  31 import           Subversion.FileSystem
  32 import           Subversion.Repository
  33 import           System.Directory
  34 import           System.FilePath
  35 import           System.IO
  36 import           System.IO.Unsafe
  37 import           System.Log.Logger
  38 import           Text.HyperEstraier hiding (WriteLock)
  39
  40
  41 logger :: String
  42 logger = "Rakka.Storage"
  43
  44
  45 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
  46 getPage' repos name rev
  47     = do page <- loadPageInRepository repos name rev
  48          case page of
  49            Nothing -> loadDefaultPage name
  50            p       -> return p
  51
  52
  53 putPage' :: Repository -> Maybe String -> Page -> IO StatusCode
  54 putPage' = putPageIntoRepository
  55
  56
  57 deletePage' :: Repository -> Maybe String -> PageName -> IO StatusCode
  58 deletePage' = deletePageFromRepository
  59
  60
  61 findAllPages :: Repository -> RevNum -> IO (Set PageName)
  62 findAllPages _     0   = findAllDefaultPages
  63 findAllPages repos rev = do reposPages   <- findAllPagesInRevision repos rev
  64                             defaultPages <- findAllDefaultPages
  65                             return (reposPages `S.union` defaultPages)
  66
  67
  68 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
  69 findChangedPages repos 0      newRev = findAllPages repos newRev
  70 findChangedPages repos oldRev newRev
  71     = liftM S.unions (mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev])
  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 "@mdate"         SeqIndex
 162                      addAttrIndex index "@type"          StrIndex
 163                      addAttrIndex index "@uri"           SeqIndex
 164                      addAttrIndex index "rakka:revision" SeqIndex
 165                      addAttrIndex index "rakka:isTheme"  StrIndex
 166                      addAttrIndex index "rakka:isFeed"   StrIndex
 167                      noticeM logger ("Created an H.E. index on " ++ indexDir)
 168
 169                      return index
 170
 171
 172 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
 173 syncIndex' index revFile repos mkDraft
 174     = updateIndexRev revFile $ \ oldRev ->
 175       do debugM logger ("The index revision is currently " ++ show oldRev)
 176
 177          newRev <- getCurrentRevNum repos
 178          debugM logger ("The repository revision is currently " ++ show newRev)
 179
 180          when (oldRev == 0 || newRev /= oldRev)
 181               $ syncIndex'' oldRev newRev
 182          return newRev
 183     where
 184       syncIndex'' :: RevNum -> RevNum -> IO ()
 185       syncIndex'' oldRev newRev
 186           = do pages <- findChangedPages repos oldRev newRev
 187                mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
 188
 189
 190 searchIndex :: Database -> Condition -> IO SearchResult
 191 searchIndex index cond
 192     = do (ids, hint) <- searchDatabase' index cond
 193          let (total, words) = parseHint hint
 194          pages <- mapM (fromId words) ids
 195          return SearchResult {
 196                       srTotal = total
 197                     , srPages = pages
 198                     }
 199     where
 200       parseHint :: [(String, Int)] -> (Int, [String])
 201       parseHint xs
 202           = let total = fromJust $ lookup "" xs
 203                 words = filter (/= "") $ map fst xs
 204             in
 205               (total, words)
 206
 207       fromId :: [String] -> DocumentID -> IO HitPage
 208       fromId words docId
 209           = do uri     <- getDocURI index docId
 210                rev     <- unsafeInterleaveIO $
 211                           liftM (read . fromJust)
 212                                 (getDocAttr index docId "rakka:revision")
 213                lastMod <- unsafeInterleaveIO $
 214                           liftM (zonedTimeToUTC . fromJust . parseW3CDateTime . fromJust)
 215                                 (getDocAttr index docId "@mdate")
 216                summary <- unsafeInterleaveIO $
 217                           getDocAttr index docId "rakka:summary"
 218                snippet <- unsafeInterleaveIO $
 219                           do doc <- getDocument index docId [NoAttributes, NoKeywords]
 220                              sn  <- makeSnippet doc words 300 80 80
 221                              return (trim (== Boundary) $ map toFragment sn)
 222                return HitPage {
 223                             hpPageName = decodePageName $ uriPath uri
 224                           , hpPageRev  = rev
 225                           , hpLastMod  = lastMod
 226                           , hpSummary  = summary
 227                           , hpSnippet  = snippet
 228                           }
 229
 230       toFragment :: Either String (String, String) -> SnippetFragment
 231       toFragment (Left "")      = Boundary
 232       toFragment (Left t)       = NormalText t
 233       toFragment (Right (w, _)) = HighlightedWord w
 234
 235
 236 updateIndex :: Database
 237             -> Repository
 238             -> (Page -> IO Document)
 239             -> RevNum
 240             -> PageName
 241             -> IO ()
 242 updateIndex index repos mkDraft rev name
 243     = do pageM <- getPage' repos name (Just rev)
 244          case pageM of
 245            -- ページが削除された
 246            Nothing
 247                -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
 248                      case docIdM of
 249                        Nothing    -> return ()
 250                        Just docId -> do removeDocument index docId [CleaningRemove]
 251                                         infoM logger ("Removed page " ++ name ++ " from the index")
 252            Just page
 253                -> do draft <- mkDraft page
 254                      putDocument index draft [CleaningPut]
 255                      infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
 256
 257
 258 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
 259 updateIndexRev revFile f = withFile revFile ReadWriteMode update
 260     where
 261       update :: Handle -> IO ()
 262       update h = do eof  <- hIsEOF h
 263                     rev  <- if eof then
 264                                 return 0
 265                             else
 266                                 liftM read (hGetLine h)
 267                     rev' <- f rev
 268                     hSeek h AbsoluteSeek 0
 269                     hSetFileSize h 0
 270                     hPutStrLn h (show rev')