Fixing build breakage...

[Rakka.git] / Rakka / SystemConfig.hs

diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs
index eb526fbc45939a6863d2fc139fd2a45876f8138c..c151427263a45e65c966ba8deb66f969098f522f 100644 (file)
--- a/Rakka/SystemConfig.hs
+++ b/Rakka/SystemConfig.hs
@@ -7,18 +7,20 @@ module Rakka.SystemConfig
     , getSysConf
     , getSysConfA
 
     , getSysConf
     , getSysConfA
 

+    , setSysConf
+    , setSysConfA
+

     , SiteName(..)
     , BaseURI(..)
     , DefaultPage(..)
     , StyleSheet(..)
     , Languages(..)
     , SiteName(..)
     , BaseURI(..)
     , DefaultPage(..)
     , StyleSheet(..)
     , Languages(..)

+    , GlobalLock(..)

 
     , serializeStringPairs
     , deserializeStringPairs
     )
     where
 
     , serializeStringPairs
     , deserializeStringPairs
     )
     where

-
-import           Codec.Binary.UTF8.String

 import           Control.Arrow.ArrowIO
 import           Control.Concurrent.STM
 import           Control.Monad
 import           Control.Arrow.ArrowIO
 import           Control.Concurrent.STM
 import           Control.Monad


@@ -30,17 +32,21 @@ import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.Maybe
 import           GHC.Conc (unsafeIOToSTM)
 import qualified Data.Map as M
 import           Data.Maybe
 import           GHC.Conc (unsafeIOToSTM)

-import           Network
+import           Network.BSD

 import qualified Network.HTTP.Lucu.Config as LC
 import           Network.HTTP.Lucu.Utils
 import qualified Network.HTTP.Lucu.Config as LC
 import           Network.HTTP.Lucu.Utils

+import           Network.HTTP.Lucu hiding (Config)

 import           Network.URI hiding (path)
 import           Rakka.Page
 import           Rakka.Utils
 import           Subversion.FileSystem
 import           Subversion.FileSystem.Revision
 import           Subversion.FileSystem.Root
 import           Network.URI hiding (path)
 import           Rakka.Page
 import           Rakka.Utils
 import           Subversion.FileSystem
 import           Subversion.FileSystem.Revision
 import           Subversion.FileSystem.Root

+import           Subversion.FileSystem.Transaction

 import           Subversion.Repository
 import           Subversion.Repository

+import           Subversion.Types

 import           System.FilePath.Posix
 import           System.FilePath.Posix

+import           System.IO.Unsafe

 import           System.Log.Logger
 
 
 import           System.Log.Logger
 
 


@@ -55,7 +61,7 @@ data SystemConfig = SystemConfig {
     }
 
 
     }
 
 

-class (Typeable a, Show a) => SysConfValue a where
+class (Typeable a, Show a, Eq a) => SysConfValue a where

     confPath     :: a -> FilePath
     serialize    :: a -> String
     deserialize  :: String -> Maybe a
     confPath     :: a -> FilePath
     serialize    :: a -> String
     deserialize  :: String -> Maybe a


@@ -65,7 +71,7 @@ class (Typeable a, Show a) => SysConfValue a where
 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
 mkSystemConfig lc repos
     = do cache <- newTVarIO M.empty
 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
 mkSystemConfig lc repos
     = do cache <- newTVarIO M.empty

