From: pho Date: Fri, 1 Aug 2008 05:22:01 +0000 (+0900) Subject: Rakka.Resource.Users X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=commitdiff_plain;h=547fd6221931c8025085db91f7424db850156129 Rakka.Resource.Users darcs-hash:20080801052201-62b54-22b2c5a18e3639a3542ce6e1333c0252774b0022.gz --- diff --git a/Main.hs b/Main.hs index b6e5d6d..2ea8ef0 100644 --- a/Main.hs +++ b/Main.hs @@ -16,6 +16,7 @@ import Rakka.Resource.Render import Rakka.Resource.Search import Rakka.Resource.SystemConfig -- import Rakka.Resource.TrackBack +import Rakka.Resource.Users import Rakka.Storage import Subversion import System.Console.GetOpt @@ -154,6 +155,7 @@ resTree env , (["search.xml" ], resSearch env) , (["systemConfig"], resSystemConfig env) -- , (["trackback" ], resTrackBack env) + , (["users" ], resUsers env) ] diff --git a/Rakka.cabal b/Rakka.cabal index 6652e96..dca3575 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -76,6 +76,7 @@ Executable rakka Rakka.Resource.Search Rakka.Resource.SystemConfig Rakka.Resource.TrackBack + Rakka.Resource.Users Rakka.Storage Rakka.Storage.DefaultPage Rakka.Storage.Repos diff --git a/Rakka/Authorization.hs b/Rakka/Authorization.hs index 0f865c3..be7f490 100644 --- a/Rakka/Authorization.hs +++ b/Rakka/Authorization.hs @@ -2,6 +2,9 @@ module Rakka.Authorization ( AuthDB , mkAuthDB , isValidPair + , getUserList + , addUser + , delUser ) where @@ -51,6 +54,36 @@ isValidPair adb name pass return (M.lookup name m == Just hash) +getUserList :: MonadIO m => AuthDB -> m [String] +getUserList adb + = liftIO $ + atomically $ + do m <- readTVar (adbUserMap adb) + return (M.keys m) + + +addUser :: MonadIO m => AuthDB -> String -> String -> m () +addUser adb name pass + = liftIO $ + do sha1 <- return . fromJust =<< getDigestByName "SHA1" + let hash = digestBS sha1 $ B.pack $ UTF8.encode pass + m <- atomically $ do m <- readTVar (adbUserMap adb) + let m' = M.insert name hash m + writeTVar (adbUserMap adb) m' + return m' + saveUserMap (adbFilePath adb) m + + +delUser :: MonadIO m => AuthDB -> String -> m () +delUser adb name + = liftIO $ + do m <- atomically $ do m <- readTVar (adbUserMap adb) + let m' = M.delete name m + writeTVar (adbUserMap adb) m' + return m' + saveUserMap (adbFilePath adb) m + + loadUserMap :: FilePath -> IO UserMap loadUserMap path = do exist <- doesFileExist path @@ -74,3 +107,12 @@ loadUserMap path in M.singleton name hash | otherwise = m + + +saveUserMap :: FilePath -> UserMap -> IO () +saveUserMap path m + = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m + where + encodePair :: (String, String) -> (String, String) + encodePair (name, hash) + = (UTF8.encodeString name, encodeBase64 hash) diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs index 9f3af22..c207744 100644 --- a/Rakka/Resource.hs +++ b/Rakka/Resource.hs @@ -1,9 +1,11 @@ module Rakka.Resource ( runIdempotentA + , runIdempotentA' , runXmlA , getEntityType , outputXmlPage , outputXmlPage' + , outputXml , getUserID ) where @@ -68,6 +70,17 @@ runIdempotentA baseURI a rsrc +runIdempotentA' :: IOSArrow () (Resource c) -> Resource c +runIdempotentA' a + = do [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail + >>> + constA () + >>> + a + ) + rsrc + + runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c runXmlA env schemaPath a = do inputA <- getInputXmlA env schemaPath @@ -159,6 +172,18 @@ outputXmlPage' tree toXHTML = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)] +outputXml :: XmlTree -> Resource () +outputXml tree + = do setContentType (MIMEType "text" "xml" []) + [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail + >>> + constA tree + >>> + writeDocumentToString [ (a_indent, v_1) ] + ) + output xmlStr + + getUserID :: Environment -> Resource (Maybe String) getUserID env = do auth <- getAuthorization diff --git a/Rakka/Resource/SystemConfig.hs b/Rakka/Resource/SystemConfig.hs index beae831..1a4b796 100644 --- a/Rakka/Resource/SystemConfig.hs +++ b/Rakka/Resource/SystemConfig.hs @@ -3,7 +3,6 @@ module Rakka.Resource.SystemConfig ) where -import Control.Monad.Trans import Data.Maybe import Network.HTTP.Lucu import Rakka.Environment @@ -12,6 +11,10 @@ import Rakka.SystemConfig import Text.XML.HXT.Arrow +-- FIXME: +-- GET /systemConfig ==> 全設定値を返す +-- GET /systemConfig/siteName ==> siteName を返す +-- PUT /systemConfig/siteName ==> siteName を設定 resSystemConfig :: Environment -> ResourceDef resSystemConfig env = ResourceDef { @@ -33,14 +36,9 @@ resSystemConfig env -} handleGet :: Environment -> Resource () handleGet env - = do setContentType $ read "text/xml" - [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail - >>> - mkSystemConfigTree env - >>> - writeDocumentToString [ (a_indent, v_1) ] - ) - output xmlStr + = runIdempotentA' $ proc () + -> do tree <- mkSystemConfigTree env -< () + returnA -< outputXml tree mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree diff --git a/Rakka/Resource/Users.hs b/Rakka/Resource/Users.hs new file mode 100644 index 0000000..7eb0e13 --- /dev/null +++ b/Rakka/Resource/Users.hs @@ -0,0 +1,149 @@ +module Rakka.Resource.Users + ( resUsers + ) + where + +import Control.Monad +import Control.Monad.Trans +import Data.Maybe +import Network.HTTP.Lucu +import Network.URI hiding (path) +import Rakka.Authorization +import Rakka.Environment +import Rakka.Resource +import Rakka.SystemConfig +import System.FilePath +import Text.XML.HXT.Arrow hiding (when) + + +resUsers :: Environment -> ResourceDef +resUsers env + = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = True + , resGet = Just $ handleGet env + , resHead = Nothing + , resPost = Nothing + , resPut = Just $ handlePut env + , resDelete = Just $ handleDelete env + } + + +{- + [GET /users] + + + + + + + ... + + + + + + [GET /users/foo] + 204 No Content + + [GET /users/nonexistent] + 404 Not Found +-} +handleGet :: Environment -> Resource () +handleGet env + = do userID <- getUserID env + when (isNothing userID) + $ abort Forbidden [] Nothing + + path <- getPathInfo + case path of + [] -> returnUserList + [name] -> returnUser name + _ -> foundNoEntity Nothing + where + returnUserList :: Resource () + returnUserList + = do BaseURI baseURI <- getSysConf (envSysConf env) + users <- liftIO $ getUserList $ envAuthDB env + runIdempotentA' $ proc () + -> do tree <- ( eelem "/" + += ( eelem "rdf:RDF" + += sattr "xmlns" "http://cielonegro.org/terms/" + += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#" + += ( eelem "rdf:Description" + += sattr "rdf:about" (uriToString id (mkUserURI baseURI Nothing) "") + += ( eelem "users" + += ( eelem "rdf:Bag" + += ( constL users + >>> + ( eelem "rdf:li" + += attr "rdf:resource" ( arr ( \ name -> + uriToString + id + (mkUserURI baseURI $ Just name) + "" + ) + >>> + mkText + ) + ) + ) + ) + ) + ) + ) + ) -< () + returnA -< outputXml tree + + mkUserURI :: URI -> Maybe String -> URI + mkUserURI baseURI Nothing = baseURI { uriPath = uriPath baseURI "users" } + mkUserURI baseURI (Just x) = baseURI { uriPath = uriPath baseURI "users" x } + + returnUser :: String -> Resource () + returnUser name + = do users <- liftIO $ getUserList $ envAuthDB env + if any (== name) users + then setStatus NoContent + else foundNoEntity Nothing + + +{- + > PUT /users/foo HTTP/1.1 + > Content-Type: text/plain + > + > password + + < HTTP/1.1 201 Created +-} +handlePut :: Environment -> Resource () +handlePut env + = do userID <- getUserID env + when (isNothing userID) + $ abort Forbidden [] Nothing + + path <- getPathInfo + case path of + [name] -> do mimeType <- getContentType + case mimeType of + Nothing + -> abort BadRequest [] (Just "Missing Content-Type") + Just (MIMEType "text" "plain" _) + -> do pass <- input defaultLimit + addUser (envAuthDB env) name pass + Just t + -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t) + setStatus Created + _ -> abort BadRequest [] (Just "Invalid URI") + + +handleDelete :: Environment -> Resource () +handleDelete env + = do userID <- getUserID env + when (isNothing userID) + $ abort Forbidden [] Nothing + + path <- getPathInfo + case path of + [name] -> delUser (envAuthDB env) name + _ -> abort BadRequest [] (Just "Invalid URI") + setStatus NoContent