, deserializeStringPairs
)
where
-
-import Codec.Binary.UTF8.String
import Control.Arrow.ArrowIO
import Control.Concurrent.STM
import Control.Monad
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)
import Subversion.Repository
import Subversion.Types
import System.FilePath.Posix
+import System.IO.Unsafe
import System.Log.Logger
mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
mkSystemConfig lc repos
= do cache <- newTVarIO M.empty
- return $ SystemConfig {
+ return SystemConfig {
scLucuConf = lc
, scRepository = repos
, scCache = cache
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
instance SysConfValue SiteName where
confPath _ = "siteName"
serialize (SiteName name) = name
- deserialize name = Just (SiteName name)
+ deserialize = Just . SiteName
defaultValue _ = SiteName "Rakka"
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) ++ "/"
instance SysConfValue DefaultPage where
confPath _ = "defaultPage"
serialize (DefaultPage name) = name
- deserialize name = Just (DefaultPage name)
+ deserialize = Just . DefaultPage
defaultValue _ = DefaultPage "MainPage"
instance SysConfValue StyleSheet where
confPath _ = "styleSheet"
serialize (StyleSheet name) = name
- deserialize name = Just (StyleSheet name)
+ deserialize = Just . StyleSheet
defaultValue _ = StyleSheet "StyleSheet/Default"
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" )