1 module Rakka.Authorization
8 import qualified Codec.Binary.UTF8.String as UTF8
9 import Control.Concurrent.STM
10 import Control.Monad.Trans
11 import qualified Data.ByteString as B
13 import qualified Data.Map as M hiding (Map)
15 import OpenSSL.EVP.Base64
16 import OpenSSL.EVP.Digest
17 import Rakka.SystemConfig
18 import System.Directory
19 import System.FilePath
25 adbFilePath :: !FilePath
26 , adbUserMap :: !(TVar UserMap)
27 , adbSyncRequest :: !(TVar Bool)
31 type UserMap = Map String String
34 mkAuthDB :: FilePath -> IO AuthDB
36 = do let path = lsdir </> "authDB"
37 m <- newTVarIO =<< loadUserMap path
38 req <- newTVarIO False
42 , adbSyncRequest = req
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 loadUserMap :: FilePath -> IO UserMap
56 = do exist <- doesFileExist path
60 return . M.fromList . map decodePair . fromJust . deserializeStringPairs
63 sha1 <- return . fromJust =<< getDigestByName "SHA1"
64 return (initMap sha1 m)
66 decodePair :: (String, String) -> (String, String)
67 decodePair (name, b64Hash)
68 = (UTF8.decodeString name, decodeBase64 b64Hash)
70 initMap :: Digest -> UserMap -> UserMap
72 | M.null m = let name = "root"