VaultHandler.hs

{-# LANGUAGE NamedFieldPuns #-}

module Festung.Vault.VaultHandler 
    ( VaultOpener
    , Vault
    , VaultError(..)
    , newHandler
    , query
    , parametrizedQuery
    , checkOpener
    , updateOpenerPath
    ) where

import           Control.Monad.Trans.Either
import           Control.Monad.Trans.Class
import           Control.Concurrent
import           System.Directory           (canonicalizePath)
import           System.FilePath            ((</>))

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


-- | Data necessary to open vault (filename, password, parameters)
type VaultOpener = (FilePath, P.Password, P.VaultParameters)

data VaultError = CouldNotReach
                | CouldNotOpen
                | VaultError P.Error 
                deriving (Show)

data VaultCommand = Query (Command String (Either VaultError P.QueryResult))
                  | ParametrizedQuery (Command (String, [P.Value]) (Either VaultError P.QueryResult))

type Vault = Job (VaultOpener, VaultCommand)


type VaultState = (VaultOpener, P.VaultHandle)


-- | Create a new vault handler job
newHandler :: Config -> VaultOpener -> IO (Either VaultError Vault)
newHandler config@Config{dataDirectory,vaultTimeout} opener@(path, password, params) = runEitherT $ do
    canonicalPath <- lift $ canonicalizePath $ dataDirectory </> path
    handle <- hoistMEither $ mapLeft (const CouldNotOpen) <$> P.openVault' canonicalPath password params
    lift $ do
        let state = (opener, handle)
        vault <- newGig vaultTimeout state $ handlerLoop config
        onExit vault (P.closeVault handle)
        return vault


checkOpener :: VaultOpener -> VaultOpener -> IO (Either VaultError ())
checkOpener o1 o2 =
    return $ if o1 == o2 
                then Right ()
                else Left  CouldNotOpen


updateOpenerPath :: VaultOpener -> FilePath -> VaultOpener
updateOpenerPath (_, password, params) path = (path, password, params)


-- | Vault handler consuming messages send to the processor
--
-- This function is for internal use only
handlerLoop :: Config -> VaultState -> (VaultOpener, VaultCommand) -> IO (JobStatus, VaultState)
handlerLoop _config state@(opener, vault) (cmdOpener, cmd) = do
    err <- checkOpener opener cmdOpener
    case err of
        Left msg -> handleError cmd msg
        Right _  -> handleCommand vault cmd
    return (KeepGoing, state)


wrapVaultErrors :: Either P.Error a -> Either VaultError a
wrapVaultErrors = mapLeft VaultError


-- FIXME(Antoine): This code is totally copy pasted, we need to find a better
--                 solution for this
handleCommand :: P.VaultHandle -> VaultCommand -> IO ()
handleCommand vault (Query (Command query_ responder)) =
    putMVar responder =<< wrapVaultErrors <$> P.executeQuery vault query_
handleCommand vault (ParametrizedQuery (Command (query_, params) responder)) =
    putMVar responder =<< wrapVaultErrors <$> P.executeParameterizedQuery vault query_ params


-- FIXME(Antoine): This code is totally copy pasted, we need to find a better
--                 solution for this. Type kinds, or polymorphism, I don't want
--                 to use dynamic types.
handleError :: VaultCommand -> VaultError -> IO ()
handleError (Query             (Command _ responder)) err = putMVar responder (Left err)
handleError (ParametrizedQuery (Command _ responder)) err = putMVar responder (Left err)


flattenError :: Maybe (Either VaultError a) -> Either VaultError a
flattenError Nothing  = Left CouldNotReach
flattenError (Just e) = e


-- | Execute a query
query :: VaultOpener -> Vault -> String -> IO (Either VaultError P.QueryResult)
query o v q = flattenError <$> sendMappedCommand f v q
    where f = (,) o . Query


-- | Execute a parametrized query
parametrizedQuery :: VaultOpener -> Vault -> String -> [P.Value] -> IO (Either VaultError P.QueryResult)
parametrizedQuery o v q p = flattenError <$> sendMappedCommand f v (q, p)
    where f = (,) o . ParametrizedQuery