module Rakka.Authorization
    ( AuthDB
    , mkAuthDB
    , isValidPair
    , getUserList
    , addUser
    , delUser
    )
    where

import qualified Codec.Binary.UTF8.String as UTF8
import           Control.Concurrent.STM
import           Control.Monad
import           Control.Monad.Trans
import qualified Data.ByteString as B
import           Data.Map (Map)
import qualified Data.Map as M hiding (Map)
import           Data.Maybe
import           OpenSSL.EVP.Base64
import           OpenSSL.EVP.Digest
import           Rakka.SystemConfig
import           System.Directory
import           System.FilePath
import           System.IO


data AuthDB
    = AuthDB {
        adbFilePath    :: !FilePath
      , adbUserMap     :: !(TVar UserMap)
      , adbSyncRequest :: !(TVar Bool)
      }


type UserMap = Map String String


mkAuthDB :: FilePath -> IO AuthDB
mkAuthDB lsdir
    = do let path = lsdir </> "authDB"
         m   <- newTVarIO =<< loadUserMap path
         req <- newTVarIO False
         return AuthDB {
                      adbFilePath    = path
                    , adbUserMap     = m
                    , adbSyncRequest = req
                    }


isValidPair :: MonadIO m => AuthDB -> String -> String -> 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)


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
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)
    where
      decodePair :: (String, String) -> (String, String)
      decodePair (name, b64Hash)
          = (UTF8.decodeString name, decodeBase64 b64Hash)

      initMap :: Digest -> UserMap -> UserMap
      initMap sha1 m
          | M.null m  = let name = "root"
                            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)