+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
+-- FIXME: authentication
module Rakka.Authorization
( AuthDB
, mkAuthDB
, delUser
)
where
-
-import qualified Codec.Binary.UTF8.String as UTF8
+import Control.Applicative
import Control.Concurrent.STM
-import Control.Monad
import Control.Monad.Trans
-import qualified Data.ByteString as B
+import Data.ByteString (ByteString)
import Data.Map (Map)
import qualified Data.Map as M hiding (Map)
import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.IO as T
import OpenSSL.EVP.Base64
import OpenSSL.EVP.Digest
+import Prelude.Unicode
import Rakka.SystemConfig
import System.Directory
import System.FilePath
-import System.IO
-
data AuthDB
= AuthDB {
- adbFilePath :: !FilePath
- , adbUserMap :: !(TVar UserMap)
- , adbSyncRequest :: !(TVar Bool)
+ adbFilePath ∷ !FilePath
+ , adbUserMap ∷ !(TVar UserMap)
}
-
-type UserMap = Map String String
-
+type UserMap = Map Text ByteString
mkAuthDB :: FilePath -> IO AuthDB
mkAuthDB lsdir
= do let path = lsdir </> "authDB"
- m <- newTVarIO =<< loadUserMap path
- req <- newTVarIO False
+ m <- newTVarIO =<< loadUserMap path
return AuthDB {
- adbFilePath = path
- , adbUserMap = m
- , adbSyncRequest = req
+ adbFilePath = path
+ , adbUserMap = m
}
-isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
+isValidPair ∷ MonadIO m ⇒ AuthDB → Text → Text → m Bool
isValidPair adb name pass
- = 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)
+ = liftIO $ do sha1 ← fromJust <$> getDigestByName "SHA1"
+ let hash = digestBS' sha1 $ T.encodeUtf8 pass
+ atomically $ do m ← readTVar (adbUserMap adb)
+ pure $ M.lookup name m ≡ Just hash
+getUserList ∷ MonadIO m ⇒ AuthDB → m [Text]
+getUserList = liftIO ∘ atomically ∘ (M.keys <$>) ∘ readTVar ∘ adbUserMap
-addUser :: MonadIO m => AuthDB -> String -> String -> m ()
+addUser ∷ MonadIO m ⇒ AuthDB → Text → Text → 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'
+ do sha1 ← fromJust <$> getDigestByName "SHA1"
+ let hash = digestBS' sha1 $ T.encodeUtf8 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 ∷ MonadIO m ⇒ AuthDB → Text → 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'
+ 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
+loadUserMap ∷ FilePath → IO UserMap
loadUserMap path
- = do exist <- doesFileExist path
- m <- if exist then
- liftM (M.fromList . map decodePair . fromJust . deserializeStringPairs)
- (readFile path)
- else
- return M.empty
- sha1 <- return . fromJust =<< getDigestByName "SHA1"
- return (initMap sha1 m)
+ = do exist ← doesFileExist path
+ m ← if exist then
+ fromJust ∘ deserializeMap id (decodeBase64BS ∘ T.encodeUtf8)
+ <$> T.readFile path
+ else
+ pure M.empty
+ sha1 ← fromJust <$> getDigestByName "SHA1"
+ pure $ initMap sha1 m
where
- decodePair :: (String, String) -> (String, String)
- decodePair (name, b64Hash)
- = (UTF8.decodeString name, decodeBase64 b64Hash)
-
- initMap :: Digest -> UserMap -> UserMap
+ initMap ∷ Digest → UserMap → UserMap
initMap sha1 m
| M.null m = let name = "root"
- hash = digest sha1 ""
+ hash = digestBS' 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)
+saveUserMap ∷ FilePath → UserMap → IO ()
+saveUserMap path
+ = T.writeFile path ∘ serializeMap id (T.decodeUtf8 ∘ encodeBase64BS)