{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}

module Simplex.FileTransfer.Server.Env where

import Control.Logger.Simple
import Control.Monad
import Crypto.Random
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as M
import Data.Time.Clock (getCurrentTime)
import Data.Word (Word32)
import Data.X509.Validation (Fingerprint (..))
import Network.Socket
import qualified Network.TLS as T
import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
import Simplex.FileTransfer.Server.Stats
import Simplex.FileTransfer.Server.Store
import Simplex.FileTransfer.Server.StoreLog
import Simplex.FileTransfer.Transport (VersionRangeXFTP)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential)
import Simplex.Messaging.Util (tshow)
import System.IO (IOMode (..))
import UnliftIO.STM

data XFTPServerConfig = XFTPServerConfig
  { XFTPServerConfig -> ServiceName
xftpPort :: ServiceName,
    XFTPServerConfig -> Maybe ServiceName
controlPort :: Maybe ServiceName,
    XFTPServerConfig -> Int
fileIdSize :: Int,
    XFTPServerConfig -> Maybe ServiceName
storeLogFile :: Maybe FilePath,
    XFTPServerConfig -> ServiceName
filesPath :: FilePath,
    -- | server storage quota
    XFTPServerConfig -> Maybe Int64
fileSizeQuota :: Maybe Int64,
    -- | allowed file chunk sizes
    XFTPServerConfig -> [Word32]
allowedChunkSizes :: [Word32],
    -- | set to False to prohibit creating new files
    XFTPServerConfig -> Bool
allowNewFiles :: Bool,
    -- | simple password that the clients need to pass in handshake to be able to create new files
    XFTPServerConfig -> Maybe BasicAuth
newFileBasicAuth :: Maybe BasicAuth,
    -- | control port passwords,
    XFTPServerConfig -> Maybe BasicAuth
controlPortUserAuth :: Maybe BasicAuth,
    XFTPServerConfig -> Maybe BasicAuth
controlPortAdminAuth :: Maybe BasicAuth,
    -- | time after which the files can be removed and check interval, seconds
    XFTPServerConfig -> Maybe ExpirationConfig
fileExpiration :: Maybe ExpirationConfig,
    -- | timeout to receive file
    XFTPServerConfig -> Int
fileTimeout :: Int,
    -- | time after which inactive clients can be disconnected and check interval, seconds
    XFTPServerConfig -> Maybe ExpirationConfig
inactiveClientExpiration :: Maybe ExpirationConfig,
    XFTPServerConfig -> ServerCredentials
xftpCredentials :: ServerCredentials,
    -- | XFTP client-server protocol version range
    XFTPServerConfig -> VersionRangeXFTP
xftpServerVRange :: VersionRangeXFTP,
    -- stats config - see SMP server config
    XFTPServerConfig -> Maybe Int64
logStatsInterval :: Maybe Int64,
    XFTPServerConfig -> Int64
logStatsStartTime :: Int64,
    XFTPServerConfig -> ServiceName
serverStatsLogFile :: FilePath,
    XFTPServerConfig -> Maybe ServiceName
serverStatsBackupFile :: Maybe FilePath,
    XFTPServerConfig -> Maybe Int
prometheusInterval :: Maybe Int,
    XFTPServerConfig -> ServiceName
prometheusMetricsFile :: FilePath,
    XFTPServerConfig -> TransportServerConfig
transportConfig :: TransportServerConfig,
    XFTPServerConfig -> Int
responseDelay :: Int
  }

defaultInactiveClientExpiration :: ExpirationConfig
defaultInactiveClientExpiration :: ExpirationConfig
defaultInactiveClientExpiration =
  ExpirationConfig
    { ttl :: Int64
ttl = Int64
21600, -- seconds, 6 hours
      checkInterval :: Int64
checkInterval = Int64
3600 -- seconds, 1 hours
    }

