{-# LANGUAGE
    OverloadedStrings
  , UnicodeSyntax
  #-}
-- FIXME: authentication
module Rakka.Authorization
    ( AuthDB
    , mkAuthDB
    , isValidPair
    , getUserList
    , addUser
    , delUser
    )
    where
import Control.Applicative
import           Control.Concurrent.STM
import           Control.Monad.Trans
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

data AuthDB
    = AuthDB {
        adbFilePath ∷ !FilePath
      , adbUserMap  ∷ !(TVar UserMap)
      }

type UserMap = Map Text ByteString

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


isValidPair ∷ MonadIO m ⇒ AuthDB → Text → Text → m Bool
isValidPair adb name pass
    = 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 → Text → Text → m ()
addUser adb name pass
    = liftIO $
      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 → 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'
	 saveUserMap (adbFilePath adb) m

loadUserMap ∷ FilePath → IO UserMap
loadUserMap path
    = 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
      initMap ∷ Digest → UserMap → UserMap
      initMap sha1 m
          | M.null m  = let name = "root"
                            hash = digestBS' sha1 ""
                        in
                          M.singleton name hash
          | otherwise = m

saveUserMap ∷ FilePath → UserMap → IO ()
saveUserMap path
    = T.writeFile path ∘ serializeMap id (T.decodeUtf8 ∘ encodeBase64BS)