beginning of implementation of Rakka.Authorization

[Rakka.git] / Rakka / Authorization.hs

diff --git a/Rakka/Authorization.hs b/Rakka/Authorization.hs
new file mode 100644 (file)
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