5 -- FIXME: authentication
6 module Rakka.Authorization
15 import Control.Applicative
16 import Control.Concurrent.STM
17 import Control.Monad.Trans
18 import Data.ByteString (ByteString)
20 import qualified Data.Map as M hiding (Map)
22 import Data.Text (Text)
23 import qualified Data.Text.Encoding as T
24 import qualified Data.Text.IO as T
25 import OpenSSL.EVP.Base64
26 import OpenSSL.EVP.Digest
27 import Prelude.Unicode
28 import Rakka.SystemConfig
29 import System.Directory
30 import System.FilePath
34 adbFilePath ∷ !FilePath
35 , adbUserMap ∷ !(TVar UserMap)
38 type UserMap = Map Text ByteString
40 mkAuthDB :: FilePath -> IO AuthDB
42 = do let path = lsdir </> "authDB"
43 m <- newTVarIO =<< loadUserMap path
50 isValidPair ∷ MonadIO m ⇒ AuthDB → Text → Text → m Bool
51 isValidPair adb name pass
52 = liftIO $ do sha1 ← fromJust <$> getDigestByName "SHA1"
53 let hash = digestBS' sha1 $ T.encodeUtf8 pass
54 atomically $ do m ← readTVar (adbUserMap adb)
55 pure $ M.lookup name m ≡ Just hash
57 getUserList ∷ MonadIO m ⇒ AuthDB → m [Text]
58 getUserList = liftIO ∘ atomically ∘ (M.keys <$>) ∘ readTVar ∘ adbUserMap
60 addUser ∷ MonadIO m ⇒ AuthDB → Text → Text → m ()
63 do sha1 ← fromJust <$> getDigestByName "SHA1"
64 let hash = digestBS' sha1 $ T.encodeUtf8 pass
65 m ← atomically $ do m ← readTVar (adbUserMap adb)
66 let m' = M.insert name hash m
67 writeTVar (adbUserMap adb) m'
69 saveUserMap (adbFilePath adb) m
71 delUser ∷ MonadIO m ⇒ AuthDB → Text → m ()
74 do m ← atomically $ do m ← readTVar (adbUserMap adb)
75 let m' = M.delete name m
76 writeTVar (adbUserMap adb) m'
78 saveUserMap (adbFilePath adb) m
80 loadUserMap ∷ FilePath → IO UserMap
82 = do exist ← doesFileExist path
84 fromJust ∘ deserializeMap id (decodeBase64BS ∘ T.encodeUtf8)
88 sha1 ← fromJust <$> getDigestByName "SHA1"
91 initMap ∷ Digest → UserMap → UserMap
93 | M.null m = let name = "root"
94 hash = digestBS' sha1 ""
99 saveUserMap ∷ FilePath → UserMap → IO ()
101 = T.writeFile path ∘ serializeMap id (T.decodeUtf8 ∘ encodeBase64BS)