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 qualified Data.Digest.SHA1 as SHA1
  12 import           Data.Map (Map)
  13 import qualified Data.Map as M hiding (Map)
  14 import           Data.Maybe
  15 import           Data.Word
  16 import           Rakka.SystemConfig
  17 import           System.Directory
  18 import           System.FilePath
  19 import           System.IO
  20
  21
  22 data AuthDB
  23     = AuthDB {
  24         adbFilePath    :: !FilePath
  25       , adbUserMap     :: !(TVar UserMap)
  26       , adbSyncRequest :: !(TVar Bool)
  27       }
  28
  29
  30 type UserMap = Map String [Word8]
  31
  32
  33 mkAuthDB :: FilePath -> IO AuthDB
  34 mkAuthDB lsdir
  35     = do let path = lsdir </> "authDB"
  36          m   <- newTVarIO =<< loadUserMap path
  37          req <- newTVarIO False
  38          return AuthDB {
  39                       adbFilePath    = path
  40                     , adbUserMap     = m
  41                     , adbSyncRequest = req
  42                     }
  43
  44
  45 isValidPair :: AuthDB -> String -> String -> IO Bool
  46 isValidPair adb name pass
  47     = let hash = SHA1.hash (UTF8.encode pass)
  48       in
  49         atomically $ do m <- readTVar (adbUserMap adb)
  50                         return (M.lookup name m == Just hash)
  51
  52
  53 loadUserMap :: FilePath -> IO UserMap
  54 loadUserMap path
  55     = do exist <- doesFileExist path
  56          if exist then
  57              readFile path
  58                 >>=
  59                 return . initMap . M.fromList . map decodePair . fromJust . deserializeStringPairs
  60            else
  61              return M.empty
  62     where
  63       decodePair :: (String, String) -> (String, [Word8])
  64       decodePair (name, b64Hash)
  65           = (UTF8.decodeString name, B64.decode b64Hash)
  66
  67       initMap :: UserMap -> UserMap
  68       initMap m
  69           | M.null m  = let name = "root"
  70                             hash = SHA1.hash []
  71                         in
  72                           M.singleton name hash
  73           | otherwise = m