Fixing build breakage...

[Rakka.git] / Rakka / Authorization.hs

diff --git a/Rakka/Authorization.hs b/Rakka/Authorization.hs
index 0f865c3dee08b7be0baf710c5a6216d23d41a879..d4da7dba078d6a4bfbeb45f8d367b3bfbe3b1623 100644 (file)
--- a/Rakka/Authorization.hs
+++ b/Rakka/Authorization.hs
@@ -2,11 +2,13 @@ module Rakka.Authorization
     ( AuthDB
     , mkAuthDB
     , isValidPair
+    , getUserList
+    , addUser
+    , delUser
     )
     where
-
-import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Concurrent.STM
+import           Control.Monad
 import           Control.Monad.Trans
 import qualified Data.ByteString as B
 import           Data.Map (Map)
@@ -17,14 +19,12 @@ import           OpenSSL.EVP.Digest
 import           Rakka.SystemConfig
 import           System.Directory
 import           System.FilePath
-import           System.IO
 
 
 data AuthDB
     = AuthDB {
         adbFilePath    :: !FilePath
       , adbUserMap     :: !(TVar UserMap)
-      , adbSyncRequest :: !(TVar Bool)
       }
 
 
@@ -34,12 +34,10 @@ type UserMap = Map String String
 mkAuthDB :: FilePath -> IO AuthDB
 mkAuthDB lsdir
     = do let path = lsdir </> "authDB"
-         m   <- newTVarIO =<< loadUserMap path
-         req <- newTVarIO False
+         m <- newTVarIO =<< loadUserMap path
          return AuthDB {
-                      adbFilePath    = path
-                    , adbUserMap     = m
-                    , adbSyncRequest = req
+                      adbFilePath = path
+                    , adbUserMap  = m
                     }
 
 
@@ -51,13 +49,42 @@ 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
          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
          sha1  <- return . fromJust =<< getDigestByName "SHA1"
@@ -74,3 +101,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)