-         return $ SystemConfig {
+         return SystemConfig {

                       scLucuConf   = lc
                     , scRepository = repos
                     , scCache      = cache
                       scLucuConf   = lc
                     , scRepository = repos
                     , scCache      = cache


@@ -115,10 +121,64 @@ getSysConf' sc
                      return val
 
 
                      return val
 
 

+setSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> String -> a -> m StatusCode
+setSysConf sc userID value
+    = liftIO $
+      do let path = confPath (undefined :: a)
+
+         current <- getSysConf sc
+        if current == value
+           then return NotModified
+           else do atomically $ do cache <- readTVar (scCache sc)
+                                    writeTVar (scCache sc) (M.delete path cache)
+                   setSysConf' sc userID value
+
+
+setSysConf' :: forall a. SysConfValue a => SystemConfig -> String -> a -> IO StatusCode
+setSysConf' sc userID value
+    = do let path  = fromConfPath $ confPath (undefined :: a)
+            str   = L.pack $ encode $ serialize value ++ "\n"
+            repos = scRepository sc
+         fs  <- getRepositoryFS repos
+        rev <- getYoungestRev fs
+        ret <- doReposTxn
+               repos
+               rev
+               userID
+               (Just "Automatic commit by Rakka for systemConfig update")
+               $ do exists <- isFile path
+                    unless exists
+                        $ createValueEntry path
+                    applyTextLBS path Nothing str
+        case ret of
+                 Left  _ -> return Conflict
+                 Right _ -> do debugM logger ("Set a config value at `" ++ path ++ "': " ++ show value)
+                               return Created
+    where
+    createValueEntry :: FilePath -> Txn ()
+    createValueEntry path
+       = do createParentDirectories path
+            makeFile path
+
+    createParentDirectories :: FilePath -> Txn ()
+    createParentDirectories path
+       = do let parentPath = takeDirectory path
+            kind <- checkPath parentPath
+            case kind of
+                      NoNode   -> do createParentDirectories parentPath
+                                     makeDirectory parentPath
+                      FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
+                      DirNode  -> return ()
+
+

 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
 getSysConfA = arrIO0 . getSysConf
 
 
 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
 getSysConfA = arrIO0 . getSysConf
 
 

+setSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> String -> a c StatusCode
+setSysConfA = (arrIO .) . setSysConf
+
+

 fromConfPath :: FilePath -> FilePath
 fromConfPath = ("/config" </>)
 
 fromConfPath :: FilePath -> FilePath
 fromConfPath = ("/config" </>)
 


@@ -131,10 +191,10 @@ serializeStringPairs = joinWith "\n" . map serializePair'
 
 
 deserializeStringPairs :: String -> Maybe [(String, String)]
 
 
 deserializeStringPairs :: String -> Maybe [(String, String)]

-deserializeStringPairs = sequence . map deserializePair' . lines
+deserializeStringPairs = mapM deserializePair' . lines

     where
       deserializePair' :: String -> Maybe (String, String)
     where
       deserializePair' :: String -> Maybe (String, String)

-      deserializePair' s = case break (/= ' ') s of
+      deserializePair' s = case break (== ' ') s of

                              (a, ' ':b) -> Just (a, b)
                              _          -> Nothing
 
                              (a, ' ':b) -> Just (a, b)
                              _          -> Nothing
 


@@ -142,15 +202,15 @@ deserializeStringPairs = sequence . map deserializePair' . lines
 
 {- config values -}
 
 
 {- config values -}
 

-newtype SiteName = SiteName String deriving (Show, Typeable)
+newtype SiteName = SiteName String deriving (Show, Typeable, Eq)

 instance SysConfValue SiteName where
     confPath _                = "siteName"
     serialize (SiteName name) = name
 instance SysConfValue SiteName where
     confPath _                = "siteName"
     serialize (SiteName name) = name

-    deserialize name          = Just (SiteName name)
+    deserialize               = Just . SiteName

     defaultValue _            = SiteName "Rakka"
 
 
     defaultValue _            = SiteName "Rakka"
 
 

-newtype BaseURI = BaseURI URI deriving (Show, Typeable)
+newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq)

 instance SysConfValue BaseURI where
     confPath _              = "baseURI"
     serialize (BaseURI uri) = uriToString id uri ""
 instance SysConfValue BaseURI where
     confPath _              = "baseURI"
     serialize (BaseURI uri) = uriToString id uri ""


@@ -164,11 +224,14 @@ instance SysConfValue BaseURI where
     defaultValue sc
         = let conf = scLucuConf sc
               host = C8.unpack $ LC.cnfServerHost conf
     defaultValue sc
         = let conf = scLucuConf sc
               host = C8.unpack $ LC.cnfServerHost conf

-              port = case LC.cnfServerPort conf of
-                       PortNumber num -> fromIntegral num :: Int
-                       _              -> undefined
+              port = unsafePerformIO $
+                     do ent <- getServiceByName (LC.cnfServerPort conf) "tcp"
+                        return (servicePort ent)
+              -- FIXME: There should be a way to change configurations
+              -- without web interface nor direct repository
+              -- modification.

               defaultURI
               defaultURI

-                  = "http://" ++ host ++ -- FIXME: consider IPv6 address
+                  = "http://" ++ host ++ 

                     (if port == 80
                      then ""
                      else ':' : show port) ++ "/"
                     (if port == 80
                      then ""
                      else ':' : show port) ++ "/"


@@ -176,27 +239,27 @@ instance SysConfValue BaseURI where
             BaseURI $ fromJust $ parseURI defaultURI
 
 
             BaseURI $ fromJust $ parseURI defaultURI
 
 

-newtype DefaultPage = DefaultPage String deriving (Show, Typeable)
+newtype DefaultPage = DefaultPage String deriving (Show, Typeable, Eq)

 instance SysConfValue DefaultPage where
     confPath _                   = "defaultPage"
     serialize (DefaultPage name) = name
 instance SysConfValue DefaultPage where
     confPath _                   = "defaultPage"
     serialize (DefaultPage name) = name

-    deserialize name             = Just (DefaultPage name)
+    deserialize                  = Just . DefaultPage

     defaultValue _               = DefaultPage "MainPage"
 
 
     defaultValue _               = DefaultPage "MainPage"
 
 

-newtype StyleSheet = StyleSheet String deriving (Show, Typeable)
+newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq)

 instance SysConfValue StyleSheet where
     confPath _                  = "styleSheet"
     serialize (StyleSheet name) = name
 instance SysConfValue StyleSheet where
     confPath _                  = "styleSheet"
     serialize (StyleSheet name) = name

