Rakka/Authorization.hs

   1 module Rakka.Authorization
   2     ( AuthDB
   3     , mkAuthDB
   4     , isValidPair
   5     , getUserList
   6     , addUser
   7     , delUser
   8     )
   9     where
  10 import           Control.Concurrent.STM
  11 import           Control.Monad
  12 import           Control.Monad.Trans
  13 import qualified Data.ByteString as B
  14 import           Data.Map (Map)
  15 import qualified Data.Map as M hiding (Map)
  16 import           Data.Maybe
  17 import           OpenSSL.EVP.Base64
  18 import           OpenSSL.EVP.Digest
  19 import           Rakka.SystemConfig
  20 import           System.Directory
  21 import           System.FilePath
  22
  23
  24 data AuthDB
  25     = AuthDB {
  26         adbFilePath    :: !FilePath
  27       , adbUserMap     :: !(TVar UserMap)
  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          return AuthDB {
  39                       adbFilePath = path
  40                     , adbUserMap  = m
  41                     }
  42
  43
  44 isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
  45 isValidPair adb name pass
  46     = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
  47                   let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
  48                   atomically $ do m <- readTVar (adbUserMap adb)
  49                                   return (M.lookup name m == Just hash)
  50
  51
  52 getUserList :: MonadIO m => AuthDB -> m [String]
  53 getUserList adb
  54     = liftIO $
  55       atomically $
  56       do m <- readTVar (adbUserMap adb)
  57          return (M.keys m)
  58
  59
  60 addUser :: MonadIO m => AuthDB -> String -> String -> m ()
  61 addUser adb name pass
  62     = liftIO $
  63       do sha1 <- return . fromJust =<< getDigestByName "SHA1"
  64          let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
  65          m <- atomically $ do m <- readTVar (adbUserMap adb)
  66                               let m' = M.insert name hash m
  67                               writeTVar (adbUserMap adb) m'
  68                               return m'
  69          saveUserMap (adbFilePath adb) m
  70
  71
  72 delUser :: MonadIO m => AuthDB -> String -> m ()
  73 delUser adb name
  74     = liftIO $
  75       do m <- atomically $ do m <- readTVar (adbUserMap adb)
  76                               let m' = M.delete name m
  77                               writeTVar (adbUserMap adb) m'
  78                               return m'
  79          saveUserMap (adbFilePath adb) m
  80
  81
  82 loadUserMap :: FilePath -> IO UserMap
  83 loadUserMap path
  84     = do exist <- doesFileExist path
  85          m     <- if exist then
  86                       liftM (M.fromList . map decodePair . fromJust . deserializeStringPairs)
  87                             (readFile path)
  88                   else
  89                       return M.empty
  90          sha1  <- return . fromJust =<< getDigestByName "SHA1"
  91          return (initMap sha1 m)
  92     where
  93       decodePair :: (String, String) -> (String, String)
  94       decodePair (name, b64Hash)
  95           = (UTF8.decodeString name, decodeBase64 b64Hash)
  96
  97       initMap :: Digest -> UserMap -> UserMap
  98       initMap sha1 m
  99           | M.null m  = let name = "root"
 100                             hash = digest sha1 ""
 101                         in
 102                           M.singleton name hash
 103           | otherwise = m
 104
 105
 106 saveUserMap :: FilePath -> UserMap -> IO ()
 107 saveUserMap path m
 108     = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m
 109     where
 110     encodePair :: (String, String) -> (String, String)
 111     encodePair (name, hash)
 112         = (UTF8.encodeString name, encodeBase64 hash)