X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FAuthorization.hs;h=ccc4b36c477318177f064fdca75f79d7ab43b427;hb=a4b849476ee3a204ea91dee8f3fd235b0b33a10a;hp=8f32ddfc613420e005e898e24ac08be920cbee0e;hpb=4e428cf86da68b72ef8fdff87990e7c953c8f12e;p=Rakka.git

diff --git a/Rakka/Authorization.hs b/Rakka/Authorization.hs
index 8f32ddf..ccc4b36 100644
--- a/Rakka/Authorization.hs
+++ b/Rakka/Authorization.hs
@@ -2,18 +2,22 @@ module Rakka.Authorization
     ( AuthDB
     , mkAuthDB
     , isValidPair
+    , getUserList
+    , addUser
+    , delUser
     )
     where
 
-import qualified Codec.Binary.Base64 as B64
 import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Concurrent.STM
+import           Control.Monad
 import           Control.Monad.Trans
-import qualified Data.Digest.SHA1 as SHA1
+import qualified Data.ByteString as B
 import           Data.Map (Map)
 import qualified Data.Map as M hiding (Map)
 import           Data.Maybe
-import           Data.Word
+import           OpenSSL.EVP.Base64
+import           OpenSSL.EVP.Digest
 import           Rakka.SystemConfig
 import           System.Directory
 import           System.FilePath
@@ -28,7 +32,7 @@ data AuthDB
       }
 
 
-type UserMap = Map String [Word8]
+type UserMap = Map String String
 
 
 mkAuthDB :: FilePath -> IO AuthDB
@@ -45,31 +49,70 @@ mkAuthDB lsdir
 
 isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
 isValidPair adb name pass
-    = let hash = SHA1.hash (UTF8.encode pass)
-      in
-        liftIO $ atomically $ do m <- readTVar (adbUserMap adb)
-                                 return (M.lookup name m == Just hash)
+    = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
+                  let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
+                  atomically $ do m <- readTVar (adbUserMap adb)
+                                  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
          m     <- if exist then
-                      readFile path
-                      >>=
-                      return . M.fromList . map decodePair . fromJust . deserializeStringPairs
+                      liftM (M.fromList . map decodePair . fromJust . deserializeStringPairs)
+                            (readFile path)
                   else
                       return M.empty
-         return (initMap m)
+         sha1  <- return . fromJust =<< getDigestByName "SHA1"
+         return (initMap sha1 m)
     where
-      decodePair :: (String, String) -> (String, [Word8])
+      decodePair :: (String, String) -> (String, String)
       decodePair (name, b64Hash)
-          = (UTF8.decodeString name, B64.decode b64Hash)
+          = (UTF8.decodeString name, decodeBase64 b64Hash)
 
-      initMap :: UserMap -> UserMap
-      initMap m
+      initMap :: Digest -> UserMap -> UserMap
+      initMap sha1 m
           | M.null m  = let name = "root"
-                            hash = SHA1.hash []
+                            hash = digest sha1 ""
                         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)