-    deserialize name            = Just (StyleSheet name)
+    deserialize                 = Just . StyleSheet

     defaultValue _              = StyleSheet "StyleSheet/Default"
 
 
     defaultValue _              = StyleSheet "StyleSheet/Default"
 
 

-newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable)
+newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq)

 instance SysConfValue Languages where
     confPath _                  = "languages"
     serialize (Languages langs) = serializeStringPairs (M.toList langs)
 instance SysConfValue Languages where
     confPath _                  = "languages"
     serialize (Languages langs) = serializeStringPairs (M.toList langs)

-    deserialize langs           = fmap (Languages . M.fromList) (deserializeStringPairs langs)
+    deserialize                 = fmap (Languages . M.fromList) . deserializeStringPairs

     defaultValue _         
         = Languages $ M.fromList [ ("en", "English"  )
                                  , ("es", "Español"  )
     defaultValue _         
         = Languages $ M.fromList [ ("en", "English"  )
                                  , ("es", "Español"  )


@@ -209,3 +272,15 @@ instance SysConfValue Languages where
                                  , ("pt", "Português")
                                  , ("sv", "Svenska"  )
                                  ]
                                  , ("pt", "Português")
                                  , ("sv", "Svenska"  )
                                  ]

+
+
+newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable, Eq)
+instance SysConfValue GlobalLock where
+    confPath _      = "globalLock"
+    serialize (GlobalLock isLocked)
+        | isLocked  = "*"
+        | otherwise = ""
+    deserialize "*" = Just (GlobalLock True)
+    deserialize ""  = Just (GlobalLock False)
+    deserialize _   = Nothing
+    defaultValue _  = GlobalLock False