VaultManager.hs

{-# LANGUAGE NamedFieldPuns #-}

module Festung.Vault.VaultManager 
    ( newManager
    , stopManager
    , VaultManager
    , query
    , parametrizedQuery
    , deleteVault
    , ManagerError(..)
    ) where

import           Control.Concurrent
import           Control.Monad
import qualified Data.HashMap.Strict        as M
import           Data.Either                (isRight)
import           Control.Monad.Trans.Either
import           System.FilePath            ((</>), normalise)
import           System.Directory

import           Festung.Concurrency.Job
import           Festung.Concurrency.Utils
import           Festung.Config
import qualified Festung.Vault.VaultHandler as V
import qualified Festung.Vault.Persistence  as P
import           Festung.Utils              (hoistMEither, mapLeft, whenJust)


type VaultManager = Job VaultManagerCommand

data ManagerError = VaultError V.VaultError
                  | CouldNotReachManager
                    deriving (Show)

type TimeoutSubscriber = MVar ()

data VaultManagerCommand = OpenVault       (Command V.VaultOpener (Either ManagerError V.Vault))
                         | VaultTimedOut   (Command V.VaultOpener (Either ManagerError ()))
                         | GetSubscription (Command V.VaultOpener (Either ManagerError TimeoutSubscriber))
                         | DeleteVault     (Command V.VaultOpener (Either ManagerError ()))


type VaultMapKey = FilePath

data VaultMapValue = VaultMapValue { opener        :: V.VaultOpener
                                   , vault         :: V.Vault
                                   , subscriptions :: [TimeoutSubscriber]
                                   }

type VaultMap = M.HashMap VaultMapKey VaultMapValue

data ManagerState = ManagerState { registry :: VaultMap
                                 , timeouts :: Chan V.VaultOpener
                                 }


-- | Initial manager state (for internal use only)
newInitialState :: IO ManagerState
newInitialState = do
    timeouts <- newChan
    return ManagerState { registry = M.empty, timeouts = timeouts }


addSubscription :: TimeoutSubscriber -> VaultMapValue -> VaultMapValue
addSubscription s val@VaultMapValue{subscriptions} =
    let subscriptions' = s:subscriptions in
    val{subscriptions=subscriptions'}


-- | Create a timeout consumer
--
-- Process that reads a @'Chan' of vault opener and sends a VaultTimoedOut command
-- to the manager whan a new value is sent to the @'Chan' in question.
--
-- This is for internal use only
newTimeoutConsumer :: VaultManager -> Chan V.VaultOpener -> IO ThreadId
newTimeoutConsumer manager timeouts =
    let sendTimeout = sendMappedCommand VaultTimedOut in
    forkIOForSure $ forever $ do 
        opener <- readChan timeouts
        sendTimeout manager opener


newManager :: Config -> IO VaultManager
newManager config = do
    state           <- newInitialState
    manager         <- newJob state $ handlerLoop config
    timeoutConsumer <- newTimeoutConsumer manager (timeouts state)
    onExit manager $ killThread timeoutConsumer
    return manager


stopManager :: VaultManager -> IO ()
stopManager = killJob


updateStateRegistry :: (VaultMap -> VaultMap) -> ManagerState -> ManagerState
updateStateRegistry f ManagerState{registry,timeouts} =
    ManagerState { registry = f registry, timeouts = timeouts }


-- | Internal function to check the opener when
canAccess :: VaultMap -> VaultMapKey -> V.VaultOpener -> IO Bool
canAccess mapping key opener =
    case M.lookup key mapping of
        Just VaultMapValue{opener=opener'} -> isRight <$> V.checkOpener opener opener'
        Nothing -> return True


-- | Manager intenal loop (for internal use only)
handlerLoop :: Config -> ManagerState -> VaultManagerCommand -> IO (JobStatus, ManagerState)
handlerLoop config state cmd = do
    let opener@(path, _, _) = getOpener cmd
        key = normalise path
    canAccess' <- canAccess (registry state) key opener
    state'     <- if canAccess'
                      -- The opener is wrong, we stupidly say "vault does not exist" because you can't
                      -- access this vault with these parameters.
                      then handleCommand config state key cmd
                      else handleError cmd (VaultError V.CouldNotOpen) >> return state
    return (KeepGoing, state')


-- FIXME(Antoine): This code is totally copy pasted. This needs to use polymorphism.
handleError :: VaultManagerCommand -> ManagerError -> IO ()
handleError (OpenVault     (Command _ responder)) err = putMVar responder (Left err)
handleError (VaultTimedOut (Command _ responder)) err = putMVar responder (Left err)
handleError (DeleteVault   (Command _ responder)) err = putMVar responder (Left err)


getOpener :: VaultManagerCommand -> V.VaultOpener
getOpener (OpenVault       (Command o _)) = o
getOpener (VaultTimedOut   (Command o _)) = o
getOpener (DeleteVault     (Command o _)) = o
getOpener (GetSubscription (Command o _)) = o


-- XXX(Antoine): This is very very bad code
handleCommand :: Config -> ManagerState -> VaultMapKey -> VaultManagerCommand -> IO ManagerState
handleCommand config state key (OpenVault     (Command opener responder)) =
    case M.lookup key (registry state) of
        Just VaultMapValue{vault} -> do
            putMVar responder (Right vault)
            return state
        Nothing -> do
            res <- wrapManagerError <$> V.newHandler config opener
            -- FIXME(Antoine): Nesting!!!
            case res of
                Left err    -> do
                    putMVar responder (Left err)
                    return state
                Right vault -> do
                    onExit vault $ writeChan (timeouts state) opener
                    putMVar responder (Right vault)
                    let value = VaultMapValue {opener=opener, vault=vault, subscriptions=[]}
                    return $ updateStateRegistry (M.insert key value) state

handleCommand _config state key (VaultTimedOut (Command _opener responder)) = do
    whenJust (M.lookup key (registry state)) $ \ VaultMapValue{vault,subscriptions} -> do
        killJob vault -- Just making sure the vault is dead
        forM_ subscriptions $ \ s ->
            void $ tryPutMVar s ()
    putMVar responder $ Right ()
    return $ updateStateRegistry (M.delete key) state

handleCommand _config state key (GetSubscription (Command _opener responder)) =
    let noop = do subscription <- newMVar ()
                  putMVar responder $ Right subscription
                  return state
    in
    case M.lookup key (registry state) of
        Just VaultMapValue{vault} -> do
            running <- isJobRunning vault
            if running
                then noop
                else do
                    subscription <- newEmptyMVar
                    let addSubscription' = addSubscription subscription
                    putMVar responder $ Right subscription
                    return $ updateStateRegistry (M.adjust addSubscription' key) state
        Nothing -> noop

handleCommand Config{dataDirectory} state key (DeleteVault   (Command _opener responder)) = do
    let deleteVault = do filename <- canonicalizePath $ dataDirectory </> key
                         exists   <- doesFileExist filename
                         when exists $ removeFile filename
    case M.lookup key (registry state) of
        Just VaultMapValue{vault, subscriptions} -> do
            killJob vault
            forM_ subscriptions $ \s -> void $ tryPutMVar s ()
            deleteVault
        Nothing -> deleteVault
    putMVar responder $ Right ()
    return $ updateStateRegistry (M.delete key) state


wrapManagerError :: Either V.VaultError a -> Either ManagerError a
wrapManagerError = mapLeft VaultError


flattenError :: Maybe (Either ManagerError a) -> Either ManagerError a
flattenError Nothing  = Left CouldNotReachManager
flattenError (Just e) = e


-- | This is for internal use only
getVault :: V.VaultOpener -> VaultManager -> EitherT ManagerError IO V.Vault
getVault opener manager = hoistMEither $ flattenError <$> sendMappedCommand OpenVault manager opener


-- | This is for internal use only
waitForTimeout :: V.VaultOpener -> VaultManager -> IO (Either ManagerError ())
waitForTimeout opener manager =
    waitOnSubscription =<< flattenError <$> sendMappedCommand GetSubscription manager opener
        where waitOnSubscription (Left err)   = return $ Left err
              waitOnSubscription (Right mvar) = readMVar mvar >> return (Right ())


retryWhenTimedOut :: V.VaultOpener -> VaultManager -> IO (Either ManagerError a)
                  -> IO (Either ManagerError a)
retryWhenTimedOut opener manager action = do
    res <- action
    case res of
        Left (VaultError V.CouldNotReach) -> do
            timeout <- waitForTimeout opener manager
            case timeout of
                Left err -> return $ Left err
                Right _  -> action
        _                                 -> return res


-- | Execute a query on a vault
query :: V.VaultOpener -> VaultManager -> String -> IO (Either ManagerError P.QueryResult)
query opener manager query_ = retryWhenTimedOut opener manager $ runEitherT $ do
    vault <- getVault opener manager
    hoistMEither $ wrapManagerError <$> V.query opener vault query_


-- | Execute a parametrized query
parametrizedQuery :: V.VaultOpener -> VaultManager -> String -> [P.Value]
                  -> IO (Either ManagerError P.QueryResult)
parametrizedQuery opener manager query_ params = retryWhenTimedOut opener manager $ runEitherT $ do
    vault <- getVault opener manager
    hoistMEither $ wrapManagerError <$> V.parametrizedQuery opener vault query_ params


deleteVault :: V.VaultOpener -> VaultManager -> IO (Either ManagerError ())
deleteVault opener manager = flattenError <$> sendMappedCommand DeleteVault manager opener