Rakka/SystemConfig.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , OverloadedStrings
   4   , ScopedTypeVariables
   5   , UnicodeSyntax
   6   #-}
   7 module Rakka.SystemConfig
   8     ( SystemConfig
   9     , SysConfValue(..)
  10
  11     , mkSystemConfig -- private
  12
  13     , getSysConf
  14     , getSysConfA
  15
  16     , setSysConf
  17     , setSysConfA
  18
  19     , SiteName(..)
  20     , BaseURI(..)
  21     , DefaultPage(..)
  22     , StyleSheet(..)
  23     , Languages(..)
  24     , GlobalLock(..)
  25
  26     , serializeTextPairs
  27     , deserializeTextPairs
  28     , serializeMap
  29     , deserializeMap
  30     )
  31     where
  32 import Control.Applicative
  33 import           Codec.Binary.UTF8.String
  34 import           Control.Arrow.ArrowIO
  35 import Control.Arrow.Unicode
  36 import           Control.Concurrent.STM
  37 import           Control.Monad
  38 import           Control.Monad.Trans
  39 import Control.Monad.Unicode
  40 import qualified Data.ByteString.Char8 as C8
  41 import qualified Data.ByteString.Lazy  as L
  42 import qualified Data.CaseInsensitive as CI
  43 import           Data.Dynamic
  44 import           Data.Map (Map)
  45 import qualified Data.Map as M
  46 import           Data.Maybe
  47 import Data.Monoid.Unicode
  48 import Data.Text (Text)
  49 import qualified Data.Text as T
  50 import qualified Data.Text.Encoding as T
  51 import           GHC.Conc (unsafeIOToSTM)
  52 import           Network.BSD
  53 import qualified Network.HTTP.Lucu.Config as LC
  54 import           Network.HTTP.Lucu hiding (Config)
  55 import           Network.URI hiding (path)
  56 import Prelude.Unicode
  57 import           Rakka.Page
  58 import           Rakka.Utils
  59 import           Subversion.FileSystem
  60 import           Subversion.FileSystem.Revision
  61 import           Subversion.FileSystem.Root
  62 import           Subversion.FileSystem.Transaction
  63 import           Subversion.Repository
  64 import           Subversion.Types
  65 import           System.FilePath.Posix
  66 import System.IO.Unsafe
  67 import           System.Log.Logger
  68
  69 logger :: String
  70 logger = "Rakka.SystemConfig"
  71
  72
  73 data SystemConfig = SystemConfig {
  74       scLucuConf   :: !LC.Config
  75     , scRepository :: !Repository
  76     , scCache      :: !(TVar (Map FilePath Dynamic))
  77     }
  78
  79 class (Typeable α, Show α, Eq α) ⇒ SysConfValue α where
  80     confPath     ∷ α → FilePath
  81     serialize    ∷ α → Text
  82     deserialize  ∷ Text → Maybe α
  83     defaultValue ∷ SystemConfig → α
  84
  85 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
  86 mkSystemConfig lc repos
  87     = do cache <- newTVarIO M.empty
  88          return SystemConfig {
  89                       scLucuConf   = lc
  90                     , scRepository = repos
  91                     , scCache      = cache
  92                     }
  93
  94 getSysConf ∷ ∀m a. (MonadIO m, SysConfValue a) ⇒ SystemConfig → m a
  95 getSysConf sc
  96     = liftIO $ atomically $
  97       do cache ← readTVar (scCache sc)
  98          let path = confPath ((⊥) ∷ a)
  99          case M.lookup path cache of
 100            Just val → pure ∘ fromJust $ fromDynamic val
 101            Nothing  → do val ← unsafeIOToSTM (getSysConf' sc)
 102                          writeTVar (scCache sc) (M.insert path (toDyn val) cache)
 103                          return val
 104
 105 getSysConf' ∷ ∀α. SysConfValue α ⇒ SystemConfig → IO α
 106 getSysConf' sc
 107     = do let path = fromConfPath $ confPath ((⊥) ∷ α)
 108          fs    ← getRepositoryFS (scRepository sc)
 109          rev   ← getYoungestRev fs
 110          value ← withRevision fs rev
 111                  $ do exists ← isFile path
 112                       case exists of
 113                         True
 114                             → do str ← getFileContentsLBS path
 115                                  return $ Just $ T.pack $ chomp $ decode $ L.unpack str
 116                         False
 117                             → return Nothing
 118          case value of
 119            Just str
 120                → case deserialize str of
 121                    Just val
 122                        → debugM logger ("Got a config value at `" ⊕ path ⊕ "': " ⊕ show val) ≫
 123                          return val
 124                    Nothing
 125                        → fail ("Got an invalid config value at `" ⊕ path ⊕ "': " ⊕ show str)
 126            Nothing
 127                → do let val = defaultValue sc
 128                     debugM logger ("Got no config value at `" ⊕ path ⊕ "'. Defaulting to " ⊕ show val)
 129                     return val
 130
 131 setSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> String -> a -> m StatusCode
 132 setSysConf sc userID value
 133     = liftIO $
 134       do let path = confPath (undefined :: a)
 135
 136          current <- getSysConf sc
 137          if current == value
 138             then return NotModified
 139             else do atomically $ do cache <- readTVar (scCache sc)
 140                                     writeTVar (scCache sc) (M.delete path cache)
 141                     setSysConf' sc userID value
 142
 143
 144 setSysConf' ∷ ∀α. SysConfValue α ⇒ SystemConfig → String → α → IO StatusCode
 145 setSysConf' sc userID value
 146     = do let path  = fromConfPath $ confPath ((⊥) ∷ α)
 147              str   = (L.fromChunks ∘ (:[]) ∘ T.encodeUtf8 $ serialize value) ⊕ "\n"
 148              repos = scRepository sc
 149          fs  ← getRepositoryFS repos
 150          rev ← getYoungestRev fs
 151          ret ← doReposTxn
 152                repos
 153                rev
 154                userID
 155                (Just "Automatic commit by Rakka for systemConfig update")
 156                $ do exists ← isFile path
 157                     unless exists
 158                         $ createValueEntry path
 159                     applyTextLBS path Nothing str
 160          case ret of
 161            Left  _ → return Conflict
 162            Right _ → do debugM logger ("Set a config value at `" ⊕ path ⊕ "': " ⊕ show value)
 163                         return Created
 164     where
 165     createValueEntry ∷ FilePath → Txn ()
 166     createValueEntry path
 167         = do createParentDirectories path
 168              makeFile path
 169
 170     createParentDirectories ∷ FilePath → Txn ()
 171     createParentDirectories path
 172         = do let parentPath = takeDirectory path
 173              kind ← checkPath parentPath
 174              case kind of
 175                NoNode   → createParentDirectories parentPath ≫
 176                           makeDirectory parentPath
 177                FileNode → fail ("createParentDirectories: already exists a file: " ⊕ parentPath)
 178                DirNode  → return ()
 179
 180 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
 181 getSysConfA = arrIO0 . getSysConf
 182
 183
 184 setSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> String -> a c StatusCode
 185 setSysConfA = (arrIO .) . setSysConf
 186
 187
 188 fromConfPath :: FilePath -> FilePath
 189 fromConfPath = ("/config" </>)
 190
 191 serializeTextPairs ∷ [(Text, Text)] → Text
 192 serializeTextPairs = T.intercalate "\n" ∘ (serializePair' <$>)
 193     where
 194       serializePair' ∷ (Text, Text) → Text
 195       serializePair' (a, b) = a ⊕ " " ⊕ b
 196
 197 serializeMap ∷ (k → Text) → (v → Text) → Map k v → Text
 198 serializeMap f g = serializeTextPairs ∘ ((f ⁂ g) <$>) ∘ M.toList
 199
 200 deserializeTextPairs ∷ Text → Maybe [(Text, Text)]
 201 deserializeTextPairs = mapM deserializePair' ∘ T.lines
 202     where
 203       deserializePair' ∷ Text → Maybe (Text, Text)
 204       deserializePair' s = case T.breakOn " " s of
 205                              (a, b)
 206                                  | (¬) (T.null b) → Just (a, T.tail b)
 207                              _                    → Nothing
 208
 209 deserializeMap ∷ Ord k ⇒ (Text → k) → (Text → v) → Text → Maybe (Map k v)
 210 deserializeMap f g = (M.fromList ∘ ((f ⁂ g) <$>) <$>) ∘ deserializeTextPairs
 211
 212 newtype SiteName = SiteName Text deriving (Show, Typeable, Eq)
 213 instance SysConfValue SiteName where
 214     confPath _                = "siteName"
 215     serialize (SiteName name) = name
 216     deserialize               = Just . SiteName
 217     defaultValue _            = SiteName "Rakka"
 218
 219 newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq)
 220 instance SysConfValue BaseURI where
 221     confPath _              = "baseURI"
 222     serialize (BaseURI uri) = T.pack $ uriToString id uri ""
 223     deserialize uri         = fmap BaseURI
 224                               $ do parsed ← parseURI (T.unpack uri)
 225                                    when (uriPath parsed        ≡ "" ) mzero
 226                                    when (last (uriPath parsed) ≠ '/') mzero
 227                                    when (uriQuery parsed       ≠ "" ) mzero
 228                                    when (uriFragment parsed    ≠ "" ) mzero
 229                                    return parsed
 230     defaultValue sc
 231         = let conf = scLucuConf sc
 232               host = C8.unpack $ LC.cnfServerHost conf
 233               port = unsafePerformIO $
 234                      do ent <- getServiceByName (LC.cnfServerPort conf) "tcp"
 235                         return (servicePort ent)
 236               -- FIXME: There should be a way to change configurations
 237               -- without web interface nor direct repository
 238               -- modification.
 239               defaultURI
 240                   = "http://" ++ host ++
 241                     (if port == 80
 242                      then ""
 243                      else ':' : show port) ++ "/"
 244           in
 245             BaseURI $ fromJust $ parseURI defaultURI
 246
 247 newtype DefaultPage = DefaultPage Text deriving (Show, Typeable, Eq)
 248 instance SysConfValue DefaultPage where
 249     confPath _                   = "defaultPage"
 250     serialize (DefaultPage name) = name
 251     deserialize                  = Just . DefaultPage
 252     defaultValue _               = DefaultPage "MainPage"
 253
 254 newtype StyleSheet = StyleSheet Text deriving (Show, Typeable, Eq)
 255 instance SysConfValue StyleSheet where
 256     confPath _                  = "styleSheet"
 257     serialize (StyleSheet name) = name
 258     deserialize                 = Just . StyleSheet
 259     defaultValue _              = StyleSheet "StyleSheet/Default"
 260
 261 newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq)
 262 instance SysConfValue Languages where
 263     confPath _                  = "languages"
 264     serialize (Languages langs) = serializeMap CI.foldedCase id langs
 265     deserialize                 = (Languages <$>) ∘ deserializeMap CI.mk id
 266     defaultValue _
 267         = Languages $ M.fromList [ ("en", "English"  )
 268                                  , ("es", "Español"  )
 269                                  , ("de", "Deutsch"  )
 270                                  , ("fi", "Suomi"    )
 271                                  , ("fr", "Français" )
 272                                  , ("ga", "Gaeilge"  )
 273                                  , ("gd", "Gàidhlig" )
 274                                  , ("ja", "日本語"  )
 275                                  , ("pt", "Português")
 276                                  , ("sv", "Svenska"  )
 277                                  ]
 278
 279
 280 newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable, Eq)
 281 instance SysConfValue GlobalLock where
 282     confPath _      = "globalLock"
 283     serialize (GlobalLock isLocked)
 284         | isLocked  = "*"
 285         | otherwise = ""
 286     deserialize "*" = Just (GlobalLock True)
 287     deserialize ""  = Just (GlobalLock False)
 288     deserialize _   = Nothing
 289     defaultValue _  = GlobalLock False