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           Rakka.SystemConfig
  18 import           System.Directory
  19 import           System.FilePath
  20
  21
  22 data AuthDB
  23     = AuthDB {
  24         adbFilePath    :: !FilePath
  25       , adbUserMap     :: !(TVar UserMap)
  26       }
  27
  28
  29 type UserMap = Map String String
  30
  31
  32 mkAuthDB :: FilePath -> IO AuthDB
  33 mkAuthDB lsdir
  34     = do let path = lsdir </> "authDB"
  35          m <- newTVarIO =<< loadUserMap path
  36          return AuthDB {
  37                       adbFilePath = path
  38                     , adbUserMap  = m
  39                     }
  40
  41
  42 isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
  43 isValidPair adb name pass
  44     = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
  45                   let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
  46                   atomically $ do m <- readTVar (adbUserMap adb)
  47                                   return (M.lookup name m == Just hash)
  48
  49
  50 getUserList :: MonadIO m => AuthDB -> m [String]
  51 getUserList adb
  52     = liftIO $
  53       atomically $
  54       do m <- readTVar (adbUserMap adb)
  55          return (M.keys m)
  56
  57
  58 addUser :: MonadIO m => AuthDB -> String -> String -> m ()
  59 addUser adb name pass
  60     = liftIO $
  61       do sha1 <- return . fromJust =<< getDigestByName "SHA1"
  62          let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
  63          m <- atomically $ do m <- readTVar (adbUserMap adb)
  64                               let m' = M.insert name hash m
  65                               writeTVar (adbUserMap adb) m'
  66                               return m'
  67          saveUserMap (adbFilePath adb) m
  68
  69
  70 delUser :: MonadIO m => AuthDB -> String -> m ()
  71 delUser adb name
  72     = liftIO $
  73       do m <- atomically $ do m <- readTVar (adbUserMap adb)
  74                               let m' = M.delete name m
  75                               writeTVar (adbUserMap adb) m'
  76                               return m'
  77          saveUserMap (adbFilePath adb) m
  78
  79
  80 loadUserMap :: FilePath -> IO UserMap
  81 loadUserMap path
  82     = do exist <- doesFileExist path
  83          m     <- if exist then
  84                       liftM (M.fromList . map decodePair . fromJust . deserializeStringPairs)
  85                             (readFile path)
  86                   else
  87                       return M.empty
  88          sha1  <- return . fromJust =<< getDigestByName "SHA1"
  89          return (initMap sha1 m)
  90     where
  91       decodePair :: (String, String) -> (String, String)
  92       decodePair (name, b64Hash)
  93           = (UTF8.decodeString name, decodeBase64 b64Hash)
  94
  95       initMap :: Digest -> UserMap -> UserMap
  96       initMap sha1 m
  97           | M.null m  = let name = "root"
  98                             hash = digest sha1 ""
  99                         in
 100                           M.singleton name hash
 101           | otherwise = m
 102
 103
 104 saveUserMap :: FilePath -> UserMap -> IO ()
 105 saveUserMap path m
 106     = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m
 107     where
 108     encodePair :: (String, String) -> (String, String)
 109     encodePair (name, hash)
 110         = (UTF8.encodeString name, encodeBase64 hash)