+{-# LANGUAGE
+ DeriveDataTypeable
+ , OverloadedStrings
+ , ScopedTypeVariables
+ , UnicodeSyntax
+ #-}
module Rakka.SystemConfig
( SystemConfig
, SysConfValue(..)
, 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
+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
import Subversion.Repository
import Subversion.Types
import System.FilePath.Posix
+import System.IO.Unsafe
import System.Log.Logger
-
logger :: String
logger = "Rakka.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
, 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
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
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
host = C8.unpack $ LC.cnfServerHost conf
- port = case LC.cnfServerPort conf of
- PortNumber num -> fromIntegral num :: Int
- _ -> undefined
+ port = unsafePerformIO ∘ getServicePortNumber $ LC.cnfServerPort conf
defaultURI
= "http://" ++ host ++ -- FIXME: consider IPv6 address
(if port == 80
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" )
projects / Rakka.git / blobdiff