From: pho <pho@cielonegro.org>
Date: Thu, 10 Jan 2008 10:19:40 +0000 (+0900)
Subject: implemented /checkAuth
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=commitdiff_plain;h=4e428cf86da68b72ef8fdff87990e7c953c8f12e

implemented /checkAuth

darcs-hash:20080110101940-62b54-b098f5008f655a3b661d051fde55e08eedd0b8d4.gz
---

diff --git a/Main.hs b/Main.hs
index b3313d6..77c17a1 100644
--- a/Main.hs
+++ b/Main.hs
@@ -5,6 +5,7 @@ import           Data.Maybe
 import           Network
 import           Network.HTTP.Lucu
 import           Rakka.Environment
+import           Rakka.Resource.CheckAuth
 import           Rakka.Resource.Index
 import           Rakka.Resource.JavaScript
 import           Rakka.Resource.PageEntity
@@ -136,10 +137,11 @@ main = withSubversion $
           
 resTree :: Environment -> ResTree
 resTree env
-    = mkResTree [ ([]        , resIndex  env)
-                , (["js"    ], javaScript   )
-                , (["object"], resObject env)
-                , (["render"], resRender env)
+    = mkResTree [ ([]           , resIndex     env)
+                , (["checkAuth"], resCheckAuth env)
+                , (["js"       ], javaScript      )
+                , (["object"   ], resObject    env)
+                , (["render"   ], resRender    env)
                 ]
 
 
diff --git a/Rakka.cabal b/Rakka.cabal
index 17da185..da9c403 100644
--- a/Rakka.cabal
+++ b/Rakka.cabal
@@ -53,6 +53,7 @@ Executable rakka
         Rakka.Environment
         Rakka.Page
         Rakka.Resource
+        Rakka.Resource.CheckAuth
         Rakka.Resource.Index
         Rakka.Resource.JavaScript
         Rakka.Resource.Object
diff --git a/Rakka/Authorization.hs b/Rakka/Authorization.hs
index 8da8afe..8f32ddf 100644
--- a/Rakka/Authorization.hs
+++ b/Rakka/Authorization.hs
@@ -8,6 +8,7 @@ module Rakka.Authorization
 import qualified Codec.Binary.Base64 as B64
 import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Concurrent.STM
+import           Control.Monad.Trans
 import qualified Data.Digest.SHA1 as SHA1
 import           Data.Map (Map)
 import qualified Data.Map as M hiding (Map)
@@ -42,23 +43,24 @@ mkAuthDB lsdir
                     }
 
 
-isValidPair :: AuthDB -> String -> String -> IO Bool
+isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
 isValidPair adb name pass
     = let hash = SHA1.hash (UTF8.encode pass)
       in
-        atomically $ do m <- readTVar (adbUserMap adb)
-                        return (M.lookup name m == Just hash)
+        liftIO $ atomically $ do m <- readTVar (adbUserMap adb)
+                                 return (M.lookup name m == Just hash)
 
 
 loadUserMap :: FilePath -> IO UserMap
 loadUserMap path
     = do exist <- doesFileExist path
-         if exist then
-             readFile path
-                >>=
-                return . initMap . M.fromList . map decodePair . fromJust . deserializeStringPairs
-           else
-             return M.empty
+         m     <- if exist then
+                      readFile path
+                      >>=
+                      return . M.fromList . map decodePair . fromJust . deserializeStringPairs
+                  else
+                      return M.empty
+         return (initMap m)
     where
       decodePair :: (String, String) -> (String, [Word8])
       decodePair (name, b64Hash)
diff --git a/Rakka/Resource/CheckAuth.hs b/Rakka/Resource/CheckAuth.hs
new file mode 100644
index 0000000..8b4d54b
--- /dev/null
+++ b/Rakka/Resource/CheckAuth.hs
@@ -0,0 +1,31 @@
+module Rakka.Resource.CheckAuth
+    ( resCheckAuth
+    )
+    where
+
+import           Network.HTTP.Lucu
+import           Rakka.Authorization
+import           Rakka.Environment
+
+
+resCheckAuth :: Environment -> ResourceDef
+resCheckAuth env
+    = ResourceDef {
+        resUsesNativeThread = False
+      , resIsGreedy         = False
+      , resGet
+          = Just $
+            do authM <- getAuthorization
+               case authM of
+                 Just (BasicAuthCredential userID password)
+                     -> do valid <- isValidPair (envAuthDB env) userID password
+                           if valid then
+                               setStatus NoContent
+                             else
+                               setStatus Forbidden
+                 _   -> setStatus Forbidden
+      , resHead             = Nothing
+      , resPost             = Nothing
+      , resPut              = Nothing
+      , resDelete           = Nothing
+      }