1 module Rakka.Authorization
11 import qualified Codec.Binary.UTF8.String as UTF8
12 import Control.Concurrent.STM
13 import Control.Monad.Trans
14 import qualified Data.ByteString as B
16 import qualified Data.Map as M hiding (Map)
18 import OpenSSL.EVP.Base64
19 import OpenSSL.EVP.Digest
20 import Rakka.SystemConfig
21 import System.Directory
22 import System.FilePath
28 adbFilePath :: !FilePath
29 , adbUserMap :: !(TVar UserMap)
30 , adbSyncRequest :: !(TVar Bool)
34 type UserMap = Map String String
37 mkAuthDB :: FilePath -> IO AuthDB
39 = do let path = lsdir </> "authDB"
40 m <- newTVarIO =<< loadUserMap path
41 req <- newTVarIO False
45 , adbSyncRequest = req
49 isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
50 isValidPair adb name pass
51 = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
52 let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
53 atomically $ do m <- readTVar (adbUserMap adb)
54 return (M.lookup name m == Just hash)
57 getUserList :: MonadIO m => AuthDB -> m [String]
61 do m <- readTVar (adbUserMap adb)
65 addUser :: MonadIO m => AuthDB -> String -> String -> m ()
68 do sha1 <- return . fromJust =<< getDigestByName "SHA1"
69 let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
70 m <- atomically $ do m <- readTVar (adbUserMap adb)
71 let m' = M.insert name hash m
72 writeTVar (adbUserMap adb) m'
74 saveUserMap (adbFilePath adb) m
77 delUser :: MonadIO m => AuthDB -> String -> m ()
80 do m <- atomically $ do m <- readTVar (adbUserMap adb)
81 let m' = M.delete name m
82 writeTVar (adbUserMap adb) m'
84 saveUserMap (adbFilePath adb) m
87 loadUserMap :: FilePath -> IO UserMap
89 = do exist <- doesFileExist path
93 return . M.fromList . map decodePair . fromJust . deserializeStringPairs
96 sha1 <- return . fromJust =<< getDigestByName "SHA1"
97 return (initMap sha1 m)
99 decodePair :: (String, String) -> (String, String)
100 decodePair (name, b64Hash)
101 = (UTF8.decodeString name, decodeBase64 b64Hash)
103 initMap :: Digest -> UserMap -> UserMap
105 | M.null m = let name = "root"
106 hash = digest sha1 ""
108 M.singleton name hash
112 saveUserMap :: FilePath -> UserMap -> IO ()
114 = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m
116 encodePair :: (String, String) -> (String, String)
117 encodePair (name, hash)
118 = (UTF8.encodeString name, encodeBase64 hash)