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