Rakka/Storage/Impl.hs

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