1 module Rakka.Authorization
10 import Control.Concurrent.STM
12 import Control.Monad.Trans
13 import qualified Data.ByteString as B
15 import qualified Data.Map as M hiding (Map)
17 import OpenSSL.EVP.Base64
18 import OpenSSL.EVP.Digest
19 import Rakka.SystemConfig
20 import System.Directory
21 import System.FilePath
26 adbFilePath :: !FilePath
27 , adbUserMap :: !(TVar UserMap)
31 type UserMap = Map String String
34 mkAuthDB :: FilePath -> IO AuthDB
36 = do let path = lsdir </> "authDB"
37 m <- newTVarIO =<< loadUserMap path
44 isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
45 isValidPair adb name pass
46 = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
47 let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
48 atomically $ do m <- readTVar (adbUserMap adb)
49 return (M.lookup name m == Just hash)
52 getUserList :: MonadIO m => AuthDB -> m [String]
56 do m <- readTVar (adbUserMap adb)
60 addUser :: MonadIO m => AuthDB -> String -> String -> m ()
63 do sha1 <- return . fromJust =<< getDigestByName "SHA1"
64 let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
65 m <- atomically $ do m <- readTVar (adbUserMap adb)
66 let m' = M.insert name hash m
67 writeTVar (adbUserMap adb) m'
69 saveUserMap (adbFilePath adb) m
72 delUser :: MonadIO m => AuthDB -> String -> m ()
75 do m <- atomically $ do m <- readTVar (adbUserMap adb)
76 let m' = M.delete name m
77 writeTVar (adbUserMap adb) m'
79 saveUserMap (adbFilePath adb) m
82 loadUserMap :: FilePath -> IO UserMap
84 = do exist <- doesFileExist path
86 liftM (M.fromList . map decodePair . fromJust . deserializeStringPairs)
90 sha1 <- return . fromJust =<< getDigestByName "SHA1"
91 return (initMap sha1 m)
93 decodePair :: (String, String) -> (String, String)
94 decodePair (name, b64Hash)
95 = (UTF8.decodeString name, decodeBase64 b64Hash)
97 initMap :: Digest -> UserMap -> UserMap
99 | M.null m = let name = "root"
100 hash = digest sha1 ""
102 M.singleton name hash
106 saveUserMap :: FilePath -> UserMap -> IO ()
108 = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m
110 encodePair :: (String, String) -> (String, String)
111 encodePair (name, hash)
112 = (UTF8.encodeString name, encodeBase64 hash)