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                       readFile path
  92                       >>=
  93                       return . M.fromList . map decodePair . fromJust . deserializeStringPairs
  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)