Rakka/Environment.hs

   1 module Rakka.Environment
   2     ( Environment(..)
   3     , InterpTable
   4     , setupEnv
   5     )
   6     where
   7
   8 import           Control.Arrow
   9 import           Control.Arrow.ArrowList
  10 import qualified Data.Map as M
  11 import           Network.Socket
  12 import qualified Network.HTTP.Lucu.Config as LC
  13 import           Rakka.Authorization
  14 import           Rakka.Page
  15 import           Rakka.Storage
  16 import           Rakka.SystemConfig
  17 import           Rakka.Wiki.Engine
  18 import           Rakka.Wiki.Interpreter
  19 import qualified Rakka.Wiki.Interpreter.Base      as Base
  20 import qualified Rakka.Wiki.Interpreter.Image     as Image
  21 import qualified Rakka.Wiki.Interpreter.PageList  as PageList
  22 --import qualified Rakka.Wiki.Interpreter.Trackback as Trackback
  23 import qualified Rakka.Wiki.Interpreter.Outline   as Outline
  24 import           Subversion.Repository
  25 import           System.Directory
  26 import           System.FilePath
  27 import           System.Log.Logger
  28 import           Text.HyperEstraier
  29 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  30
  31
  32 logger :: String
  33 logger = "Rakka.Environment"
  34
  35
  36 data Environment = Environment {
  37       envLocalStateDir :: !FilePath
  38     , envLucuConf      :: !LC.Config
  39     , envRepository    :: !Repository
  40     , envSysConf       :: !SystemConfig
  41     , envStorage       :: !Storage
  42     , envInterpTable   :: !InterpTable
  43     , envAuthDB        :: !AuthDB
  44     }
  45
  46
  47 setupEnv :: FilePath -> ServiceName -> IO Environment
  48 setupEnv lsdir portNum
  49     = do let lucuConf    = LC.defaultConfig {
  50                              LC.cnfServerPort = portNum
  51                            }
  52              reposPath   = lsdir </> "repos"
  53              interpTable = mkInterpTable
  54
  55          reposExist  <- doesDirectoryExist reposPath
  56          repos       <- if reposExist then
  57                             do debugM logger ("Found a subversion repository on " ++ reposPath)
  58                                openRepository reposPath
  59                         else
  60                             do noticeM logger ("Creating a subversion repository on " ++ reposPath)
  61                                createRepository reposPath [] []
  62          sysConf     <- mkSystemConfig lucuConf repos
  63          storage     <- mkStorage lsdir repos (makeDraft' interpTable)
  64          authDB      <- mkAuthDB lsdir
  65
  66          return Environment {
  67                       envLocalStateDir = lsdir
  68                     , envLucuConf      = lucuConf
  69                     , envRepository    = repos
  70                     , envSysConf       = sysConf
  71                     , envStorage       = storage
  72                     , envInterpTable   = interpTable
  73                     , envAuthDB        = authDB
  74                     }
  75     where
  76       makeDraft' :: InterpTable -> Page -> IO Document
  77       makeDraft' interpTable page
  78           = do [doc] <- runX ( setErrorMsgHandler False fail
  79                                >>>
  80                                constA page
  81                                >>>
  82                                xmlizePage
  83                                >>>
  84                                makeDraft interpTable
  85                              )
  86                return doc
  87
  88
  89 mkInterpTable :: InterpTable
  90 mkInterpTable = listToTable $
  91                 foldl (++) [] [ Base.interpreters
  92                               , Image.interpreters
  93                               , PageList.interpreters
  94                               --, Trackback.interpreters
  95                               , Outline.interpreters
  96                               ]
  97     where
  98       listToTable :: [Interpreter] -> InterpTable
  99       listToTable xs
 100           = M.fromList [ (commandName x, x) | x <- xs ]