{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Simplex.FileTransfer.Server where

import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Data.Bifunctor (first)
import qualified Data.ByteString.Base64.URL as B64
import Data.ByteString.Builder (Builder, byteString)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.Word (Word32)
import qualified Data.X509 as X
import GHC.IO.Handle (hSetNewlineMode)
import GHC.IORef (atomicSwapIORef)
import GHC.Stats (getRTSStats)
import qualified Network.HTTP.Types as N
import qualified Network.HTTP2.Server as H
import Network.Socket
import Simplex.FileTransfer.Protocol
import Simplex.FileTransfer.Server.Control
import Simplex.FileTransfer.Server.Env
import Simplex.FileTransfer.Server.Prometheus
import Simplex.FileTransfer.Server.Stats
import Simplex.FileTransfer.Server.Store
import Simplex.FileTransfer.Server.StoreLog
import Simplex.FileTransfer.Transport
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
import Simplex.Messaging.Server (controlPortAuth, dummyVerifyCmd, verifyCmdAuthorization)
import Simplex.Messaging.Server.Control (CPClientRole (..))
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.SystemTime
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
import Simplex.Messaging.Transport.Buffer (trimCR)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
import Simplex.Messaging.Transport.HTTP2.Server
import Simplex.Messaging.Transport.Server (runLocalTCPServer)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.Environment (lookupEnv)
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.IO (hPrint, hPutStrLn, universalNewlineMode)
#ifdef slow_servers
import System.Random (getStdRandom, randomR)
#endif
import UnliftIO
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Directory (doesFileExist, removeFile, renameFile)
import qualified UnliftIO.Exception as E

type M a = ReaderT XFTPEnv IO a

data XFTPTransportRequest = XFTPTransportRequest
  { XFTPTransportRequest -> THandleParamsXFTP 'TServer
thParams :: THandleParamsXFTP 'TServer,
    XFTPTransportRequest -> HTTP2Body
reqBody :: HTTP2Body,
    XFTPTransportRequest -> Request
request :: H.Request,
    XFTPTransportRequest -> Response -> IO ()
sendResponse :: H.Response -> IO ()
  }

runXFTPServer :: XFTPServerConfig -> IO ()
runXFTPServer :: XFTPServerConfig -> IO ()
runXFTPServer XFTPServerConfig
cfg = do
  TMVar Bool
started <- IO (TMVar Bool)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  TMVar Bool -> XFTPServerConfig -> IO ()
runXFTPServerBlocking TMVar Bool
started XFTPServerConfig
cfg

runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
runXFTPServerBlocking TMVar Bool
started XFTPServerConfig
cfg = XFTPServerConfig -> IO XFTPEnv
newXFTPServerEnv XFTPServerConfig
cfg IO XFTPEnv -> (XFTPEnv -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= M () -> XFTPEnv -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (XFTPServerConfig -> TMVar Bool -> M ()
xftpServer XFTPServerConfig
cfg TMVar Bool
started)

data Handshake
  = HandshakeSent C.PrivateKeyX25519
  | HandshakeAccepted (THandleParams XFTPVersion 'TServer)

xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
xftpServer cfg :: XFTPServerConfig
cfg@XFTPServerConfig {String
xftpPort :: String
xftpPort :: XFTPServerConfig -> String
xftpPort, TransportServerConfig
transportConfig :: TransportServerConfig
transportConfig :: XFTPServerConfig -> TransportServerConfig
transportConfig, Maybe ExpirationConfig
inactiveClientExpiration :: Maybe ExpirationConfig
inactiveClientExpiration :: XFTPServerConfig -> Maybe ExpirationConfig
inactiveClientExpiration, Maybe ExpirationConfig
fileExpiration :: Maybe ExpirationConfig
fileExpiration :: XFTPServerConfig -> Maybe ExpirationConfig
fileExpiration, VersionRangeXFTP
xftpServerVRange :: VersionRangeXFTP
xftpServerVRange :: XFTPServerConfig -> VersionRangeXFTP
xftpServerVRange} TMVar Bool
started = do
  (ExpirationConfig -> M ()) -> Maybe ExpirationConfig -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe Int -> ExpirationConfig -> M ()
expireServerFiles Maybe Int
forall a. Maybe a
Nothing) Maybe ExpirationConfig
fileExpiration
  M ()
restoreServerStats
  [M ()] -> M ()
forall (m :: * -> *) a. MonadUnliftIO m => [m a] -> m ()
raceAny_
    ( M ()
runServer
        M () -> [M ()] -> [M ()]
forall a. a -> [a] -> [a]
: XFTPServerConfig -> [M ()]
expireFilesThread_ XFTPServerConfig
cfg
          [M ()] -> [M ()] -> [M ()]
forall a. Semigroup a => a -> a -> a
<> XFTPServerConfig -> [M ()]
serverStatsThread_ XFTPServerConfig
cfg
          [M ()] -> [M ()] -> [M ()]
forall a. Semigroup a => a -> a -> a
<> XFTPServerConfig -> [M ()]
prometheusMetricsThread_ XFTPServerConfig
cfg
          [M ()] -> [M ()] -> [M ()]
forall a. Semigroup a => a -> a -> a
<> XFTPServerConfig -> [M ()]
controlPortThread_ XFTPServerConfig
cfg
    )
    M () -> M () -> M ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` M ()
stopServer
  where
    runServer :: M ()
    runServer :: M ()
runServer = do
      srvCreds :: Credential
srvCreds@(CertificateChain
chain, PrivKey
pk) <- (XFTPEnv -> Credential) -> ReaderT XFTPEnv IO Credential
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> Credential
tlsServerCreds
      APrivateSignKey
signKey <- IO APrivateSignKey -> ReaderT XFTPEnv IO APrivateSignKey
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO APrivateSignKey -> ReaderT XFTPEnv IO APrivateSignKey)
-> IO APrivateSignKey -> ReaderT XFTPEnv IO APrivateSignKey
forall a b. (a -> b) -> a -> b
$ case PrivKey -> Either String APrivateSignKey
forall k. CryptoPrivateKey k => PrivKey -> Either String k
C.x509ToPrivate' PrivKey
pk of
        Right APrivateSignKey
pk' -> APrivateSignKey -> IO APrivateSignKey
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure APrivateSignKey
pk'
        Left String
e -> String -> IO ()
putStrLn (String
"Server has no valid key: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
e) IO () -> IO APrivateSignKey -> IO APrivateSignKey
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO APrivateSignKey
forall a. IO a
exitFailure
      XFTPEnv
env <- ReaderT XFTPEnv IO XFTPEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
      TMap ByteString Handshake
sessions <- IO (TMap ByteString Handshake)
-> ReaderT XFTPEnv IO (TMap ByteString Handshake)
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMap ByteString Handshake)
forall k a. IO (TMap k a)
TM.emptyIO
      let cleanup :: ByteString -> IO ()
cleanup ByteString
sessionId = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> TMap ByteString Handshake -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete ByteString
sessionId TMap ByteString Handshake
sessions
      IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ())
-> (HTTP2ServerFunc -> IO ()) -> HTTP2ServerFunc -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar Bool
-> String
-> Int
-> Supported
-> Credential
-> TransportServerConfig
-> Maybe ExpirationConfig
-> (ByteString -> IO ())
-> HTTP2ServerFunc
-> IO ()
runHTTP2Server TMVar Bool
started String
xftpPort Int
defaultHTTP2BufferSize Supported
defaultSupportedParams Credential
srvCreds TransportServerConfig
transportConfig Maybe ExpirationConfig
inactiveClientExpiration ByteString -> IO ()
cleanup (HTTP2ServerFunc -> M ()) -> HTTP2ServerFunc -> M ()
forall a b. (a -> b) -> a -> b
$ \ByteString
sessionId Maybe ByteString
sessionALPN Request
r Response -> IO ()
sendResponse -> do
        HTTP2Body
reqBody <- Request -> Int -> IO HTTP2Body
forall a. HTTP2BodyChunk a => a -> Int -> IO HTTP2Body
getHTTP2Body Request
r Int
xftpBlockSize
        let v :: VersionXFTP
v = Word16 -> VersionXFTP
VersionXFTP Word16
1
            thServerVRange :: VersionRangeXFTP
thServerVRange = VersionXFTP -> VersionRangeXFTP
forall v. Version v -> VersionRange v
versionToRange VersionXFTP
v
            thParams0 :: THandleParamsXFTP 'TServer
thParams0 = THandleParams {ByteString
sessionId :: ByteString
sessionId :: ByteString
sessionId, blockSize :: Int
blockSize = Int
xftpBlockSize, thVersion :: VersionXFTP
thVersion = VersionXFTP
v, VersionRangeXFTP
thServerVRange :: VersionRangeXFTP
thServerVRange :: VersionRangeXFTP
thServerVRange, thAuth :: Maybe (THandleAuth 'TServer)
thAuth = Maybe (THandleAuth 'TServer)
forall a. Maybe a
Nothing, implySessId :: Bool
implySessId = Bool
False, encryptBlock :: Maybe TSbChainKeys
encryptBlock = Maybe TSbChainKeys
forall a. Maybe a
Nothing, batch :: Bool
batch = Bool
True, serviceAuth :: Bool
serviceAuth = Bool
False}
            req0 :: XFTPTransportRequest
req0 = XFTPTransportRequest {thParams :: THandleParamsXFTP 'TServer
thParams = THandleParamsXFTP 'TServer
thParams0, request :: Request
request = Request
r, HTTP2Body
reqBody :: HTTP2Body
reqBody :: HTTP2Body
reqBody, Response -> IO ()
sendResponse :: Response -> IO ()
sendResponse :: Response -> IO ()
sendResponse}
        (M () -> XFTPEnv -> IO ()) -> XFTPEnv -> M () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip M () -> XFTPEnv -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT XFTPEnv
env (M () -> IO ()) -> M () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe ByteString
sessionALPN of
          Maybe ByteString
Nothing -> XFTPTransportRequest -> M ()
processRequest XFTPTransportRequest
req0
          Just ByteString
alpn | ByteString
alpn ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
xftpALPNv1 Bool -> Bool -> Bool
|| ByteString
alpn ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
httpALPN11 ->
            CertificateChain
-> APrivateSignKey
-> TMap ByteString Handshake
-> XFTPTransportRequest
-> M (Maybe (THandleParamsXFTP 'TServer))
xftpServerHandshakeV1 CertificateChain
chain APrivateSignKey
signKey TMap ByteString Handshake
sessions XFTPTransportRequest
req0 M (Maybe (THandleParamsXFTP 'TServer))
-> (Maybe (THandleParamsXFTP 'TServer) -> M ()) -> M ()
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe (THandleParamsXFTP 'TServer)
Nothing -> () -> M ()
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- handshake response sent
              Just THandleParamsXFTP 'TServer
thParams -> XFTPTransportRequest -> M ()
processRequest XFTPTransportRequest
req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here)
          Maybe ByteString
_ -> IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> (Response -> IO ()) -> Response -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ()
sendResponse (Response -> M ()) -> Response -> M ()
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Response
H.responseNoBody Status
N.ok200 [] -- shouldn't happen: means server picked handshake protocol it doesn't know about
    xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M (Maybe (THandleParams XFTPVersion 'TServer))
    xftpServerHandshakeV1 :: CertificateChain
-> APrivateSignKey
-> TMap ByteString Handshake
-> XFTPTransportRequest
-> M (Maybe (THandleParamsXFTP 'TServer))
xftpServerHandshakeV1 CertificateChain
chain APrivateSignKey
serverSignKey TMap ByteString Handshake
sessions XFTPTransportRequest {thParams :: XFTPTransportRequest -> THandleParamsXFTP 'TServer
thParams = thParams0 :: THandleParamsXFTP 'TServer
thParams0@THandleParams {ByteString
sessionId :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId :: ByteString
sessionId}, reqBody :: XFTPTransportRequest -> HTTP2Body
reqBody = HTTP2Body {ByteString
bodyHead :: ByteString
bodyHead :: HTTP2Body -> ByteString
bodyHead}, Response -> IO ()
sendResponse :: XFTPTransportRequest -> Response -> IO ()
sendResponse :: Response -> IO ()
sendResponse} = do
      Maybe Handshake
s <- STM (Maybe Handshake) -> ReaderT XFTPEnv IO (Maybe Handshake)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe Handshake) -> ReaderT XFTPEnv IO (Maybe Handshake))
-> STM (Maybe Handshake) -> ReaderT XFTPEnv IO (Maybe Handshake)
forall a b. (a -> b) -> a -> b
$ ByteString -> TMap ByteString Handshake -> STM (Maybe Handshake)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup ByteString
sessionId TMap ByteString Handshake
sessions
      Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer))
r <- ExceptT
  XFTPErrorType
  (ReaderT XFTPEnv IO)
  (Maybe (THandleParamsXFTP 'TServer))
-> ReaderT
     XFTPEnv
     IO
     (Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   XFTPErrorType
   (ReaderT XFTPEnv IO)
   (Maybe (THandleParamsXFTP 'TServer))
 -> ReaderT
      XFTPEnv
      IO
      (Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer))))
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (Maybe (THandleParamsXFTP 'TServer))
-> ReaderT
     XFTPEnv
     IO
     (Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer)))
forall a b. (a -> b) -> a -> b
$ case Maybe Handshake
s of
        Maybe Handshake
Nothing -> ExceptT
  XFTPErrorType
  (ReaderT XFTPEnv IO)
  (Maybe (THandleParamsXFTP 'TServer))
processHello
        Just (HandshakeSent PrivateKeyX25519
pk) -> PrivateKeyX25519
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (Maybe (THandleParamsXFTP 'TServer))
processClientHandshake PrivateKeyX25519
pk
        Just (HandshakeAccepted THandleParamsXFTP 'TServer
thParams) -> Maybe (THandleParamsXFTP 'TServer)
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (Maybe (THandleParamsXFTP 'TServer))
forall a. a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (THandleParamsXFTP 'TServer)
 -> ExceptT
      XFTPErrorType
      (ReaderT XFTPEnv IO)
      (Maybe (THandleParamsXFTP 'TServer)))
-> Maybe (THandleParamsXFTP 'TServer)
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (Maybe (THandleParamsXFTP 'TServer))
forall a b. (a -> b) -> a -> b
$ THandleParamsXFTP 'TServer -> Maybe (THandleParamsXFTP 'TServer)
forall a. a -> Maybe a
Just THandleParamsXFTP 'TServer
thParams
      (XFTPErrorType -> M (Maybe (THandleParamsXFTP 'TServer)))
-> (Maybe (THandleParamsXFTP 'TServer)
    -> M (Maybe (THandleParamsXFTP 'TServer)))
-> Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer))
-> M (Maybe (THandleParamsXFTP 'TServer))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XFTPErrorType -> M (Maybe (THandleParamsXFTP 'TServer))
sendError Maybe (THandleParamsXFTP 'TServer)
-> M (Maybe (THandleParamsXFTP 'TServer))
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer))
r
      where
        processHello :: ExceptT
  XFTPErrorType
  (ReaderT XFTPEnv IO)
  (Maybe (THandleParamsXFTP 'TServer))
processHello = do
          Bool
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
bodyHead) (ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
HANDSHAKE
          (PublicKey 'X25519
k, PrivateKeyX25519
pk) <- STM (PublicKey 'X25519, PrivateKeyX25519)
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (PublicKey 'X25519, PrivateKeyX25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey 'X25519, PrivateKeyX25519)
 -> ExceptT
      XFTPErrorType
      (ReaderT XFTPEnv IO)
      (PublicKey 'X25519, PrivateKeyX25519))
-> (TVar ChaChaDRG -> STM (PublicKey 'X25519, PrivateKeyX25519))
-> TVar ChaChaDRG
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (PublicKey 'X25519, PrivateKeyX25519)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG -> STM (KeyPair 'X25519)
TVar ChaChaDRG -> STM (PublicKey 'X25519, PrivateKeyX25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair (TVar ChaChaDRG
 -> ExceptT
      XFTPErrorType
      (ReaderT XFTPEnv IO)
      (PublicKey 'X25519, PrivateKeyX25519))
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) (TVar ChaChaDRG)
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (PublicKey 'X25519, PrivateKeyX25519)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XFTPEnv -> TVar ChaChaDRG)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> TVar ChaChaDRG
random
          STM () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> STM () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Handshake -> TMap ByteString Handshake -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert ByteString
sessionId (PrivateKeyX25519 -> Handshake
HandshakeSent PrivateKeyX25519
pk) TMap ByteString Handshake
sessions
          let authPubKey :: CertChainPubKey
authPubKey = CertificateChain -> SignedExact PubKey -> CertChainPubKey
CertChainPubKey CertificateChain
chain (APrivateSignKey -> PubKey -> SignedExact PubKey
forall o.
(ASN1Object o, Eq o, Show o) =>
APrivateSignKey -> o -> SignedExact o
C.signX509 APrivateSignKey
serverSignKey (PubKey -> SignedExact PubKey) -> PubKey -> SignedExact PubKey
forall a b. (a -> b) -> a -> b
$ PublicKey 'X25519 -> PubKey
forall (a :: Algorithm). PublicKey a -> PubKey
C.publicToX509 PublicKey 'X25519
k)
          let hs :: XFTPServerHandshake
hs = XFTPServerHandshake {xftpVersionRange :: VersionRangeXFTP
xftpVersionRange = VersionRangeXFTP
xftpServerVRange, ByteString
sessionId :: ByteString
sessionId :: ByteString
sessionId, CertChainPubKey
authPubKey :: CertChainPubKey
authPubKey :: CertChainPubKey
authPubKey}
          Builder
shs <- XFTPServerHandshake
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
forall a.
Encoding a =>
a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
encodeXftp XFTPServerHandshake
hs
#ifdef slow_servers
          lift randomDelay
#endif
          IO () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a. IO a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> (Response -> IO ())
-> Response
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ()
sendResponse (Response -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> Response -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
H.responseBuilder Status
N.ok200 [] Builder
shs
          Maybe (THandleParamsXFTP 'TServer)
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (Maybe (THandleParamsXFTP 'TServer))
forall a. a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (THandleParamsXFTP 'TServer)
forall a. Maybe a
Nothing
        processClientHandshake :: PrivateKeyX25519
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (Maybe (THandleParamsXFTP 'TServer))
processClientHandshake PrivateKeyX25519
pk = do
          Bool
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
B.length ByteString
bodyHead Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
xftpBlockSize) (ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
HANDSHAKE
          ByteString
body <- Either CryptoError ByteString
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ByteString
forall {e} {a}.
Either e a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
liftHS (Either CryptoError ByteString
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ByteString)
-> Either CryptoError ByteString
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either CryptoError ByteString
C.unPad ByteString
bodyHead
          XFTPClientHandshake {xftpVersion :: XFTPClientHandshake -> VersionXFTP
xftpVersion = VersionXFTP
v, KeyHash
keyHash :: KeyHash
keyHash :: XFTPClientHandshake -> KeyHash
keyHash} <- Either String XFTPClientHandshake
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) XFTPClientHandshake
forall {e} {a}.
Either e a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
liftHS (Either String XFTPClientHandshake
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) XFTPClientHandshake)
-> Either String XFTPClientHandshake
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) XFTPClientHandshake
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String XFTPClientHandshake
forall a. Encoding a => ByteString -> Either String a
smpDecode ByteString
body
          KeyHash
kh <- (XFTPEnv -> KeyHash)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) KeyHash
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> KeyHash
serverIdentity
          Bool
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyHash
keyHash KeyHash -> KeyHash -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash
kh) (ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
HANDSHAKE
          case VersionRangeXFTP
-> VersionXFTP -> Maybe (Compatible VersionRangeXFTP)
forall v a.
VersionRangeI v a =>
a -> Version v -> Maybe (Compatible a)
compatibleVRange' VersionRangeXFTP
xftpServerVRange VersionXFTP
v of
            Just (Compatible VersionRangeXFTP
vr) -> do
              let auth :: THandleAuth 'TServer
auth = THAuthServer {serverPrivKey :: PrivateKeyX25519
serverPrivKey = PrivateKeyX25519
pk, peerClientService :: Maybe THPeerClientService
peerClientService = Maybe THPeerClientService
forall a. Maybe a
Nothing, sessSecret' :: Maybe DhSecretX25519
sessSecret' = Maybe DhSecretX25519
forall a. Maybe a
Nothing}
                  thParams :: THandleParamsXFTP 'TServer
thParams = THandleParamsXFTP 'TServer
thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr}
              STM () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> STM () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Handshake -> TMap ByteString Handshake -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert ByteString
sessionId (THandleParamsXFTP 'TServer -> Handshake
HandshakeAccepted THandleParamsXFTP 'TServer
thParams) TMap ByteString Handshake
sessions
#ifdef slow_servers
              lift randomDelay
#endif
              IO () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a. IO a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> (Response -> IO ())
-> Response
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ()
sendResponse (Response -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> Response -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Response
H.responseNoBody Status
N.ok200 []
              Maybe (THandleParamsXFTP 'TServer)
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (Maybe (THandleParamsXFTP 'TServer))
forall a. a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (THandleParamsXFTP 'TServer)
forall a. Maybe a
Nothing
            Maybe (Compatible VersionRangeXFTP)
Nothing -> XFTPErrorType
-> ExceptT
     XFTPErrorType
     (ReaderT XFTPEnv IO)
     (Maybe (THandleParamsXFTP 'TServer))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
HANDSHAKE
        sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion 'TServer))
        sendError :: XFTPErrorType -> M (Maybe (THandleParamsXFTP 'TServer))
sendError XFTPErrorType
err = do
          ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
-> ReaderT XFTPEnv IO (Either XFTPErrorType Builder)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (XFTPErrorType -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
forall a.
Encoding a =>
a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
encodeXftp XFTPErrorType
err) ReaderT XFTPEnv IO (Either XFTPErrorType Builder)
-> (Either XFTPErrorType Builder -> M ()) -> M ()
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Right Builder
bs -> IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> (Response -> IO ()) -> Response -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ()
sendResponse (Response -> M ()) -> Response -> M ()
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
H.responseBuilder Status
N.ok200 [] Builder
bs
            Left XFTPErrorType
_ -> Text -> M ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> M ()) -> Text -> M ()
forall a b. (a -> b) -> a -> b
$ Text
"Error encoding handshake error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> XFTPErrorType -> Text
forall a. Show a => a -> Text
tshow XFTPErrorType
err
          Maybe (THandleParamsXFTP 'TServer)
-> M (Maybe (THandleParamsXFTP 'TServer))
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (THandleParamsXFTP 'TServer)
forall a. Maybe a
Nothing
        encodeXftp :: Encoding a => a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
        encodeXftp :: forall a.
Encoding a =>
a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
encodeXftp a
a = ByteString -> Builder
byteString (ByteString -> Builder)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ByteString
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either CryptoError ByteString
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ByteString
forall {e} {a}.
Either e a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
liftHS (ByteString -> Int -> Either CryptoError ByteString
C.pad (a -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode a
a) Int
xftpBlockSize)
        liftHS :: Either e a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
liftHS = (e -> XFTPErrorType)
-> Either e a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (XFTPErrorType -> e -> XFTPErrorType
forall a b. a -> b -> a
const XFTPErrorType
HANDSHAKE)

    stopServer :: M ()
    stopServer :: M ()
stopServer = do
      (StoreLog 'WriteMode -> IO ()) -> M ()
forall a. (StoreLog 'WriteMode -> IO a) -> M ()
withFileLog StoreLog 'WriteMode -> IO ()
forall (a :: IOMode). StoreLog a -> IO ()
closeStoreLog
      M ()
saveServerStats
      Text -> M ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"Server stopped"

    expireFilesThread_ :: XFTPServerConfig -> [M ()]
    expireFilesThread_ :: XFTPServerConfig -> [M ()]
expireFilesThread_ XFTPServerConfig {fileExpiration :: XFTPServerConfig -> Maybe ExpirationConfig
fileExpiration = Just ExpirationConfig
fileExp} = [ExpirationConfig -> M ()
expireFiles ExpirationConfig
fileExp]
    expireFilesThread_ XFTPServerConfig
_ = []

    expireFiles :: ExpirationConfig -> M ()
    expireFiles :: ExpirationConfig -> M ()
expireFiles ExpirationConfig
expCfg = do
      let interval :: Int64
interval = ExpirationConfig -> Int64
checkInterval ExpirationConfig
expCfg Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000000
      M () -> M ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ Int64 -> IO ()
threadDelay' Int64
interval
        Maybe Int -> ExpirationConfig -> M ()
expireServerFiles (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
100000) ExpirationConfig
expCfg

    serverStatsThread_ :: XFTPServerConfig -> [M ()]
    serverStatsThread_ :: XFTPServerConfig -> [M ()]
serverStatsThread_ XFTPServerConfig {logStatsInterval :: XFTPServerConfig -> Maybe Int64
logStatsInterval = Just Int64
interval, Int64
logStatsStartTime :: Int64
logStatsStartTime :: XFTPServerConfig -> Int64
logStatsStartTime, String
serverStatsLogFile :: String
serverStatsLogFile :: XFTPServerConfig -> String
serverStatsLogFile} =
      [Int64 -> Int64 -> String -> M ()
logServerStats Int64
logStatsStartTime Int64
interval String
serverStatsLogFile]
    serverStatsThread_ XFTPServerConfig
_ = []

    logServerStats :: Int64 -> Int64 -> FilePath -> M ()
    logServerStats :: Int64 -> Int64 -> String -> M ()
logServerStats Int64
startAt Int64
logInterval String
statsFilePath = do
      Int64
initialDelay <- (Int64
startAt Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
-) (Int64 -> Int64) -> (UTCTime -> Int64) -> UTCTime -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> (UTCTime -> Integer) -> UTCTime -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1000000_000000) (Integer -> Integer) -> (UTCTime -> Integer) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Integer
diffTimeToPicoseconds (DiffTime -> Integer)
-> (UTCTime -> DiffTime) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> DiffTime
utctDayTime (UTCTime -> Int64)
-> ReaderT XFTPEnv IO UTCTime -> ReaderT XFTPEnv IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> ReaderT XFTPEnv IO UTCTime
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"server stats log enabled: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
statsFilePath
      IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ Int64 -> IO ()
threadDelay' (Int64 -> IO ()) -> Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int64
1_000_000 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* (Int64
initialDelay Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ if Int64
initialDelay Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0 then Int64
86_400 else Int64
0)
      FileServerStats {IORef UTCTime
fromTime :: IORef UTCTime
fromTime :: FileServerStats -> IORef UTCTime
fromTime, IORef Int
filesCreated :: IORef Int
filesCreated :: FileServerStats -> IORef Int
filesCreated, IORef Int
fileRecipients :: IORef Int
fileRecipients :: FileServerStats -> IORef Int
fileRecipients, IORef Int
filesUploaded :: IORef Int
filesUploaded :: FileServerStats -> IORef Int
filesUploaded, IORef Int
filesExpired :: IORef Int
filesExpired :: FileServerStats -> IORef Int
filesExpired, IORef Int
filesDeleted :: IORef Int
filesDeleted :: FileServerStats -> IORef Int
filesDeleted, PeriodStats
filesDownloaded :: PeriodStats
filesDownloaded :: FileServerStats -> PeriodStats
filesDownloaded, IORef Int
fileDownloads :: IORef Int
fileDownloads :: FileServerStats -> IORef Int
fileDownloads, IORef Int
fileDownloadAcks :: IORef Int
fileDownloadAcks :: FileServerStats -> IORef Int
fileDownloadAcks, IORef Int
filesCount :: IORef Int
filesCount :: FileServerStats -> IORef Int
filesCount, IORef Int64
filesSize :: IORef Int64
filesSize :: FileServerStats -> IORef Int64
filesSize} <- (XFTPEnv -> FileServerStats) -> ReaderT XFTPEnv IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileServerStats
serverStats
      let interval :: Int64
interval = Int64
1_000_000 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
logInterval
      M () -> M ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IOMode -> (Handle -> M ()) -> M ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile String
statsFilePath IOMode
AppendMode ((Handle -> M ()) -> M ()) -> (Handle -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ do
          Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
h BufferMode
LineBuffering
          UTCTime
ts <- IO UTCTime
getCurrentTime
          UTCTime
fromTime' <- IORef UTCTime -> UTCTime -> IO UTCTime
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef UTCTime
fromTime UTCTime
ts
          Int
filesCreated' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
filesCreated Int
0
          Int
fileRecipients' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
fileRecipients Int
0
          Int
filesUploaded' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
filesUploaded Int
0
          Int
filesExpired' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
filesExpired Int
0
          Int
filesDeleted' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
filesDeleted Int
0
          PeriodStatCounts
files <- IO PeriodStatCounts -> IO PeriodStatCounts
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PeriodStatCounts -> IO PeriodStatCounts)
-> IO PeriodStatCounts -> IO PeriodStatCounts
forall a b. (a -> b) -> a -> b
$ PeriodStats -> UTCTime -> IO PeriodStatCounts
periodStatCounts PeriodStats
filesDownloaded UTCTime
ts
          Int
fileDownloads' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
fileDownloads Int
0
          Int
fileDownloadAcks' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
fileDownloadAcks Int
0
          Int
filesCount' <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
filesCount
          Int64
filesSize' <- IORef Int64 -> IO Int64
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int64
filesSize
          Handle -> Text -> IO ()
T.hPutStrLn Handle
h (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text -> [Text] -> Text
T.intercalate
              Text
","
              [ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Day -> String
forall t. ISO8601 t => t -> String
iso8601Show (Day -> String) -> Day -> String
forall a b. (a -> b) -> a -> b
$ UTCTime -> Day
utctDay UTCTime
fromTime',
                Int -> Text
forall a. Show a => a -> Text
tshow Int
filesCreated',
                Int -> Text
forall a. Show a => a -> Text
tshow Int
fileRecipients',
                Int -> Text
forall a. Show a => a -> Text
tshow Int
filesUploaded',
                Int -> Text
forall a. Show a => a -> Text
tshow Int
filesDeleted',
                PeriodStatCounts -> Text
dayCount PeriodStatCounts
files,
                PeriodStatCounts -> Text
weekCount PeriodStatCounts
files,
                PeriodStatCounts -> Text
monthCount PeriodStatCounts
files,
                Int -> Text
forall a. Show a => a -> Text
tshow Int
fileDownloads',
                Int -> Text
forall a. Show a => a -> Text
tshow Int
fileDownloadAcks',
                Int -> Text
forall a. Show a => a -> Text
tshow Int
filesCount',
                Int64 -> Text
forall a. Show a => a -> Text
tshow Int64
filesSize',
                Int -> Text
forall a. Show a => a -> Text
tshow Int
filesExpired'
              ]
        IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ Int64 -> IO ()
threadDelay' Int64
interval

    prometheusMetricsThread_ :: XFTPServerConfig -> [M ()]
    prometheusMetricsThread_ :: XFTPServerConfig -> [M ()]
prometheusMetricsThread_ XFTPServerConfig {prometheusInterval :: XFTPServerConfig -> Maybe Int
prometheusInterval = Just Int
interval, String
prometheusMetricsFile :: String
prometheusMetricsFile :: XFTPServerConfig -> String
prometheusMetricsFile} =
      [Int -> String -> M ()
savePrometheusMetrics Int
interval String
prometheusMetricsFile]
    prometheusMetricsThread_ XFTPServerConfig
_ = []

    savePrometheusMetrics :: Int -> FilePath -> M ()
    savePrometheusMetrics :: Int -> String -> M ()
savePrometheusMetrics Int
saveInterval String
metricsFile = do
      String -> M ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"savePrometheusMetrics"
      IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Prometheus metrics saved every " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
saveInterval String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" seconds to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
metricsFile
      FileServerStats
ss <- (XFTPEnv -> FileServerStats) -> ReaderT XFTPEnv IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileServerStats
serverStats
      Text
rtsOpts <- IO Text -> ReaderT XFTPEnv IO Text
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ReaderT XFTPEnv IO Text)
-> IO Text -> ReaderT XFTPEnv IO Text
forall a b. (a -> b) -> a -> b
$ Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text
"set " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rtsOptionsEnv) String -> Text
T.pack (Maybe String -> Text) -> IO (Maybe String) -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv (Text -> String
T.unpack Text
rtsOptionsEnv)
      let interval :: Int
interval = Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
saveInterval
      IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
interval
        UTCTime
ts <- IO UTCTime
getCurrentTime
        FileServerMetrics
sm <- FileServerStats -> Text -> IO FileServerMetrics
getFileServerMetrics FileServerStats
ss Text
rtsOpts
        String -> Text -> IO ()
T.writeFile String
metricsFile (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FileServerMetrics -> UTCTime -> Text
xftpPrometheusMetrics FileServerMetrics
sm UTCTime
ts

    getFileServerMetrics :: FileServerStats -> T.Text -> IO FileServerMetrics
    getFileServerMetrics :: FileServerStats -> Text -> IO FileServerMetrics
getFileServerMetrics FileServerStats
ss Text
rtsOptions = do
      FileServerStatsData
d <- FileServerStats -> IO FileServerStatsData
getFileServerStatsData FileServerStats
ss
      let fd :: PeriodStatCounts
fd = PeriodStatsData -> PeriodStatCounts
periodStatDataCounts (PeriodStatsData -> PeriodStatCounts)
-> PeriodStatsData -> PeriodStatCounts
forall a b. (a -> b) -> a -> b
$ FileServerStatsData -> PeriodStatsData
_filesDownloaded FileServerStatsData
d
      FileServerMetrics -> IO FileServerMetrics
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileServerMetrics {statsData :: FileServerStatsData
statsData = FileServerStatsData
d, filesDownloadedPeriods :: PeriodStatCounts
filesDownloadedPeriods = PeriodStatCounts
fd, Text
rtsOptions :: Text
rtsOptions :: Text
rtsOptions}

    controlPortThread_ :: XFTPServerConfig -> [M ()]
    controlPortThread_ :: XFTPServerConfig -> [M ()]
controlPortThread_ XFTPServerConfig {controlPort :: XFTPServerConfig -> Maybe String
controlPort = Just String
port} = [String -> M ()
runCPServer String
port]
    controlPortThread_ XFTPServerConfig
_ = []

    runCPServer :: ServiceName -> M ()
    runCPServer :: String -> M ()
runCPServer String
port = do
      TMVar Bool
cpStarted <- ReaderT XFTPEnv IO (TMVar Bool)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      UnliftIO (ReaderT XFTPEnv IO)
u <- ReaderT XFTPEnv IO (UnliftIO (ReaderT XFTPEnv IO))
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
      IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"control port server"
        TMVar Bool -> String -> (Socket -> IO ()) -> IO ()
runLocalTCPServer TMVar Bool
cpStarted String
port ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (ReaderT XFTPEnv IO) -> Socket -> IO ()
runCPClient UnliftIO (ReaderT XFTPEnv IO)
u
      where
        runCPClient :: UnliftIO (ReaderT XFTPEnv IO) -> Socket -> IO ()
        runCPClient :: UnliftIO (ReaderT XFTPEnv IO) -> Socket -> IO ()
runCPClient UnliftIO (ReaderT XFTPEnv IO)
u Socket
sock = do
          String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"control port client"
          Handle
h <- Socket -> IOMode -> IO Handle
socketToHandle Socket
sock IOMode
ReadWriteMode
          Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
h BufferMode
LineBuffering
          Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
universalNewlineMode
          Handle -> String -> IO ()
hPutStrLn Handle
h String
"XFTP server control port\n'help' for supported commands"
          TVar CPClientRole
role <- CPClientRole -> IO (TVar CPClientRole)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO CPClientRole
CPRNone
          Handle -> TVar CPClientRole -> IO ()
cpLoop Handle
h TVar CPClientRole
role
          where
            cpLoop :: Handle -> TVar CPClientRole -> IO ()
cpLoop Handle
h TVar CPClientRole
role = do
              ByteString
s <- ByteString -> ByteString
trimCR (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
B.hGetLine Handle
h
              case ByteString -> Either String ControlProtocol
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
s of
                Right ControlProtocol
CPQuit -> Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
                Right ControlProtocol
cmd -> ByteString -> ControlProtocol -> IO ()
forall {f :: * -> *} {a}.
(MonadIO f, Show a) =>
a -> ControlProtocol -> f ()
logCmd ByteString
s ControlProtocol
cmd IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> TVar CPClientRole -> ControlProtocol -> IO ()
processCP Handle
h TVar CPClientRole
role ControlProtocol
cmd IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> TVar CPClientRole -> IO ()
cpLoop Handle
h TVar CPClientRole
role
                Left String
err -> Handle -> String -> IO ()
hPutStrLn Handle
h (String
"error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> TVar CPClientRole -> IO ()
cpLoop Handle
h TVar CPClientRole
role
            logCmd :: a -> ControlProtocol -> f ()
logCmd a
s ControlProtocol
cmd = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldLog (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ Text -> f ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn (Text -> f ()) -> Text -> f ()
forall a b. (a -> b) -> a -> b
$ Text
"ControlPort: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow a
s
              where
                shouldLog :: Bool
shouldLog = case ControlProtocol
cmd of
                  CPAuth BasicAuth
_ -> Bool
False
                  ControlProtocol
CPHelp -> Bool
False
                  ControlProtocol
CPQuit -> Bool
False
                  ControlProtocol
CPSkip -> Bool
False
                  ControlProtocol
_ -> Bool
True
            processCP :: Handle -> TVar CPClientRole -> ControlProtocol -> IO ()
processCP Handle
h TVar CPClientRole
role = \case
              CPAuth BasicAuth
auth -> Handle
-> Maybe BasicAuth
-> Maybe BasicAuth
-> TVar CPClientRole
-> BasicAuth
-> IO ()
controlPortAuth Handle
h Maybe BasicAuth
user Maybe BasicAuth
admin TVar CPClientRole
role BasicAuth
auth
                where
                  XFTPServerConfig {controlPortUserAuth :: XFTPServerConfig -> Maybe BasicAuth
controlPortUserAuth = Maybe BasicAuth
user, controlPortAdminAuth :: XFTPServerConfig -> Maybe BasicAuth
controlPortAdminAuth = Maybe BasicAuth
admin} = XFTPServerConfig
cfg
              ControlProtocol
CPStatsRTS -> IO RTSStats -> IO (Either SomeException RTSStats)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
E.tryAny IO RTSStats
getRTSStats IO (Either SomeException RTSStats)
-> (Either SomeException RTSStats -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO ())
-> (RTSStats -> IO ()) -> Either SomeException RTSStats -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Handle -> SomeException -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
h) (Handle -> RTSStats -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
h)
              CPDelete XFTPFileId
fileId -> IO () -> IO ()
withUserRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (ReaderT XFTPEnv IO)
-> forall a. ReaderT XFTPEnv IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT XFTPEnv IO)
u (M () -> IO ()) -> M () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                FileStore
fs <- (XFTPEnv -> FileStore) -> ReaderT XFTPEnv IO FileStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileStore
store
                Either XFTPErrorType ()
r <- ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
 -> ReaderT XFTPEnv IO (Either XFTPErrorType ()))
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ do
                  (FileRec
fr, APublicAuthKey
_) <- ReaderT XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ExceptT
     XFTPErrorType (ReaderT XFTPEnv IO) (FileRec, APublicAuthKey)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT
   XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey))
 -> ExceptT
      XFTPErrorType (ReaderT XFTPEnv IO) (FileRec, APublicAuthKey))
-> ReaderT
     XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ExceptT
     XFTPErrorType (ReaderT XFTPEnv IO) (FileRec, APublicAuthKey)
forall a b. (a -> b) -> a -> b
$ STM (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ReaderT
     XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either XFTPErrorType (FileRec, APublicAuthKey))
 -> ReaderT
      XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ReaderT
     XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a b. (a -> b) -> a -> b
$ FileStore
-> SFileParty 'FRecipient
-> XFTPFileId
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall (p :: FileParty).
FileStore
-> SFileParty p
-> XFTPFileId
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
getFile FileStore
fs SFileParty 'FRecipient
SFRecipient XFTPFileId
fileId
                  ReaderT XFTPEnv IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT XFTPEnv IO (Either XFTPErrorType ())
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ FileRec -> ReaderT XFTPEnv IO (Either XFTPErrorType ())
deleteServerFile_ FileRec
fr
                IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> (String -> IO ()) -> String -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
h (String -> M ()) -> String -> M ()
forall a b. (a -> b) -> a -> b
$ (XFTPErrorType -> String)
-> (() -> String) -> Either XFTPErrorType () -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\XFTPErrorType
e -> String
"error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> XFTPErrorType -> String
forall a. Show a => a -> String
show XFTPErrorType
e) (\() -> String
"ok") Either XFTPErrorType ()
r
              CPBlock XFTPFileId
fileId BlockingInfo
info -> IO () -> IO ()
withUserRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (ReaderT XFTPEnv IO)
-> forall a. ReaderT XFTPEnv IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT XFTPEnv IO)
u (M () -> IO ()) -> M () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                FileStore
fs <- (XFTPEnv -> FileStore) -> ReaderT XFTPEnv IO FileStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileStore
store
                Either XFTPErrorType ()
r <- ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
 -> ReaderT XFTPEnv IO (Either XFTPErrorType ()))
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ do
                  (FileRec
fr, APublicAuthKey
_) <- ReaderT XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ExceptT
     XFTPErrorType (ReaderT XFTPEnv IO) (FileRec, APublicAuthKey)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT
   XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey))
 -> ExceptT
      XFTPErrorType (ReaderT XFTPEnv IO) (FileRec, APublicAuthKey))
-> ReaderT
     XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ExceptT
     XFTPErrorType (ReaderT XFTPEnv IO) (FileRec, APublicAuthKey)
forall a b. (a -> b) -> a -> b
$ STM (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ReaderT
     XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either XFTPErrorType (FileRec, APublicAuthKey))
 -> ReaderT
      XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ReaderT
     XFTPEnv IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a b. (a -> b) -> a -> b
$ FileStore
-> SFileParty 'FRecipient
-> XFTPFileId
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall (p :: FileParty).
FileStore
-> SFileParty p
-> XFTPFileId
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
getFile FileStore
fs SFileParty 'FRecipient
SFRecipient XFTPFileId
fileId
                  ReaderT XFTPEnv IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT XFTPEnv IO (Either XFTPErrorType ())
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ FileRec
-> BlockingInfo -> ReaderT XFTPEnv IO (Either XFTPErrorType ())
blockServerFile FileRec
fr BlockingInfo
info
                IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> (String -> IO ()) -> String -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
h (String -> M ()) -> String -> M ()
forall a b. (a -> b) -> a -> b
$ (XFTPErrorType -> String)
-> (() -> String) -> Either XFTPErrorType () -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\XFTPErrorType
e -> String
"error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> XFTPErrorType -> String
forall a. Show a => a -> String
show XFTPErrorType
e) (\() -> String
"ok") Either XFTPErrorType ()
r
              ControlProtocol
CPHelp -> Handle -> String -> IO ()
hPutStrLn Handle
h String
"commands: stats-rts, delete, help, quit"
              ControlProtocol
CPQuit -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              ControlProtocol
CPSkip -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              where
                withUserRole :: IO () -> IO ()
withUserRole IO ()
action =
                  TVar CPClientRole -> IO CPClientRole
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar CPClientRole
role IO CPClientRole -> (CPClientRole -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    CPClientRole
CPRAdmin -> IO ()
action
                    CPClientRole
CPRUser -> IO ()
action
                    CPClientRole
_ -> do
                      Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError Text
"Unauthorized control port command"
                      Handle -> String -> IO ()
hPutStrLn Handle
h String
"AUTH"

data ServerFile = ServerFile
  { ServerFile -> String
filePath :: FilePath,
    ServerFile -> Word32
fileSize :: Word32,
    ServerFile -> SbState
sbState :: LC.SbState
  }

processRequest :: XFTPTransportRequest -> M ()
processRequest :: XFTPTransportRequest -> M ()
processRequest XFTPTransportRequest {THandleParamsXFTP 'TServer
thParams :: XFTPTransportRequest -> THandleParamsXFTP 'TServer
thParams :: THandleParamsXFTP 'TServer
thParams, reqBody :: XFTPTransportRequest -> HTTP2Body
reqBody = body :: HTTP2Body
body@HTTP2Body {ByteString
bodyHead :: HTTP2Body -> ByteString
bodyHead :: ByteString
bodyHead}, Response -> IO ()
sendResponse :: XFTPTransportRequest -> Response -> IO ()
sendResponse :: Response -> IO ()
sendResponse}
  | ByteString -> Int
B.length ByteString
bodyHead Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
xftpBlockSize = Transmission FileResponse -> Maybe ServerFile -> M ()
sendXFTPResponse (CorrId
"", XFTPFileId
NoEntity, XFTPErrorType -> FileResponse
FRErr XFTPErrorType
BLOCK) Maybe ServerFile
forall a. Maybe a
Nothing
  | Bool
otherwise =
      case THandleParamsXFTP 'TServer
-> ByteString
-> Either
     XFTPErrorType (SignedTransmissionOrError XFTPErrorType FileCmd)
xftpDecodeTServer THandleParamsXFTP 'TServer
thParams ByteString
bodyHead of
        Right (Right t :: SignedTransmission FileCmd
t@(Maybe TAuthorizations
_, ByteString
_, (CorrId
corrId, XFTPFileId
fId, FileCmd
_))) -> do
          let THandleParams {Maybe (THandleAuth 'TServer)
thAuth :: forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth :: Maybe (THandleAuth 'TServer)
thAuth} = THandleParamsXFTP 'TServer
thParams
          Maybe (THandleAuth 'TServer)
-> SignedTransmission FileCmd -> M VerificationResult
verifyXFTPTransmission Maybe (THandleAuth 'TServer)
thAuth SignedTransmission FileCmd
t M VerificationResult -> (VerificationResult -> M ()) -> M ()
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            VRVerified XFTPRequest
req -> (FileResponse -> Maybe ServerFile -> M ())
-> (FileResponse, Maybe ServerFile) -> M ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FileResponse -> Maybe ServerFile -> M ()
send ((FileResponse, Maybe ServerFile) -> M ())
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile) -> M ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HTTP2Body
-> XFTPRequest
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
processXFTPRequest HTTP2Body
body XFTPRequest
req
            VRFailed XFTPErrorType
e -> FileResponse -> Maybe ServerFile -> M ()
send (XFTPErrorType -> FileResponse
FRErr XFTPErrorType
e) Maybe ServerFile
forall a. Maybe a
Nothing
          where
            send :: FileResponse -> Maybe ServerFile -> M ()
send FileResponse
resp = Transmission FileResponse -> Maybe ServerFile -> M ()
sendXFTPResponse (CorrId
corrId, XFTPFileId
fId, FileResponse
resp)
        Right (Left (CorrId
corrId, XFTPFileId
fId, XFTPErrorType
e)) -> Transmission FileResponse -> Maybe ServerFile -> M ()
sendXFTPResponse (CorrId
corrId, XFTPFileId
fId, XFTPErrorType -> FileResponse
FRErr XFTPErrorType
e) Maybe ServerFile
forall a. Maybe a
Nothing
        Left XFTPErrorType
e -> Transmission FileResponse -> Maybe ServerFile -> M ()
sendXFTPResponse (CorrId
"", XFTPFileId
NoEntity, XFTPErrorType -> FileResponse
FRErr XFTPErrorType
e) Maybe ServerFile
forall a. Maybe a
Nothing
  where
    sendXFTPResponse :: Transmission FileResponse -> Maybe ServerFile -> M ()
sendXFTPResponse Transmission FileResponse
t' Maybe ServerFile
serverFile_ = do
      let t_ :: Either TransportError ByteString
t_ = THandleParamsXFTP 'TServer
-> Transmission FileResponse -> Either TransportError ByteString
forall c (p :: TransportPeer).
ProtocolEncoding XFTPVersion XFTPErrorType c =>
THandleParams XFTPVersion p
-> Transmission c -> Either TransportError ByteString
xftpEncodeTransmission THandleParamsXFTP 'TServer
thParams Transmission FileResponse
t'
#ifdef slow_servers
      randomDelay
#endif
      IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ Response -> IO ()
sendResponse (Response -> IO ()) -> Response -> IO ()
forall a b. (a -> b) -> a -> b
$ Status
-> ResponseHeaders
-> ((Builder -> IO ()) -> IO () -> IO ())
-> Response
H.responseStreaming Status
N.ok200 [] (((Builder -> IO ()) -> IO () -> IO ()) -> Response)
-> ((Builder -> IO ()) -> IO () -> IO ()) -> Response
forall a b. (a -> b) -> a -> b
$ Either TransportError ByteString
-> (Builder -> IO ()) -> IO () -> IO ()
streamBody Either TransportError ByteString
t_
      where
        streamBody :: Either TransportError ByteString
-> (Builder -> IO ()) -> IO () -> IO ()
streamBody Either TransportError ByteString
t_ Builder -> IO ()
send IO ()
done = do
          case Either TransportError ByteString
t_ of
            Left TransportError
_ -> do
              Builder -> IO ()
send Builder
"padding error" -- TODO respond with BLOCK error?
              IO ()
done
            Right ByteString
t -> do
              Builder -> IO ()
send (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
t
              -- timeout sending file in the same way as receiving
              Maybe ServerFile -> (ServerFile -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ServerFile
serverFile_ ((ServerFile -> IO ()) -> IO ()) -> (ServerFile -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ServerFile {String
filePath :: ServerFile -> String
filePath :: String
filePath, Word32
fileSize :: ServerFile -> Word32
fileSize :: Word32
fileSize, SbState
sbState :: ServerFile -> SbState
sbState :: SbState
sbState} -> do
                String -> IOMode -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile String
filePath IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> (Builder -> IO ()) -> SbState -> Word32 -> IO ()
sendEncFile Handle
h Builder -> IO ()
send SbState
sbState Word32
fileSize
          IO ()
done

#ifdef slow_servers
randomDelay :: M ()
randomDelay = do
  d <- asks $ responseDelay . config
  when (d > 0) $ do
    pc <- getStdRandom (randomR (-200, 200))
    threadDelay $ (d * (1000 + pc)) `div` 1000
#endif

data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType

verifyXFTPTransmission :: Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M VerificationResult
verifyXFTPTransmission :: Maybe (THandleAuth 'TServer)
-> SignedTransmission FileCmd -> M VerificationResult
verifyXFTPTransmission Maybe (THandleAuth 'TServer)
thAuth (Maybe TAuthorizations
tAuth, ByteString
authorized, (CorrId
corrId, XFTPFileId
fId, FileCmd
cmd)) =
  case FileCmd
cmd of
    FileCmd SFileParty p
SFSender (FNEW FileInfo
file NonEmpty APublicAuthKey
rcps Maybe BasicAuth
auth') -> VerificationResult -> M VerificationResult
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationResult -> M VerificationResult)
-> VerificationResult -> M VerificationResult
forall a b. (a -> b) -> a -> b
$ FileInfo
-> NonEmpty APublicAuthKey -> Maybe BasicAuth -> XFTPRequest
XFTPReqNew FileInfo
file NonEmpty APublicAuthKey
rcps Maybe BasicAuth
auth' XFTPRequest -> APublicAuthKey -> VerificationResult
`verifyWith` FileInfo -> APublicAuthKey
sndKey FileInfo
file
    FileCmd SFileParty p
SFRecipient FileCommand p
PING -> VerificationResult -> M VerificationResult
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationResult -> M VerificationResult)
-> VerificationResult -> M VerificationResult
forall a b. (a -> b) -> a -> b
$ XFTPRequest -> VerificationResult
VRVerified XFTPRequest
XFTPReqPing
    FileCmd SFileParty p
party FileCommand p
_ -> SFileParty p -> M VerificationResult
forall (p :: FileParty). SFileParty p -> M VerificationResult
verifyCmd SFileParty p
party
  where
    verifyCmd :: SFileParty p -> M VerificationResult
    verifyCmd :: forall (p :: FileParty). SFileParty p -> M VerificationResult
verifyCmd SFileParty p
party = do
      FileStore
st <- (XFTPEnv -> FileStore) -> ReaderT XFTPEnv IO FileStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileStore
store
      STM VerificationResult -> M VerificationResult
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM VerificationResult -> M VerificationResult)
-> STM VerificationResult -> M VerificationResult
forall a b. (a -> b) -> a -> b
$ Either XFTPErrorType (FileRec, APublicAuthKey)
-> STM VerificationResult
verify (Either XFTPErrorType (FileRec, APublicAuthKey)
 -> STM VerificationResult)
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
-> STM VerificationResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FileStore
-> SFileParty p
-> XFTPFileId
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall (p :: FileParty).
FileStore
-> SFileParty p
-> XFTPFileId
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
getFile FileStore
st SFileParty p
party XFTPFileId
fId
      where
        verify :: Either XFTPErrorType (FileRec, APublicAuthKey)
-> STM VerificationResult
verify = \case
          Right (FileRec
fr, APublicAuthKey
k) -> ServerEntityStatus -> VerificationResult
result (ServerEntityStatus -> VerificationResult)
-> STM ServerEntityStatus -> STM VerificationResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar ServerEntityStatus -> STM ServerEntityStatus
forall a. TVar a -> STM a
readTVar (FileRec -> TVar ServerEntityStatus
fileStatus FileRec
fr)
            where
              result :: ServerEntityStatus -> VerificationResult
result = \case
                ServerEntityStatus
EntityActive -> XFTPFileId -> FileRec -> FileCmd -> XFTPRequest
XFTPReqCmd XFTPFileId
fId FileRec
fr FileCmd
cmd XFTPRequest -> APublicAuthKey -> VerificationResult
`verifyWith` APublicAuthKey
k
                EntityBlocked BlockingInfo
info -> XFTPErrorType -> VerificationResult
VRFailed (XFTPErrorType -> VerificationResult)
-> XFTPErrorType -> VerificationResult
forall a b. (a -> b) -> a -> b
$ BlockingInfo -> XFTPErrorType
BLOCKED BlockingInfo
info
                ServerEntityStatus
EntityOff -> VerificationResult
noFileAuth
          Left XFTPErrorType
_ -> VerificationResult -> STM VerificationResult
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VerificationResult
noFileAuth
        noFileAuth :: VerificationResult
noFileAuth = Maybe (THandleAuth 'TServer)
-> Maybe TAuthorizations -> ByteString -> CorrId -> Bool
dummyVerifyCmd Maybe (THandleAuth 'TServer)
thAuth Maybe TAuthorizations
tAuth ByteString
authorized CorrId
corrId Bool -> VerificationResult -> VerificationResult
forall a b. a -> b -> b
`seq` XFTPErrorType -> VerificationResult
VRFailed XFTPErrorType
AUTH
    -- TODO verify with DH authorization
    XFTPRequest
req verifyWith :: XFTPRequest -> APublicAuthKey -> VerificationResult
`verifyWith` APublicAuthKey
k = if Maybe (THandleAuth 'TServer)
-> Maybe TAuthorizations
-> ByteString
-> CorrId
-> APublicAuthKey
-> Bool
verifyCmdAuthorization Maybe (THandleAuth 'TServer)
thAuth Maybe TAuthorizations
tAuth ByteString
authorized CorrId
corrId APublicAuthKey
k then XFTPRequest -> VerificationResult
VRVerified XFTPRequest
req else XFTPErrorType -> VerificationResult
VRFailed XFTPErrorType
AUTH

processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
processXFTPRequest :: HTTP2Body
-> XFTPRequest
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
processXFTPRequest HTTP2Body {Maybe (Int -> IO ByteString)
bodyPart :: Maybe (Int -> IO ByteString)
bodyPart :: HTTP2Body -> Maybe (Int -> IO ByteString)
bodyPart} = \case
  XFTPReqNew FileInfo
file NonEmpty APublicAuthKey
rks Maybe BasicAuth
auth -> FileResponse -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse
 -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile))
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT XFTPEnv IO Bool
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO FileResponse
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ReaderT XFTPEnv IO Bool
allowNew (FileInfo
-> NonEmpty APublicAuthKey -> ReaderT XFTPEnv IO FileResponse
createFile FileInfo
file NonEmpty APublicAuthKey
rks) (FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT XFTPEnv IO FileResponse)
-> FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
AUTH)
    where
      allowNew :: ReaderT XFTPEnv IO Bool
allowNew = do
        XFTPServerConfig {Bool
allowNewFiles :: Bool
allowNewFiles :: XFTPServerConfig -> Bool
allowNewFiles, Maybe BasicAuth
newFileBasicAuth :: Maybe BasicAuth
newFileBasicAuth :: XFTPServerConfig -> Maybe BasicAuth
newFileBasicAuth} <- (XFTPEnv -> XFTPServerConfig)
-> ReaderT XFTPEnv IO XFTPServerConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> XFTPServerConfig
config
        Bool -> ReaderT XFTPEnv IO Bool
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ReaderT XFTPEnv IO Bool)
-> Bool -> ReaderT XFTPEnv IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
allowNewFiles Bool -> Bool -> Bool
&& Bool -> (BasicAuth -> Bool) -> Maybe BasicAuth -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Maybe BasicAuth -> Maybe BasicAuth -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe BasicAuth
auth) (Maybe BasicAuth -> Bool)
-> (BasicAuth -> Maybe BasicAuth) -> BasicAuth -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BasicAuth -> Maybe BasicAuth
forall a. a -> Maybe a
Just) Maybe BasicAuth
newFileBasicAuth
  XFTPReqCmd XFTPFileId
fId FileRec
fr (FileCmd SFileParty p
_ FileCommand p
cmd) -> case FileCommand p
cmd of
    FADD NonEmpty APublicAuthKey
rks -> FileResponse -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse
 -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile))
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< XFTPFileId
-> NonEmpty APublicAuthKey -> ReaderT XFTPEnv IO FileResponse
addRecipients XFTPFileId
fId NonEmpty APublicAuthKey
rks
    FileCommand p
FPUT -> FileResponse -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse
 -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile))
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FileRec -> ReaderT XFTPEnv IO FileResponse
receiveServerFile FileRec
fr
    FileCommand p
FDEL -> FileResponse -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse
 -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile))
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FileRec -> ReaderT XFTPEnv IO FileResponse
deleteServerFile FileRec
fr
    FGET PublicKey 'X25519
rDhKey -> FileRec
-> PublicKey 'X25519
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
sendServerFile FileRec
fr PublicKey 'X25519
rDhKey
    FileCommand p
FACK -> FileResponse -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse
 -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile))
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< XFTPFileId -> FileRec -> ReaderT XFTPEnv IO FileResponse
ackFileReception XFTPFileId
fId FileRec
fr
    -- it should never get to the commands below, they are passed in other constructors of XFTPRequest
    FNEW {} -> FileResponse -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse
 -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile))
-> FileResponse
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
INTERNAL
    FileCommand p
PING -> FileResponse -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse
 -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile))
-> FileResponse
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
INTERNAL
  XFTPRequest
XFTPReqPing -> FileResponse -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile FileResponse
FRPong
  where
    noFile :: a -> f (a, Maybe a)
noFile a
resp = (a, Maybe a) -> f (a, Maybe a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
resp, Maybe a
forall a. Maybe a
Nothing)
    createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M FileResponse
    createFile :: FileInfo
-> NonEmpty APublicAuthKey -> ReaderT XFTPEnv IO FileResponse
createFile FileInfo
file NonEmpty APublicAuthKey
rks = do
      FileStore
st <- (XFTPEnv -> FileStore) -> ReaderT XFTPEnv IO FileStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileStore
store
      Either XFTPErrorType FileResponse
r <- ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse
-> ReaderT XFTPEnv IO (Either XFTPErrorType FileResponse)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse
 -> ReaderT XFTPEnv IO (Either XFTPErrorType FileResponse))
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse
-> ReaderT XFTPEnv IO (Either XFTPErrorType FileResponse)
forall a b. (a -> b) -> a -> b
$ do
        [Word32]
sizes <- (XFTPEnv -> [Word32])
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) [Word32]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XFTPEnv -> [Word32])
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) [Word32])
-> (XFTPEnv -> [Word32])
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) [Word32]
forall a b. (a -> b) -> a -> b
$ XFTPServerConfig -> [Word32]
allowedChunkSizes (XFTPServerConfig -> [Word32])
-> (XFTPEnv -> XFTPServerConfig) -> XFTPEnv -> [Word32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv -> XFTPServerConfig
config
        Bool
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FileInfo -> Word32
size FileInfo
file Word32 -> [Word32] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word32]
sizes) (ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
SIZE
        RoundedFileTime
ts <- IO RoundedFileTime
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) RoundedFileTime
forall a. IO a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RoundedFileTime
getFileTime
        -- TODO validate body empty
        XFTPFileId
sId <- ReaderT XFTPEnv IO (Either XFTPErrorType XFTPFileId)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) XFTPFileId
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT XFTPEnv IO (Either XFTPErrorType XFTPFileId)
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) XFTPFileId)
-> ReaderT XFTPEnv IO (Either XFTPErrorType XFTPFileId)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) XFTPFileId
forall a b. (a -> b) -> a -> b
$ FileStore
-> FileInfo
-> Int
-> RoundedFileTime
-> ReaderT XFTPEnv IO (Either XFTPErrorType XFTPFileId)
addFileRetry FileStore
st FileInfo
file Int
3 RoundedFileTime
ts
        NonEmpty FileRecipient
rcps <- (APublicAuthKey
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileRecipient)
-> NonEmpty APublicAuthKey
-> ExceptT
     XFTPErrorType (ReaderT XFTPEnv IO) (NonEmpty FileRecipient)
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) -> NonEmpty a -> m (NonEmpty b)
mapM (ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileRecipient
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient)
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileRecipient)
-> (APublicAuthKey
    -> ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient))
-> APublicAuthKey
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileRecipient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStore
-> Int
-> XFTPFileId
-> APublicAuthKey
-> ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient)
addRecipientRetry FileStore
st Int
3 XFTPFileId
sId) NonEmpty APublicAuthKey
rks
        M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT XFTPErrorType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ (StoreLog 'WriteMode -> IO ()) -> M ()
forall a. (StoreLog 'WriteMode -> IO a) -> M ()
withFileLog ((StoreLog 'WriteMode -> IO ()) -> M ())
-> (StoreLog 'WriteMode -> IO ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \StoreLog 'WriteMode
sl -> do
          StoreLog 'WriteMode
-> XFTPFileId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> IO ()
logAddFile StoreLog 'WriteMode
sl XFTPFileId
sId FileInfo
file RoundedFileTime
ts ServerEntityStatus
EntityActive
          StoreLog 'WriteMode
-> XFTPFileId -> NonEmpty FileRecipient -> IO ()
logAddRecipients StoreLog 'WriteMode
sl XFTPFileId
sId NonEmpty FileRecipient
rcps
        FileServerStats
stats <- (XFTPEnv -> FileServerStats)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileServerStats
serverStats
        M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT XFTPErrorType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ (FileServerStats -> IORef Int) -> M ()
incFileStat FileServerStats -> IORef Int
filesCreated
        IO () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a. IO a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> IO () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (FileServerStats -> IORef Int
fileRecipients FileServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ NonEmpty APublicAuthKey -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty APublicAuthKey
rks)
        let rIds :: NonEmpty XFTPFileId
rIds = (FileRecipient -> XFTPFileId)
-> NonEmpty FileRecipient -> NonEmpty XFTPFileId
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(FileRecipient XFTPFileId
rId APublicAuthKey
_) -> XFTPFileId
rId) NonEmpty FileRecipient
rcps
        FileResponse
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse
forall a. a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse)
-> FileResponse
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse
forall a b. (a -> b) -> a -> b
$ XFTPFileId -> NonEmpty XFTPFileId -> FileResponse
FRSndIds XFTPFileId
sId NonEmpty XFTPFileId
rIds
      FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT XFTPEnv IO FileResponse)
-> FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a b. (a -> b) -> a -> b
$ (XFTPErrorType -> FileResponse)
-> (FileResponse -> FileResponse)
-> Either XFTPErrorType FileResponse
-> FileResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XFTPErrorType -> FileResponse
FRErr FileResponse -> FileResponse
forall a. a -> a
id Either XFTPErrorType FileResponse
r
    addFileRetry :: FileStore -> FileInfo -> Int -> RoundedFileTime -> M (Either XFTPErrorType XFTPFileId)
    addFileRetry :: FileStore
-> FileInfo
-> Int
-> RoundedFileTime
-> ReaderT XFTPEnv IO (Either XFTPErrorType XFTPFileId)
addFileRetry FileStore
st FileInfo
file Int
n RoundedFileTime
ts =
      Int
-> (XFTPFileId -> STM (Either XFTPErrorType XFTPFileId))
-> ReaderT XFTPEnv IO (Either XFTPErrorType XFTPFileId)
forall a.
Int
-> (XFTPFileId -> STM (Either XFTPErrorType a))
-> M (Either XFTPErrorType a)
retryAdd Int
n ((XFTPFileId -> STM (Either XFTPErrorType XFTPFileId))
 -> ReaderT XFTPEnv IO (Either XFTPErrorType XFTPFileId))
-> (XFTPFileId -> STM (Either XFTPErrorType XFTPFileId))
-> ReaderT XFTPEnv IO (Either XFTPErrorType XFTPFileId)
forall a b. (a -> b) -> a -> b
$ \XFTPFileId
sId -> ExceptT XFTPErrorType STM XFTPFileId
-> STM (Either XFTPErrorType XFTPFileId)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType STM XFTPFileId
 -> STM (Either XFTPErrorType XFTPFileId))
-> ExceptT XFTPErrorType STM XFTPFileId
-> STM (Either XFTPErrorType XFTPFileId)
forall a b. (a -> b) -> a -> b
$ do
        STM (Either XFTPErrorType ()) -> ExceptT XFTPErrorType STM ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (STM (Either XFTPErrorType ()) -> ExceptT XFTPErrorType STM ())
-> STM (Either XFTPErrorType ()) -> ExceptT XFTPErrorType STM ()
forall a b. (a -> b) -> a -> b
$ FileStore
-> XFTPFileId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> STM (Either XFTPErrorType ())
addFile FileStore
st XFTPFileId
sId FileInfo
file RoundedFileTime
ts ServerEntityStatus
EntityActive
        XFTPFileId -> ExceptT XFTPErrorType STM XFTPFileId
forall a. a -> ExceptT XFTPErrorType STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPFileId
sId
    addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicAuthKey -> M (Either XFTPErrorType FileRecipient)
    addRecipientRetry :: FileStore
-> Int
-> XFTPFileId
-> APublicAuthKey
-> ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient)
addRecipientRetry FileStore
st Int
n XFTPFileId
sId APublicAuthKey
rpk =
      Int
-> (XFTPFileId -> STM (Either XFTPErrorType FileRecipient))
-> ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient)
forall a.
Int
-> (XFTPFileId -> STM (Either XFTPErrorType a))
-> M (Either XFTPErrorType a)
retryAdd Int
n ((XFTPFileId -> STM (Either XFTPErrorType FileRecipient))
 -> ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient))
-> (XFTPFileId -> STM (Either XFTPErrorType FileRecipient))
-> ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient)
forall a b. (a -> b) -> a -> b
$ \XFTPFileId
rId -> ExceptT XFTPErrorType STM FileRecipient
-> STM (Either XFTPErrorType FileRecipient)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType STM FileRecipient
 -> STM (Either XFTPErrorType FileRecipient))
-> ExceptT XFTPErrorType STM FileRecipient
-> STM (Either XFTPErrorType FileRecipient)
forall a b. (a -> b) -> a -> b
$ do
        let rcp :: FileRecipient
rcp = XFTPFileId -> APublicAuthKey -> FileRecipient
FileRecipient XFTPFileId
rId APublicAuthKey
rpk
        STM (Either XFTPErrorType ()) -> ExceptT XFTPErrorType STM ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (STM (Either XFTPErrorType ()) -> ExceptT XFTPErrorType STM ())
-> STM (Either XFTPErrorType ()) -> ExceptT XFTPErrorType STM ()
forall a b. (a -> b) -> a -> b
$ FileStore
-> XFTPFileId -> FileRecipient -> STM (Either XFTPErrorType ())
addRecipient FileStore
st XFTPFileId
sId FileRecipient
rcp
        FileRecipient -> ExceptT XFTPErrorType STM FileRecipient
forall a. a -> ExceptT XFTPErrorType STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileRecipient
rcp
    retryAdd :: Int -> (XFTPFileId -> STM (Either XFTPErrorType a)) -> M (Either XFTPErrorType a)
    retryAdd :: forall a.
Int
-> (XFTPFileId -> STM (Either XFTPErrorType a))
-> M (Either XFTPErrorType a)
retryAdd Int
0 XFTPFileId -> STM (Either XFTPErrorType a)
_ = Either XFTPErrorType a
-> ReaderT XFTPEnv IO (Either XFTPErrorType a)
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType a
 -> ReaderT XFTPEnv IO (Either XFTPErrorType a))
-> Either XFTPErrorType a
-> ReaderT XFTPEnv IO (Either XFTPErrorType a)
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> Either XFTPErrorType a
forall a b. a -> Either a b
Left XFTPErrorType
INTERNAL
    retryAdd Int
n XFTPFileId -> STM (Either XFTPErrorType a)
add = do
      XFTPFileId
fId <- M XFTPFileId
getFileId
      STM (Either XFTPErrorType a)
-> ReaderT XFTPEnv IO (Either XFTPErrorType a)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (XFTPFileId -> STM (Either XFTPErrorType a)
add XFTPFileId
fId) ReaderT XFTPEnv IO (Either XFTPErrorType a)
-> (Either XFTPErrorType a
    -> ReaderT XFTPEnv IO (Either XFTPErrorType a))
-> ReaderT XFTPEnv IO (Either XFTPErrorType a)
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left XFTPErrorType
DUPLICATE_ -> Int
-> (XFTPFileId -> STM (Either XFTPErrorType a))
-> ReaderT XFTPEnv IO (Either XFTPErrorType a)
forall a.
Int
-> (XFTPFileId -> STM (Either XFTPErrorType a))
-> M (Either XFTPErrorType a)
retryAdd (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) XFTPFileId -> STM (Either XFTPErrorType a)
add
        Either XFTPErrorType a
r -> Either XFTPErrorType a
-> ReaderT XFTPEnv IO (Either XFTPErrorType a)
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either XFTPErrorType a
r
    addRecipients :: XFTPFileId -> NonEmpty RcvPublicAuthKey -> M FileResponse
    addRecipients :: XFTPFileId
-> NonEmpty APublicAuthKey -> ReaderT XFTPEnv IO FileResponse
addRecipients XFTPFileId
sId NonEmpty APublicAuthKey
rks = do
      FileStore
st <- (XFTPEnv -> FileStore) -> ReaderT XFTPEnv IO FileStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileStore
store
      Either XFTPErrorType FileResponse
r <- ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse
-> ReaderT XFTPEnv IO (Either XFTPErrorType FileResponse)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse
 -> ReaderT XFTPEnv IO (Either XFTPErrorType FileResponse))
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse
-> ReaderT XFTPEnv IO (Either XFTPErrorType FileResponse)
forall a b. (a -> b) -> a -> b
$ do
        NonEmpty FileRecipient
rcps <- (APublicAuthKey
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileRecipient)
-> NonEmpty APublicAuthKey
-> ExceptT
     XFTPErrorType (ReaderT XFTPEnv IO) (NonEmpty FileRecipient)
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) -> NonEmpty a -> m (NonEmpty b)
mapM (ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileRecipient
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient)
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileRecipient)
-> (APublicAuthKey
    -> ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient))
-> APublicAuthKey
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileRecipient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStore
-> Int
-> XFTPFileId
-> APublicAuthKey
-> ReaderT XFTPEnv IO (Either XFTPErrorType FileRecipient)
addRecipientRetry FileStore
st Int
3 XFTPFileId
sId) NonEmpty APublicAuthKey
rks
        M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT XFTPErrorType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ (StoreLog 'WriteMode -> IO ()) -> M ()
forall a. (StoreLog 'WriteMode -> IO a) -> M ()
withFileLog ((StoreLog 'WriteMode -> IO ()) -> M ())
-> (StoreLog 'WriteMode -> IO ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \StoreLog 'WriteMode
sl -> StoreLog 'WriteMode
-> XFTPFileId -> NonEmpty FileRecipient -> IO ()
logAddRecipients StoreLog 'WriteMode
sl XFTPFileId
sId NonEmpty FileRecipient
rcps
        FileServerStats
stats <- (XFTPEnv -> FileServerStats)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileServerStats
serverStats
        IO () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a. IO a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> IO () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (FileServerStats -> IORef Int
fileRecipients FileServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ NonEmpty APublicAuthKey -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty APublicAuthKey
rks)
        let rIds :: NonEmpty XFTPFileId
rIds = (FileRecipient -> XFTPFileId)
-> NonEmpty FileRecipient -> NonEmpty XFTPFileId
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(FileRecipient XFTPFileId
rId APublicAuthKey
_) -> XFTPFileId
rId) NonEmpty FileRecipient
rcps
        FileResponse
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse
forall a. a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse)
-> FileResponse
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileResponse
forall a b. (a -> b) -> a -> b
$ NonEmpty XFTPFileId -> FileResponse
FRRcvIds NonEmpty XFTPFileId
rIds
      FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT XFTPEnv IO FileResponse)
-> FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a b. (a -> b) -> a -> b
$ (XFTPErrorType -> FileResponse)
-> (FileResponse -> FileResponse)
-> Either XFTPErrorType FileResponse
-> FileResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XFTPErrorType -> FileResponse
FRErr FileResponse -> FileResponse
forall a. a -> a
id Either XFTPErrorType FileResponse
r
    receiveServerFile :: FileRec -> M FileResponse
    receiveServerFile :: FileRec -> ReaderT XFTPEnv IO FileResponse
receiveServerFile FileRec {XFTPFileId
senderId :: XFTPFileId
senderId :: FileRec -> XFTPFileId
senderId, fileInfo :: FileRec -> FileInfo
fileInfo = FileInfo {Word32
size :: FileInfo -> Word32
size :: Word32
size, ByteString
digest :: ByteString
digest :: FileInfo -> ByteString
digest}, TVar (Maybe String)
filePath :: TVar (Maybe String)
filePath :: FileRec -> TVar (Maybe String)
filePath} = case Maybe (Int -> IO ByteString)
bodyPart of
      Maybe (Int -> IO ByteString)
Nothing -> FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT XFTPEnv IO FileResponse)
-> FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
SIZE
      -- TODO validate body size from request before downloading, once it's populated
      Just Int -> IO ByteString
getBody -> ReaderT XFTPEnv IO FileResponse -> ReaderT XFTPEnv IO FileResponse
skipCommitted (ReaderT XFTPEnv IO FileResponse
 -> ReaderT XFTPEnv IO FileResponse)
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO FileResponse
forall a b. (a -> b) -> a -> b
$ ReaderT XFTPEnv IO Bool
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO FileResponse
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ReaderT XFTPEnv IO Bool
reserve ReaderT XFTPEnv IO FileResponse
receive (FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT XFTPEnv IO FileResponse)
-> FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
QUOTA)
        where
          -- having a filePath means the file is already uploaded and committed, must not change anything
          skipCommitted :: ReaderT XFTPEnv IO FileResponse -> ReaderT XFTPEnv IO FileResponse
skipCommitted = ReaderT XFTPEnv IO Bool
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO FileResponse
-> ReaderT XFTPEnv IO FileResponse
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool)
-> ReaderT XFTPEnv IO (Maybe String) -> ReaderT XFTPEnv IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe String) -> ReaderT XFTPEnv IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe String)
filePath) (IO FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileResponse -> ReaderT XFTPEnv IO FileResponse)
-> IO FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a b. (a -> b) -> a -> b
$ Int -> IO FileResponse
drain (Int -> IO FileResponse) -> Int -> IO FileResponse
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size)
            where
              -- can't send FROk without reading the request body or a client will block on sending it
              -- can't send any old error as the client would fail or restart indefinitely
              drain :: Int -> IO FileResponse
drain Int
s = do
                Int
bs <- ByteString -> Int
B.length (ByteString -> Int) -> IO ByteString -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
getBody Int
fileBlockSize
                if
                  | Int
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
s -> FileResponse -> IO FileResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileResponse
FROk
                  | Int
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
s -> FileResponse -> IO FileResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> IO FileResponse)
-> FileResponse -> IO FileResponse
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
SIZE
                  | Bool
otherwise -> Int -> IO FileResponse
drain (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bs)
          reserve :: ReaderT XFTPEnv IO Bool
reserve = do
            TVar Int64
us <- (XFTPEnv -> TVar Int64) -> ReaderT XFTPEnv IO (TVar Int64)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XFTPEnv -> TVar Int64) -> ReaderT XFTPEnv IO (TVar Int64))
-> (XFTPEnv -> TVar Int64) -> ReaderT XFTPEnv IO (TVar Int64)
forall a b. (a -> b) -> a -> b
$ FileStore -> TVar Int64
usedStorage (FileStore -> TVar Int64)
-> (XFTPEnv -> FileStore) -> XFTPEnv -> TVar Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv -> FileStore
store
            Int64
quota <- (XFTPEnv -> Int64) -> ReaderT XFTPEnv IO Int64
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XFTPEnv -> Int64) -> ReaderT XFTPEnv IO Int64)
-> (XFTPEnv -> Int64) -> ReaderT XFTPEnv IO Int64
forall a b. (a -> b) -> a -> b
$ Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe Int64
forall a. Bounded a => a
maxBound (Maybe Int64 -> Int64)
-> (XFTPEnv -> Maybe Int64) -> XFTPEnv -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPServerConfig -> Maybe Int64
fileSizeQuota (XFTPServerConfig -> Maybe Int64)
-> (XFTPEnv -> XFTPServerConfig) -> XFTPEnv -> Maybe Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv -> XFTPServerConfig
config
            STM Bool -> ReaderT XFTPEnv IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ReaderT XFTPEnv IO Bool)
-> ((Int64 -> (Bool, Int64)) -> STM Bool)
-> (Int64 -> (Bool, Int64))
-> ReaderT XFTPEnv IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Int64 -> (Int64 -> (Bool, Int64)) -> STM Bool
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar Int64
us ((Int64 -> (Bool, Int64)) -> ReaderT XFTPEnv IO Bool)
-> (Int64 -> (Bool, Int64)) -> ReaderT XFTPEnv IO Bool
forall a b. (a -> b) -> a -> b
$
              \Int64
used -> let used' :: Int64
used' = Int64
used Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size in if Int64
used' Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
quota then (Bool
True, Int64
used') else (Bool
False, Int64
used)
          receive :: ReaderT XFTPEnv IO FileResponse
receive = do
            String
path <- (XFTPEnv -> String) -> ReaderT XFTPEnv IO String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XFTPEnv -> String) -> ReaderT XFTPEnv IO String)
-> (XFTPEnv -> String) -> ReaderT XFTPEnv IO String
forall a b. (a -> b) -> a -> b
$ XFTPServerConfig -> String
filesPath (XFTPServerConfig -> String)
-> (XFTPEnv -> XFTPServerConfig) -> XFTPEnv -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv -> XFTPServerConfig
config
            let fPath :: String
fPath = String
path String -> String -> String
</> ByteString -> String
B.unpack (ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ XFTPFileId -> ByteString
unEntityId XFTPFileId
senderId)
            XFTPRcvChunkSpec -> ReaderT XFTPEnv IO (Either XFTPErrorType ())
receiveChunk (String -> Word32 -> ByteString -> XFTPRcvChunkSpec
XFTPRcvChunkSpec String
fPath Word32
size ByteString
digest) ReaderT XFTPEnv IO (Either XFTPErrorType ())
-> (Either XFTPErrorType () -> ReaderT XFTPEnv IO FileResponse)
-> ReaderT XFTPEnv IO FileResponse
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Right () -> do
                FileServerStats
stats <- (XFTPEnv -> FileServerStats) -> ReaderT XFTPEnv IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileServerStats
serverStats
                (StoreLog 'WriteMode -> IO ()) -> M ()
forall a. (StoreLog 'WriteMode -> IO a) -> M ()
withFileLog ((StoreLog 'WriteMode -> IO ()) -> M ())
-> (StoreLog 'WriteMode -> IO ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \StoreLog 'WriteMode
sl -> StoreLog 'WriteMode -> XFTPFileId -> String -> IO ()
logPutFile StoreLog 'WriteMode
sl XFTPFileId
senderId String
fPath
                STM () -> M ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M ()) -> STM () -> M ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe String) -> Maybe String -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe String)
filePath (String -> Maybe String
forall a. a -> Maybe a
Just String
fPath)
                (FileServerStats -> IORef Int) -> M ()
incFileStat FileServerStats -> IORef Int
filesUploaded
                (FileServerStats -> IORef Int) -> M ()
incFileStat FileServerStats -> IORef Int
filesCount
                IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ IORef Int64 -> (Int64 -> Int64) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (FileServerStats -> IORef Int64
filesSize FileServerStats
stats) (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size)
                FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileResponse
FROk
              Left XFTPErrorType
e -> do
                TVar Int64
us <- (XFTPEnv -> TVar Int64) -> ReaderT XFTPEnv IO (TVar Int64)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XFTPEnv -> TVar Int64) -> ReaderT XFTPEnv IO (TVar Int64))
-> (XFTPEnv -> TVar Int64) -> ReaderT XFTPEnv IO (TVar Int64)
forall a b. (a -> b) -> a -> b
$ FileStore -> TVar Int64
usedStorage (FileStore -> TVar Int64)
-> (XFTPEnv -> FileStore) -> XFTPEnv -> TVar Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv -> FileStore
store
                STM () -> M ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M ()) -> STM () -> M ()
forall a b. (a -> b) -> a -> b
$ TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int64
us ((Int64 -> Int64) -> STM ()) -> (Int64 -> Int64) -> STM ()
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
subtract (Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size)
                IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
fPath) (String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
fPath) IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> IO ()
logFileError
                FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT XFTPEnv IO FileResponse)
-> FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
e
          receiveChunk :: XFTPRcvChunkSpec -> ReaderT XFTPEnv IO (Either XFTPErrorType ())
receiveChunk XFTPRcvChunkSpec
spec = do
            Int
t <- (XFTPEnv -> Int) -> ReaderT XFTPEnv IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XFTPEnv -> Int) -> ReaderT XFTPEnv IO Int)
-> (XFTPEnv -> Int) -> ReaderT XFTPEnv IO Int
forall a b. (a -> b) -> a -> b
$ XFTPServerConfig -> Int
fileTimeout (XFTPServerConfig -> Int)
-> (XFTPEnv -> XFTPServerConfig) -> XFTPEnv -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv -> XFTPServerConfig
config
            IO (Either XFTPErrorType ())
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either XFTPErrorType ())
 -> ReaderT XFTPEnv IO (Either XFTPErrorType ()))
-> IO (Either XFTPErrorType ())
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ Either XFTPErrorType ()
-> Maybe (Either XFTPErrorType ()) -> Either XFTPErrorType ()
forall a. a -> Maybe a -> a
fromMaybe (XFTPErrorType -> Either XFTPErrorType ()
forall a b. a -> Either a b
Left XFTPErrorType
TIMEOUT) (Maybe (Either XFTPErrorType ()) -> Either XFTPErrorType ())
-> IO (Maybe (Either XFTPErrorType ()))
-> IO (Either XFTPErrorType ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> IO (Either XFTPErrorType ())
-> IO (Maybe (Either XFTPErrorType ()))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
t (ExceptT XFTPErrorType IO () -> IO (Either XFTPErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType IO () -> IO (Either XFTPErrorType ()))
-> ExceptT XFTPErrorType IO () -> IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ (Int -> IO ByteString)
-> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
receiveFile Int -> IO ByteString
getBody XFTPRcvChunkSpec
spec)
    sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
    sendServerFile :: FileRec
-> PublicKey 'X25519
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
sendServerFile FileRec {XFTPFileId
senderId :: FileRec -> XFTPFileId
senderId :: XFTPFileId
senderId, TVar (Maybe String)
filePath :: FileRec -> TVar (Maybe String)
filePath :: TVar (Maybe String)
filePath, fileInfo :: FileRec -> FileInfo
fileInfo = FileInfo {Word32
size :: FileInfo -> Word32
size :: Word32
size}} PublicKey 'X25519
rDhKey = do
      TVar (Maybe String) -> ReaderT XFTPEnv IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe String)
filePath ReaderT XFTPEnv IO (Maybe String)
-> (Maybe String
    -> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile))
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just String
path -> ReaderT XFTPEnv IO Bool
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> ReaderT XFTPEnv IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
path) ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
sendFile ((FileResponse, Maybe ServerFile)
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XFTPErrorType -> FileResponse
FRErr XFTPErrorType
AUTH, Maybe ServerFile
forall a. Maybe a
Nothing))
          where
            sendFile :: ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
sendFile = do
              TVar ChaChaDRG
g <- (XFTPEnv -> TVar ChaChaDRG) -> ReaderT XFTPEnv IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> TVar ChaChaDRG
random
              (PublicKey 'X25519
sDhKey, PrivateKeyX25519
spDhKey) <- STM (PublicKey 'X25519, PrivateKeyX25519)
-> ReaderT XFTPEnv IO (PublicKey 'X25519, PrivateKeyX25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey 'X25519, PrivateKeyX25519)
 -> ReaderT XFTPEnv IO (PublicKey 'X25519, PrivateKeyX25519))
-> STM (PublicKey 'X25519, PrivateKeyX25519)
-> ReaderT XFTPEnv IO (PublicKey 'X25519, PrivateKeyX25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g
              let dhSecret :: DhSecretX25519
dhSecret = PublicKey 'X25519 -> PrivateKeyX25519 -> DhSecretX25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKey 'X25519
rDhKey PrivateKeyX25519
spDhKey
              CbNonce
cbNonce <- STM CbNonce -> ReaderT XFTPEnv IO CbNonce
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CbNonce -> ReaderT XFTPEnv IO CbNonce)
-> STM CbNonce -> ReaderT XFTPEnv IO CbNonce
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM CbNonce
C.randomCbNonce TVar ChaChaDRG
g
              case DhSecretX25519 -> CbNonce -> Either CryptoError SbState
LC.cbInit DhSecretX25519
dhSecret CbNonce
cbNonce of
                Right SbState
sbState -> do
                  FileServerStats
stats <- (XFTPEnv -> FileServerStats) -> ReaderT XFTPEnv IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileServerStats
serverStats
                  (FileServerStats -> IORef Int) -> M ()
incFileStat FileServerStats -> IORef Int
fileDownloads
                  IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ PeriodStats -> XFTPFileId -> IO ()
updatePeriodStats (FileServerStats -> PeriodStats
filesDownloaded FileServerStats
stats) XFTPFileId
senderId
                  (FileResponse, Maybe ServerFile)
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PublicKey 'X25519 -> CbNonce -> FileResponse
FRFile PublicKey 'X25519
sDhKey CbNonce
cbNonce, ServerFile -> Maybe ServerFile
forall a. a -> Maybe a
Just ServerFile {filePath :: String
filePath = String
path, fileSize :: Word32
fileSize = Word32
size, SbState
sbState :: SbState
sbState :: SbState
sbState})
                Either CryptoError SbState
_ -> (FileResponse, Maybe ServerFile)
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XFTPErrorType -> FileResponse
FRErr XFTPErrorType
INTERNAL, Maybe ServerFile
forall a. Maybe a
Nothing)
        Maybe String
_ -> (FileResponse, Maybe ServerFile)
-> ReaderT XFTPEnv IO (FileResponse, Maybe ServerFile)
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XFTPErrorType -> FileResponse
FRErr XFTPErrorType
NO_FILE, Maybe ServerFile
forall a. Maybe a
Nothing)

    deleteServerFile :: FileRec -> M FileResponse
    deleteServerFile :: FileRec -> ReaderT XFTPEnv IO FileResponse
deleteServerFile FileRec
fr = (XFTPErrorType -> FileResponse)
-> (() -> FileResponse) -> Either XFTPErrorType () -> FileResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XFTPErrorType -> FileResponse
FRErr (\() -> FileResponse
FROk) (Either XFTPErrorType () -> FileResponse)
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
-> ReaderT XFTPEnv IO FileResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FileRec -> ReaderT XFTPEnv IO (Either XFTPErrorType ())
deleteServerFile_ FileRec
fr

    logFileError :: SomeException -> IO ()
    logFileError :: SomeException -> IO ()
logFileError SomeException
e = Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error deleting file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e

    ackFileReception :: RecipientId -> FileRec -> M FileResponse
    ackFileReception :: XFTPFileId -> FileRec -> ReaderT XFTPEnv IO FileResponse
ackFileReception XFTPFileId
rId FileRec
fr = do
      (StoreLog 'WriteMode -> IO ()) -> M ()
forall a. (StoreLog 'WriteMode -> IO a) -> M ()
withFileLog (StoreLog 'WriteMode -> XFTPFileId -> IO ()
`logAckFile` XFTPFileId
rId)
      FileStore
st <- (XFTPEnv -> FileStore) -> ReaderT XFTPEnv IO FileStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileStore
store
      STM () -> M ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M ()) -> STM () -> M ()
forall a b. (a -> b) -> a -> b
$ FileStore -> XFTPFileId -> FileRec -> STM ()
deleteRecipient FileStore
st XFTPFileId
rId FileRec
fr
      (FileServerStats -> IORef Int) -> M ()
incFileStat FileServerStats -> IORef Int
fileDownloadAcks
      FileResponse -> ReaderT XFTPEnv IO FileResponse
forall a. a -> ReaderT XFTPEnv IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileResponse
FROk

deleteServerFile_ :: FileRec -> M (Either XFTPErrorType ())
deleteServerFile_ :: FileRec -> ReaderT XFTPEnv IO (Either XFTPErrorType ())
deleteServerFile_ fr :: FileRec
fr@FileRec {XFTPFileId
senderId :: FileRec -> XFTPFileId
senderId :: XFTPFileId
senderId} = do
  (StoreLog 'WriteMode -> IO ()) -> M ()
forall a. (StoreLog 'WriteMode -> IO a) -> M ()
withFileLog (StoreLog 'WriteMode -> XFTPFileId -> IO ()
`logDeleteFile` XFTPFileId
senderId)
  FileRec
-> (FileServerStats -> IORef Int)
-> (FileStore -> STM (Either XFTPErrorType ()))
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
deleteOrBlockServerFile_ FileRec
fr FileServerStats -> IORef Int
filesDeleted (FileStore -> XFTPFileId -> STM (Either XFTPErrorType ())
`deleteFile` XFTPFileId
senderId)

-- this also deletes the file from storage, but doesn't include it in delete statistics
blockServerFile :: FileRec -> BlockingInfo -> M (Either XFTPErrorType ())
blockServerFile :: FileRec
-> BlockingInfo -> ReaderT XFTPEnv IO (Either XFTPErrorType ())
blockServerFile fr :: FileRec
fr@FileRec {XFTPFileId
senderId :: FileRec -> XFTPFileId
senderId :: XFTPFileId
senderId} BlockingInfo
info = do
  (StoreLog 'WriteMode -> IO ()) -> M ()
forall a. (StoreLog 'WriteMode -> IO a) -> M ()
withFileLog ((StoreLog 'WriteMode -> IO ()) -> M ())
-> (StoreLog 'WriteMode -> IO ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \StoreLog 'WriteMode
sl -> StoreLog 'WriteMode -> XFTPFileId -> BlockingInfo -> IO ()
logBlockFile StoreLog 'WriteMode
sl XFTPFileId
senderId BlockingInfo
info
  FileRec
-> (FileServerStats -> IORef Int)
-> (FileStore -> STM (Either XFTPErrorType ()))
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
deleteOrBlockServerFile_ FileRec
fr FileServerStats -> IORef Int
filesBlocked ((FileStore -> STM (Either XFTPErrorType ()))
 -> ReaderT XFTPEnv IO (Either XFTPErrorType ()))
-> (FileStore -> STM (Either XFTPErrorType ()))
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ \FileStore
st -> FileStore
-> XFTPFileId
-> BlockingInfo
-> Bool
-> STM (Either XFTPErrorType ())
blockFile FileStore
st XFTPFileId
senderId BlockingInfo
info Bool
True

deleteOrBlockServerFile_ :: FileRec -> (FileServerStats -> IORef Int) -> (FileStore -> STM (Either XFTPErrorType ())) -> M (Either XFTPErrorType ())
deleteOrBlockServerFile_ :: FileRec
-> (FileServerStats -> IORef Int)
-> (FileStore -> STM (Either XFTPErrorType ()))
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
deleteOrBlockServerFile_ FileRec {TVar (Maybe String)
filePath :: FileRec -> TVar (Maybe String)
filePath :: TVar (Maybe String)
filePath, FileInfo
fileInfo :: FileRec -> FileInfo
fileInfo :: FileInfo
fileInfo} FileServerStats -> IORef Int
stat FileStore -> STM (Either XFTPErrorType ())
storeAction = ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
 -> ReaderT XFTPEnv IO (Either XFTPErrorType ()))
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ do
  Maybe String
path <- TVar (Maybe String)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) (Maybe String)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe String)
filePath
  FileServerStats
stats <- (XFTPEnv -> FileServerStats)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileServerStats
serverStats
  ReaderT XFTPEnv IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT XFTPEnv IO (Either XFTPErrorType ())
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ (SomeException -> XFTPErrorType)
-> Either SomeException () -> Either XFTPErrorType ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\(SomeException
_ :: SomeException) -> XFTPErrorType
FILE_IO) (Either SomeException () -> Either XFTPErrorType ())
-> ReaderT XFTPEnv IO (Either SomeException ())
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> M () -> ReaderT XFTPEnv IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Maybe String -> (String -> M ()) -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
path ((String -> M ()) -> M ()) -> (String -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \String
p -> ReaderT XFTPEnv IO Bool -> M () -> M ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> ReaderT XFTPEnv IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
p) (String -> M ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
p M () -> M () -> M ()
forall a b.
ReaderT XFTPEnv IO a
-> ReaderT XFTPEnv IO b -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FileServerStats -> M ()
deletedStats FileServerStats
stats))
  FileStore
st <- (XFTPEnv -> FileStore)
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) FileStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileStore
store
  ExceptT
  XFTPErrorType (ReaderT XFTPEnv IO) (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   XFTPErrorType (ReaderT XFTPEnv IO) (Either XFTPErrorType ())
 -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> ExceptT
     XFTPErrorType (ReaderT XFTPEnv IO) (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ STM (Either XFTPErrorType ())
-> ExceptT
     XFTPErrorType (ReaderT XFTPEnv IO) (Either XFTPErrorType ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either XFTPErrorType ())
 -> ExceptT
      XFTPErrorType (ReaderT XFTPEnv IO) (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
-> ExceptT
     XFTPErrorType (ReaderT XFTPEnv IO) (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ FileStore -> STM (Either XFTPErrorType ())
storeAction FileStore
st
  M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT XFTPErrorType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ())
-> M () -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) ()
forall a b. (a -> b) -> a -> b
$ (FileServerStats -> IORef Int) -> M ()
incFileStat FileServerStats -> IORef Int
stat
  where
    deletedStats :: FileServerStats -> M ()
deletedStats FileServerStats
stats = do
      IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (FileServerStats -> IORef Int
filesCount FileServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)
      IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ IORef Int64 -> (Int64 -> Int64) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (FileServerStats -> IORef Int64
filesSize FileServerStats
stats) (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
subtract (Int64 -> Int64 -> Int64) -> Int64 -> Int64 -> Int64
forall a b. (a -> b) -> a -> b
$ Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int64) -> Word32 -> Int64
forall a b. (a -> b) -> a -> b
$ FileInfo -> Word32
size FileInfo
fileInfo)

getFileTime :: IO RoundedFileTime
getFileTime :: IO RoundedFileTime
getFileTime = IO RoundedFileTime
forall (t :: Nat). KnownNat t => IO (RoundedSystemTime t)
getRoundedSystemTime

expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
expireServerFiles Maybe Int
itemDelay ExpirationConfig
expCfg = do
  FileStore
st <- (XFTPEnv -> FileStore) -> ReaderT XFTPEnv IO FileStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileStore
store
  Int64
usedStart <- TVar Int64 -> ReaderT XFTPEnv IO Int64
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar Int64 -> ReaderT XFTPEnv IO Int64)
-> TVar Int64 -> ReaderT XFTPEnv IO Int64
forall a b. (a -> b) -> a -> b
$ FileStore -> TVar Int64
usedStorage FileStore
st
  Int64
old <- IO Int64 -> ReaderT XFTPEnv IO Int64
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> ReaderT XFTPEnv IO Int64)
-> IO Int64 -> ReaderT XFTPEnv IO Int64
forall a b. (a -> b) -> a -> b
$ ExpirationConfig -> IO Int64
expireBeforeEpoch ExpirationConfig
expCfg
  Map XFTPFileId FileRec
files' <- TVar (Map XFTPFileId FileRec)
-> ReaderT XFTPEnv IO (Map XFTPFileId FileRec)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (FileStore -> TVar (Map XFTPFileId FileRec)
files FileStore
st)
  Text -> M ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> M ()) -> Text -> M ()
forall a b. (a -> b) -> a -> b
$ Text
"Expiration check: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Map XFTPFileId FileRec -> Int
forall k a. Map k a -> Int
M.size Map XFTPFileId FileRec
files') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" files"
  [XFTPFileId] -> (XFTPFileId -> M ()) -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map XFTPFileId FileRec -> [XFTPFileId]
forall k a. Map k a -> [k]
M.keys Map XFTPFileId FileRec
files') ((XFTPFileId -> M ()) -> M ()) -> (XFTPFileId -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \XFTPFileId
sId -> do
    (Int -> M ()) -> Maybe Int -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> M ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Maybe Int
itemDelay
    STM (Maybe (Maybe String))
-> ReaderT XFTPEnv IO (Maybe (Maybe String))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (FileStore -> XFTPFileId -> Int64 -> STM (Maybe (Maybe String))
expiredFilePath FileStore
st XFTPFileId
sId Int64
old)
      ReaderT XFTPEnv IO (Maybe (Maybe String))
-> (Maybe (Maybe String) -> M ()) -> M ()
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe String -> M ()) -> Maybe (Maybe String) -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (M () -> Maybe String -> M ()
forall {m :: * -> *}.
MonadUnliftIO m =>
m () -> Maybe String -> m ()
maybeRemove (M () -> Maybe String -> M ()) -> M () -> Maybe String -> M ()
forall a b. (a -> b) -> a -> b
$ FileStore -> XFTPFileId -> M ()
delete FileStore
st XFTPFileId
sId)
  Int64
usedEnd <- TVar Int64 -> ReaderT XFTPEnv IO Int64
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar Int64 -> ReaderT XFTPEnv IO Int64)
-> TVar Int64 -> ReaderT XFTPEnv IO Int64
forall a b. (a -> b) -> a -> b
$ FileStore -> TVar Int64
usedStorage FileStore
st
  Text -> M ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> M ()) -> Text -> M ()
forall a b. (a -> b) -> a -> b
$ Text
"Used " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall {a}. (Show a, Integral a) => a -> Text
mbs Int64
usedStart 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, Integral a) => a -> Text
mbs Int64
usedEnd 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, Integral a) => a -> Text
mbs (Int64
usedStart Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
usedEnd) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" reclaimed."
  where
    mbs :: a -> Text
mbs a
bs = a -> Text
forall a. Show a => a -> Text
tshow (a
bs a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
1048576) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"mb"
    maybeRemove :: m () -> Maybe String -> m ()
maybeRemove m ()
del = m () -> (String -> m ()) -> Maybe String -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ()
del (m () -> String -> m ()
forall {m :: * -> *}. MonadUnliftIO m => m () -> String -> m ()
remove m ()
del)
    remove :: m () -> String -> m ()
remove m ()
del String
filePath =
      m Bool -> m () -> m () -> m ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
        (String -> m Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
filePath)
        ((String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
filePath m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
del) m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
e :: SomeException) -> Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"failed to remove expired file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
tshow String
filePath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e)
        m ()
del
    delete :: FileStore -> XFTPFileId -> M ()
delete FileStore
st XFTPFileId
sId = do
      (StoreLog 'WriteMode -> IO ()) -> M ()
forall a. (StoreLog 'WriteMode -> IO a) -> M ()
withFileLog (StoreLog 'WriteMode -> XFTPFileId -> IO ()
`logDeleteFile` XFTPFileId
sId)
      ReaderT XFTPEnv IO (Either XFTPErrorType ()) -> M ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT XFTPEnv IO (Either XFTPErrorType ()) -> M ())
-> (STM (Either XFTPErrorType ())
    -> ReaderT XFTPEnv IO (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
-> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Either XFTPErrorType ())
-> ReaderT XFTPEnv IO (Either XFTPErrorType ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either XFTPErrorType ()) -> M ())
-> STM (Either XFTPErrorType ()) -> M ()
forall a b. (a -> b) -> a -> b
$ FileStore -> XFTPFileId -> STM (Either XFTPErrorType ())
deleteFile FileStore
st XFTPFileId
sId -- will not update usedStorage if sId isn't in store
      (FileServerStats -> IORef Int) -> M ()
incFileStat FileServerStats -> IORef Int
filesExpired

randomId :: Int -> M ByteString
randomId :: Int -> M ByteString
randomId Int
n = STM ByteString -> M ByteString
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ByteString -> M ByteString)
-> (TVar ChaChaDRG -> STM ByteString)
-> TVar ChaChaDRG
-> M ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TVar ChaChaDRG -> STM ByteString
C.randomBytes Int
n (TVar ChaChaDRG -> M ByteString)
-> ReaderT XFTPEnv IO (TVar ChaChaDRG) -> M ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XFTPEnv -> TVar ChaChaDRG) -> ReaderT XFTPEnv IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> TVar ChaChaDRG
random

getFileId :: M XFTPFileId
getFileId :: M XFTPFileId
getFileId = (ByteString -> XFTPFileId) -> M ByteString -> M XFTPFileId
forall a b.
(a -> b) -> ReaderT XFTPEnv IO a -> ReaderT XFTPEnv IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> XFTPFileId
EntityId (M ByteString -> M XFTPFileId)
-> (Int -> M ByteString) -> Int -> M XFTPFileId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> M ByteString
randomId (Int -> M XFTPFileId) -> ReaderT XFTPEnv IO Int -> M XFTPFileId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XFTPEnv -> Int) -> ReaderT XFTPEnv IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XFTPServerConfig -> Int
fileIdSize (XFTPServerConfig -> Int)
-> (XFTPEnv -> XFTPServerConfig) -> XFTPEnv -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv -> XFTPServerConfig
config)

withFileLog :: (StoreLog 'WriteMode -> IO a) -> M ()
withFileLog :: forall a. (StoreLog 'WriteMode -> IO a) -> M ()
withFileLog StoreLog 'WriteMode -> IO a
action = IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ())
-> (Maybe (StoreLog 'WriteMode) -> IO ())
-> Maybe (StoreLog 'WriteMode)
-> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StoreLog 'WriteMode -> IO a)
-> Maybe (StoreLog 'WriteMode) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StoreLog 'WriteMode -> IO a
action (Maybe (StoreLog 'WriteMode) -> M ())
-> ReaderT XFTPEnv IO (Maybe (StoreLog 'WriteMode)) -> M ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XFTPEnv -> Maybe (StoreLog 'WriteMode))
-> ReaderT XFTPEnv IO (Maybe (StoreLog 'WriteMode))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> Maybe (StoreLog 'WriteMode)
storeLog

incFileStat :: (FileServerStats -> IORef Int) -> M ()
incFileStat :: (FileServerStats -> IORef Int) -> M ()
incFileStat FileServerStats -> IORef Int
statSel = do
  FileServerStats
stats <- (XFTPEnv -> FileServerStats) -> ReaderT XFTPEnv IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileServerStats
serverStats
  IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (FileServerStats -> IORef Int
statSel FileServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

saveServerStats :: M ()
saveServerStats :: M ()
saveServerStats =
  (XFTPEnv -> Maybe String) -> ReaderT XFTPEnv IO (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XFTPServerConfig -> Maybe String
serverStatsBackupFile (XFTPServerConfig -> Maybe String)
-> (XFTPEnv -> XFTPServerConfig) -> XFTPEnv -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv -> XFTPServerConfig
config)
    ReaderT XFTPEnv IO (Maybe String) -> (Maybe String -> M ()) -> M ()
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> M ()) -> Maybe String -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
f -> (XFTPEnv -> FileServerStats) -> ReaderT XFTPEnv IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileServerStats
serverStats ReaderT XFTPEnv IO FileServerStats
-> (FileServerStats -> ReaderT XFTPEnv IO FileServerStatsData)
-> ReaderT XFTPEnv IO FileServerStatsData
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO FileServerStatsData -> ReaderT XFTPEnv IO FileServerStatsData
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileServerStatsData -> ReaderT XFTPEnv IO FileServerStatsData)
-> (FileServerStats -> IO FileServerStatsData)
-> FileServerStats
-> ReaderT XFTPEnv IO FileServerStatsData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileServerStats -> IO FileServerStatsData
getFileServerStatsData ReaderT XFTPEnv IO FileServerStatsData
-> (FileServerStatsData -> M ()) -> M ()
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> M ()
forall a. IO a -> ReaderT XFTPEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ())
-> (FileServerStatsData -> IO ()) -> FileServerStatsData -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FileServerStatsData -> IO ()
forall {a}. StrEncoding a => String -> a -> IO ()
saveStats String
f)
  where
    saveStats :: String -> a -> IO ()
saveStats String
f a
stats = do
      Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"saving server stats to file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f
      String -> ByteString -> IO ()
B.writeFile String
f (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode a
stats
      Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"server stats saved"

restoreServerStats :: M ()
restoreServerStats :: M ()
restoreServerStats = (XFTPEnv -> Maybe String) -> ReaderT XFTPEnv IO (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XFTPServerConfig -> Maybe String
serverStatsBackupFile (XFTPServerConfig -> Maybe String)
-> (XFTPEnv -> XFTPServerConfig) -> XFTPEnv -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv -> XFTPServerConfig
config) ReaderT XFTPEnv IO (Maybe String) -> (Maybe String -> M ()) -> M ()
forall a b.
ReaderT XFTPEnv IO a
-> (a -> ReaderT XFTPEnv IO b) -> ReaderT XFTPEnv IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> M ()) -> Maybe String -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> M ()
forall {m :: * -> *}.
(MonadIO m, MonadReader XFTPEnv m) =>
String -> m ()
restoreStats
  where
    restoreStats :: String -> m ()
restoreStats String
f = m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> m Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
f) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"restoring server stats from file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f
      IO (Either String FileServerStatsData)
-> m (Either String FileServerStatsData)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ByteString -> Either String FileServerStatsData
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either String FileServerStatsData)
-> IO ByteString -> IO (Either String FileServerStatsData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
f) m (Either String FileServerStatsData)
-> (Either String FileServerStatsData -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right d :: FileServerStatsData
d@FileServerStatsData {_filesCount :: FileServerStatsData -> Int
_filesCount = Int
statsFilesCount, _filesSize :: FileServerStatsData -> Int64
_filesSize = Int64
statsFilesSize} -> do
          FileServerStats
s <- (XFTPEnv -> FileServerStats) -> m FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileServerStats
serverStats
          FileStore {TVar (Map XFTPFileId FileRec)
files :: FileStore -> TVar (Map XFTPFileId FileRec)
files :: TVar (Map XFTPFileId FileRec)
files, TVar Int64
usedStorage :: FileStore -> TVar Int64
usedStorage :: TVar Int64
usedStorage} <- (XFTPEnv -> FileStore) -> m FileStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv -> FileStore
store
          Int
_filesCount <- Map XFTPFileId FileRec -> Int
forall k a. Map k a -> Int
M.size (Map XFTPFileId FileRec -> Int)
-> m (Map XFTPFileId FileRec) -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map XFTPFileId FileRec) -> m (Map XFTPFileId FileRec)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map XFTPFileId FileRec)
files
          Int64
_filesSize <- TVar Int64 -> m Int64
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Int64
usedStorage
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FileServerStats -> FileServerStatsData -> IO ()
setFileServerStats FileServerStats
s FileServerStatsData
d {_filesCount, _filesSize}
          String -> String -> m ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
renameFile String
f (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".bak"
          Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"server stats restored"
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
statsFilesCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
_filesCount) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Files count differs: stats: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
statsFilesCount Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", store: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
_filesCount
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
statsFilesSize Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
_filesSize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Files size differs: stats: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow Int64
statsFilesSize Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", store: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow Int64
_filesSize
          Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Restored " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow (Int64
_filesSize Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1048576) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" MBs in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
_filesCount Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" files"
        Left String
e -> do
          Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"error restoring server stats: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall a. IO a
exitFailure