X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FSystemConfig.hs;h=4978b46d131bc853271438120e860b5ac17f5fdc;hb=223d4df57fa1371945075d4d2714e5f36c1fc5dd;hp=91d9ca4178ed4f6f7b0a597d41662d0bc9e1e6ec;hpb=52bafd675e7ac9d3fc9d3bf2d72e66a22efb6db9;p=Rakka.git

diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs
index 91d9ca4..4978b46 100644
--- a/Rakka/SystemConfig.hs
+++ b/Rakka/SystemConfig.hs
@@ -34,7 +34,7 @@ import           Data.Map (Map)
 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           Network.HTTP.Lucu hiding (Config)
@@ -48,6 +48,7 @@ import           Subversion.FileSystem.Transaction
 import           Subversion.Repository
 import           Subversion.Types
 import           System.FilePath.Posix
+import           System.IO.Unsafe
 import           System.Log.Logger
 
 
@@ -72,7 +73,7 @@ class (Typeable a, Show a, Eq a) => SysConfValue a where
 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
 mkSystemConfig lc repos
     = do cache <- newTVarIO M.empty
-         return $ SystemConfig {
+         return SystemConfig {
                       scLucuConf   = lc
                     , scRepository = repos
                     , scCache      = cache
@@ -192,7 +193,7 @@ serializeStringPairs = joinWith "\n" . map serializePair'
 
 
 deserializeStringPairs :: String -> Maybe [(String, String)]
-deserializeStringPairs = sequence . map deserializePair' . lines
+deserializeStringPairs = mapM deserializePair' . lines
     where
       deserializePair' :: String -> Maybe (String, String)
       deserializePair' s = case break (== ' ') s of
@@ -207,7 +208,7 @@ newtype SiteName = SiteName String deriving (Show, Typeable, Eq)
 instance SysConfValue SiteName where
     confPath _                = "siteName"
     serialize (SiteName name) = name
-    deserialize name          = Just (SiteName name)
+    deserialize               = Just . SiteName
     defaultValue _            = SiteName "Rakka"
 
 
@@ -225,11 +226,14 @@ instance SysConfValue BaseURI where
     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
-                  = "http://" ++ host ++ -- FIXME: consider IPv6 address
+                  = "http://" ++ host ++ 
                     (if port == 80
                      then ""
                      else ':' : show port) ++ "/"
@@ -241,7 +245,7 @@ newtype DefaultPage = DefaultPage String deriving (Show, Typeable, Eq)
 instance SysConfValue DefaultPage where
     confPath _                   = "defaultPage"
     serialize (DefaultPage name) = name
-    deserialize name             = Just (DefaultPage name)
+    deserialize                  = Just . DefaultPage
     defaultValue _               = DefaultPage "MainPage"
 
 
@@ -249,7 +253,7 @@ newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq)
 instance SysConfValue StyleSheet where
     confPath _                  = "styleSheet"
     serialize (StyleSheet name) = name
-    deserialize name            = Just (StyleSheet name)
+    deserialize                 = Just . StyleSheet
     defaultValue _              = StyleSheet "StyleSheet/Default"
 
 
@@ -257,7 +261,7 @@ newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typ
 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"  )