Rakka/Authorization.hs

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