{-# LANGUAGE TemplateHaskell #-}

{-| The Ganeti WConfd core functions.

This module defines all the functions that WConfD exports for
RPC calls. They are in a separate module so that in a later
stage, TemplateHaskell can generate, e.g., the python interface
for those.

-}

{-

Copyright (C) 2013, 2014 Google Inc.
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-}

module Ganeti.WConfd.Core where

import Control.Arrow ((&&&))
import Control.Concurrent (myThreadId)
import Control.Lens.Setter (set)
import Control.Monad (liftM, unless)
import qualified Data.Map as M
import qualified Data.Set as S
import Language.Haskell.TH (Name)
import System.Posix.Process (getProcessID)
import qualified System.Random as Rand

import Ganeti.BasicTypes
import qualified Ganeti.Constants as C
import qualified Ganeti.JSON as J
import qualified Ganeti.Locking.Allocation as L
import Ganeti.Logging (logDebug, logWarning)
import Ganeti.Locking.Locks ( GanetiLocks(ConfigLock, BGL)
                            , LockLevel(LevelConfig)
                            , lockLevel, LockLevel
                            , ClientType(ClientOther), ClientId(..) )
import qualified Ganeti.Locking.Waiting as LW
import Ganeti.Objects ( ConfigData, DRBDSecret, LogicalVolume, Ip4Address
                      , configMaintenance, maintRoundDelay, maintJobs
                      , maintBalance, maintBalanceThreshold, maintEvacuated
                      , Incident, maintIncidents
                      )
import Ganeti.Objects.Lens (configClusterL, clusterMasterNodeL)
import Ganeti.Types (JobId)
import Ganeti.WConfd.ConfigState (csConfigDataL)
import qualified Ganeti.WConfd.ConfigVerify as V
import Ganeti.WConfd.DeathDetection (cleanupLocks)
import Ganeti.WConfd.Language
import Ganeti.WConfd.Monad
import qualified Ganeti.WConfd.TempRes as T
import qualified Ganeti.WConfd.ConfigModifications as CM
import qualified Ganeti.WConfd.ConfigWriter as CW

-- * Functions available to the RPC module

-- Just a test function
echo :: String -> WConfdMonad String
echo = return

-- ** Configuration related functions

checkConfigLock :: ClientId -> L.OwnerState -> WConfdMonad ()
checkConfigLock cid state = do
  la <- readLockAllocation
  unless (L.holdsLock cid ConfigLock state la)
         . failError $ "Requested lock " ++ show state
                       ++ " on the configuration missing"

-- | Read the configuration.
readConfig :: WConfdMonad ConfigData
readConfig = CW.readConfig

-- | Write the configuration, checking that an exclusive lock is held.
-- If not, the call fails.
writeConfig :: ClientId -> ConfigData -> WConfdMonad ()
writeConfig ident cdata = do
  checkConfigLock ident L.OwnExclusive
  -- V.verifyConfigErr cdata
  CW.writeConfig cdata

-- | Explicitly run verification of the configuration.
-- The caller doesn't need to hold the configuration lock.
verifyConfig :: WConfdMonad ()
verifyConfig = CW.readConfig >>= V.verifyConfigErr

-- *** Locks on the configuration (only transitional, will be removed later)

-- | Tries to acquire 'ConfigLock' for the client.
-- If the second parameter is set to 'True', the lock is acquired in
-- shared mode.
--
-- If the lock was successfully acquired, returns the current configuration
-- state.
lockConfig
    :: ClientId
    -> Bool -- ^ set to 'True' if the lock should be shared
    -> WConfdMonad (J.MaybeForJSON ConfigData)
lockConfig cid shared = do
  let (reqtype, owntype) = if shared
                             then (ReqShared, L.OwnShared)
                             else (ReqExclusive, L.OwnExclusive)
  la <- readLockAllocation
  if L.holdsLock cid ConfigLock owntype la
    then do
      -- warn if we already have the lock, but continue (with no-op)
      -- on the locks
      logWarning $ "Client " ++ show cid ++ " asked to lock the config"
                   ++ " while owning the lock"
      liftM (J.MaybeForJSON . Just) CW.readConfig
    else do
      waiting <- tryUpdateLocks cid [(ConfigLock, reqtype)]
      liftM J.MaybeForJSON $ case waiting of
        []  -> liftM Just CW.readConfig
        _   -> return Nothing

-- | Release the config lock, if the client currently holds it.
unlockConfig
  :: ClientId -> WConfdMonad ()
unlockConfig cid = freeLocksLevel cid LevelConfig

-- | Write the configuration, if the config lock is held exclusively,
-- and release the config lock. It the caller does not have the config
-- lock, return False.
writeConfigAndUnlock :: ClientId -> ConfigData -> WConfdMonad Bool
writeConfigAndUnlock cid cdata = do
  la <- readLockAllocation
  if L.holdsLock cid ConfigLock L.OwnExclusive la
    then do
      CW.writeConfig cdata
      unlockConfig cid
      return True
    else do
      logWarning $ show cid ++ " tried writeConfigAndUnlock without owning"
                   ++ " the config lock"
      return False

-- | Force the distribution of configuration without actually modifying it.
-- It is not necessary to hold a lock for this operation.
flushConfig :: WConfdMonad ()
flushConfig = forceConfigStateDistribution Everywhere

-- | Force the distribution of configuration to a given group without actually
-- modifying it. It is not necessary to hold a lock for this operation.
flushConfigGroup :: String -> WConfdMonad ()
flushConfigGroup = forceConfigStateDistribution . ToGroups . S.singleton

-- *** Access to individual parts of the configuration

-- | Get the configurable value of the maintenance interval
maintenanceRoundDelay :: WConfdMonad Int
maintenanceRoundDelay = liftM ( maintRoundDelay . configMaintenance )
                              CW.readConfig

-- | Get the list of jobs in the state of the maintenance daemon.
maintenanceJobs :: WConfdMonad [JobId]
maintenanceJobs = liftM ( maintJobs . configMaintenance ) CW.readConfig

-- | Get the information related to balancing for the maintenance daemon.
maintenanceBalancing :: WConfdMonad (Bool, Double)
maintenanceBalancing = liftM ((maintBalance &&& maintBalanceThreshold)
                              . configMaintenance) CW.readConfig

-- | Get the list of recently evacuated instances.
maintenanceEvacuated :: WConfdMonad [String]
maintenanceEvacuated = liftM (maintEvacuated . configMaintenance) CW.readConfig

-- | Get the list of current incidents.
maintenanceIncidents :: WConfdMonad [Incident]
maintenanceIncidents = liftM (maintIncidents . configMaintenance) CW.readConfig

-- ** Temporary reservations related functions

dropAllReservations :: ClientId -> WConfdMonad ()
dropAllReservations cid =
  modifyTempResState (const $ T.dropAllReservations cid)

-- *** DRBD

computeDRBDMap :: WConfdMonad T.DRBDMap
computeDRBDMap = uncurry T.computeDRBDMap =<< readTempResState

-- Allocate a drbd minor.
--
-- The free minor will be automatically computed from the existing devices.
-- A node can not be given multiple times.
-- The result is the list of minors, in the same order as the passed nodes.
allocateDRBDMinor
  :: T.DiskUUID -> [T.NodeUUID] -> WConfdMonad [T.DRBDMinor]
allocateDRBDMinor disk nodes =
  modifyTempResStateErr (\cfg -> T.allocateDRBDMinor cfg disk nodes)

-- Release temporary drbd minors allocated for a given disk using
-- 'allocateDRBDMinor'.
--
-- This should be called on the error paths, on the success paths
-- it's automatically called by the ConfigWriter add and update
-- functions.
releaseDRBDMinors
  :: T.DiskUUID -> WConfdMonad ()
releaseDRBDMinors disk = modifyTempResState (const $ T.releaseDRBDMinors disk)

-- *** MACs

-- Randomly generate a MAC for an instance and reserve it for
-- a given client.
generateMAC
  :: ClientId -> J.MaybeForJSON T.NetworkUUID -> WConfdMonad T.MAC
generateMAC cid (J.MaybeForJSON netId) = do
  g <- liftIO Rand.newStdGen
  modifyTempResStateErr $ T.generateMAC g cid netId

-- Reserves a MAC for an instance in the list of temporary reservations.
reserveMAC :: ClientId -> T.MAC -> WConfdMonad ()
reserveMAC = (modifyTempResStateErr .) . T.reserveMAC

-- *** DRBDSecrets

-- Randomly generate a DRBDSecret for an instance and reserves it for
-- a given client.
generateDRBDSecret :: ClientId -> WConfdMonad DRBDSecret
generateDRBDSecret cid = do
  g <- liftIO Rand.newStdGen
  modifyTempResStateErr $ T.generateDRBDSecret g cid

-- *** LVs

reserveLV :: ClientId -> LogicalVolume -> WConfdMonad ()
reserveLV jobId lv = modifyTempResStateErr $ T.reserveLV jobId lv

-- *** IPv4s

-- | Reserve a given IPv4 address for use by an instance.
reserveIp :: ClientId -> T.NetworkUUID -> Ip4Address -> Bool -> WConfdMonad ()
reserveIp = (((modifyTempResStateErr .) .) .) . T.reserveIp

-- | Give a specific IP address back to an IP pool.
-- The IP address is returned to the IP pool designated by network id
-- and marked as reserved.
releaseIp :: ClientId -> T.NetworkUUID -> Ip4Address -> WConfdMonad ()
releaseIp = (((modifyTempResStateErr .) const .) .) . T.releaseIp

-- Find a free IPv4 address for an instance and reserve it.
generateIp :: ClientId -> T.NetworkUUID -> WConfdMonad Ip4Address
generateIp = (modifyTempResStateErr .) . T.generateIp

-- | Commit all reserved/released IP address to an IP pool.
-- The IP addresses are taken from the network's IP pool and marked as
-- reserved/free for instances.
--
-- Note that the reservations are kept, they are supposed to be cleaned
-- when a job finishes.
commitTemporaryIps :: ClientId -> WConfdMonad ()
commitTemporaryIps = modifyConfigDataErr_ . T.commitReservedIps

-- | Immediately release an IP address, without using the reservations pool.
commitReleaseTemporaryIp
  :: T.NetworkUUID -> Ip4Address -> WConfdMonad ()
commitReleaseTemporaryIp net_uuid addr =
  modifyConfigDataErr_ (const $ T.commitReleaseIp net_uuid addr)

-- | List all IP reservations for the current client.
--
-- This function won't be needed once the corresponding calls are moved to
-- WConfd.
listReservedIps :: ClientId -> WConfdMonad [T.IPv4Reservation]
listReservedIps jobId =
  liftM (S.toList . T.listReservedIps jobId . snd) readTempResState

-- ** Locking related functions

-- | List the locks of a given owner (i.e., a job-id lockfile pair).
listLocks :: ClientId -> WConfdMonad [(GanetiLocks, L.OwnerState)]
listLocks cid = liftM (M.toList . L.listLocks cid) readLockAllocation

-- | List all active locks.
listAllLocks :: WConfdMonad [GanetiLocks]
listAllLocks = liftM L.listAllLocks readLockAllocation

-- | List all active locks with their owners.
listAllLocksOwners :: WConfdMonad [(GanetiLocks, [(ClientId, L.OwnerState)])]
listAllLocksOwners = liftM L.listAllLocksOwners readLockAllocation

-- | Get full information of the lock waiting status, i.e., provide
-- the information about all locks owners and all pending requests.
listLocksWaitingStatus :: WConfdMonad
                            ( [(GanetiLocks, [(ClientId, L.OwnerState)])]
                            , [(Integer, ClientId, [L.LockRequest GanetiLocks])]
                            )
listLocksWaitingStatus = liftM ( (L.listAllLocksOwners . LW.getAllocation)
                                 &&& (S.toList . LW.getPendingRequests) )
                         readLockWaiting

-- | Try to update the locks of a given owner (i.e., a job-id lockfile pair).
-- This function always returns immediately. If the lock update was possible,
-- the empty list is returned; otherwise, the lock status is left completly
-- unchanged, and the return value is the list of jobs which need to release
-- some locks before this request can succeed.
tryUpdateLocks :: ClientId -> GanetiLockRequest -> WConfdMonad [ClientId]
tryUpdateLocks cid req =
  liftM S.toList
  . (>>= toErrorStr)
  $ modifyLockWaiting (LW.updateLocks cid (fromGanetiLockRequest req))

-- | Try to update the locks of a given owner and make that a pending
-- request if not immediately possible.
updateLocksWaiting :: ClientId -> Integer
                      -> GanetiLockRequest -> WConfdMonad [ClientId]
updateLocksWaiting cid prio req =
  liftM S.toList
  . (>>= toErrorStr)
  . modifyLockWaiting
  $ LW.safeUpdateLocksWaiting prio cid (fromGanetiLockRequest req)

-- | Tell whether a given owner has pending requests.
hasPendingRequest :: ClientId -> WConfdMonad Bool
hasPendingRequest cid = liftM (LW.hasPendingRequest cid) readLockWaiting

-- | Free all locks of a given owner (i.e., a job-id lockfile pair).
freeLocks :: ClientId -> WConfdMonad ()
freeLocks cid =
  modifyLockWaiting_ $ LW.releaseResources cid

-- | Free all locks of a given owner (i.e., a job-id lockfile pair)
-- of a given level in the Ganeti sense (e.g., "cluster", "node").
freeLocksLevel :: ClientId -> LockLevel -> WConfdMonad ()
freeLocksLevel cid level =
  modifyLockWaiting_ $ LW.freeLocksPredicate ((==) level . lockLevel) cid

-- | Downgrade all locks of the given level to shared.
downGradeLocksLevel :: ClientId -> LockLevel -> WConfdMonad ()
downGradeLocksLevel cid level =
  modifyLockWaiting_ $ LW.downGradeLocksPredicate ((==) level . lockLevel) cid

-- | Intersect the possesed locks of an owner with a given set.
intersectLocks :: ClientId -> [GanetiLocks] -> WConfdMonad ()
intersectLocks cid locks = modifyLockWaiting_ $ LW.intersectLocks locks cid

-- | Opportunistically allocate locks for a given owner.
opportunisticLockUnion :: ClientId
                       -> [(GanetiLocks, L.OwnerState)]
                       -> WConfdMonad [GanetiLocks]
opportunisticLockUnion cid req =
  modifyLockWaiting $ LW.opportunisticLockUnion cid req

-- | Opprtunistially allocate locks for a given owner, requesting a
-- certain minimum of success.
guardedOpportunisticLockUnion :: Int
                                 -> ClientId
                                 -> [(GanetiLocks, L.OwnerState)]
                                 -> WConfdMonad [GanetiLocks]
guardedOpportunisticLockUnion count cid req =
  modifyLockWaiting $ LW.guardedOpportunisticLockUnion count cid req

-- * Prepareation for cluster destruction

-- | Prepare daemon for cluster destruction. This consists of
-- verifying that the requester owns the BGL exclusively, transfering the BGL
-- to WConfD itself, and modifying the configuration so that no
-- node is the master any more. Note that, since we own the BGL exclusively,
-- we can safely modify the configuration, as no other process can request
-- changes.
prepareClusterDestruction :: ClientId -> WConfdMonad ()
prepareClusterDestruction cid = do
  la <- readLockAllocation
  unless (L.holdsLock cid BGL L.OwnExclusive la)
    . failError $ "Cluster destruction requested without owning BGL exclusively"
  logDebug $ "preparing cluster destruction as requested by " ++ show cid
  -- transfer BGL to ourselfs. The do this, by adding a super-priority waiting
  -- request and then releasing the BGL of the requestor.
  dh <- daemonHandle
  pid <- liftIO getProcessID
  tid <- liftIO myThreadId
  let mycid = ClientId { ciIdentifier = ClientOther $ "wconfd-" ++ show tid
                       , ciLockFile = dhLivelock dh
                       , ciPid = pid
                       }
  _ <- modifyLockWaiting $ LW.updateLocksWaiting
                           (fromIntegral C.opPrioHighest - 1) mycid
                           [L.requestExclusive BGL]
  _ <- modifyLockWaiting $ LW.updateLocks cid [L.requestRelease BGL]
  -- To avoid beeing restarted we change the configuration to a no-master
  -- state.
  modifyConfigState $ (,) ()
    . set (csConfigDataL . configClusterL . clusterMasterNodeL) ""


-- * The list of all functions exported to RPC.

exportedFunctions :: [Name]
exportedFunctions = [ 'echo
                    , 'cleanupLocks
                    , 'prepareClusterDestruction
                    -- config
                    , 'readConfig
                    , 'writeConfig
                    , 'verifyConfig
                    , 'lockConfig
                    , 'unlockConfig
                    , 'writeConfigAndUnlock
                    , 'flushConfig
                    , 'flushConfigGroup
                    , 'maintenanceRoundDelay
                    , 'maintenanceJobs
                    , 'maintenanceBalancing
                    , 'maintenanceEvacuated
                    , 'maintenanceIncidents
                    -- temporary reservations (common)
                    , 'dropAllReservations
                    -- DRBD
                    , 'computeDRBDMap
                    , 'allocateDRBDMinor
                    , 'releaseDRBDMinors
                    -- MACs
                    , 'reserveMAC
                    , 'generateMAC
                    -- DRBD secrets
                    , 'generateDRBDSecret
                    -- LVs
                    , 'reserveLV
                    -- IPv4s
                    , 'reserveIp
                    , 'releaseIp
                    , 'generateIp
                    , 'commitTemporaryIps
                    , 'commitReleaseTemporaryIp
                    , 'listReservedIps
                    -- locking
                    , 'listLocks
                    , 'listAllLocks
                    , 'listAllLocksOwners
                    , 'listLocksWaitingStatus
                    , 'tryUpdateLocks
                    , 'updateLocksWaiting
                    , 'freeLocks
                    , 'freeLocksLevel
                    , 'downGradeLocksLevel
                    , 'intersectLocks
                    , 'opportunisticLockUnion
                    , 'guardedOpportunisticLockUnion
                    , 'hasPendingRequest
                    ]
                    ++ CM.exportedFunctions