( AuthDB
, mkAuthDB
, isValidPair
+ , getUserList
+ , addUser
+ , delUser
)
where
-import qualified Codec.Binary.Base64 as B64
import qualified Codec.Binary.UTF8.String as UTF8
import Control.Concurrent.STM
import Control.Monad.Trans
-import Data.Digest.SHA2
+import qualified Data.ByteString as B
import Data.Map (Map)
import qualified Data.Map as M hiding (Map)
import Data.Maybe
-import Data.Word
+import OpenSSL.EVP.Base64
+import OpenSSL.EVP.Digest
import Rakka.SystemConfig
import System.Directory
import System.FilePath
}
-type UserMap = Map String [Word8]
+type UserMap = Map String String
mkAuthDB :: FilePath -> IO AuthDB
isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
isValidPair adb name pass
- = let hash = toOctets $ sha256 $ UTF8.encode pass
- in
- liftIO $ atomically $ do m <- readTVar (adbUserMap adb)
- return (M.lookup name m == Just hash)
+ = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
+ let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
+ atomically $ do m <- readTVar (adbUserMap adb)
+ return (M.lookup name m == Just hash)
+
+
+getUserList :: MonadIO m => AuthDB -> m [String]
+getUserList adb
+ = liftIO $
+ atomically $
+ do m <- readTVar (adbUserMap adb)
+ return (M.keys m)
+
+
+addUser :: MonadIO m => AuthDB -> String -> String -> m ()
+addUser adb name pass
+ = liftIO $
+ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
+ let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
+ m <- atomically $ do m <- readTVar (adbUserMap adb)
+ let m' = M.insert name hash m
+ writeTVar (adbUserMap adb) m'
+ return m'
+ saveUserMap (adbFilePath adb) m
+
+
+delUser :: MonadIO m => AuthDB -> String -> m ()
+delUser adb name
+ = liftIO $
+ do m <- atomically $ do m <- readTVar (adbUserMap adb)
+ let m' = M.delete name m
+ writeTVar (adbUserMap adb) m'
+ return m'
+ saveUserMap (adbFilePath adb) m
loadUserMap :: FilePath -> IO UserMap
return . M.fromList . map decodePair . fromJust . deserializeStringPairs
else
return M.empty
- return (initMap m)
+ sha1 <- return . fromJust =<< getDigestByName "SHA1"
+ return (initMap sha1 m)
where
- decodePair :: (String, String) -> (String, [Word8])
+ decodePair :: (String, String) -> (String, String)
decodePair (name, b64Hash)
- = (UTF8.decodeString name, fromJust $ B64.decode b64Hash)
+ = (UTF8.decodeString name, decodeBase64 b64Hash)
- initMap :: UserMap -> UserMap
- initMap m
+ initMap :: Digest -> UserMap -> UserMap
+ initMap sha1 m
| M.null m = let name = "root"
- hash = toOctets $ sha256 ([] :: [Word8])
+ hash = digest sha1 ""
in
M.singleton name hash
| otherwise = m
+
+
+saveUserMap :: FilePath -> UserMap -> IO ()
+saveUserMap path m
+ = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m
+ where
+ encodePair :: (String, String) -> (String, String)
+ encodePair (name, hash)
+ = (UTF8.encodeString name, encodeBase64 hash)