{-# 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
  ( runXFTPServer,
    runXFTPServerBlocking,
  ) 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 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 Network.HPACK.Token (tokenKey)
import qualified Network.HTTP2.Server as H
import Network.Socket
import Simplex.FileTransfer.Protocol
import Simplex.FileTransfer.Server.Control (ControlProtocol (..))
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, defaultSupportedParamsHTTPS)
import Simplex.Messaging.Transport.Buffer (trimCR)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
import Simplex.Messaging.Transport.HTTP2.Server (runHTTP2Server)
import Simplex.Messaging.Transport.Server (SNICredentialUsed, TransportServerConfig (..), runLocalTCPServer)
import Simplex.Messaging.Server.Web (serveStaticPageH2)
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 (canonicalizePath, doesFileExist, removeFile, renameFile)
import qualified UnliftIO.Exception as E

type M s a = ReaderT (XFTPEnv s) 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 (),
    XFTPTransportRequest -> SNICredentialUsed
sniUsed :: SNICredentialUsed,
    XFTPTransportRequest -> SNICredentialUsed
addCORS :: Bool
  }

corsHeaders :: Bool -> [N.Header]
corsHeaders :: SNICredentialUsed -> [Header]
corsHeaders SNICredentialUsed
addCORS
  | SNICredentialUsed
addCORS = [(HeaderName
"Access-Control-Allow-Origin", ByteString
"*"), (HeaderName
"Access-Control-Expose-Headers", ByteString
"*")]
  | SNICredentialUsed
otherwise = []

corsPreflightHeaders :: [N.Header]
corsPreflightHeaders :: [Header]
corsPreflightHeaders =
  [ (HeaderName
"Access-Control-Allow-Origin", ByteString
"*"),
    (HeaderName
"Access-Control-Allow-Methods", ByteString
"POST, OPTIONS"),
    (HeaderName
"Access-Control-Allow-Headers", ByteString
"*"),
    (HeaderName
"Access-Control-Max-Age", ByteString
"86400")
  ]

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

runXFTPServerBlocking :: FileStoreClass s => TMVar Bool -> XFTPServerConfig s -> IO ()
runXFTPServerBlocking :: forall s.
FileStoreClass s =>
TMVar SNICredentialUsed -> XFTPServerConfig s -> IO ()
runXFTPServerBlocking TMVar SNICredentialUsed
started XFTPServerConfig s
cfg = XFTPServerConfig s -> IO (XFTPEnv s)
forall s. FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s)
newXFTPServerEnv XFTPServerConfig s
cfg IO (XFTPEnv s) -> (XFTPEnv s -> 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
>>= ReaderT (XFTPEnv s) IO () -> XFTPEnv s -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (XFTPServerConfig s
-> TMVar SNICredentialUsed -> ReaderT (XFTPEnv s) IO ()
forall s.
FileStoreClass s =>
XFTPServerConfig s -> TMVar SNICredentialUsed -> M s ()
xftpServer XFTPServerConfig s
cfg TMVar SNICredentialUsed
started)

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

xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s ()
xftpServer :: forall s.
FileStoreClass s =>
XFTPServerConfig s -> TMVar SNICredentialUsed -> M s ()
xftpServer cfg :: XFTPServerConfig s
cfg@XFTPServerConfig {String
xftpPort :: String
$sel:xftpPort:XFTPServerConfig :: forall s. XFTPServerConfig s -> String
xftpPort, TransportServerConfig
transportConfig :: TransportServerConfig
$sel:transportConfig:XFTPServerConfig :: forall s. XFTPServerConfig s -> TransportServerConfig
transportConfig, Maybe ExpirationConfig
inactiveClientExpiration :: Maybe ExpirationConfig
$sel:inactiveClientExpiration:XFTPServerConfig :: forall s. XFTPServerConfig s -> Maybe ExpirationConfig
inactiveClientExpiration, Maybe ExpirationConfig
fileExpiration :: Maybe ExpirationConfig
$sel:fileExpiration:XFTPServerConfig :: forall s. XFTPServerConfig s -> Maybe ExpirationConfig
fileExpiration, VersionRangeXFTP
xftpServerVRange :: VersionRangeXFTP
$sel:xftpServerVRange:XFTPServerConfig :: forall s. XFTPServerConfig s -> VersionRangeXFTP
xftpServerVRange} TMVar SNICredentialUsed
started = do
  (ExpirationConfig -> M s ()) -> Maybe ExpirationConfig -> M s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe Int -> ExpirationConfig -> M s ()
forall s.
FileStoreClass s =>
Maybe Int -> ExpirationConfig -> M s ()
expireServerFiles Maybe Int
forall a. Maybe a
Nothing) Maybe ExpirationConfig
fileExpiration
  M s ()
forall s. FileStoreClass s => M s ()
restoreServerStats
  [M s ()] -> M s ()
forall (m :: * -> *) a. MonadUnliftIO m => [m a] -> m ()
raceAny_
    ( M s ()
runServer
        M s () -> [M s ()] -> [M s ()]
forall a. a -> [a] -> [a]
: XFTPServerConfig s -> [M s ()]
expireFilesThread_ XFTPServerConfig s
cfg
          [M s ()] -> [M s ()] -> [M s ()]
forall a. Semigroup a => a -> a -> a
<> XFTPServerConfig s -> [M s ()]
serverStatsThread_ XFTPServerConfig s
cfg
          [M s ()] -> [M s ()] -> [M s ()]
forall a. Semigroup a => a -> a -> a
<> XFTPServerConfig s -> [M s ()]
prometheusMetricsThread_ XFTPServerConfig s
cfg
          [M s ()] -> [M s ()] -> [M s ()]
forall a. Semigroup a => a -> a -> a
<> XFTPServerConfig s -> [M s ()]
controlPortThread_ XFTPServerConfig s
cfg
    )
    M s () -> M s () -> M s ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` M s ()
stopServer
  where
    runServer :: M s ()
    runServer :: M s ()
runServer = do
      srvCreds :: Credential
srvCreds@(CertificateChain
chain, PrivKey
pk) <- (XFTPEnv s -> Credential) -> ReaderT (XFTPEnv s) IO Credential
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> Credential
forall s. XFTPEnv s -> Credential
tlsServerCreds
      Maybe Credential
httpCreds_ <- (XFTPEnv s -> Maybe Credential)
-> ReaderT (XFTPEnv s) IO (Maybe Credential)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> Maybe Credential
forall s. XFTPEnv s -> Maybe Credential
httpServerCreds
      APrivateSignKey
signKey <- IO APrivateSignKey -> ReaderT (XFTPEnv s) IO APrivateSignKey
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO APrivateSignKey -> ReaderT (XFTPEnv s) IO APrivateSignKey)
-> IO APrivateSignKey -> ReaderT (XFTPEnv s) 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 s
env <- ReaderT (XFTPEnv s) IO (XFTPEnv s)
forall r (m :: * -> *). MonadReader r m => m r
ask
      TMap ByteString Handshake
sessions <- IO (TMap ByteString Handshake)
-> ReaderT (XFTPEnv s) IO (TMap ByteString Handshake)
forall a. IO a -> ReaderT (XFTPEnv s) 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
          srvParams :: Supported
srvParams = if Maybe Credential -> SNICredentialUsed
forall a. Maybe a -> SNICredentialUsed
isJust Maybe Credential
httpCreds_ then Supported
defaultSupportedParamsHTTPS else Supported
defaultSupportedParams
      Maybe String
webCanonicalRoot_ <- IO (Maybe String) -> ReaderT (XFTPEnv s) IO (Maybe String)
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> ReaderT (XFTPEnv s) IO (Maybe String))
-> IO (Maybe String) -> ReaderT (XFTPEnv s) IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ (String -> IO String) -> Maybe String -> IO (Maybe String)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM String -> IO String
forall (m :: * -> *). MonadIO m => String -> m String
canonicalizePath (XFTPServerConfig s -> Maybe String
forall s. XFTPServerConfig s -> Maybe String
webStaticPath XFTPServerConfig s
cfg)
      IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ())
-> ((SNICredentialUsed -> HTTP2ServerFunc) -> IO ())
-> (SNICredentialUsed -> HTTP2ServerFunc)
-> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar SNICredentialUsed
-> String
-> Int
-> Supported
-> Credential
-> Maybe Credential
-> TransportServerConfig
-> Maybe ExpirationConfig
-> (ByteString -> IO ())
-> (SNICredentialUsed -> HTTP2ServerFunc)
-> IO ()
runHTTP2Server TMVar SNICredentialUsed
started String
xftpPort Int
defaultHTTP2BufferSize Supported
srvParams Credential
srvCreds Maybe Credential
httpCreds_ TransportServerConfig
transportConfig Maybe ExpirationConfig
inactiveClientExpiration ByteString -> IO ()
cleanup ((SNICredentialUsed -> HTTP2ServerFunc) -> M s ())
-> (SNICredentialUsed -> HTTP2ServerFunc) -> M s ()
forall a b. (a -> b) -> a -> b
$ \SNICredentialUsed
sniUsed ByteString
sessionId Maybe ByteString
sessionALPN Request
r Response -> IO ()
sendResponse -> do
        let addCORS' :: SNICredentialUsed
addCORS' = SNICredentialUsed
sniUsed SNICredentialUsed -> SNICredentialUsed -> SNICredentialUsed
&& TransportServerConfig -> SNICredentialUsed
addCORSHeaders TransportServerConfig
transportConfig
        case Request -> Maybe ByteString
H.requestMethod Request
r of
          Just ByteString
"OPTIONS" | SNICredentialUsed
addCORS' -> Response -> IO ()
sendResponse (Response -> IO ()) -> Response -> IO ()
forall a b. (a -> b) -> a -> b
$ Status -> [Header] -> Response
H.responseNoBody Status
N.ok200 [Header]
corsPreflightHeaders
          Just ByteString
"GET" | SNICredentialUsed
sniUsed -> Maybe String -> (String -> IO SNICredentialUsed) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
webCanonicalRoot_ ((String -> IO SNICredentialUsed) -> IO ())
-> (String -> IO SNICredentialUsed) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
root -> String -> Request -> (Response -> IO ()) -> IO SNICredentialUsed
serveStaticPageH2 String
root Request
r Response -> IO ()
sendResponse
          Maybe ByteString
_ -> 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
$sel:sessionId:THandleParams :: ByteString
sessionId, $sel:blockSize:THandleParams :: Int
blockSize = Int
xftpBlockSize, $sel:thVersion:THandleParams :: VersionXFTP
thVersion = VersionXFTP
v, VersionRangeXFTP
thServerVRange :: VersionRangeXFTP
$sel:thServerVRange:THandleParams :: VersionRangeXFTP
thServerVRange, $sel:thAuth:THandleParams :: Maybe (THandleAuth 'TServer)
thAuth = Maybe (THandleAuth 'TServer)
forall a. Maybe a
Nothing, $sel:implySessId:THandleParams :: SNICredentialUsed
implySessId = SNICredentialUsed
False, $sel:encryptBlock:THandleParams :: Maybe TSbChainKeys
encryptBlock = Maybe TSbChainKeys
forall a. Maybe a
Nothing, $sel:batch:THandleParams :: SNICredentialUsed
batch = SNICredentialUsed
True, $sel:serviceAuth:THandleParams :: SNICredentialUsed
serviceAuth = SNICredentialUsed
False}
                req0 :: XFTPTransportRequest
req0 = XFTPTransportRequest {$sel:thParams:XFTPTransportRequest :: THandleParamsXFTP 'TServer
thParams = THandleParamsXFTP 'TServer
thParams0, $sel:request:XFTPTransportRequest :: Request
request = Request
r, HTTP2Body
$sel:reqBody:XFTPTransportRequest :: HTTP2Body
reqBody :: HTTP2Body
reqBody, Response -> IO ()
$sel:sendResponse:XFTPTransportRequest :: Response -> IO ()
sendResponse :: Response -> IO ()
sendResponse, SNICredentialUsed
$sel:sniUsed:XFTPTransportRequest :: SNICredentialUsed
sniUsed :: SNICredentialUsed
sniUsed, $sel:addCORS:XFTPTransportRequest :: SNICredentialUsed
addCORS = SNICredentialUsed
addCORS'}
            (M s () -> XFTPEnv s -> IO ()) -> XFTPEnv s -> M s () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip M s () -> XFTPEnv s -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT XFTPEnv s
env (M s () -> IO ()) -> M s () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe ByteString
sessionALPN of
              Maybe ByteString
Nothing -> XFTPTransportRequest -> M s ()
forall s. FileStoreClass s => XFTPTransportRequest -> M s ()
processRequest XFTPTransportRequest
req0
              Just ByteString
alpn
                | ByteString
alpn ByteString -> ByteString -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
== ByteString
xftpALPNv1 SNICredentialUsed -> SNICredentialUsed -> SNICredentialUsed
|| ByteString
alpn ByteString -> ByteString -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
== ByteString
httpALPN11 SNICredentialUsed -> SNICredentialUsed -> SNICredentialUsed
|| (SNICredentialUsed
sniUsed SNICredentialUsed -> SNICredentialUsed -> SNICredentialUsed
&& ByteString
alpn ByteString -> ByteString -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
== ByteString
"h2") ->
                    CertificateChain
-> APrivateSignKey
-> TMap ByteString Handshake
-> XFTPTransportRequest
-> M s (Maybe (THandleParamsXFTP 'TServer))
xftpServerHandshakeV1 CertificateChain
chain APrivateSignKey
signKey TMap ByteString Handshake
sessions XFTPTransportRequest
req0 M s (Maybe (THandleParamsXFTP 'TServer))
-> (Maybe (THandleParamsXFTP 'TServer) -> M s ()) -> M s ()
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                      Maybe (THandleParamsXFTP 'TServer)
Nothing -> () -> M s ()
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                      Just THandleParamsXFTP 'TServer
thParams -> XFTPTransportRequest -> M s ()
forall s. FileStoreClass s => XFTPTransportRequest -> M s ()
processRequest XFTPTransportRequest
req0 {thParams}
                | SNICredentialUsed
otherwise -> IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> (Response -> IO ()) -> Response -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ()
sendResponse (Response -> M s ()) -> Response -> M s ()
forall a b. (a -> b) -> a -> b
$ Status -> [Header] -> Response
H.responseNoBody Status
N.ok200 (SNICredentialUsed -> [Header]
corsHeaders SNICredentialUsed
addCORS')
    xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M s (Maybe (THandleParams XFTPVersion 'TServer))
    xftpServerHandshakeV1 :: CertificateChain
-> APrivateSignKey
-> TMap ByteString Handshake
-> XFTPTransportRequest
-> M s (Maybe (THandleParamsXFTP 'TServer))
xftpServerHandshakeV1 CertificateChain
chain APrivateSignKey
serverSignKey TMap ByteString Handshake
sessions XFTPTransportRequest {$sel:thParams:XFTPTransportRequest :: XFTPTransportRequest -> THandleParamsXFTP 'TServer
thParams = thParams0 :: THandleParamsXFTP 'TServer
thParams0@THandleParams {ByteString
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId :: ByteString
sessionId}, Request
$sel:request:XFTPTransportRequest :: XFTPTransportRequest -> Request
request :: Request
request, $sel:reqBody:XFTPTransportRequest :: XFTPTransportRequest -> HTTP2Body
reqBody = HTTP2Body {ByteString
bodyHead :: ByteString
bodyHead :: HTTP2Body -> ByteString
bodyHead}, Response -> IO ()
$sel:sendResponse:XFTPTransportRequest :: XFTPTransportRequest -> Response -> IO ()
sendResponse :: Response -> IO ()
sendResponse, SNICredentialUsed
$sel:sniUsed:XFTPTransportRequest :: XFTPTransportRequest -> SNICredentialUsed
sniUsed :: SNICredentialUsed
sniUsed, SNICredentialUsed
$sel:addCORS:XFTPTransportRequest :: XFTPTransportRequest -> SNICredentialUsed
addCORS :: SNICredentialUsed
addCORS} = do
      Maybe Handshake
s <- STM (Maybe Handshake) -> ReaderT (XFTPEnv s) IO (Maybe Handshake)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe Handshake) -> ReaderT (XFTPEnv s) IO (Maybe Handshake))
-> STM (Maybe Handshake)
-> ReaderT (XFTPEnv s) 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 s) IO)
  (Maybe (THandleParamsXFTP 'TServer))
-> ReaderT
     (XFTPEnv s)
     IO
     (Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   XFTPErrorType
   (ReaderT (XFTPEnv s) IO)
   (Maybe (THandleParamsXFTP 'TServer))
 -> ReaderT
      (XFTPEnv s)
      IO
      (Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer))))
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
-> ReaderT
     (XFTPEnv s)
     IO
     (Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer)))
forall a b. (a -> b) -> a -> b
$ case Maybe Handshake
s of
        Maybe Handshake
Nothing
          | SNICredentialUsed
sniUsed SNICredentialUsed -> SNICredentialUsed -> SNICredentialUsed
&& SNICredentialUsed -> SNICredentialUsed
not SNICredentialUsed
webHello -> XFTPErrorType
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
SESSION
          | SNICredentialUsed
otherwise -> Maybe (PrivateKey 'X25519)
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
processHello Maybe (PrivateKey 'X25519)
forall a. Maybe a
Nothing
        Just (HandshakeSent PrivateKey 'X25519
pk)
          | SNICredentialUsed
webHello -> Maybe (PrivateKey 'X25519)
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
processHello (PrivateKey 'X25519 -> Maybe (PrivateKey 'X25519)
forall a. a -> Maybe a
Just PrivateKey 'X25519
pk)
          | SNICredentialUsed
otherwise -> PrivateKey 'X25519
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
processClientHandshake PrivateKey 'X25519
pk
        Just (HandshakeAccepted THandleParamsXFTP 'TServer
thParams)
          | SNICredentialUsed
webHello -> Maybe (PrivateKey 'X25519)
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
processHello (THandleAuth 'TServer -> PrivateKey 'X25519
serverPrivKey (THandleAuth 'TServer -> PrivateKey 'X25519)
-> Maybe (THandleAuth 'TServer) -> Maybe (PrivateKey 'X25519)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> THandleParamsXFTP 'TServer -> Maybe (THandleAuth 'TServer)
forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth THandleParamsXFTP 'TServer
thParams)
          | SNICredentialUsed
webHandshake, Just THandleAuth 'TServer
auth <- THandleParamsXFTP 'TServer -> Maybe (THandleAuth 'TServer)
forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth THandleParamsXFTP 'TServer
thParams -> PrivateKey 'X25519
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
processClientHandshake (THandleAuth 'TServer -> PrivateKey 'X25519
serverPrivKey THandleAuth 'TServer
auth)
          | SNICredentialUsed
otherwise -> Maybe (THandleParamsXFTP 'TServer)
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
forall a. a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (THandleParamsXFTP 'TServer)
 -> ExceptT
      XFTPErrorType
      (ReaderT (XFTPEnv s) IO)
      (Maybe (THandleParamsXFTP 'TServer)))
-> Maybe (THandleParamsXFTP 'TServer)
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) 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 s (Maybe (THandleParamsXFTP 'TServer)))
-> (Maybe (THandleParamsXFTP 'TServer)
    -> M s (Maybe (THandleParamsXFTP 'TServer)))
-> Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer))
-> M s (Maybe (THandleParamsXFTP 'TServer))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XFTPErrorType -> M s (Maybe (THandleParamsXFTP 'TServer))
sendError Maybe (THandleParamsXFTP 'TServer)
-> M s (Maybe (THandleParamsXFTP 'TServer))
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either XFTPErrorType (Maybe (THandleParamsXFTP 'TServer))
r
      where
        webHello :: SNICredentialUsed
webHello = SNICredentialUsed
sniUsed SNICredentialUsed -> SNICredentialUsed -> SNICredentialUsed
&& ((Token, ByteString) -> SNICredentialUsed)
-> [(Token, ByteString)] -> SNICredentialUsed
forall (t :: * -> *) a.
Foldable t =>
(a -> SNICredentialUsed) -> t a -> SNICredentialUsed
any (\(Token
t, ByteString
_) -> Token -> HeaderName
tokenKey Token
t HeaderName -> HeaderName -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
== HeaderName
"xftp-web-hello") (([(Token, ByteString)], ValueTable) -> [(Token, ByteString)]
forall a b. (a, b) -> a
fst (([(Token, ByteString)], ValueTable) -> [(Token, ByteString)])
-> ([(Token, ByteString)], ValueTable) -> [(Token, ByteString)]
forall a b. (a -> b) -> a -> b
$ Request -> ([(Token, ByteString)], ValueTable)
H.requestHeaders Request
request)
        webHandshake :: SNICredentialUsed
webHandshake = SNICredentialUsed
sniUsed SNICredentialUsed -> SNICredentialUsed -> SNICredentialUsed
&& ((Token, ByteString) -> SNICredentialUsed)
-> [(Token, ByteString)] -> SNICredentialUsed
forall (t :: * -> *) a.
Foldable t =>
(a -> SNICredentialUsed) -> t a -> SNICredentialUsed
any (\(Token
t, ByteString
_) -> Token -> HeaderName
tokenKey Token
t HeaderName -> HeaderName -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
== HeaderName
"xftp-handshake") (([(Token, ByteString)], ValueTable) -> [(Token, ByteString)]
forall a b. (a, b) -> a
fst (([(Token, ByteString)], ValueTable) -> [(Token, ByteString)])
-> ([(Token, ByteString)], ValueTable) -> [(Token, ByteString)]
forall a b. (a -> b) -> a -> b
$ Request -> ([(Token, ByteString)], ValueTable)
H.requestHeaders Request
request)
        processHello :: Maybe (PrivateKey 'X25519)
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
processHello Maybe (PrivateKey 'X25519)
pk_ = do
          Maybe ByteString
challenge_ <-
            if
              | ByteString -> SNICredentialUsed
B.null ByteString
bodyHead -> Maybe ByteString
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) IO) (Maybe ByteString)
forall a. a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
              | SNICredentialUsed
sniUsed -> do
                  ByteString
body <- Either CryptoError ByteString
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ByteString
forall {e} {a}.
Either e a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
liftHS (Either CryptoError ByteString
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ByteString)
-> Either CryptoError ByteString
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either CryptoError ByteString
C.unPad ByteString
bodyHead
                  XFTPClientHello {Maybe ByteString
webChallenge :: Maybe ByteString
$sel:webChallenge:XFTPClientHello :: XFTPClientHello -> Maybe ByteString
webChallenge} <- Either String XFTPClientHello
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) XFTPClientHello
forall {e} {a}.
Either e a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
liftHS (Either String XFTPClientHello
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) XFTPClientHello)
-> Either String XFTPClientHello
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) XFTPClientHello
forall a b. (a -> b) -> a -> b
$ (String -> String)
-> Either String XFTPClientHello -> Either String XFTPClientHello
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 String -> String
forall a. Show a => a -> String
show (ByteString -> Either String XFTPClientHello
forall a. Encoding a => ByteString -> Either String a
smpDecode ByteString
body)
                  Maybe ByteString
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) IO) (Maybe ByteString)
forall a. a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
webChallenge
              | SNICredentialUsed
otherwise -> XFTPErrorType
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) IO) (Maybe ByteString)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
HANDSHAKE
          TVar ChaChaDRG
rng <- (XFTPEnv s -> TVar ChaChaDRG)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> TVar ChaChaDRG
forall s. XFTPEnv s -> TVar ChaChaDRG
random
          PublicKey 'X25519
k <- STM (PublicKey 'X25519)
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) IO) (PublicKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey 'X25519)
 -> ExceptT
      XFTPErrorType (ReaderT (XFTPEnv s) IO) (PublicKey 'X25519))
-> STM (PublicKey 'X25519)
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) IO) (PublicKey 'X25519)
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 STM (Maybe Handshake)
-> (Maybe Handshake -> STM (PublicKey 'X25519))
-> STM (PublicKey 'X25519)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just (HandshakeSent PrivateKey 'X25519
pk') -> PublicKey 'X25519 -> STM (PublicKey 'X25519)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PublicKey 'X25519 -> STM (PublicKey 'X25519))
-> PublicKey 'X25519 -> STM (PublicKey 'X25519)
forall a b. (a -> b) -> a -> b
$ PrivateKey 'X25519 -> PublicKey 'X25519
forall (a :: Algorithm). PrivateKey a -> PublicKey a
C.publicKey PrivateKey 'X25519
pk'
            Maybe Handshake
_ -> do
              (PublicKey 'X25519, PrivateKey 'X25519)
kp <- STM (PublicKey 'X25519, PrivateKey 'X25519)
-> (PrivateKey 'X25519
    -> STM (PublicKey 'X25519, PrivateKey 'X25519))
-> Maybe (PrivateKey 'X25519)
-> STM (PublicKey 'X25519, PrivateKey 'X25519)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
rng) (\PrivateKey 'X25519
p -> (PublicKey 'X25519, PrivateKey 'X25519)
-> STM (PublicKey 'X25519, PrivateKey 'X25519)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrivateKey 'X25519 -> PublicKey 'X25519
forall (a :: Algorithm). PrivateKey a -> PublicKey a
C.publicKey PrivateKey 'X25519
p, PrivateKey 'X25519
p)) Maybe (PrivateKey 'X25519)
pk_
              (PublicKey 'X25519, PrivateKey 'X25519) -> PublicKey 'X25519
forall a b. (a, b) -> a
fst (PublicKey 'X25519, PrivateKey 'X25519)
kp PublicKey 'X25519 -> STM () -> STM (PublicKey 'X25519)
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Handshake -> TMap ByteString Handshake -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert ByteString
sessionId (PrivateKey 'X25519 -> Handshake
HandshakeSent (PrivateKey 'X25519 -> Handshake)
-> PrivateKey 'X25519 -> Handshake
forall a b. (a -> b) -> a -> b
$ (PublicKey 'X25519, PrivateKey 'X25519) -> PrivateKey 'X25519
forall a b. (a, b) -> b
snd (PublicKey 'X25519, PrivateKey 'X25519)
kp) 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)
              webIdentityProof :: Maybe ASignature
webIdentityProof = APrivateSignKey -> ByteString -> ASignature
C.sign APrivateSignKey
serverSignKey (ByteString -> ASignature)
-> (ByteString -> ByteString) -> ByteString -> ASignature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sessionId) (ByteString -> ASignature) -> Maybe ByteString -> Maybe ASignature
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
challenge_
          let hs :: XFTPServerHandshake
hs = XFTPServerHandshake {$sel:xftpVersionRange:XFTPServerHandshake :: VersionRangeXFTP
xftpVersionRange = VersionRangeXFTP
xftpServerVRange, ByteString
sessionId :: ByteString
$sel:sessionId:XFTPServerHandshake :: ByteString
sessionId, CertChainPubKey
authPubKey :: CertChainPubKey
$sel:authPubKey:XFTPServerHandshake :: CertChainPubKey
authPubKey, Maybe ASignature
webIdentityProof :: Maybe ASignature
$sel:webIdentityProof:XFTPServerHandshake :: Maybe ASignature
webIdentityProof}
          Builder
shs <- XFTPServerHandshake
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) Builder
forall a.
Encoding a =>
a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) Builder
encodeXftp XFTPServerHandshake
hs
#ifdef slow_servers
          lift randomDelay
#endif
          IO () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a. IO a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> (Response -> IO ())
-> Response
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ()
sendResponse (Response -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> Response -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ Status -> [Header] -> Builder -> Response
H.responseBuilder Status
N.ok200 (SNICredentialUsed -> [Header]
corsHeaders SNICredentialUsed
addCORS) Builder
shs
          Maybe (THandleParamsXFTP 'TServer)
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
forall a. a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (THandleParamsXFTP 'TServer)
forall a. Maybe a
Nothing
        processClientHandshake :: PrivateKey 'X25519
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
processClientHandshake PrivateKey 'X25519
pk = do
          SNICredentialUsed
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall (f :: * -> *).
Applicative f =>
SNICredentialUsed -> f () -> f ()
unless (ByteString -> Int
B.length ByteString
bodyHead Int -> Int -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
== Int
xftpBlockSize) (ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
HANDSHAKE
          ByteString
body <- Either CryptoError ByteString
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ByteString
forall {e} {a}.
Either e a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
liftHS (Either CryptoError ByteString
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ByteString)
-> Either CryptoError ByteString
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either CryptoError ByteString
C.unPad ByteString
bodyHead
          XFTPClientHandshake {$sel:xftpVersion:XFTPClientHandshake :: XFTPClientHandshake -> VersionXFTP
xftpVersion = VersionXFTP
v, KeyHash
keyHash :: KeyHash
$sel:keyHash:XFTPClientHandshake :: XFTPClientHandshake -> KeyHash
keyHash} <- Either String XFTPClientHandshake
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) IO) XFTPClientHandshake
forall {e} {a}.
Either e a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
liftHS (Either String XFTPClientHandshake
 -> ExceptT
      XFTPErrorType (ReaderT (XFTPEnv s) IO) XFTPClientHandshake)
-> Either String XFTPClientHandshake
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) 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 s -> KeyHash)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) KeyHash
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> KeyHash
forall s. XFTPEnv s -> KeyHash
serverIdentity
          SNICredentialUsed
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall (f :: * -> *).
Applicative f =>
SNICredentialUsed -> f () -> f ()
unless (KeyHash
keyHash KeyHash -> KeyHash -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
== KeyHash
kh) (ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 {$sel:serverPrivKey:THAuthClient :: PrivateKey 'X25519
serverPrivKey = PrivateKey 'X25519
pk, $sel:peerClientService:THAuthClient :: Maybe THPeerClientService
peerClientService = Maybe THPeerClientService
forall a. Maybe a
Nothing, $sel:sessSecret':THAuthClient :: 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 s) IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> STM () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 s) IO) ()
forall a. IO a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> (Response -> IO ())
-> Response
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ()
sendResponse (Response -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> Response -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ Status -> [Header] -> Response
H.responseNoBody Status
N.ok200 (SNICredentialUsed -> [Header]
corsHeaders SNICredentialUsed
addCORS)
              Maybe (THandleParamsXFTP 'TServer)
-> ExceptT
     XFTPErrorType
     (ReaderT (XFTPEnv s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
forall a. a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 s) IO)
     (Maybe (THandleParamsXFTP 'TServer))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
HANDSHAKE
        sendError :: XFTPErrorType -> M s (Maybe (THandleParams XFTPVersion 'TServer))
        sendError :: XFTPErrorType -> M s (Maybe (THandleParamsXFTP 'TServer))
sendError XFTPErrorType
err = do
          ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) Builder
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType Builder)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (XFTPErrorType
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) Builder
forall a.
Encoding a =>
a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) Builder
encodeXftp XFTPErrorType
err) ReaderT (XFTPEnv s) IO (Either XFTPErrorType Builder)
-> (Either XFTPErrorType Builder -> M s ()) -> M s ()
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Right Builder
bs -> IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> (Response -> IO ()) -> Response -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ()
sendResponse (Response -> M s ()) -> Response -> M s ()
forall a b. (a -> b) -> a -> b
$ Status -> [Header] -> Builder -> Response
H.responseBuilder Status
N.ok200 (SNICredentialUsed -> [Header]
corsHeaders SNICredentialUsed
addCORS) Builder
bs
            Left XFTPErrorType
_ -> Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> M s ()) -> Text -> M s ()
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 s (Maybe (THandleParamsXFTP 'TServer))
forall a. a -> ReaderT (XFTPEnv s) 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 s) IO) Builder
        encodeXftp :: forall a.
Encoding a =>
a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) Builder
encodeXftp a
a = ByteString -> Builder
byteString (ByteString -> Builder)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ByteString
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either CryptoError ByteString
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ByteString
forall {e} {a}.
Either e a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 s) IO) a
liftHS = (e -> XFTPErrorType)
-> Either e a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 s ()
    stopServer :: M s ()
stopServer = do
      s
st <- (XFTPEnv s -> s) -> ReaderT (XFTPEnv s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
      IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ s -> IO ()
forall s. FileStoreClass s => s -> IO ()
closeFileStore s
st
      M s ()
forall s. M s ()
saveServerStats
      Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"Server stopped"

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

    expireFiles :: ExpirationConfig -> M s ()
    expireFiles :: ExpirationConfig -> M s ()
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 s () -> M s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Int64 -> IO ()
threadDelay' Int64
interval
        Maybe Int -> ExpirationConfig -> M s ()
forall s.
FileStoreClass s =>
Maybe Int -> ExpirationConfig -> M s ()
expireServerFiles (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
100000) ExpirationConfig
expCfg

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

    logServerStats :: Int64 -> Int64 -> FilePath -> M s ()
    logServerStats :: Int64 -> Int64 -> String -> M s ()
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 s) IO UTCTime -> ReaderT (XFTPEnv s) IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> ReaderT (XFTPEnv s) IO UTCTime
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
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 s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
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 -> SNICredentialUsed
forall a. Ord a => a -> a -> SNICredentialUsed
< Int64
0 then Int64
86_400 else Int64
0)
      FileServerStats {IORef UTCTime
fromTime :: IORef UTCTime
$sel:fromTime:FileServerStats :: FileServerStats -> IORef UTCTime
fromTime, IORef Int
filesCreated :: IORef Int
$sel:filesCreated:FileServerStats :: FileServerStats -> IORef Int
filesCreated, IORef Int
fileRecipients :: IORef Int
$sel:fileRecipients:FileServerStats :: FileServerStats -> IORef Int
fileRecipients, IORef Int
filesUploaded :: IORef Int
$sel:filesUploaded:FileServerStats :: FileServerStats -> IORef Int
filesUploaded, IORef Int
filesExpired :: IORef Int
$sel:filesExpired:FileServerStats :: FileServerStats -> IORef Int
filesExpired, IORef Int
filesDeleted :: IORef Int
$sel:filesDeleted:FileServerStats :: FileServerStats -> IORef Int
filesDeleted, PeriodStats
filesDownloaded :: PeriodStats
$sel:filesDownloaded:FileServerStats :: FileServerStats -> PeriodStats
filesDownloaded, IORef Int
fileDownloads :: IORef Int
$sel:fileDownloads:FileServerStats :: FileServerStats -> IORef Int
fileDownloads, IORef Int
fileDownloadAcks :: IORef Int
$sel:fileDownloadAcks:FileServerStats :: FileServerStats -> IORef Int
fileDownloadAcks, IORef Int
filesCount :: IORef Int
$sel:filesCount:FileServerStats :: FileServerStats -> IORef Int
filesCount, IORef Int64
filesSize :: IORef Int64
$sel:filesSize:FileServerStats :: FileServerStats -> IORef Int64
filesSize} <- (XFTPEnv s -> FileServerStats)
-> ReaderT (XFTPEnv s) IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> FileServerStats
forall s. XFTPEnv s -> FileServerStats
serverStats
      let interval :: Int64
interval = Int64
1_000_000 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
logInterval
      M s () -> M s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IOMode -> (Handle -> M s ()) -> M s ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile String
statsFilePath IOMode
AppendMode ((Handle -> M s ()) -> M s ()) -> (Handle -> M s ()) -> M s ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
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 s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Int64 -> IO ()
threadDelay' Int64
interval

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

    savePrometheusMetrics :: Int -> FilePath -> M s ()
    savePrometheusMetrics :: Int -> String -> M s ()
savePrometheusMetrics Int
saveInterval String
metricsFile = do
      String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"savePrometheusMetrics"
      IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
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 s -> FileServerStats)
-> ReaderT (XFTPEnv s) IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> FileServerStats
forall s. XFTPEnv s -> FileServerStats
serverStats
      Text
rtsOpts <- IO Text -> ReaderT (XFTPEnv s) IO Text
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ReaderT (XFTPEnv s) IO Text)
-> IO Text -> ReaderT (XFTPEnv s) 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 s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
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 {$sel:statsData:FileServerMetrics :: FileServerStatsData
statsData = FileServerStatsData
d, $sel:filesDownloadedPeriods:FileServerMetrics :: PeriodStatCounts
filesDownloadedPeriods = PeriodStatCounts
fd, Text
rtsOptions :: Text
$sel:rtsOptions:FileServerMetrics :: Text
rtsOptions}

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

    runCPServer :: ServiceName -> M s ()
    runCPServer :: String -> M s ()
runCPServer String
port = do
      TMVar SNICredentialUsed
cpStarted <- ReaderT (XFTPEnv s) IO (TMVar SNICredentialUsed)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      UnliftIO (ReaderT (XFTPEnv s) IO)
u <- ReaderT (XFTPEnv s) IO (UnliftIO (ReaderT (XFTPEnv s) IO))
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
      IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"control port server"
        TMVar SNICredentialUsed -> String -> (Socket -> IO ()) -> IO ()
runLocalTCPServer TMVar SNICredentialUsed
cpStarted String
port ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (ReaderT (XFTPEnv s) IO) -> Socket -> IO ()
runCPClient UnliftIO (ReaderT (XFTPEnv s) IO)
u
      where
        runCPClient :: UnliftIO (ReaderT (XFTPEnv s) IO) -> Socket -> IO ()
        runCPClient :: UnliftIO (ReaderT (XFTPEnv s) IO) -> Socket -> IO ()
runCPClient UnliftIO (ReaderT (XFTPEnv s) 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 = SNICredentialUsed -> f () -> f ()
forall (f :: * -> *).
Applicative f =>
SNICredentialUsed -> f () -> f ()
when SNICredentialUsed
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 :: SNICredentialUsed
shouldLog = case ControlProtocol
cmd of
                  CPAuth BasicAuth
_ -> SNICredentialUsed
False
                  ControlProtocol
CPHelp -> SNICredentialUsed
False
                  ControlProtocol
CPQuit -> SNICredentialUsed
False
                  ControlProtocol
CPSkip -> SNICredentialUsed
False
                  ControlProtocol
_ -> SNICredentialUsed
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 {$sel:controlPortUserAuth:XFTPServerConfig :: forall s. XFTPServerConfig s -> Maybe BasicAuth
controlPortUserAuth = Maybe BasicAuth
user, $sel:controlPortAdminAuth:XFTPServerConfig :: forall s. XFTPServerConfig s -> Maybe BasicAuth
controlPortAdminAuth = Maybe BasicAuth
admin} = XFTPServerConfig s
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 s) IO)
-> forall a. ReaderT (XFTPEnv s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (XFTPEnv s) IO)
u (M s () -> IO ()) -> M s () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                s
fs <- (XFTPEnv s -> s) -> ReaderT (XFTPEnv s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
                Either XFTPErrorType ()
r <- ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
 -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ()))
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ do
                  (FileRec
fr, APublicAuthKey
_) <- ReaderT
  (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) IO) (FileRec, APublicAuthKey)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT
   (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey))
 -> ExceptT
      XFTPErrorType (ReaderT (XFTPEnv s) IO) (FileRec, APublicAuthKey))
-> ReaderT
     (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) IO) (FileRec, APublicAuthKey)
forall a b. (a -> b) -> a -> b
$ IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ReaderT
     (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either XFTPErrorType (FileRec, APublicAuthKey))
 -> ReaderT
      (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ReaderT
     (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a b. (a -> b) -> a -> b
$ s
-> SFileParty 'FRecipient
-> XFTPFileId
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall s (p :: FileParty).
FileStoreClass s =>
s
-> SFileParty p
-> XFTPFileId
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall (p :: FileParty).
s
-> SFileParty p
-> XFTPFileId
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
getFile s
fs SFileParty 'FRecipient
SFRecipient XFTPFileId
fileId
                  ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ FileRec -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
FileRec -> M s (Either XFTPErrorType ())
deleteServerFile_ FileRec
fr
                IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> (String -> IO ()) -> String -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
h (String -> M s ()) -> String -> M s ()
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 s) IO)
-> forall a. ReaderT (XFTPEnv s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (XFTPEnv s) IO)
u (M s () -> IO ()) -> M s () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                s
fs <- (XFTPEnv s -> s) -> ReaderT (XFTPEnv s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
                Either XFTPErrorType ()
r <- ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
 -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ()))
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ do
                  (FileRec
fr, APublicAuthKey
_) <- ReaderT
  (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) IO) (FileRec, APublicAuthKey)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT
   (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey))
 -> ExceptT
      XFTPErrorType (ReaderT (XFTPEnv s) IO) (FileRec, APublicAuthKey))
-> ReaderT
     (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) IO) (FileRec, APublicAuthKey)
forall a b. (a -> b) -> a -> b
$ IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ReaderT
     (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either XFTPErrorType (FileRec, APublicAuthKey))
 -> ReaderT
      (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> ReaderT
     (XFTPEnv s) IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a b. (a -> b) -> a -> b
$ s
-> SFileParty 'FRecipient
-> XFTPFileId
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall s (p :: FileParty).
FileStoreClass s =>
s
-> SFileParty p
-> XFTPFileId
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall (p :: FileParty).
s
-> SFileParty p
-> XFTPFileId
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
getFile s
fs SFileParty 'FRecipient
SFRecipient XFTPFileId
fileId
                  ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ FileRec
-> BlockingInfo -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
FileRec -> BlockingInfo -> M s (Either XFTPErrorType ())
blockServerFile FileRec
fr BlockingInfo
info
                IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> (String -> IO ()) -> String -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
h (String -> M s ()) -> String -> M s ()
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 :: FileStoreClass s => XFTPTransportRequest -> M s ()
processRequest :: forall s. FileStoreClass s => XFTPTransportRequest -> M s ()
processRequest XFTPTransportRequest {THandleParamsXFTP 'TServer
$sel:thParams:XFTPTransportRequest :: XFTPTransportRequest -> THandleParamsXFTP 'TServer
thParams :: THandleParamsXFTP 'TServer
thParams, $sel:reqBody:XFTPTransportRequest :: XFTPTransportRequest -> HTTP2Body
reqBody = body :: HTTP2Body
body@HTTP2Body {ByteString
bodyHead :: HTTP2Body -> ByteString
bodyHead :: ByteString
bodyHead}, Response -> IO ()
$sel:sendResponse:XFTPTransportRequest :: XFTPTransportRequest -> Response -> IO ()
sendResponse :: Response -> IO ()
sendResponse, SNICredentialUsed
$sel:addCORS:XFTPTransportRequest :: XFTPTransportRequest -> SNICredentialUsed
addCORS :: SNICredentialUsed
addCORS}
  | ByteString -> Int
B.length ByteString
bodyHead Int -> Int -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
/= Int
xftpBlockSize = Transmission FileResponse
-> Maybe ServerFile -> ReaderT (XFTPEnv s) IO ()
sendXFTPResponse (CorrId
"", XFTPFileId
NoEntity, XFTPErrorType -> FileResponse
FRErr XFTPErrorType
BLOCK) Maybe ServerFile
forall a. Maybe a
Nothing
  | SNICredentialUsed
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)
$sel:thAuth:THandleParams :: forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth :: Maybe (THandleAuth 'TServer)
thAuth} = THandleParamsXFTP 'TServer
thParams
          Maybe (THandleAuth 'TServer)
-> SignedTransmission FileCmd -> M s VerificationResult
forall s.
FileStoreClass s =>
Maybe (THandleAuth 'TServer)
-> SignedTransmission FileCmd -> M s VerificationResult
verifyXFTPTransmission Maybe (THandleAuth 'TServer)
thAuth SignedTransmission FileCmd
t M s VerificationResult
-> (VerificationResult -> ReaderT (XFTPEnv s) IO ())
-> ReaderT (XFTPEnv s) IO ()
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            VRVerified XFTPRequest
req -> (FileResponse -> Maybe ServerFile -> ReaderT (XFTPEnv s) IO ())
-> (FileResponse, Maybe ServerFile) -> ReaderT (XFTPEnv s) IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FileResponse -> Maybe ServerFile -> ReaderT (XFTPEnv s) IO ()
send ((FileResponse, Maybe ServerFile) -> ReaderT (XFTPEnv s) IO ())
-> ReaderT (XFTPEnv s) IO (FileResponse, Maybe ServerFile)
-> ReaderT (XFTPEnv s) IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HTTP2Body
-> XFTPRequest
-> ReaderT (XFTPEnv s) IO (FileResponse, Maybe ServerFile)
forall s.
FileStoreClass s =>
HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
processXFTPRequest HTTP2Body
body XFTPRequest
req
            VRFailed XFTPErrorType
e -> FileResponse -> Maybe ServerFile -> ReaderT (XFTPEnv s) IO ()
send (XFTPErrorType -> FileResponse
FRErr XFTPErrorType
e) Maybe ServerFile
forall a. Maybe a
Nothing
          where
            send :: FileResponse -> Maybe ServerFile -> ReaderT (XFTPEnv s) IO ()
send FileResponse
resp = Transmission FileResponse
-> Maybe ServerFile -> ReaderT (XFTPEnv s) IO ()
sendXFTPResponse (CorrId
corrId, XFTPFileId
fId, FileResponse
resp)
        Right (Left (CorrId
corrId, XFTPFileId
fId, XFTPErrorType
e)) -> Transmission FileResponse
-> Maybe ServerFile -> ReaderT (XFTPEnv s) IO ()
sendXFTPResponse (CorrId
corrId, XFTPFileId
fId, XFTPErrorType -> FileResponse
FRErr XFTPErrorType
e) Maybe ServerFile
forall a. Maybe a
Nothing
        Left XFTPErrorType
e -> Transmission FileResponse
-> Maybe ServerFile -> ReaderT (XFTPEnv s) IO ()
sendXFTPResponse (CorrId
"", XFTPFileId
NoEntity, XFTPErrorType -> FileResponse
FRErr XFTPErrorType
e) Maybe ServerFile
forall a. Maybe a
Nothing
  where
    sendXFTPResponse :: Transmission FileResponse
-> Maybe ServerFile -> ReaderT (XFTPEnv s) IO ()
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 () -> ReaderT (XFTPEnv s) IO ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (XFTPEnv s) IO ())
-> IO () -> ReaderT (XFTPEnv s) IO ()
forall a b. (a -> b) -> a -> b
$ Response -> IO ()
sendResponse (Response -> IO ()) -> Response -> IO ()
forall a b. (a -> b) -> a -> b
$ Status
-> [Header] -> ((Builder -> IO ()) -> IO () -> IO ()) -> Response
H.responseStreaming Status
N.ok200 (SNICredentialUsed -> [Header]
corsHeaders SNICredentialUsed
addCORS) (((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
$sel:filePath:ServerFile :: ServerFile -> String
filePath :: String
filePath, Word32
$sel:fileSize:ServerFile :: ServerFile -> Word32
fileSize :: Word32
fileSize, SbState
$sel:sbState:ServerFile :: 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 s ()
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 :: forall s. FileStoreClass s => Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M s VerificationResult
verifyXFTPTransmission :: forall s.
FileStoreClass s =>
Maybe (THandleAuth 'TServer)
-> SignedTransmission FileCmd -> M s 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 s VerificationResult
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationResult -> M s VerificationResult)
-> VerificationResult -> M s 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 s VerificationResult
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationResult -> M s VerificationResult)
-> VerificationResult -> M s VerificationResult
forall a b. (a -> b) -> a -> b
$ XFTPRequest -> VerificationResult
VRVerified XFTPRequest
XFTPReqPing
    FileCmd SFileParty p
party FileCommand p
_ -> SFileParty p -> M s VerificationResult
forall (p :: FileParty). SFileParty p -> M s VerificationResult
verifyCmd SFileParty p
party
  where
    verifyCmd :: SFileParty p -> M s VerificationResult
    verifyCmd :: forall (p :: FileParty). SFileParty p -> M s VerificationResult
verifyCmd SFileParty p
party = do
      s
st <- (XFTPEnv s -> s) -> ReaderT (XFTPEnv s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
      IO VerificationResult -> M s VerificationResult
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO VerificationResult -> M s VerificationResult)
-> IO VerificationResult -> M s VerificationResult
forall a b. (a -> b) -> a -> b
$ Either XFTPErrorType (FileRec, APublicAuthKey)
-> IO VerificationResult
verify (Either XFTPErrorType (FileRec, APublicAuthKey)
 -> IO VerificationResult)
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
-> IO VerificationResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s
-> SFileParty p
-> XFTPFileId
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall s (p :: FileParty).
FileStoreClass s =>
s
-> SFileParty p
-> XFTPFileId
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall (p :: FileParty).
s
-> SFileParty p
-> XFTPFileId
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
getFile s
st SFileParty p
party XFTPFileId
fId
      where
        verify :: Either XFTPErrorType (FileRec, APublicAuthKey)
-> IO VerificationResult
verify = \case
          Right (FileRec
fr, APublicAuthKey
k) -> ServerEntityStatus -> VerificationResult
result (ServerEntityStatus -> VerificationResult)
-> IO ServerEntityStatus -> IO VerificationResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar ServerEntityStatus -> IO ServerEntityStatus
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (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 -> IO VerificationResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VerificationResult
noFileAuth
        noFileAuth :: VerificationResult
noFileAuth = Maybe (THandleAuth 'TServer)
-> Maybe TAuthorizations
-> ByteString
-> CorrId
-> SNICredentialUsed
dummyVerifyCmd Maybe (THandleAuth 'TServer)
thAuth Maybe TAuthorizations
tAuth ByteString
authorized CorrId
corrId SNICredentialUsed -> 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
-> SNICredentialUsed
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 :: forall s. FileStoreClass s => HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
processXFTPRequest :: forall s.
FileStoreClass s =>
HTTP2Body -> XFTPRequest -> M s (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 -> M s (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse -> M s (FileResponse, Maybe ServerFile))
-> ReaderT (XFTPEnv s) IO FileResponse
-> M s (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT (XFTPEnv s) IO SNICredentialUsed
-> ReaderT (XFTPEnv s) IO FileResponse
-> ReaderT (XFTPEnv s) IO FileResponse
-> ReaderT (XFTPEnv s) IO FileResponse
forall (m :: * -> *) a.
Monad m =>
m SNICredentialUsed -> m a -> m a -> m a
ifM ReaderT (XFTPEnv s) IO SNICredentialUsed
allowNew (FileInfo
-> NonEmpty APublicAuthKey -> ReaderT (XFTPEnv s) IO FileResponse
createFile FileInfo
file NonEmpty APublicAuthKey
rks) (FileResponse -> ReaderT (XFTPEnv s) IO FileResponse
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT (XFTPEnv s) IO FileResponse)
-> FileResponse -> ReaderT (XFTPEnv s) IO FileResponse
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
AUTH)
    where
      allowNew :: ReaderT (XFTPEnv s) IO SNICredentialUsed
allowNew = do
        XFTPServerConfig {SNICredentialUsed
allowNewFiles :: SNICredentialUsed
$sel:allowNewFiles:XFTPServerConfig :: forall s. XFTPServerConfig s -> SNICredentialUsed
allowNewFiles, Maybe BasicAuth
newFileBasicAuth :: Maybe BasicAuth
$sel:newFileBasicAuth:XFTPServerConfig :: forall s. XFTPServerConfig s -> Maybe BasicAuth
newFileBasicAuth} <- (XFTPEnv s -> XFTPServerConfig s)
-> ReaderT (XFTPEnv s) IO (XFTPServerConfig s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> XFTPServerConfig s
forall s. XFTPEnv s -> XFTPServerConfig s
config
        SNICredentialUsed -> ReaderT (XFTPEnv s) IO SNICredentialUsed
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SNICredentialUsed -> ReaderT (XFTPEnv s) IO SNICredentialUsed)
-> SNICredentialUsed -> ReaderT (XFTPEnv s) IO SNICredentialUsed
forall a b. (a -> b) -> a -> b
$ SNICredentialUsed
allowNewFiles SNICredentialUsed -> SNICredentialUsed -> SNICredentialUsed
&& SNICredentialUsed
-> (BasicAuth -> SNICredentialUsed)
-> Maybe BasicAuth
-> SNICredentialUsed
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SNICredentialUsed
True ((Maybe BasicAuth -> Maybe BasicAuth -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
== Maybe BasicAuth
auth) (Maybe BasicAuth -> SNICredentialUsed)
-> (BasicAuth -> Maybe BasicAuth) -> BasicAuth -> SNICredentialUsed
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 -> M s (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse -> M s (FileResponse, Maybe ServerFile))
-> ReaderT (XFTPEnv s) IO FileResponse
-> M s (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< XFTPFileId
-> NonEmpty APublicAuthKey -> ReaderT (XFTPEnv s) IO FileResponse
addRecipients XFTPFileId
fId NonEmpty APublicAuthKey
rks
    FileCommand p
FPUT -> FileResponse -> M s (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse -> M s (FileResponse, Maybe ServerFile))
-> ReaderT (XFTPEnv s) IO FileResponse
-> M s (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FileRec -> ReaderT (XFTPEnv s) IO FileResponse
receiveServerFile FileRec
fr
    FileCommand p
FDEL -> FileResponse -> M s (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse -> M s (FileResponse, Maybe ServerFile))
-> ReaderT (XFTPEnv s) IO FileResponse
-> M s (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FileRec -> ReaderT (XFTPEnv s) IO FileResponse
deleteServerFile FileRec
fr
    FGET PublicKey 'X25519
rDhKey -> FileRec
-> PublicKey 'X25519 -> M s (FileResponse, Maybe ServerFile)
sendServerFile FileRec
fr PublicKey 'X25519
rDhKey
    FileCommand p
FACK -> FileResponse -> M s (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse -> M s (FileResponse, Maybe ServerFile))
-> ReaderT (XFTPEnv s) IO FileResponse
-> M s (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< XFTPFileId -> FileRec -> ReaderT (XFTPEnv s) 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 -> M s (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse -> M s (FileResponse, Maybe ServerFile))
-> FileResponse -> M s (FileResponse, Maybe ServerFile)
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
INTERNAL
    FileCommand p
PING -> FileResponse -> M s (FileResponse, Maybe ServerFile)
forall {f :: * -> *} {a} {a}. Applicative f => a -> f (a, Maybe a)
noFile (FileResponse -> M s (FileResponse, Maybe ServerFile))
-> FileResponse -> M s (FileResponse, Maybe ServerFile)
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
INTERNAL
  XFTPRequest
XFTPReqPing -> FileResponse -> M s (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 s FileResponse
    createFile :: FileInfo
-> NonEmpty APublicAuthKey -> ReaderT (XFTPEnv s) IO FileResponse
createFile FileInfo
file NonEmpty APublicAuthKey
rks = do
      s
st <- (XFTPEnv s -> s) -> ReaderT (XFTPEnv s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
      Either XFTPErrorType FileResponse
r <- ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileResponse
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileResponse)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileResponse
 -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileResponse))
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileResponse
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileResponse)
forall a b. (a -> b) -> a -> b
$ do
        [Word32]
sizes <- (XFTPEnv s -> [Word32])
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) [Word32]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XFTPEnv s -> [Word32])
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) [Word32])
-> (XFTPEnv s -> [Word32])
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) [Word32]
forall a b. (a -> b) -> a -> b
$ XFTPServerConfig s -> [Word32]
forall s. XFTPServerConfig s -> [Word32]
allowedChunkSizes (XFTPServerConfig s -> [Word32])
-> (XFTPEnv s -> XFTPServerConfig s) -> XFTPEnv s -> [Word32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv s -> XFTPServerConfig s
forall s. XFTPEnv s -> XFTPServerConfig s
config
        SNICredentialUsed
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall (f :: * -> *).
Applicative f =>
SNICredentialUsed -> f () -> f ()
unless (FileInfo -> Word32
size FileInfo
file Word32 -> [Word32] -> SNICredentialUsed
forall a. Eq a => a -> [a] -> SNICredentialUsed
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> SNICredentialUsed
`elem` [Word32]
sizes) (ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
SIZE
        RoundedFileTime
ts <- IO RoundedFileTime
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) RoundedFileTime
forall a. IO a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RoundedFileTime
getFileTime
        -- TODO validate body empty
        XFTPFileId
sId <- ReaderT (XFTPEnv s) IO (Either XFTPErrorType XFTPFileId)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) XFTPFileId
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT (XFTPEnv s) IO (Either XFTPErrorType XFTPFileId)
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) XFTPFileId)
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType XFTPFileId)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) XFTPFileId
forall a b. (a -> b) -> a -> b
$ s
-> FileInfo
-> Int
-> RoundedFileTime
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType XFTPFileId)
addFileRetry s
st FileInfo
file Int
3 RoundedFileTime
ts
        NonEmpty FileRecipient
rcps <- (APublicAuthKey
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileRecipient)
-> NonEmpty APublicAuthKey
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) 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 s) IO (Either XFTPErrorType FileRecipient)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileRecipient
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileRecipient)
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileRecipient)
-> (APublicAuthKey
    -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileRecipient))
-> APublicAuthKey
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileRecipient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s
-> Int
-> XFTPFileId
-> APublicAuthKey
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileRecipient)
addRecipientRetry s
st Int
3 XFTPFileId
sId) NonEmpty APublicAuthKey
rks
        ReaderT (XFTPEnv s) IO ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 (ReaderT (XFTPEnv s) IO ()
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ReaderT (XFTPEnv s) IO ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ (StoreLog 'WriteMode -> IO ()) -> ReaderT (XFTPEnv s) IO ()
forall a s. (StoreLog 'WriteMode -> IO a) -> M s ()
withFileLog ((StoreLog 'WriteMode -> IO ()) -> ReaderT (XFTPEnv s) IO ())
-> (StoreLog 'WriteMode -> IO ()) -> ReaderT (XFTPEnv s) IO ()
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 s -> FileServerStats)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> FileServerStats
forall s. XFTPEnv s -> FileServerStats
serverStats
        ReaderT (XFTPEnv s) IO ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 (ReaderT (XFTPEnv s) IO ()
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ReaderT (XFTPEnv s) IO ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ (FileServerStats -> IORef Int) -> ReaderT (XFTPEnv s) IO ()
forall s. (FileServerStats -> IORef Int) -> M s ()
incFileStat FileServerStats -> IORef Int
filesCreated
        IO () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a. IO a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> IO () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 s) IO) FileResponse
forall a. a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileResponse)
-> FileResponse
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileResponse
forall a b. (a -> b) -> a -> b
$ XFTPFileId -> NonEmpty XFTPFileId -> FileResponse
FRSndIds XFTPFileId
sId NonEmpty XFTPFileId
rIds
      FileResponse -> ReaderT (XFTPEnv s) IO FileResponse
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT (XFTPEnv s) IO FileResponse)
-> FileResponse -> ReaderT (XFTPEnv s) 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 :: s -> FileInfo -> Int -> RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId)
    addFileRetry :: s
-> FileInfo
-> Int
-> RoundedFileTime
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType XFTPFileId)
addFileRetry s
st FileInfo
file Int
n RoundedFileTime
ts =
      Int
-> (XFTPFileId -> IO (Either XFTPErrorType XFTPFileId))
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType XFTPFileId)
forall a.
Int
-> (XFTPFileId -> IO (Either XFTPErrorType a))
-> M s (Either XFTPErrorType a)
retryAdd Int
n ((XFTPFileId -> IO (Either XFTPErrorType XFTPFileId))
 -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType XFTPFileId))
-> (XFTPFileId -> IO (Either XFTPErrorType XFTPFileId))
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType XFTPFileId)
forall a b. (a -> b) -> a -> b
$ \XFTPFileId
sId -> ExceptT XFTPErrorType IO XFTPFileId
-> IO (Either XFTPErrorType XFTPFileId)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType IO XFTPFileId
 -> IO (Either XFTPErrorType XFTPFileId))
-> ExceptT XFTPErrorType IO XFTPFileId
-> IO (Either XFTPErrorType XFTPFileId)
forall a b. (a -> b) -> a -> b
$ do
        IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ())
-> IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ()
forall a b. (a -> b) -> a -> b
$ s
-> XFTPFileId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s
-> XFTPFileId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> IO (Either XFTPErrorType ())
addFile s
st XFTPFileId
sId FileInfo
file RoundedFileTime
ts ServerEntityStatus
EntityActive
        XFTPFileId -> ExceptT XFTPErrorType IO XFTPFileId
forall a. a -> ExceptT XFTPErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPFileId
sId
    addRecipientRetry :: s -> Int -> XFTPFileId -> RcvPublicAuthKey -> M s (Either XFTPErrorType FileRecipient)
    addRecipientRetry :: s
-> Int
-> XFTPFileId
-> APublicAuthKey
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileRecipient)
addRecipientRetry s
st Int
n XFTPFileId
sId APublicAuthKey
rpk =
      Int
-> (XFTPFileId -> IO (Either XFTPErrorType FileRecipient))
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileRecipient)
forall a.
Int
-> (XFTPFileId -> IO (Either XFTPErrorType a))
-> M s (Either XFTPErrorType a)
retryAdd Int
n ((XFTPFileId -> IO (Either XFTPErrorType FileRecipient))
 -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileRecipient))
-> (XFTPFileId -> IO (Either XFTPErrorType FileRecipient))
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileRecipient)
forall a b. (a -> b) -> a -> b
$ \XFTPFileId
rId -> ExceptT XFTPErrorType IO FileRecipient
-> IO (Either XFTPErrorType FileRecipient)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType IO FileRecipient
 -> IO (Either XFTPErrorType FileRecipient))
-> ExceptT XFTPErrorType IO FileRecipient
-> IO (Either XFTPErrorType FileRecipient)
forall a b. (a -> b) -> a -> b
$ do
        let rcp :: FileRecipient
rcp = XFTPFileId -> APublicAuthKey -> FileRecipient
FileRecipient XFTPFileId
rId APublicAuthKey
rpk
        IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ())
-> IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ()
forall a b. (a -> b) -> a -> b
$ s -> XFTPFileId -> FileRecipient -> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s -> XFTPFileId -> FileRecipient -> IO (Either XFTPErrorType ())
addRecipient s
st XFTPFileId
sId FileRecipient
rcp
        FileRecipient -> ExceptT XFTPErrorType IO FileRecipient
forall a. a -> ExceptT XFTPErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileRecipient
rcp
    retryAdd :: Int -> (XFTPFileId -> IO (Either XFTPErrorType a)) -> M s (Either XFTPErrorType a)
    retryAdd :: forall a.
Int
-> (XFTPFileId -> IO (Either XFTPErrorType a))
-> M s (Either XFTPErrorType a)
retryAdd Int
0 XFTPFileId -> IO (Either XFTPErrorType a)
_ = Either XFTPErrorType a
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType a)
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType a
 -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType a))
-> Either XFTPErrorType a
-> ReaderT (XFTPEnv s) 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 -> IO (Either XFTPErrorType a)
add = do
      XFTPFileId
fId <- M s XFTPFileId
forall s. M s XFTPFileId
getFileId
      IO (Either XFTPErrorType a)
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType a)
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (XFTPFileId -> IO (Either XFTPErrorType a)
add XFTPFileId
fId) ReaderT (XFTPEnv s) IO (Either XFTPErrorType a)
-> (Either XFTPErrorType a
    -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType a))
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType a)
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left XFTPErrorType
DUPLICATE_ -> Int
-> (XFTPFileId -> IO (Either XFTPErrorType a))
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType a)
forall a.
Int
-> (XFTPFileId -> IO (Either XFTPErrorType a))
-> M s (Either XFTPErrorType a)
retryAdd (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) XFTPFileId -> IO (Either XFTPErrorType a)
add
        Either XFTPErrorType a
r -> Either XFTPErrorType a
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType a)
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either XFTPErrorType a
r
    addRecipients :: XFTPFileId -> NonEmpty RcvPublicAuthKey -> M s FileResponse
    addRecipients :: XFTPFileId
-> NonEmpty APublicAuthKey -> ReaderT (XFTPEnv s) IO FileResponse
addRecipients XFTPFileId
sId NonEmpty APublicAuthKey
rks = do
      s
st <- (XFTPEnv s -> s) -> ReaderT (XFTPEnv s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
      Either XFTPErrorType FileResponse
r <- ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileResponse
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileResponse)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileResponse
 -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileResponse))
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileResponse
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileResponse)
forall a b. (a -> b) -> a -> b
$ do
        NonEmpty FileRecipient
rcps <- (APublicAuthKey
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileRecipient)
-> NonEmpty APublicAuthKey
-> ExceptT
     XFTPErrorType (ReaderT (XFTPEnv s) 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 s) IO (Either XFTPErrorType FileRecipient)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileRecipient
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileRecipient)
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileRecipient)
-> (APublicAuthKey
    -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileRecipient))
-> APublicAuthKey
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileRecipient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s
-> Int
-> XFTPFileId
-> APublicAuthKey
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType FileRecipient)
addRecipientRetry s
st Int
3 XFTPFileId
sId) NonEmpty APublicAuthKey
rks
        ReaderT (XFTPEnv s) IO ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 (ReaderT (XFTPEnv s) IO ()
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ReaderT (XFTPEnv s) IO ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ (StoreLog 'WriteMode -> IO ()) -> ReaderT (XFTPEnv s) IO ()
forall a s. (StoreLog 'WriteMode -> IO a) -> M s ()
withFileLog ((StoreLog 'WriteMode -> IO ()) -> ReaderT (XFTPEnv s) IO ())
-> (StoreLog 'WriteMode -> IO ()) -> ReaderT (XFTPEnv s) IO ()
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 s -> FileServerStats)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> FileServerStats
forall s. XFTPEnv s -> FileServerStats
serverStats
        IO () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a. IO a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> IO () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 s) IO) FileResponse
forall a. a -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileResponse)
-> FileResponse
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileResponse
forall a b. (a -> b) -> a -> b
$ NonEmpty XFTPFileId -> FileResponse
FRRcvIds NonEmpty XFTPFileId
rIds
      FileResponse -> ReaderT (XFTPEnv s) IO FileResponse
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT (XFTPEnv s) IO FileResponse)
-> FileResponse -> ReaderT (XFTPEnv s) 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 s FileResponse
    receiveServerFile :: FileRec -> ReaderT (XFTPEnv s) 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 s) IO FileResponse
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT (XFTPEnv s) IO FileResponse)
-> FileResponse -> ReaderT (XFTPEnv s) 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 s) IO FileResponse
-> ReaderT (XFTPEnv s) IO FileResponse
skipCommitted (ReaderT (XFTPEnv s) IO FileResponse
 -> ReaderT (XFTPEnv s) IO FileResponse)
-> ReaderT (XFTPEnv s) IO FileResponse
-> ReaderT (XFTPEnv s) IO FileResponse
forall a b. (a -> b) -> a -> b
$ ReaderT (XFTPEnv s) IO SNICredentialUsed
-> ReaderT (XFTPEnv s) IO FileResponse
-> ReaderT (XFTPEnv s) IO FileResponse
-> ReaderT (XFTPEnv s) IO FileResponse
forall (m :: * -> *) a.
Monad m =>
m SNICredentialUsed -> m a -> m a -> m a
ifM ReaderT (XFTPEnv s) IO SNICredentialUsed
reserve ReaderT (XFTPEnv s) IO FileResponse
receive (FileResponse -> ReaderT (XFTPEnv s) IO FileResponse
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT (XFTPEnv s) IO FileResponse)
-> FileResponse -> ReaderT (XFTPEnv s) 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 s) IO FileResponse
-> ReaderT (XFTPEnv s) IO FileResponse
skipCommitted = ReaderT (XFTPEnv s) IO SNICredentialUsed
-> ReaderT (XFTPEnv s) IO FileResponse
-> ReaderT (XFTPEnv s) IO FileResponse
-> ReaderT (XFTPEnv s) IO FileResponse
forall (m :: * -> *) a.
Monad m =>
m SNICredentialUsed -> m a -> m a -> m a
ifM (Maybe String -> SNICredentialUsed
forall a. Maybe a -> SNICredentialUsed
isJust (Maybe String -> SNICredentialUsed)
-> ReaderT (XFTPEnv s) IO (Maybe String)
-> ReaderT (XFTPEnv s) IO SNICredentialUsed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe String) -> ReaderT (XFTPEnv s) IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe String)
filePath) (IO FileResponse -> ReaderT (XFTPEnv s) IO FileResponse
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileResponse -> ReaderT (XFTPEnv s) IO FileResponse)
-> IO FileResponse -> ReaderT (XFTPEnv s) 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 -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
== 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 -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
== Int
0 SNICredentialUsed -> SNICredentialUsed -> SNICredentialUsed
|| Int
bs Int -> Int -> SNICredentialUsed
forall a. Ord a => a -> a -> SNICredentialUsed
> 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
                  | SNICredentialUsed
otherwise -> Int -> IO FileResponse
drain (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bs)
          reserve :: ReaderT (XFTPEnv s) IO SNICredentialUsed
reserve = do
            TVar Int64
us <- (XFTPEnv s -> TVar Int64) -> ReaderT (XFTPEnv s) IO (TVar Int64)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> TVar Int64
forall s. XFTPEnv s -> TVar Int64
usedStorage
            Int64
quota <- (XFTPEnv s -> Int64) -> ReaderT (XFTPEnv s) IO Int64
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XFTPEnv s -> Int64) -> ReaderT (XFTPEnv s) IO Int64)
-> (XFTPEnv s -> Int64) -> ReaderT (XFTPEnv s) 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 s -> Maybe Int64) -> XFTPEnv s -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPServerConfig s -> Maybe Int64
forall s. XFTPServerConfig s -> Maybe Int64
fileSizeQuota (XFTPServerConfig s -> Maybe Int64)
-> (XFTPEnv s -> XFTPServerConfig s) -> XFTPEnv s -> Maybe Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv s -> XFTPServerConfig s
forall s. XFTPEnv s -> XFTPServerConfig s
config
            STM SNICredentialUsed -> ReaderT (XFTPEnv s) IO SNICredentialUsed
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM SNICredentialUsed -> ReaderT (XFTPEnv s) IO SNICredentialUsed)
-> ((Int64 -> (SNICredentialUsed, Int64)) -> STM SNICredentialUsed)
-> (Int64 -> (SNICredentialUsed, Int64))
-> ReaderT (XFTPEnv s) IO SNICredentialUsed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Int64
-> (Int64 -> (SNICredentialUsed, Int64)) -> STM SNICredentialUsed
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar Int64
us ((Int64 -> (SNICredentialUsed, Int64))
 -> ReaderT (XFTPEnv s) IO SNICredentialUsed)
-> (Int64 -> (SNICredentialUsed, Int64))
-> ReaderT (XFTPEnv s) IO SNICredentialUsed
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 -> SNICredentialUsed
forall a. Ord a => a -> a -> SNICredentialUsed
<= Int64
quota then (SNICredentialUsed
True, Int64
used') else (SNICredentialUsed
False, Int64
used)
          receive :: ReaderT (XFTPEnv s) IO FileResponse
receive = do
            String
path <- (XFTPEnv s -> String) -> ReaderT (XFTPEnv s) IO String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XFTPEnv s -> String) -> ReaderT (XFTPEnv s) IO String)
-> (XFTPEnv s -> String) -> ReaderT (XFTPEnv s) IO String
forall a b. (a -> b) -> a -> b
$ XFTPServerConfig s -> String
forall s. XFTPServerConfig s -> String
filesPath (XFTPServerConfig s -> String)
-> (XFTPEnv s -> XFTPServerConfig s) -> XFTPEnv s -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv s -> XFTPServerConfig s
forall s. XFTPEnv s -> XFTPServerConfig s
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 s) IO (Either XFTPErrorType ())
receiveChunk (String -> Word32 -> ByteString -> XFTPRcvChunkSpec
XFTPRcvChunkSpec String
fPath Word32
size ByteString
digest) ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
-> (Either XFTPErrorType () -> ReaderT (XFTPEnv s) IO FileResponse)
-> ReaderT (XFTPEnv s) IO FileResponse
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Right () -> do
                FileServerStats
stats <- (XFTPEnv s -> FileServerStats)
-> ReaderT (XFTPEnv s) IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> FileServerStats
forall s. XFTPEnv s -> FileServerStats
serverStats
                s
st <- (XFTPEnv s -> s) -> ReaderT (XFTPEnv s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
                IO (Either XFTPErrorType ())
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (s -> XFTPFileId -> String -> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s -> XFTPFileId -> String -> IO (Either XFTPErrorType ())
setFilePath s
st XFTPFileId
senderId String
fPath) ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
-> (Either XFTPErrorType () -> ReaderT (XFTPEnv s) IO FileResponse)
-> ReaderT (XFTPEnv s) IO FileResponse
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Right () -> do
                    (StoreLog 'WriteMode -> IO ()) -> ReaderT (XFTPEnv s) IO ()
forall a s. (StoreLog 'WriteMode -> IO a) -> M s ()
withFileLog ((StoreLog 'WriteMode -> IO ()) -> ReaderT (XFTPEnv s) IO ())
-> (StoreLog 'WriteMode -> IO ()) -> ReaderT (XFTPEnv s) IO ()
forall a b. (a -> b) -> a -> b
$ \StoreLog 'WriteMode
sl -> StoreLog 'WriteMode -> XFTPFileId -> String -> IO ()
logPutFile StoreLog 'WriteMode
sl XFTPFileId
senderId String
fPath
                    (FileServerStats -> IORef Int) -> ReaderT (XFTPEnv s) IO ()
forall s. (FileServerStats -> IORef Int) -> M s ()
incFileStat FileServerStats -> IORef Int
filesUploaded
                    (FileServerStats -> IORef Int) -> ReaderT (XFTPEnv s) IO ()
forall s. (FileServerStats -> IORef Int) -> M s ()
incFileStat FileServerStats -> IORef Int
filesCount
                    IO () -> ReaderT (XFTPEnv s) IO ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (XFTPEnv s) IO ())
-> IO () -> ReaderT (XFTPEnv s) IO ()
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 s) IO FileResponse
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileResponse
FROk
                  Left XFTPErrorType
_e -> do
                    TVar Int64
us <- (XFTPEnv s -> TVar Int64) -> ReaderT (XFTPEnv s) IO (TVar Int64)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> TVar Int64
forall s. XFTPEnv s -> TVar Int64
usedStorage
                    STM () -> ReaderT (XFTPEnv s) IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT (XFTPEnv s) IO ())
-> STM () -> ReaderT (XFTPEnv s) IO ()
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 () -> ReaderT (XFTPEnv s) IO ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (XFTPEnv s) IO ())
-> IO () -> ReaderT (XFTPEnv s) IO ()
forall a b. (a -> b) -> a -> b
$ IO SNICredentialUsed -> IO () -> IO ()
forall (m :: * -> *).
Monad m =>
m SNICredentialUsed -> m () -> m ()
whenM (String -> IO SNICredentialUsed
forall (m :: * -> *). MonadIO m => String -> m SNICredentialUsed
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 s) IO FileResponse
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT (XFTPEnv s) IO FileResponse)
-> FileResponse -> ReaderT (XFTPEnv s) IO FileResponse
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
AUTH
              Left XFTPErrorType
e -> do
                TVar Int64
us <- (XFTPEnv s -> TVar Int64) -> ReaderT (XFTPEnv s) IO (TVar Int64)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> TVar Int64
forall s. XFTPEnv s -> TVar Int64
usedStorage
                STM () -> ReaderT (XFTPEnv s) IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT (XFTPEnv s) IO ())
-> STM () -> ReaderT (XFTPEnv s) IO ()
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 () -> ReaderT (XFTPEnv s) IO ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (XFTPEnv s) IO ())
-> IO () -> ReaderT (XFTPEnv s) IO ()
forall a b. (a -> b) -> a -> b
$ IO SNICredentialUsed -> IO () -> IO ()
forall (m :: * -> *).
Monad m =>
m SNICredentialUsed -> m () -> m ()
whenM (String -> IO SNICredentialUsed
forall (m :: * -> *). MonadIO m => String -> m SNICredentialUsed
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 s) IO FileResponse
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileResponse -> ReaderT (XFTPEnv s) IO FileResponse)
-> FileResponse -> ReaderT (XFTPEnv s) IO FileResponse
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> FileResponse
FRErr XFTPErrorType
e
          receiveChunk :: XFTPRcvChunkSpec
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
receiveChunk XFTPRcvChunkSpec
spec = do
            Int
t <- (XFTPEnv s -> Int) -> ReaderT (XFTPEnv s) IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XFTPEnv s -> Int) -> ReaderT (XFTPEnv s) IO Int)
-> (XFTPEnv s -> Int) -> ReaderT (XFTPEnv s) IO Int
forall a b. (a -> b) -> a -> b
$ XFTPServerConfig s -> Int
forall s. XFTPServerConfig s -> Int
fileTimeout (XFTPServerConfig s -> Int)
-> (XFTPEnv s -> XFTPServerConfig s) -> XFTPEnv s -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv s -> XFTPServerConfig s
forall s. XFTPEnv s -> XFTPServerConfig s
config
            IO (Either XFTPErrorType ())
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either XFTPErrorType ())
 -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ()))
-> IO (Either XFTPErrorType ())
-> ReaderT (XFTPEnv s) 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 s (FileResponse, Maybe ServerFile)
    sendServerFile :: FileRec
-> PublicKey 'X25519 -> M s (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 s) IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe String)
filePath ReaderT (XFTPEnv s) IO (Maybe String)
-> (Maybe String -> M s (FileResponse, Maybe ServerFile))
-> M s (FileResponse, Maybe ServerFile)
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just String
path -> ReaderT (XFTPEnv s) IO SNICredentialUsed
-> M s (FileResponse, Maybe ServerFile)
-> M s (FileResponse, Maybe ServerFile)
-> M s (FileResponse, Maybe ServerFile)
forall (m :: * -> *) a.
Monad m =>
m SNICredentialUsed -> m a -> m a -> m a
ifM (String -> ReaderT (XFTPEnv s) IO SNICredentialUsed
forall (m :: * -> *). MonadIO m => String -> m SNICredentialUsed
doesFileExist String
path) M s (FileResponse, Maybe ServerFile)
sendFile ((FileResponse, Maybe ServerFile)
-> M s (FileResponse, Maybe ServerFile)
forall a. a -> ReaderT (XFTPEnv s) 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 :: M s (FileResponse, Maybe ServerFile)
sendFile = do
              TVar ChaChaDRG
g <- (XFTPEnv s -> TVar ChaChaDRG)
-> ReaderT (XFTPEnv s) IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> TVar ChaChaDRG
forall s. XFTPEnv s -> TVar ChaChaDRG
random
              (PublicKey 'X25519
sDhKey, PrivateKey 'X25519
spDhKey) <- STM (PublicKey 'X25519, PrivateKey 'X25519)
-> ReaderT (XFTPEnv s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey 'X25519, PrivateKey 'X25519)
 -> ReaderT (XFTPEnv s) IO (PublicKey 'X25519, PrivateKey 'X25519))
-> STM (PublicKey 'X25519, PrivateKey 'X25519)
-> ReaderT (XFTPEnv s) IO (PublicKey 'X25519, PrivateKey 'X25519)
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 -> PrivateKey 'X25519 -> DhSecretX25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKey 'X25519
rDhKey PrivateKey 'X25519
spDhKey
              CbNonce
cbNonce <- STM CbNonce -> ReaderT (XFTPEnv s) IO CbNonce
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CbNonce -> ReaderT (XFTPEnv s) IO CbNonce)
-> STM CbNonce -> ReaderT (XFTPEnv s) 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 s -> FileServerStats)
-> ReaderT (XFTPEnv s) IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> FileServerStats
forall s. XFTPEnv s -> FileServerStats
serverStats
                  (FileServerStats -> IORef Int) -> ReaderT (XFTPEnv s) IO ()
forall s. (FileServerStats -> IORef Int) -> M s ()
incFileStat FileServerStats -> IORef Int
fileDownloads
                  IO () -> ReaderT (XFTPEnv s) IO ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (XFTPEnv s) IO ())
-> IO () -> ReaderT (XFTPEnv s) IO ()
forall a b. (a -> b) -> a -> b
$ PeriodStats -> XFTPFileId -> IO ()
updatePeriodStats (FileServerStats -> PeriodStats
filesDownloaded FileServerStats
stats) XFTPFileId
senderId
                  (FileResponse, Maybe ServerFile)
-> M s (FileResponse, Maybe ServerFile)
forall a. a -> ReaderT (XFTPEnv s) 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 {$sel:filePath:ServerFile :: String
filePath = String
path, $sel:fileSize:ServerFile :: Word32
fileSize = Word32
size, SbState
$sel:sbState:ServerFile :: SbState
sbState :: SbState
sbState})
                Either CryptoError SbState
_ -> (FileResponse, Maybe ServerFile)
-> M s (FileResponse, Maybe ServerFile)
forall a. a -> ReaderT (XFTPEnv s) 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)
-> M s (FileResponse, Maybe ServerFile)
forall a. a -> ReaderT (XFTPEnv s) 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 s FileResponse
    deleteServerFile :: FileRec -> ReaderT (XFTPEnv s) 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 s) IO (Either XFTPErrorType ())
-> ReaderT (XFTPEnv s) IO FileResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FileRec -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
FileRec -> M s (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 s FileResponse
    ackFileReception :: XFTPFileId -> FileRec -> ReaderT (XFTPEnv s) IO FileResponse
ackFileReception XFTPFileId
rId FileRec
fr = do
      (StoreLog 'WriteMode -> IO ()) -> ReaderT (XFTPEnv s) IO ()
forall a s. (StoreLog 'WriteMode -> IO a) -> M s ()
withFileLog (StoreLog 'WriteMode -> XFTPFileId -> IO ()
`logAckFile` XFTPFileId
rId)
      s
st <- (XFTPEnv s -> s) -> ReaderT (XFTPEnv s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
      IO () -> ReaderT (XFTPEnv s) IO ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (XFTPEnv s) IO ())
-> IO () -> ReaderT (XFTPEnv s) IO ()
forall a b. (a -> b) -> a -> b
$ s -> XFTPFileId -> FileRec -> IO ()
forall s. FileStoreClass s => s -> XFTPFileId -> FileRec -> IO ()
deleteRecipient s
st XFTPFileId
rId FileRec
fr
      (FileServerStats -> IORef Int) -> ReaderT (XFTPEnv s) IO ()
forall s. (FileServerStats -> IORef Int) -> M s ()
incFileStat FileServerStats -> IORef Int
fileDownloadAcks
      FileResponse -> ReaderT (XFTPEnv s) IO FileResponse
forall a. a -> ReaderT (XFTPEnv s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileResponse
FROk

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

-- this also deletes the file from storage, but doesn't include it in delete statistics
blockServerFile :: FileStoreClass s => FileRec -> BlockingInfo -> M s (Either XFTPErrorType ())
blockServerFile :: forall s.
FileStoreClass s =>
FileRec -> BlockingInfo -> M s (Either XFTPErrorType ())
blockServerFile fr :: FileRec
fr@FileRec {XFTPFileId
senderId :: FileRec -> XFTPFileId
senderId :: XFTPFileId
senderId} BlockingInfo
info = do
  (StoreLog 'WriteMode -> IO ()) -> M s ()
forall a s. (StoreLog 'WriteMode -> IO a) -> M s ()
withFileLog ((StoreLog 'WriteMode -> IO ()) -> M s ())
-> (StoreLog 'WriteMode -> IO ()) -> M s ()
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)
-> (s -> IO (Either XFTPErrorType ()))
-> M s (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
FileRec
-> (FileServerStats -> IORef Int)
-> (s -> IO (Either XFTPErrorType ()))
-> M s (Either XFTPErrorType ())
deleteOrBlockServerFile_ FileRec
fr FileServerStats -> IORef Int
filesBlocked ((s -> IO (Either XFTPErrorType ()))
 -> M s (Either XFTPErrorType ()))
-> (s -> IO (Either XFTPErrorType ()))
-> M s (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ \s
st -> s
-> XFTPFileId
-> BlockingInfo
-> SNICredentialUsed
-> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s
-> XFTPFileId
-> BlockingInfo
-> SNICredentialUsed
-> IO (Either XFTPErrorType ())
blockFile s
st XFTPFileId
senderId BlockingInfo
info SNICredentialUsed
True

deleteOrBlockServerFile_ :: FileStoreClass s => FileRec -> (FileServerStats -> IORef Int) -> (s -> IO (Either XFTPErrorType ())) -> M s (Either XFTPErrorType ())
deleteOrBlockServerFile_ :: forall s.
FileStoreClass s =>
FileRec
-> (FileServerStats -> IORef Int)
-> (s -> IO (Either XFTPErrorType ()))
-> M s (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 s -> IO (Either XFTPErrorType ())
storeAction = ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
 -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ()))
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ do
  Maybe String
path <- TVar (Maybe String)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) (Maybe String)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe String)
filePath
  FileServerStats
stats <- (XFTPEnv s -> FileServerStats)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> FileServerStats
forall s. XFTPEnv s -> FileServerStats
serverStats
  ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 s) IO (Either SomeException ())
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (XFTPEnv s) IO ()
-> ReaderT (XFTPEnv s) IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Maybe String
-> (String -> ReaderT (XFTPEnv s) IO ())
-> ReaderT (XFTPEnv s) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
path ((String -> ReaderT (XFTPEnv s) IO ())
 -> ReaderT (XFTPEnv s) IO ())
-> (String -> ReaderT (XFTPEnv s) IO ())
-> ReaderT (XFTPEnv s) IO ()
forall a b. (a -> b) -> a -> b
$ \String
p -> ReaderT (XFTPEnv s) IO SNICredentialUsed
-> ReaderT (XFTPEnv s) IO () -> ReaderT (XFTPEnv s) IO ()
forall (m :: * -> *).
Monad m =>
m SNICredentialUsed -> m () -> m ()
whenM (String -> ReaderT (XFTPEnv s) IO SNICredentialUsed
forall (m :: * -> *). MonadIO m => String -> m SNICredentialUsed
doesFileExist String
p) (String -> ReaderT (XFTPEnv s) IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
p ReaderT (XFTPEnv s) IO ()
-> ReaderT (XFTPEnv s) IO () -> ReaderT (XFTPEnv s) IO ()
forall a b.
ReaderT (XFTPEnv s) IO a
-> ReaderT (XFTPEnv s) IO b -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FileServerStats -> ReaderT (XFTPEnv s) IO ()
deletedStats FileServerStats
stats))
  s
st <- (XFTPEnv s -> s)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
  ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ IO (Either XFTPErrorType ())
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either XFTPErrorType ())
 -> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ()))
-> IO (Either XFTPErrorType ())
-> ReaderT (XFTPEnv s) IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ s -> IO (Either XFTPErrorType ())
storeAction s
st
  Maybe String
-> (String -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
path ((String -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> (String -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ \String
_ -> do
    TVar Int64
us <- (XFTPEnv s -> TVar Int64)
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) (TVar Int64)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> TVar Int64
forall s. XFTPEnv s -> TVar Int64
usedStorage
    STM () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> STM () -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
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 -> Int64) -> Word32 -> Int64
forall a b. (a -> b) -> a -> b
$ FileInfo -> Word32
size FileInfo
fileInfo)
  ReaderT (XFTPEnv s) IO ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) 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 (ReaderT (XFTPEnv s) IO ()
 -> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ())
-> ReaderT (XFTPEnv s) IO ()
-> ExceptT XFTPErrorType (ReaderT (XFTPEnv s) IO) ()
forall a b. (a -> b) -> a -> b
$ (FileServerStats -> IORef Int) -> ReaderT (XFTPEnv s) IO ()
forall s. (FileServerStats -> IORef Int) -> M s ()
incFileStat FileServerStats -> IORef Int
stat
  where
    deletedStats :: FileServerStats -> ReaderT (XFTPEnv s) IO ()
deletedStats FileServerStats
stats = do
      IO () -> ReaderT (XFTPEnv s) IO ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (XFTPEnv s) IO ())
-> IO () -> ReaderT (XFTPEnv s) IO ()
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 () -> ReaderT (XFTPEnv s) IO ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (XFTPEnv s) IO ())
-> IO () -> ReaderT (XFTPEnv s) IO ()
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 :: FileStoreClass s => Maybe Int -> ExpirationConfig -> M s ()
expireServerFiles :: forall s.
FileStoreClass s =>
Maybe Int -> ExpirationConfig -> M s ()
expireServerFiles Maybe Int
itemDelay ExpirationConfig
expCfg = do
  s
st <- (XFTPEnv s -> s) -> ReaderT (XFTPEnv s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
  TVar Int64
us <- (XFTPEnv s -> TVar Int64) -> ReaderT (XFTPEnv s) IO (TVar Int64)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> TVar Int64
forall s. XFTPEnv s -> TVar Int64
usedStorage
  Int64
usedStart <- TVar Int64 -> ReaderT (XFTPEnv s) IO Int64
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Int64
us
  Int64
old <- IO Int64 -> ReaderT (XFTPEnv s) IO Int64
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> ReaderT (XFTPEnv s) IO Int64)
-> IO Int64 -> ReaderT (XFTPEnv s) IO Int64
forall a b. (a -> b) -> a -> b
$ ExpirationConfig -> IO Int64
expireBeforeEpoch ExpirationConfig
expCfg
  Int
filesCount <- IO Int -> ReaderT (XFTPEnv s) IO Int
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> ReaderT (XFTPEnv s) IO Int)
-> IO Int -> ReaderT (XFTPEnv s) IO Int
forall a b. (a -> b) -> a -> b
$ s -> IO Int
forall s. FileStoreClass s => s -> IO Int
getFileCount s
st
  Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> M s ()) -> Text -> M s ()
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 Int
filesCount Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" files"
  s -> TVar Int64 -> Int64 -> M s ()
expireLoop s
st TVar Int64
us Int64
old
  Int64
usedEnd <- TVar Int64 -> ReaderT (XFTPEnv s) IO Int64
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Int64
us
  Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> M s ()) -> Text -> M s ()
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"
    expireLoop :: s -> TVar Int64 -> Int64 -> M s ()
expireLoop s
st TVar Int64
us Int64
old = do
      [(XFTPFileId, Maybe String, Word32)]
expired <- IO [(XFTPFileId, Maybe String, Word32)]
-> ReaderT (XFTPEnv s) IO [(XFTPFileId, Maybe String, Word32)]
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(XFTPFileId, Maybe String, Word32)]
 -> ReaderT (XFTPEnv s) IO [(XFTPFileId, Maybe String, Word32)])
-> IO [(XFTPFileId, Maybe String, Word32)]
-> ReaderT (XFTPEnv s) IO [(XFTPFileId, Maybe String, Word32)]
forall a b. (a -> b) -> a -> b
$ s -> Int64 -> Int -> IO [(XFTPFileId, Maybe String, Word32)]
forall s.
FileStoreClass s =>
s -> Int64 -> Int -> IO [(XFTPFileId, Maybe String, Word32)]
expiredFiles s
st Int64
old Int
10000
      [(XFTPFileId, Maybe String, Word32)]
-> ((XFTPFileId, Maybe String, Word32) -> M s ()) -> M s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(XFTPFileId, Maybe String, Word32)]
expired (((XFTPFileId, Maybe String, Word32) -> M s ()) -> M s ())
-> ((XFTPFileId, Maybe String, Word32) -> M s ()) -> M s ()
forall a b. (a -> b) -> a -> b
$ \(XFTPFileId
sId, Maybe String
filePath_, Word32
fileSize) -> do
        (Int -> M s ()) -> Maybe Int -> M s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> M s ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Maybe Int
itemDelay
        Maybe String -> (String -> M s ()) -> M s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
filePath_ ((String -> M s ()) -> M s ()) -> (String -> M s ()) -> M s ()
forall a b. (a -> b) -> a -> b
$ \String
fp ->
          ReaderT (XFTPEnv s) IO SNICredentialUsed -> M s () -> M s ()
forall (m :: * -> *).
Monad m =>
m SNICredentialUsed -> m () -> m ()
whenM (String -> ReaderT (XFTPEnv s) IO SNICredentialUsed
forall (m :: * -> *). MonadIO m => String -> m SNICredentialUsed
doesFileExist String
fp) (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$
            String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
fp M s () -> (SomeException -> M s ()) -> M s ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
e :: SomeException) -> Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> M s ()) -> Text -> M s ()
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
fp 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
        Maybe String -> (String -> M s ()) -> M s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
filePath_ ((String -> M s ()) -> M s ()) -> (String -> M s ()) -> M s ()
forall a b. (a -> b) -> a -> b
$ \String
_ ->
          STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
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
fileSize)
        (FileServerStats -> IORef Int) -> M s ()
forall s. (FileServerStats -> IORef Int) -> M s ()
incFileStat FileServerStats -> IORef Int
filesExpired
      let sIds :: [XFTPFileId]
sIds = ((XFTPFileId, Maybe String, Word32) -> XFTPFileId)
-> [(XFTPFileId, Maybe String, Word32)] -> [XFTPFileId]
forall a b. (a -> b) -> [a] -> [b]
map (\(XFTPFileId
sId, Maybe String
_, Word32
_) -> XFTPFileId
sId) [(XFTPFileId, Maybe String, Word32)]
expired
      SNICredentialUsed -> M s () -> M s ()
forall (f :: * -> *).
Applicative f =>
SNICredentialUsed -> f () -> f ()
unless ([XFTPFileId] -> SNICredentialUsed
forall a. [a] -> SNICredentialUsed
forall (t :: * -> *) a. Foldable t => t a -> SNICredentialUsed
null [XFTPFileId]
sIds) (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
        (StoreLog 'WriteMode -> IO ()) -> M s ()
forall a s. (StoreLog 'WriteMode -> IO a) -> M s ()
withFileLog ((StoreLog 'WriteMode -> IO ()) -> M s ())
-> (StoreLog 'WriteMode -> IO ()) -> M s ()
forall a b. (a -> b) -> a -> b
$ \StoreLog 'WriteMode
sl -> (XFTPFileId -> IO ()) -> [XFTPFileId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (StoreLog 'WriteMode -> XFTPFileId -> IO ()
logDeleteFile StoreLog 'WriteMode
sl) [XFTPFileId]
sIds
        IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ s -> [XFTPFileId] -> IO ()
forall s. FileStoreClass s => s -> [XFTPFileId] -> IO ()
deleteFiles s
st [XFTPFileId]
sIds
        s -> TVar Int64 -> Int64 -> M s ()
expireLoop s
st TVar Int64
us Int64
old

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

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

withFileLog :: (StoreLog 'WriteMode -> IO a) -> M s ()
withFileLog :: forall a s. (StoreLog 'WriteMode -> IO a) -> M s ()
withFileLog StoreLog 'WriteMode -> IO a
action = IO () -> ReaderT (XFTPEnv s) IO ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (XFTPEnv s) IO ())
-> (Maybe (StoreLog 'WriteMode) -> IO ())
-> Maybe (StoreLog 'WriteMode)
-> ReaderT (XFTPEnv s) IO ()
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) -> ReaderT (XFTPEnv s) IO ())
-> ReaderT (XFTPEnv s) IO (Maybe (StoreLog 'WriteMode))
-> ReaderT (XFTPEnv s) IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XFTPEnv s -> Maybe (StoreLog 'WriteMode))
-> ReaderT (XFTPEnv s) IO (Maybe (StoreLog 'WriteMode))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> Maybe (StoreLog 'WriteMode)
forall s. XFTPEnv s -> Maybe (StoreLog 'WriteMode)
storeLog

incFileStat :: (FileServerStats -> IORef Int) -> M s ()
incFileStat :: forall s. (FileServerStats -> IORef Int) -> M s ()
incFileStat FileServerStats -> IORef Int
statSel = do
  FileServerStats
stats <- (XFTPEnv s -> FileServerStats)
-> ReaderT (XFTPEnv s) IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> FileServerStats
forall s. XFTPEnv s -> FileServerStats
serverStats
  IO () -> M s ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
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 s ()
saveServerStats :: forall s. M s ()
saveServerStats =
  (XFTPEnv s -> Maybe String)
-> ReaderT (XFTPEnv s) IO (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XFTPServerConfig s -> Maybe String
forall s. XFTPServerConfig s -> Maybe String
serverStatsBackupFile (XFTPServerConfig s -> Maybe String)
-> (XFTPEnv s -> XFTPServerConfig s) -> XFTPEnv s -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv s -> XFTPServerConfig s
forall s. XFTPEnv s -> XFTPServerConfig s
config)
    ReaderT (XFTPEnv s) IO (Maybe String)
-> (Maybe String -> ReaderT (XFTPEnv s) IO ())
-> ReaderT (XFTPEnv s) IO ()
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ReaderT (XFTPEnv s) IO ())
-> Maybe String -> ReaderT (XFTPEnv s) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
f -> (XFTPEnv s -> FileServerStats)
-> ReaderT (XFTPEnv s) IO FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> FileServerStats
forall s. XFTPEnv s -> FileServerStats
serverStats ReaderT (XFTPEnv s) IO FileServerStats
-> (FileServerStats -> ReaderT (XFTPEnv s) IO FileServerStatsData)
-> ReaderT (XFTPEnv s) IO FileServerStatsData
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO FileServerStatsData
-> ReaderT (XFTPEnv s) IO FileServerStatsData
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileServerStatsData
 -> ReaderT (XFTPEnv s) IO FileServerStatsData)
-> (FileServerStats -> IO FileServerStatsData)
-> FileServerStats
-> ReaderT (XFTPEnv s) IO FileServerStatsData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileServerStats -> IO FileServerStatsData
getFileServerStatsData ReaderT (XFTPEnv s) IO FileServerStatsData
-> (FileServerStatsData -> ReaderT (XFTPEnv s) IO ())
-> ReaderT (XFTPEnv s) IO ()
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ReaderT (XFTPEnv s) IO ()
forall a. IO a -> ReaderT (XFTPEnv s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (XFTPEnv s) IO ())
-> (FileServerStatsData -> IO ())
-> FileServerStatsData
-> ReaderT (XFTPEnv s) IO ()
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 :: FileStoreClass s => M s ()
restoreServerStats :: forall s. FileStoreClass s => M s ()
restoreServerStats = (XFTPEnv s -> Maybe String)
-> ReaderT (XFTPEnv s) IO (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XFTPServerConfig s -> Maybe String
forall s. XFTPServerConfig s -> Maybe String
serverStatsBackupFile (XFTPServerConfig s -> Maybe String)
-> (XFTPEnv s -> XFTPServerConfig s) -> XFTPEnv s -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv s -> XFTPServerConfig s
forall s. XFTPEnv s -> XFTPServerConfig s
config) ReaderT (XFTPEnv s) IO (Maybe String)
-> (Maybe String -> ReaderT (XFTPEnv s) IO ())
-> ReaderT (XFTPEnv s) IO ()
forall a b.
ReaderT (XFTPEnv s) IO a
-> (a -> ReaderT (XFTPEnv s) IO b) -> ReaderT (XFTPEnv s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ReaderT (XFTPEnv s) IO ())
-> Maybe String -> ReaderT (XFTPEnv s) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> ReaderT (XFTPEnv s) IO ()
forall {m :: * -> *} {s}.
(MonadIO m, FileStoreClass s, MonadReader (XFTPEnv s) m) =>
String -> m ()
restoreStats
  where
    restoreStats :: String -> m ()
restoreStats String
f = m SNICredentialUsed -> m () -> m ()
forall (m :: * -> *).
Monad m =>
m SNICredentialUsed -> m () -> m ()
whenM (String -> m SNICredentialUsed
forall (m :: * -> *). MonadIO m => String -> m SNICredentialUsed
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 {$sel:_filesCount:FileServerStatsData :: FileServerStatsData -> Int
_filesCount = Int
statsFilesCount, $sel:_filesSize:FileServerStatsData :: FileServerStatsData -> Int64
_filesSize = Int64
statsFilesSize} -> do
          FileServerStats
s <- (XFTPEnv s -> FileServerStats) -> m FileServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> FileServerStats
forall s. XFTPEnv s -> FileServerStats
serverStats
          s
st <- (XFTPEnv s -> s) -> m s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> s
forall s. XFTPEnv s -> s
fileStore
          Int
_filesCount <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ s -> IO Int
forall s. FileStoreClass s => s -> IO Int
getFileCount s
st
          Int64
_filesSize <- TVar Int64 -> m Int64
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar Int64 -> m Int64) -> m (TVar Int64) -> m Int64
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XFTPEnv s -> TVar Int64) -> m (TVar Int64)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XFTPEnv s -> TVar Int64
forall s. XFTPEnv s -> 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"
          SNICredentialUsed -> m () -> m ()
forall (f :: * -> *).
Applicative f =>
SNICredentialUsed -> f () -> f ()
when (Int
statsFilesCount Int -> Int -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
/= 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
          SNICredentialUsed -> m () -> m ()
forall (f :: * -> *).
Applicative f =>
SNICredentialUsed -> f () -> f ()
when (Int64
statsFilesSize Int64 -> Int64 -> SNICredentialUsed
forall a. Eq a => a -> a -> SNICredentialUsed
/= 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