Rakka/Authorization.hs

   1 module Rakka.Authorization
   2     ( AuthDB
   3     , mkAuthDB
   4     , isValidPair
   5     )
   6     where
   7
   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
  12 import           Data.Map (Map)
  13 import qualified Data.Map as M hiding (Map)
  14 import           Data.Maybe
  15 import           OpenSSL.EVP.Base64
  16 import           OpenSSL.EVP.Digest
  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 String
  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     = 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)
  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          sha1  <- return . fromJust =<< getDigestByName "SHA1"
  64          return (initMap sha1 m)
  65     where
  66       decodePair :: (String, String) -> (String, String)
  67       decodePair (name, b64Hash)
  68           = (UTF8.decodeString name, decodeBase64 b64Hash)
  69
  70       initMap :: Digest -> UserMap -> UserMap
  71       initMap sha1 m
  72           | M.null m  = let name = "root"
  73                             hash = digest sha1 ""
  74                         in
  75                           M.singleton name hash
  76           | otherwise = m