Rakka/Authorization.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5 -- FIXME: authentication
   6 module Rakka.Authorization
   7     ( AuthDB
   8     , mkAuthDB
   9     , isValidPair
  10     , getUserList
  11     , addUser
  12     , delUser
  13     )
  14     where
  15 import Control.Applicative
  16 import           Control.Concurrent.STM
  17 import           Control.Monad.Trans
  18 import Data.ByteString (ByteString)
  19 import           Data.Map (Map)
  20 import qualified Data.Map as M hiding (Map)
  21 import           Data.Maybe
  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
  31
  32 data AuthDB
  33     = AuthDB {
  34         adbFilePath ∷ !FilePath
  35       , adbUserMap  ∷ !(TVar UserMap)
  36       }
  37
  38 type UserMap = Map Text ByteString
  39
  40 mkAuthDB :: FilePath -> IO AuthDB
  41 mkAuthDB lsdir
  42     = do let path = lsdir </> "authDB"
  43          m <- newTVarIO =<< loadUserMap path
  44          return AuthDB {
  45                       adbFilePath = path
  46                     , adbUserMap  = m
  47                     }
  48
  49
  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
  56
  57 getUserList ∷ MonadIO m ⇒ AuthDB → m [Text]
  58 getUserList = liftIO ∘ atomically ∘ (M.keys <$>) ∘ readTVar ∘ adbUserMap
  59
  60 addUser ∷ MonadIO m ⇒ AuthDB → Text → Text → m ()
  61 addUser adb name pass
  62     = liftIO $
  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'
  68                              return m'
  69          saveUserMap (adbFilePath adb) m
  70
  71 delUser ∷ MonadIO m ⇒ AuthDB → Text → m ()
  72 delUser adb name
  73     = liftIO $
  74       do m ← atomically $ do m ← readTVar (adbUserMap adb)
  75                              let m' = M.delete name m
  76                              writeTVar (adbUserMap adb) m'
  77                              return m'
  78          saveUserMap (adbFilePath adb) m
  79
  80 loadUserMap ∷ FilePath → IO UserMap
  81 loadUserMap path
  82     = do exist ← doesFileExist path
  83          m     ← if exist then
  84                      fromJust ∘ deserializeMap id (decodeBase64BS ∘ T.encodeUtf8)
  85                      <$> T.readFile path
  86                  else
  87                      pure M.empty
  88          sha1  ← fromJust <$> getDigestByName "SHA1"
  89          pure $ initMap sha1 m
  90     where
  91       initMap ∷ Digest → UserMap → UserMap
  92       initMap sha1 m
  93           | M.null m  = let name = "root"
  94                             hash = digestBS' sha1 ""
  95                         in
  96                           M.singleton name hash
  97           | otherwise = m
  98
  99 saveUserMap ∷ FilePath → UserMap → IO ()
 100 saveUserMap path
 101     = T.writeFile path ∘ serializeMap id (T.decodeUtf8 ∘ encodeBase64BS)