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