1 module Rakka.Authorization
11 import qualified Codec.Binary.UTF8.String as UTF8
12 import Control.Concurrent.STM
14 import Control.Monad.Trans
15 import qualified Data.ByteString as B
17 import qualified Data.Map as M hiding (Map)
19 import OpenSSL.EVP.Base64
20 import OpenSSL.EVP.Digest
21 import Rakka.SystemConfig
22 import System.Directory
23 import System.FilePath
29 adbFilePath :: !FilePath
30 , adbUserMap :: !(TVar UserMap)
34 type UserMap = Map String String
37 mkAuthDB :: FilePath -> IO AuthDB
39 = do let path = lsdir </> "authDB"
40 m <- newTVarIO =<< loadUserMap path
47 isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
48 isValidPair adb name pass
49 = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
50 let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
51 atomically $ do m <- readTVar (adbUserMap adb)
52 return (M.lookup name m == Just hash)
55 getUserList :: MonadIO m => AuthDB -> m [String]
59 do m <- readTVar (adbUserMap adb)
63 addUser :: MonadIO m => AuthDB -> String -> String -> m ()
66 do sha1 <- return . fromJust =<< getDigestByName "SHA1"
67 let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
68 m <- atomically $ do m <- readTVar (adbUserMap adb)
69 let m' = M.insert name hash m
70 writeTVar (adbUserMap adb) m'
72 saveUserMap (adbFilePath adb) m
75 delUser :: MonadIO m => AuthDB -> String -> m ()
78 do m <- atomically $ do m <- readTVar (adbUserMap adb)
79 let m' = M.delete name m
80 writeTVar (adbUserMap adb) m'
82 saveUserMap (adbFilePath adb) m
85 loadUserMap :: FilePath -> IO UserMap
87 = do exist <- doesFileExist path
89 liftM (M.fromList . map decodePair . fromJust . deserializeStringPairs)
93 sha1 <- return . fromJust =<< getDigestByName "SHA1"
94 return (initMap sha1 m)
96 decodePair :: (String, String) -> (String, String)
97 decodePair (name, b64Hash)
98 = (UTF8.decodeString name, decodeBase64 b64Hash)
100 initMap :: Digest -> UserMap -> UserMap
102 | M.null m = let name = "root"
103 hash = digest sha1 ""
105 M.singleton name hash
109 saveUserMap :: FilePath -> UserMap -> IO ()
111 = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m
113 encodePair :: (String, String) -> (String, String)
114 encodePair (name, hash)
115 = (UTF8.encodeString name, encodeBase64 hash)