+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