From: pho <pho@cielonegro.org>
Date: Wed, 9 Jan 2008 08:09:24 +0000 (+0900)
Subject: beginning of implementation of Rakka.Authorization
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=commitdiff_plain;h=9f49e3384f1925d295355e5f60e94a8ca95039ea

beginning of implementation of Rakka.Authorization

darcs-hash:20080109080924-62b54-c5319d8bb1f29e078826f0e961c0b962a337530f.gz
---

diff --git a/Rakka.cabal b/Rakka.cabal
index f6da68d..17da185 100644
--- a/Rakka.cabal
+++ b/Rakka.cabal
@@ -49,6 +49,7 @@ Executable rakka
     Main-Is:
         Main.hs
     Other-Modules:
+        Rakka.Authorization
         Rakka.Environment
         Rakka.Page
         Rakka.Resource
diff --git a/Rakka/Authorization.hs b/Rakka/Authorization.hs
new file mode 100644
index 0000000..8da8afe
--- /dev/null
+++ b/Rakka/Authorization.hs
@@ -0,0 +1,73 @@
+module Rakka.Authorization
+    ( AuthDB
+    , mkAuthDB
+    , isValidPair
+    )
+    where
+
+import qualified Codec.Binary.Base64 as B64
+import qualified Codec.Binary.UTF8.String as UTF8
+import           Control.Concurrent.STM
+import qualified Data.Digest.SHA1 as SHA1
+import           Data.Map (Map)
+import qualified Data.Map as M hiding (Map)
+import           Data.Maybe
+import           Data.Word
+import           Rakka.SystemConfig
+import           System.Directory
+import           System.FilePath
+import           System.IO
+
+
+data AuthDB
+    = AuthDB {
+        adbFilePath    :: !FilePath
+      , adbUserMap     :: !(TVar UserMap)
+      , adbSyncRequest :: !(TVar Bool)
+      }
+
+
+type UserMap = Map String [Word8]
+
+
+mkAuthDB :: FilePath -> IO AuthDB
+mkAuthDB lsdir
+    = do let path = lsdir </> "authDB"
+         m   <- newTVarIO =<< loadUserMap path
+         req <- newTVarIO False
+         return AuthDB {
+                      adbFilePath    = path
+                    , adbUserMap     = m
+                    , adbSyncRequest = req
+                    }
+
+
+isValidPair :: AuthDB -> String -> String -> IO 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)
+
+
+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
+    where
+      decodePair :: (String, String) -> (String, [Word8])
+      decodePair (name, b64Hash)
+          = (UTF8.decodeString name, B64.decode b64Hash)
+
+      initMap :: UserMap -> UserMap
+      initMap m
+          | M.null m  = let name = "root"
+                            hash = SHA1.hash []
+                        in
+                          M.singleton name hash
+          | otherwise = m
diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs
index 480fcf2..367b673 100644
--- a/Rakka/Environment.hs
+++ b/Rakka/Environment.hs
@@ -10,6 +10,7 @@ import           Control.Arrow.ArrowList
 import qualified Data.Map as M
 import           Network
 import qualified Network.HTTP.Lucu.Config as LC
+import           Rakka.Authorization
 import           Rakka.Page
 import           Rakka.Storage
 import           Rakka.SystemConfig
@@ -40,6 +41,7 @@ data Environment = Environment {
     , envSysConf       :: !SystemConfig
     , envStorage       :: !Storage
     , envInterpTable   :: !InterpTable
+    , envAuthDB        :: !AuthDB
     }
 
 
@@ -60,6 +62,7 @@ setupEnv lsdir portNum
                                createRepository reposPath [] []
          sysConf     <- mkSystemConfig lucuConf repos
          storage     <- mkStorage lsdir repos (makeDraft' interpTable)
+         authDB      <- mkAuthDB lsdir
 
          return $ Environment {
                       envLocalStateDir = lsdir
@@ -68,6 +71,7 @@ setupEnv lsdir portNum
                     , envSysConf       = sysConf
                     , envStorage       = storage
                     , envInterpTable   = interpTable
+                    , envAuthDB        = authDB
                     }
     where
       makeDraft' :: InterpTable -> Page -> IO Document
diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs
index 2c36f51..d6d53a4 100644
--- a/Rakka/Storage/Impl.hs
+++ b/Rakka/Storage/Impl.hs
@@ -8,7 +8,6 @@ module Rakka.Storage.Impl
 
 import           Control.Concurrent
 import           Control.Concurrent.STM
-import           Control.Exception
 import           Control.Monad
 import           Data.Maybe
 import           Data.Set (Set)
@@ -26,9 +25,6 @@ import           System.Directory
 import           System.FilePath
 import           System.IO
 import           System.Log.Logger
-import           System.Posix.Files
-import           System.Posix.Types
-import           System.Posix.IO
 import           Text.HyperEstraier hiding (WriteLock)
 
 
@@ -187,37 +183,15 @@ updateIndex index repos mkDraft rev name
 
 
 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
-updateIndexRev revFile f = bracket acquireLock releaseLock update
+updateIndexRev revFile f = withFile revFile ReadWriteMode update
     where
-      acquireLock :: IO Fd
-      acquireLock
-          = do fd <- openFd revFile ReadWrite (Just stdFileMode) defaultFileFlags
-               waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
-               return fd
-
-      releaseLock :: Fd -> IO ()
-      releaseLock fd
-          = setLock fd (Unlock, AbsoluteSeek, 0, 0)
-
-      update :: Fd -> IO ()
-      update fd
-          = do fdSeek fd AbsoluteSeek 0
-               size <- return . fromIntegral . fileSize =<< getFdStatus fd
-               (revStr, gotSize) <- fdRead fd size
-               when (size /= gotSize) $ fail ("read " ++ show gotSize ++
-                                              " bytes but expected " ++ show size ++ " bytes")
-               
-               let rev = case revStr of
-                           "" -> 0
-                           _  -> read revStr
-
-               rev' <- f rev
-
-               let revStr' = show rev' ++ "\n"
-                   size'   = fromIntegral $ length revStr'
-
-               fdSeek fd AbsoluteSeek 0
-               setFdSize fd 0
-               wroteSize <- fdWrite fd revStr'
-               when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
-                                                 " bytes but expected " ++ show size' ++ " bytes")
+      update :: Handle -> IO ()
+      update h = do eof  <- hIsEOF h
+                    rev  <- if eof then
+                                return 0
+                            else
+                                hGetLine h >>= return . read
+                    rev' <- f rev
+                    hSeek h AbsoluteSeek 0
+                    hSetFileSize h 0
+                    hPutStrLn h (show rev')