Rakka/Environment.hs

   1 module Rakka.Environment
   2     ( Environment(..)
   3     , InterpTable
   4     , setupEnv
   5     , getInterpTable
   6     , getInterpTableA
   7     )
   8     where
   9
  10 import           Control.Concurrent.STM
  11 import           Control.Arrow.ArrowIO
  12 import           Data.Map (Map)
  13 import qualified Data.Map as M
  14 import           Network
  15 import qualified Network.HTTP.Lucu.Config as LC
  16 import           Rakka.Storage
  17 import           Rakka.SystemConfig
  18 import           Rakka.Wiki.Interpreter
  19 import           Rakka.Wiki.Interpreter.Base
  20 import           Subversion.Repository
  21 import           System.Directory
  22 import           System.FilePath
  23 import           System.Log.Logger
  24
  25 logger = "Rakka.Environment"
  26
  27
  28 data Environment = Environment {
  29       envLocalStateDir :: !FilePath
  30     , envLucuConf      :: !LC.Config
  31     , envRepository    :: !Repository
  32     , envStorage       :: !Storage
  33     , envSysConf       :: !SystemConfig
  34     , envInterpTable   :: !(TVar InterpTable)
  35     }
  36
  37
  38 type InterpTable = Map String Interpreter
  39
  40
  41 setupEnv :: FilePath -> PortNumber -> IO Environment
  42 setupEnv lsdir portNum
  43     = do let lucuConf  = LC.defaultConfig {
  44                            LC.cnfServerPort = PortNumber portNum
  45                          }
  46              reposPath = lsdir `combine` "repos"
  47              storage   = mkStorage
  48
  49          reposExist  <- doesDirectoryExist reposPath
  50          repos       <- if reposExist then
  51                             do debugM logger ("Found a subversion repository on " ++ reposPath)
  52                                openRepository reposPath
  53                         else
  54                             do noticeM logger ("Creating a subversion repository on " ++ reposPath)
  55                                createRepository reposPath [] []
  56          sysConf     <- mkSystemConfig lucuConf repos
  57          interpTable <- mkInterpTable
  58
  59          return $ Environment {
  60                       envLocalStateDir = lsdir
  61                     , envLucuConf      = lucuConf
  62                     , envRepository    = repos
  63                     , envStorage       = storage
  64                     , envSysConf       = sysConf
  65                     , envInterpTable   = interpTable
  66                     }
  67
  68
  69 mkInterpTable :: IO (TVar InterpTable)
  70 mkInterpTable = newTVarIO (listToTable baseInterpreters)
  71     where
  72       listToTable :: [Interpreter] -> InterpTable
  73       listToTable xs
  74           = M.fromList [ (commandName x, x) | x <- xs ]
  75
  76
  77 getInterpTable :: Environment -> IO InterpTable
  78 getInterpTable = atomically . readTVar . envInterpTable
  79
  80
  81 getInterpTableA :: ArrowIO a => Environment -> a b InterpTable
  82 getInterpTableA = arrIO0 . getInterpTable