From: pho Date: Mon, 8 Oct 2007 01:45:24 +0000 (+0900) Subject: In early development X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=790089d18791029ad268b3306ca71f8d5ae44ce1;p=Rakka.git In early development darcs-hash:20071008014524-62b54-96eff5b1009a2abef4a8347fa559718b8f43d9af.gz --- diff --git a/Main.hs b/Main.hs index 942787c..df2cccb 100644 --- a/Main.hs +++ b/Main.hs @@ -2,9 +2,16 @@ import Control.Monad import Data.Maybe import Network +import Network.HTTP.Lucu +import Rakka.Environment +import Rakka.Resource.Index +import Rakka.Resource.Object +import Rakka.Resource.Page import System.Console.GetOpt +import System.Directory import System.Environment import System.Exit +import System.Posix.Files import System.Posix.Types import System.Posix.User @@ -20,6 +27,9 @@ data CmdOpt defaultPort :: PortNumber defaultPort = fromIntegral 8080 +defaultLocalStateDir :: FilePath +defaultLocalStateDir = LOCALSTATEDIR -- replaced by CPP + defaultUserName :: String defaultUserName = "daemon" @@ -34,7 +44,7 @@ options = [ Option ['p'] ["port"] , Option ['d'] ["localstatedir"] (ReqArg OptLSDir "DIR") - ("Path to the database directory. (default: " ++ LOCALSTATEDIR ++ ")") + ("Path to the database directory. (default: " ++ defaultLocalStateDir ++ ")") , Option ['u'] ["user"] (ReqArg OptUserName "USER") @@ -73,10 +83,24 @@ main = do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs exitWith $ ExitFailure 1 portNum <- getPortNum opts - uid <- getUserID opts + uid <- getUserID opts + gid <- getGroupID opts + lsdir <- getLocalStateDir opts + + createLocalStateDir lsdir uid gid + + setGroupID gid + setUserID uid + + env <- setupEnv lsdir portNum + runHttpd (envLucuConf env) (resTree env) [fallbackPage env] - print portNum - print uid + +resTree :: Environment -> ResTree +resTree env + = mkResTree [ ([] , resIndex env) + , (["object"], resObject env) + ] getPortNum :: [CmdOpt] -> IO PortNumber @@ -102,4 +126,36 @@ getUserID opts userEnt <- getUserEntryForName name return $ userID userEnt - \ No newline at end of file + + +getGroupID :: [CmdOpt] -> IO GroupID +getGroupID opts + = do let xs = mapMaybe (\ x -> case x of + OptGroupName n -> Just n + _ -> Nothing) opts + name = case xs of + [] -> defaultGroupName + (x:[]) -> x + _ -> error "too many --group options." + + groupEnt <- getGroupEntryForName name + return $ groupID groupEnt + + +getLocalStateDir :: [CmdOpt] -> IO FilePath +getLocalStateDir opts + = do let xs = mapMaybe (\ x -> case x of + OptLSDir n -> Just n + _ -> Nothing) opts + path = case xs of + [] -> defaultLocalStateDir + (x:[]) -> x + _ -> error "too many --localstatedir options." + + return path + + +createLocalStateDir :: FilePath -> UserID -> GroupID -> IO () +createLocalStateDir path uid gid + = do createDirectoryIfMissing True path + setOwnerAndGroup path uid gid diff --git a/Rakka.cabal b/Rakka.cabal index ebb4531..a1c8a71 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -22,6 +22,9 @@ Tested-With: GHC == 6.6.1 Build-Depends: base, network, unix, Lucu +Data-Files: + defaultPages/Main_Page + schemas/rakka-page-1.0.rng Executable: rakka diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs new file mode 100644 index 0000000..069f9eb --- /dev/null +++ b/Rakka/Environment.hs @@ -0,0 +1,25 @@ +module Rakka.Environment + ( Environment(..) + , setupEnv + ) + where + +import Network +import qualified Network.HTTP.Lucu.Config as LC + + +data Environment = Environment { + envLocalStateDir :: FilePath + , envLucuConf :: LC.Config + } + + +setupEnv :: FilePath -> PortNumber -> IO Environment +setupEnv lsdir portNum + = do let lucuConf = LC.defaultConfig { + LC.cnfServerPort = PortNumber portNum + } + return $ Environment { + envLocalStateDir = lsdir + , envLucuConf = lucuConf + } \ No newline at end of file diff --git a/Rakka/Resource/Index.hs b/Rakka/Resource/Index.hs new file mode 100644 index 0000000..859b8eb --- /dev/null +++ b/Rakka/Resource/Index.hs @@ -0,0 +1,22 @@ +module Rakka.Resource.Index + ( resIndex + ) + where + +import Network.HTTP.Lucu +import Rakka.Environment + + +resIndex :: Environment -> ResourceDef +resIndex env + = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet = Just $ do setContentType $ read "text/plain" + output "FIXME: not implemented" + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs new file mode 100644 index 0000000..9e30d1e --- /dev/null +++ b/Rakka/Resource/Object.hs @@ -0,0 +1,22 @@ +module Rakka.Resource.Object + ( resObject + ) + where + +import Network.HTTP.Lucu +import Rakka.Environment + + +resObject :: Environment -> ResourceDef +resObject env + = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet = Just $ do setContentType $ read "text/plain" + output "FIXME: not implemented" + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + diff --git a/Rakka/Resource/Page.hs b/Rakka/Resource/Page.hs new file mode 100644 index 0000000..8077c4f --- /dev/null +++ b/Rakka/Resource/Page.hs @@ -0,0 +1,37 @@ +module Rakka.Resource.Page + ( fallbackPage + ) + where + +import Data.Char +import Network.HTTP.Lucu +import Rakka.Environment + + +fallbackPage :: Environment -> [String] -> IO (Maybe ResourceDef) +fallbackPage env path + | null path = return Nothing + | null $ head path = return Nothing + | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。 + | otherwise + = return $ Just $ ResourceDef { + resUsesNativeThread = False + , resIsGreedy = True + , resGet = Just $ handleGet env path + , resHead = Nothing + , resPost = Nothing + , resPut = Just $ handlePut env path + , resDelete = Just $ handleDelete env path + } + + +handleGet :: Environment -> [String] -> Resource () +handleGet = fail "FIXME: not implemented" + + +handlePut :: Environment -> [String] -> Resource () +handlePut = fail "FIXME: not implemented" + + +handleDelete :: Environment -> [String] -> Resource () +handleDelete = fail "FIXME: not implemented" diff --git a/defaultPages/Main_Page b/defaultPages/Main_Page new file mode 100644 index 0000000..1c0a421 --- /dev/null +++ b/defaultPages/Main_Page @@ -0,0 +1,7 @@ + + + + This is the main page. Hello, world! + + \ No newline at end of file diff --git a/schemas/rakka-page-1.0.rng b/schemas/rakka-page-1.0.rng new file mode 100644 index 0000000..b85385b --- /dev/null +++ b/schemas/rakka-page-1.0.rng @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + + + +