fradrive/src/Audit.hs

-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE TypeApplications #-}

module Audit
  ( module Audit.Types
  , AuditException(..)
  , audit
  , AuditRemoteException(..)
  , getRemote
  , logInterface, logInterface'
  , reportAdminProblem
  ) where


import Import.NoModel
import Settings
import Model
import Database.Persist.Sql
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils        as E
import Audit.Types

import qualified Data.Text          as Text
import qualified Data.Text.Encoding as Text

import Utils.Lens
import qualified Network.Wai as Wai
import qualified Network.Socket as Wai

import Network.IP.Addr (IP46(..), ip4FromOctets, ip6FromWords, anyIP6)
import qualified Data.Textual as Textual

import Control.Exception (ErrorCall(..))

import GHC.Stack

{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}


data AuditRemoteException
  = ARUnsupportedSocketKind
  deriving (Show, Generic)
instance Exception AuditRemoteException


getRemote :: forall m. (MonadHandler m, MonadCatch m, HasAppSettings (HandlerSite m)) => m IP
getRemote = handle testHandler $ do
  ipFromHeader <- getsYesod $ view _appIpFromHeader
  wai <- waiRequest

  ip <- if
    | ipFromHeader
    , Just ip <- byHeader wai
      -> return ip
    | otherwise
      -> byRemoteHost wai

  liftIO $ evaluate $!! ip
  where
    byHeader wai = listToMaybe $ do
      (h, v) <- Wai.requestHeaders wai
      guard $ h `elem` ["x-real-ip", "x-forwarded-for"]
      v' <- either (const mzero) return $ Text.decodeUtf8' v
      maybeToList $ Textual.fromText v'

    byRemoteHost wai = case Wai.remoteHost wai of
      Wai.SockAddrInet _ hAddr
        -> let (b1, b2, b3, b4) = Wai.hostAddressToTuple hAddr
            in return . IPv4 $ ip4FromOctets b1 b2 b3 b4
      Wai.SockAddrInet6 _ _ hAddr _
        -> let (w1, w2, w3, w4, w5, w6, w7, w8) = Wai.hostAddress6ToTuple hAddr
            in return . IPv6 $ ip6FromWords w1 w2 w3 w4 w5 w6 w7 w8
      _other -> throwM ARUnsupportedSocketKind

    testHandler :: ErrorCall -> m IP
    -- ^ `Yesod.Core.Unsafe.runFakeHandler` does not set a `Wai.remoteHost`
    --
    -- We catch only the specific error call used by
    -- `Yesod.Core.Unsafe.runFakeHandler` and replace it with `anyIP6` as a
    -- placeholder value for testing.
    testHandler (ErrorCall "runFakeHandler-remoteHost") = return $ IPv6 anyIP6
    testHandler err = throwM err


data AuditException
  = AuditRemoteException AuditRemoteException
  deriving (Show, Generic)
instance Exception AuditException


audit :: ( AuthId (HandlerSite m) ~ Key User
         , IsSqlBackend (YesodPersistBackend (HandlerSite m))
         , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
         , HasInstanceID (HandlerSite m) InstanceId
         , YesodAuthPersist (HandlerSite m)
         , MonadHandler m
         , MonadCatch m
         , HasAppSettings (HandlerSite m)
         , HasCallStack
         )
      => Transaction -- ^ Transaction to record
      -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
-- ^ Log a transaction using information available from `HandlerT`:
--
--   - `transactionLogTime` is now
--   - `transactionLogInitiator` is currently logged in user (or none)
--   - `transactionLogRemote` is determined from current HTTP-Request
audit transaction@(toJSON -> transactionLogInfo) = do
  transactionLogTime <- liftIO getCurrentTime
  transactionLogInstance <- getsYesod $ view instanceID
  transactionLogInitiator <- liftHandler maybeAuthId
  transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
  insert_ TransactionLog{..}
  $logInfoS "Audit" $ Text.filter (/= '\n') $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> " - " <> pack (prettyCallStack callStack)

logInterface :: ( AuthId (HandlerSite m) ~ Key User
         , IsSqlBackend (YesodPersistBackend (HandlerSite m))
         , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
         , HasInstanceID (HandlerSite m) InstanceId
         , YesodAuthPersist (HandlerSite m)
         , MonadHandler m
         , MonadCatch m
         , HasAppSettings (HandlerSite m)
         , HasCallStack
         )
      => Text       -- ^ Interface that is used
      -> Text       -- ^ Subtype of the interface, if any
      -> Bool       -- ^ Success=True, Failure=False
      -> Maybe Int  -- ^ Number of transmitted datasets
      -> Text       -- ^ Any additional information
      -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
  interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
  logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo

logInterface' :: ( AuthId (HandlerSite m) ~ Key User
         , IsSqlBackend (YesodPersistBackend (HandlerSite m))
         , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
         , HasInstanceID (HandlerSite m) InstanceId
         , YesodAuthPersist (HandlerSite m)
         , MonadHandler m
         , MonadCatch m
         , HasAppSettings (HandlerSite m)
         , HasCallStack
         )
      => Text       -- ^ Interface that is used
      -> Text       -- ^ Subtype of the interface, if any
      -> Bool       -- ^ True indicates Write Access to FRADrive
      -> Bool       -- ^ Success=True, Failure=False
      -> Maybe Int  -- ^ Number of transmitted datasets
      -> Text       -- ^ Any additional information
      -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do
  interfaceLogTime  <- liftIO getCurrentTime
  -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- deleteBy & insert would be justified here, leading to a new Row-ID, since the two rows are not truly connected.
  -- insert_ InterfaceLog{..}
  void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite)
    ( InterfaceLog{..} )
    [ InterfaceLogTime    =. interfaceLogTime
    , InterfaceLogRows    =. interfaceLogRows
    , InterfaceLogInfo    =. interfaceLogInfo
    , InterfaceLogSuccess =. interfaceLogSuccess
    ]
  audit TransactionInterface
    { transactionInterfaceName    = interfaceLogInterface
    , transactionInterfaceSubtype = interfaceLogSubtype
    , transactionInterfaceWrite   = interfaceLogWrite
    , transactionInterfaceRows    = interfaceLogRows
    , transactionInterfaceInfo    = interfaceLogInfo
    , transactionInterfaceSuccess = Just interfaceLogSuccess
    }

reportAdminProblem ::  ( IsSqlBackend (YesodPersistBackend (HandlerSite m))
                  , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
                  , MonadHandler m
                  -- , HasCallStack
                  )
      => AdminProblem -- ^ Problem to record
      -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
-- ^ Log a problem that needs interventions by admins, provided this problem has not already been reported and is still unsolved
--
--   - `problemLogTime` is now
--   - `problemSolver` is Nothing, we do not record the person who caused it
reportAdminProblem problem = do
  let problemLogSolved = Nothing
      problemLogSolver = Nothing
      problemLogInfo   = toJSON problem
  problemLogTime <- liftIO getCurrentTime
  isKnown <- E.selectExists $ do
    pl <- E.from $ E.table @ProblemLog
    E.where_ $ E.isNothing (pl E.^. ProblemLogSolved)
        E.&&. E.val problemLogInfo E.==. pl E.^. ProblemLogInfo
  unless isKnown $ insert_ ProblemLog{..}
  $logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)