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
28 adbFilePath :: !FilePath
29 , adbUserMap :: !(TVar UserMap)
33 type UserMap = Map String String
36 mkAuthDB :: FilePath -> IO AuthDB
38 = do let path = lsdir </> "authDB"
39 m <- newTVarIO =<< loadUserMap path
46 isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
47 isValidPair adb name pass
48 = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
49 let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
50 atomically $ do m <- readTVar (adbUserMap adb)
51 return (M.lookup name m == Just hash)
54 getUserList :: MonadIO m => AuthDB -> m [String]
58 do m <- readTVar (adbUserMap adb)
62 addUser :: MonadIO m => AuthDB -> String -> String -> m ()
65 do sha1 <- return . fromJust =<< getDigestByName "SHA1"
66 let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
67 m <- atomically $ do m <- readTVar (adbUserMap adb)
68 let m' = M.insert name hash m
69 writeTVar (adbUserMap adb) m'
71 saveUserMap (adbFilePath adb) m
74 delUser :: MonadIO m => AuthDB -> String -> m ()
77 do m <- atomically $ do m <- readTVar (adbUserMap adb)
78 let m' = M.delete name m
79 writeTVar (adbUserMap adb) m'
81 saveUserMap (adbFilePath adb) m
84 loadUserMap :: FilePath -> IO UserMap
86 = do exist <- doesFileExist path
88 liftM (M.fromList . map decodePair . fromJust . deserializeStringPairs)
92 sha1 <- return . fromJust =<< getDigestByName "SHA1"
93 return (initMap sha1 m)
95 decodePair :: (String, String) -> (String, String)
96 decodePair (name, b64Hash)
97 = (UTF8.decodeString name, decodeBase64 b64Hash)
99 initMap :: Digest -> UserMap -> UserMap
101 | M.null m = let name = "root"
102 hash = digest sha1 ""
104 M.singleton name hash
108 saveUserMap :: FilePath -> UserMap -> IO ()
110 = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m
112 encodePair :: (String, String) -> (String, String)
113 encodePair (name, hash)
114 = (UTF8.encodeString name, encodeBase64 hash)