Rakka.Resource.Users

darcs-hash:20080801052201-62b54-22b2c5a18e3639a3542ce6e1333c0252774b0022.gz

diff --git a/Main.hs b/Main.hs
index b6e5d6d489e9bfcd00d3cfca7d2d8eaffa0b9ed9..2ea8ef03d2d0091558e9e786f7b5869685878998 100644 (file)
--- 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 6652e9673595b0c4dc00759f80d97229f2c1b20f..dca35757f89d53f63af9a71cf14b0549a6c58fbb 100644 (file)
--- 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 0f865c3dee08b7be0baf710c5a6216d23d41a879..be7f490e935b0f4e491069cbd1736e8c42298ed6 100644 (file)
--- 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 9f3af22fd6ef2752c0acdece23c4926177427bbc..c207744da2ab0f4b673c8d3cd5e5354faaaf5f02 100644 (file)
--- 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 beae8316994a2389baebba8d5236c9569a0fe589..1a4b796b750912adf4f85516666c1056bc275b1e 100644 (file)
--- 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 (file)
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]
+  <rdf:RDF>
+    <rdf:Description rdf:about="http://.../users">
+      <users>
+        <rdf:Bag>
+          <rdf:li rdf:resource="http://.../users/foo" />
+         <rdf:li rdf:resource="http://.../users/bar" />
+         ...
+       </rdf:Bag>
+      </users>
+    </rdf:Description>
+  </rdf:RDF>
+
+  [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