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