]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/Authorization.hs
implemented feed generator
[Rakka.git] / Rakka / Authorization.hs
1 module Rakka.Authorization
2     ( AuthDB
3     , mkAuthDB
4     , isValidPair
5     )
6     where
7
8 import qualified Codec.Binary.Base64 as B64
9 import qualified Codec.Binary.UTF8.String as UTF8
10 import           Control.Concurrent.STM
11 import           Control.Monad.Trans
12 import           Data.Digest.SHA2
13 import           Data.Map (Map)
14 import qualified Data.Map as M hiding (Map)
15 import           Data.Maybe
16 import           Data.Word
17 import           Rakka.SystemConfig
18 import           System.Directory
19 import           System.FilePath
20 import           System.IO
21
22
23 data AuthDB
24     = AuthDB {
25         adbFilePath    :: !FilePath
26       , adbUserMap     :: !(TVar UserMap)
27       , adbSyncRequest :: !(TVar Bool)
28       }
29
30
31 type UserMap = Map String [Word8]
32
33
34 mkAuthDB :: FilePath -> IO AuthDB
35 mkAuthDB lsdir
36     = do let path = lsdir </> "authDB"
37          m   <- newTVarIO =<< loadUserMap path
38          req <- newTVarIO False
39          return AuthDB {
40                       adbFilePath    = path
41                     , adbUserMap     = m
42                     , adbSyncRequest = req
43                     }
44
45
46 isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
47 isValidPair adb name pass
48     = let hash = toOctets $ sha256 $ UTF8.encode pass
49       in
50         liftIO $ atomically $ do m <- readTVar (adbUserMap adb)
51                                  return (M.lookup name m == Just hash)
52
53
54 loadUserMap :: FilePath -> IO UserMap
55 loadUserMap path
56     = do exist <- doesFileExist path
57          m     <- if exist then
58                       readFile path
59                       >>=
60                       return . M.fromList . map decodePair . fromJust . deserializeStringPairs
61                   else
62                       return M.empty
63          return (initMap m)
64     where
65       decodePair :: (String, String) -> (String, [Word8])
66       decodePair (name, b64Hash)
67           = (UTF8.decodeString name, fromJust $ B64.decode b64Hash)
68
69       initMap :: UserMap -> UserMap
70       initMap m
71           | M.null m  = let name = "root"
72                             hash = toOctets $ sha256 ([] :: [Word8])
73                         in
74                           M.singleton name hash
75           | otherwise = m