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       }
  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          return AuthDB {
  42                       adbFilePath = path
  43                     , adbUserMap  = m
  44                     }
  45
  46
  47 isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
  48 isValidPair adb name pass
  49     = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
  50                   let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
  51                   atomically $ do m <- readTVar (adbUserMap adb)
  52                                   return (M.lookup name m == Just hash)
  53
  54
  55 getUserList :: MonadIO m => AuthDB -> m [String]
  56 getUserList adb
  57     = liftIO $
  58       atomically $
  59       do m <- readTVar (adbUserMap adb)
  60          return (M.keys m)
  61
  62
  63 addUser :: MonadIO m => AuthDB -> String -> String -> m ()
  64 addUser adb name pass
  65     = liftIO $
  66       do sha1 <- return . fromJust =<< getDigestByName "SHA1"
  67          let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
  68          m <- atomically $ do m <- readTVar (adbUserMap adb)
  69                               let m' = M.insert name hash m
  70                               writeTVar (adbUserMap adb) m'
  71                               return m'
  72          saveUserMap (adbFilePath adb) m
  73
  74
  75 delUser :: MonadIO m => AuthDB -> String -> m ()
  76 delUser adb name
  77     = liftIO $
  78       do m <- atomically $ do m <- readTVar (adbUserMap adb)
  79                               let m' = M.delete name m
  80                               writeTVar (adbUserMap adb) m'
  81                               return m'
  82          saveUserMap (adbFilePath adb) m
  83
  84
  85 loadUserMap :: FilePath -> IO UserMap
  86 loadUserMap path
  87     = do exist <- doesFileExist path
  88          m     <- if exist then
  89                       liftM (M.fromList . map decodePair . fromJust . deserializeStringPairs)
  90                             (readFile path)
  91                   else
  92                       return M.empty
  93          sha1  <- return . fromJust =<< getDigestByName "SHA1"
  94          return (initMap sha1 m)
  95     where
  96       decodePair :: (String, String) -> (String, String)
  97       decodePair (name, b64Hash)
  98           = (UTF8.decodeString name, decodeBase64 b64Hash)
  99
 100       initMap :: Digest -> UserMap -> UserMap
 101       initMap sha1 m
 102           | M.null m  = let name = "root"
 103                             hash = digest sha1 ""
 104                         in
 105                           M.singleton name hash
 106           | otherwise = m
 107
 108
 109 saveUserMap :: FilePath -> UserMap -> IO ()
 110 saveUserMap path m
 111     = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m
 112     where
 113     encodePair :: (String, String) -> (String, String)
 114     encodePair (name, hash)
 115         = (UTF8.encodeString name, encodeBase64 hash)