data XFTPEnv = XFTPEnv
  { XFTPEnv -> XFTPServerConfig
config :: XFTPServerConfig,
    XFTPEnv -> FileStore
store :: FileStore,
    XFTPEnv -> Maybe (StoreLog 'WriteMode)
storeLog :: Maybe (StoreLog 'WriteMode),
    XFTPEnv -> TVar ChaChaDRG
random :: TVar ChaChaDRG,
    XFTPEnv -> KeyHash
serverIdentity :: C.KeyHash,
    XFTPEnv -> Credential
tlsServerCreds :: T.Credential,
    XFTPEnv -> FileServerStats
serverStats :: FileServerStats
  }

defFileExpirationHours :: Int64
defFileExpirationHours :: Int64
defFileExpirationHours = Int64
48

defaultFileExpiration :: ExpirationConfig
defaultFileExpiration :: ExpirationConfig
defaultFileExpiration =
  ExpirationConfig
    { ttl :: Int64
ttl = Int64
defFileExpirationHours Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
3600, -- seconds
      checkInterval :: Int64
checkInterval = Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
3600 -- seconds, 2 hours
    }

newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
newXFTPServerEnv config :: XFTPServerConfig
config@XFTPServerConfig {Maybe ServiceName
storeLogFile :: XFTPServerConfig -> Maybe ServiceName
storeLogFile :: Maybe ServiceName
storeLogFile, Maybe Int64
fileSizeQuota :: XFTPServerConfig -> Maybe Int64
fileSizeQuota :: Maybe Int64
fileSizeQuota, ServerCredentials
xftpCredentials :: XFTPServerConfig -> ServerCredentials
xftpCredentials :: ServerCredentials
xftpCredentials} = do
  TVar ChaChaDRG
random <- IO (TVar ChaChaDRG)
C.newRandom
  FileStore
store <- IO FileStore
newFileStore
  Maybe (StoreLog 'WriteMode)
storeLog <- (ServiceName -> IO (StoreLog 'WriteMode))
-> Maybe ServiceName -> IO (Maybe (StoreLog 'WriteMode))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (ServiceName -> FileStore -> IO (StoreLog 'WriteMode)
`readWriteFileStore` FileStore
store) Maybe ServiceName
storeLogFile
  Int64
used <- Map SenderId FileRec -> Int64
forall k. Map k FileRec -> Int64
countUsedStorage (Map SenderId FileRec -> Int64)
-> IO (Map SenderId FileRec) -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map SenderId FileRec) -> IO (Map SenderId FileRec)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (FileStore -> TVar (Map SenderId FileRec)
files FileStore
store)
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int64 -> Int64 -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (FileStore -> TVar Int64
usedStorage FileStore
store) Int64
used
  Maybe Int64 -> (Int64 -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int64
fileSizeQuota ((Int64 -> IO ()) -> IO ()) -> (Int64 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int64
quota -> do
    Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Total / available storage: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow Int64
quota Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" / " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow (Int64
quota Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
used)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
quota Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
used) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn Text
"WARNING: storage quota is less than used storage, no files can be uploaded!"
  Credential
tlsServerCreds <- ServerCredentials -> IO Credential
loadServerCredential ServerCredentials
xftpCredentials
  Fingerprint ByteString
fp <- ServerCredentials -> IO Fingerprint
loadFingerprint ServerCredentials
xftpCredentials
  FileServerStats
serverStats <- UTCTime -> IO FileServerStats
newFileServerStats (UTCTime -> IO FileServerStats) -> IO UTCTime -> IO FileServerStats
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
  XFTPEnv -> IO XFTPEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPEnv {XFTPServerConfig
config :: XFTPServerConfig
config :: XFTPServerConfig
config, FileStore
store :: FileStore
store :: FileStore
store, Maybe (StoreLog 'WriteMode)
storeLog :: Maybe (StoreLog 'WriteMode)
storeLog :: Maybe (StoreLog 'WriteMode)
storeLog, TVar ChaChaDRG
random :: TVar ChaChaDRG
random :: TVar ChaChaDRG
random, Credential
tlsServerCreds :: Credential
tlsServerCreds :: Credential
tlsServerCreds, serverIdentity :: KeyHash
serverIdentity = ByteString -> KeyHash
C.KeyHash ByteString
fp, FileServerStats
serverStats :: FileServerStats
serverStats :: FileServerStats
serverStats}

countUsedStorage :: M.Map k FileRec -> Int64
countUsedStorage :: forall k. Map k FileRec -> Int64
countUsedStorage = (Int64 -> FileRec -> Int64) -> Int64 -> Map k FileRec -> Int64
forall a b k. (a -> b -> a) -> a -> Map k b -> a
M.foldl' (\Int64
acc FileRec {fileInfo :: FileRec -> FileInfo
fileInfo = FileInfo {Word32
size :: Word32
size :: FileInfo -> Word32
size}} -> Int64
acc Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size) Int64
0

data XFTPRequest
  = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth)
  | XFTPReqCmd XFTPFileId FileRec FileCmd
  | XFTPReqPing