X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FSystemConfig.hs;fp=Rakka%2FSystemConfig.hs;h=d15bc9d99a0f2bc6edb65ed467b62631d9e6a964;hp=c151427263a45e65c966ba8deb66f969098f522f;hb=HEAD;hpb=9932fbe6504e8b812703291e2497a5f010880d3b diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs index c151427..d15bc9d 100644 --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE + DeriveDataTypeable + , OverloadedStrings + , ScopedTypeVariables + , UnicodeSyntax + #-} module Rakka.SystemConfig ( SystemConfig , SysConfValue(..) @@ -17,26 +23,37 @@ module Rakka.SystemConfig , Languages(..) , GlobalLock(..) - , serializeStringPairs - , deserializeStringPairs + , serializeTextPairs + , deserializeTextPairs + , serializeMap + , deserializeMap ) where +import Control.Applicative +import Codec.Binary.UTF8.String import Control.Arrow.ArrowIO +import Control.Arrow.Unicode import Control.Concurrent.STM import Control.Monad import Control.Monad.Trans +import Control.Monad.Unicode import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L +import qualified Data.CaseInsensitive as CI import Data.Dynamic import Data.Map (Map) import qualified Data.Map as M import Data.Maybe +import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GHC.Conc (unsafeIOToSTM) import Network.BSD 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 Prelude.Unicode import Rakka.Page import Rakka.Utils import Subversion.FileSystem @@ -46,10 +63,9 @@ import Subversion.FileSystem.Transaction import Subversion.Repository import Subversion.Types import System.FilePath.Posix -import System.IO.Unsafe +import System.IO.Unsafe import System.Log.Logger - logger :: String logger = "Rakka.SystemConfig" @@ -60,13 +76,11 @@ data SystemConfig = SystemConfig { , scCache :: !(TVar (Map FilePath Dynamic)) } - -class (Typeable a, Show a, Eq a) => SysConfValue a where - confPath :: a -> FilePath - serialize :: a -> String - deserialize :: String -> Maybe a - defaultValue :: SystemConfig -> a - +class (Typeable α, Show α, Eq α) ⇒ SysConfValue α where + confPath ∷ α → FilePath + serialize ∷ α → Text + deserialize ∷ Text → Maybe α + defaultValue ∷ SystemConfig → α mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig mkSystemConfig lc repos @@ -77,49 +91,42 @@ mkSystemConfig lc repos , scCache = cache } -getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a +getSysConf ∷ ∀m a. (MonadIO m, SysConfValue a) ⇒ SystemConfig → m a getSysConf sc - = liftIO $ - atomically $ - do let path = confPath (undefined :: a) - - cache <- readTVar (scCache sc) - + = liftIO $ atomically $ + do cache ← readTVar (scCache sc) + let path = confPath ((⊥) ∷ a) case M.lookup path cache of - Just val -> return $ fromJust $ fromDynamic val - Nothing -> do val <- unsafeIOToSTM (getSysConf' sc) - writeTVar (scCache sc) (M.insert path (toDyn val) cache) - return val + Just val → pure ∘ fromJust $ fromDynamic val + Nothing → do val ← unsafeIOToSTM (getSysConf' sc) + writeTVar (scCache sc) (M.insert path (toDyn val) cache) + return val - -getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a +getSysConf' ∷ ∀α. SysConfValue α ⇒ SystemConfig → IO α getSysConf' sc - = do let path = fromConfPath $ confPath (undefined :: a) - - fs <- getRepositoryFS (scRepository sc) - rev <- getYoungestRev fs - value <- withRevision fs rev - $ do exists <- isFile path - case exists of - True - -> do str <- getFileContentsLBS path - return $ Just $ chomp $ decode $ L.unpack str - False - -> return Nothing - + = do let path = fromConfPath $ confPath ((⊥) ∷ α) + fs ← getRepositoryFS (scRepository sc) + rev ← getYoungestRev fs + value ← withRevision fs rev + $ do exists ← isFile path + case exists of + True + → do str ← getFileContentsLBS path + return $ Just $ T.pack $ chomp $ decode $ L.unpack str + False + → return Nothing case value of Just str - -> case deserialize str of - Just val - -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val) - return val - Nothing - -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str) + → case deserialize str of + Just val + → debugM logger ("Got a config value at `" ⊕ path ⊕ "': " ⊕ show val) ≫ + return val + Nothing + → fail ("Got an invalid config value at `" ⊕ path ⊕ "': " ⊕ show str) Nothing - -> do let val = defaultValue sc - debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val) - return val - + → do let val = defaultValue sc + debugM logger ("Got no config value at `" ⊕ path ⊕ "'. Defaulting to " ⊕ show val) + return val setSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> String -> a -> m StatusCode setSysConf sc userID value @@ -134,42 +141,41 @@ setSysConf sc userID value setSysConf' sc userID value -setSysConf' :: forall a. SysConfValue a => SystemConfig -> String -> a -> IO StatusCode +setSysConf' ∷ ∀α. SysConfValue α ⇒ SystemConfig → String → α → IO StatusCode setSysConf' sc userID value - = do let path = fromConfPath $ confPath (undefined :: a) - str = L.pack $ encode $ serialize value ++ "\n" + = do let path = fromConfPath $ confPath ((⊥) ∷ α) + str = (L.fromChunks ∘ (:[]) ∘ T.encodeUtf8 $ 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 + 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 + Left _ → return Conflict + Right _ → do debugM logger ("Set a config value at `" ⊕ path ⊕ "': " ⊕ show value) + return Created where - createValueEntry :: FilePath -> Txn () + createValueEntry ∷ FilePath → Txn () createValueEntry path - = do createParentDirectories path - makeFile path + = do createParentDirectories path + makeFile path - createParentDirectories :: FilePath -> Txn () + 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 () - + = do let parentPath = takeDirectory path + kind ← checkPath parentPath + case kind of + NoNode → 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 @@ -182,44 +188,44 @@ setSysConfA = (arrIO .) . setSysConf fromConfPath :: FilePath -> FilePath fromConfPath = ("/config" ) - -serializeStringPairs :: [(String, String)] -> String -serializeStringPairs = joinWith "\n" . map serializePair' +serializeTextPairs ∷ [(Text, Text)] → Text +serializeTextPairs = T.intercalate "\n" ∘ (serializePair' <$>) where - serializePair' :: (String, String) -> String - serializePair' (a, b) = a ++ " " ++ b + serializePair' ∷ (Text, Text) → Text + serializePair' (a, b) = a ⊕ " " ⊕ b +serializeMap ∷ (k → Text) → (v → Text) → Map k v → Text +serializeMap f g = serializeTextPairs ∘ ((f ⁂ g) <$>) ∘ M.toList -deserializeStringPairs :: String -> Maybe [(String, String)] -deserializeStringPairs = mapM deserializePair' . lines +deserializeTextPairs ∷ Text → Maybe [(Text, Text)] +deserializeTextPairs = mapM deserializePair' ∘ T.lines where - deserializePair' :: String -> Maybe (String, String) - deserializePair' s = case break (== ' ') s of - (a, ' ':b) -> Just (a, b) - _ -> Nothing - - + deserializePair' ∷ Text → Maybe (Text, Text) + deserializePair' s = case T.breakOn " " s of + (a, b) + | (¬) (T.null b) → Just (a, T.tail b) + _ → Nothing -{- config values -} +deserializeMap ∷ Ord k ⇒ (Text → k) → (Text → v) → Text → Maybe (Map k v) +deserializeMap f g = (M.fromList ∘ ((f ⁂ g) <$>) <$>) ∘ deserializeTextPairs -newtype SiteName = SiteName String deriving (Show, Typeable, Eq) +newtype SiteName = SiteName Text deriving (Show, Typeable, Eq) instance SysConfValue SiteName where confPath _ = "siteName" serialize (SiteName name) = name deserialize = Just . SiteName defaultValue _ = SiteName "Rakka" - newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq) instance SysConfValue BaseURI where confPath _ = "baseURI" - serialize (BaseURI uri) = uriToString id uri "" + serialize (BaseURI uri) = T.pack $ uriToString id uri "" deserialize uri = fmap BaseURI - $ do parsed <- parseURI uri - when (uriPath parsed == "" ) (fail undefined) - when (last (uriPath parsed) /= '/') (fail undefined) - when (uriQuery parsed /= "" ) (fail undefined) - when (uriFragment parsed /= "" ) (fail undefined) + $ do parsed ← parseURI (T.unpack uri) + when (uriPath parsed ≡ "" ) mzero + when (last (uriPath parsed) ≠ '/') mzero + when (uriQuery parsed ≠ "" ) mzero + when (uriFragment parsed ≠ "" ) mzero return parsed defaultValue sc = let conf = scLucuConf sc @@ -231,35 +237,32 @@ instance SysConfValue BaseURI where -- without web interface nor direct repository -- modification. defaultURI - = "http://" ++ host ++ + = "http://" ++ host ++ (if port == 80 then "" else ':' : show port) ++ "/" in BaseURI $ fromJust $ parseURI defaultURI - -newtype DefaultPage = DefaultPage String deriving (Show, Typeable, Eq) +newtype DefaultPage = DefaultPage Text deriving (Show, Typeable, Eq) instance SysConfValue DefaultPage where confPath _ = "defaultPage" serialize (DefaultPage name) = name deserialize = Just . DefaultPage defaultValue _ = DefaultPage "MainPage" - -newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq) +newtype StyleSheet = StyleSheet Text deriving (Show, Typeable, Eq) instance SysConfValue StyleSheet where confPath _ = "styleSheet" serialize (StyleSheet name) = name deserialize = Just . StyleSheet defaultValue _ = StyleSheet "StyleSheet/Default" - newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq) instance SysConfValue Languages where confPath _ = "languages" - serialize (Languages langs) = serializeStringPairs (M.toList langs) - deserialize = fmap (Languages . M.fromList) . deserializeStringPairs + serialize (Languages langs) = serializeMap CI.foldedCase id langs + deserialize = (Languages <$>) ∘ deserializeMap CI.mk id defaultValue _ = Languages $ M.fromList [ ("en", "English" ) , ("es", "Español" )