add fourmolu

fourmolu.yaml

@@ -0,0 +1,30 @@
+indentation: 2
+column-limit: none
+function-arrows: trailing
+comma-style: trailing
+import-export-style: trailing
+indent-wheres: true
+record-brace-space: true
+newlines-between-decls: 1
+haddock-style: single-line
+haddock-style-module: null
+let-style: inline
+in-style: right-align
+single-constraint-parens: never
+unicode: never
+respectful: true
+fixities:
+  - infixr 9 .
+  - infixr 8 .:, .:., .=
+  - infixr 6 <>
+  - infixr 5 ++
+  - infixl 4 <$>, <$, $>,  <$$>, <$?>
+  - infixl 4 <*>, <*, *>, <**>
+  - infix 4 ==, /=
+  - infixr 3 &&
+  - infixl 3 <|>
+  - infixr 2 ||
+  - infixl 1 >>, >>=
+  - infixr 1 =<<, >=>, <=<
+  - infixr 0 $, $!
+reexports: []

src/Simplex/FileTransfer/Agent.hs

@@ -10,7 +10,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
-
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module Simplex.FileTransfer.Agent
@@ -322,8 +321,8 @@ runXFTPSndPrepareWorker c doWork = do
         if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
           then do
             fsEncPath <- toFSFilePath $ sndFileEncPath ppath
-            when (status == SFSEncrypting) $
-              whenM (doesFileExist fsEncPath) $ removeFile fsEncPath
+            when (status == SFSEncrypting) . whenM (doesFileExist fsEncPath) $
+              removeFile fsEncPath
             withStore' c $ \db -> updateSndFileStatus db sndFileId SFSEncrypting
             (digest, chunkSpecsDigests) <- encryptFileForUpload sndFile fsEncPath
             withStore c $ \db -> do
@@ -441,11 +440,11 @@ runXFTPSndWorker c srv doWork = do
           | length rcvIdsKeys > numRecipients = throwError $ INTERNAL "too many recipients"
           | length rcvIdsKeys == numRecipients = pure cr
           | otherwise = do
-            maxRecipients <- asks $ xftpMaxRecipientsPerRequest . config
-            let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients
-            rcvIdsKeys' <- agentXFTPAddRecipients c userId chunkDigest cr numRecipients'
-            cr' <- withStore' c $ \db -> addSndChunkReplicaRecipients db cr $ L.toList rcvIdsKeys'
-            addRecipients ch cr'
+              maxRecipients <- asks $ xftpMaxRecipientsPerRequest . config
+              let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients
+              rcvIdsKeys' <- agentXFTPAddRecipients c userId chunkDigest cr numRecipients'
+              cr' <- withStore' c $ \db -> addSndChunkReplicaRecipients db cr $ L.toList rcvIdsKeys'
+              addRecipients ch cr'
         sndFileToDescrs :: SndFile -> m (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient])
         sndFileToDescrs SndFile {digest = Nothing} = throwError $ INTERNAL "snd file has no digest"
         sndFileToDescrs SndFile {chunks = []} = throwError $ INTERNAL "snd file has no chunks"
@@ -573,7 +572,7 @@ runXFTPDelWorker c srv doWork = do
                 withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay
               atomically $ assertAgentForeground c
               loop
-            retryDone e = delWorkerInternalError c deletedSndChunkReplicaId e
+            retryDone = delWorkerInternalError c deletedSndChunkReplicaId
     deleteChunkReplica :: DeletedSndChunkReplica -> m ()
     deleteChunkReplica replica@DeletedSndChunkReplica {userId, deletedSndChunkReplicaId} = do
       agentXFTPDeleteChunk c userId replica

src/Simplex/FileTransfer/Client/Main.hs

@@ -9,7 +9,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
-
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module Simplex.FileTransfer.Client.Main
@@ -527,8 +526,8 @@ prepareChunkSizes size' = prepareSizes size'
     (smallSize, bigSize)
       | size' > size34 chunkSize3 = (chunkSize2, chunkSize3)
       | otherwise = (chunkSize1, chunkSize2)
-      --  | size' > size34 chunkSize2 = (chunkSize1, chunkSize2)
-      --  | otherwise = (chunkSize0, chunkSize1)
+    --  | size' > size34 chunkSize2 = (chunkSize1, chunkSize2)
+    --  | otherwise = (chunkSize0, chunkSize1)
     size34 sz = (fromIntegral sz * 3) `div` 4
     prepareSizes 0 = []
     prepareSizes size
@@ -571,11 +570,11 @@ withRetry retryCount = withRetry' retryCount . withExceptT (CLIError . show)
 removeFD :: Bool -> FilePath -> IO ()
 removeFD yes fd
   | yes = do
-    removeFile fd
-    putStrLn $ "\nFile description " <> fd <> " is deleted."
+      removeFile fd
+      putStrLn $ "\nFile description " <> fd <> " is deleted."
   | otherwise = do
-    y <- liftIO . getConfirmation $ "\nFile description " <> fd <> " can't be used again. Delete it"
-    when y $ removeFile fd
+      y <- liftIO . getConfirmation $ "\nFile description " <> fd <> " can't be used again. Delete it"
+      when y $ removeFile fd
 
 getConfirmation :: String -> IO Bool
 getConfirmation prompt = do

src/Simplex/FileTransfer/Crypto.hs

@@ -46,12 +46,12 @@ encryptFile srcFile fileHdr key nonce fileSize' encSize encFile = do
     encryptChunks_ get w (!sb, !len)
       | len == 0 = pure sb
       | otherwise = do
-        let chSize = min len 65536
-        ch <- liftIO $ get chSize
-        when (B.length ch /= fromIntegral chSize) $ throwError $ FTCEFileIOError "encrypting file: unexpected EOF"
-        let (ch', sb') = LC.sbEncryptChunk sb ch
-        liftIO $ B.hPut w ch'
-        encryptChunks_ get w (sb', len - chSize)
+          let chSize = min len 65536
+          ch <- liftIO $ get chSize
+          when (B.length ch /= fromIntegral chSize) $ throwError $ FTCEFileIOError "encrypting file: unexpected EOF"
+          let (ch', sb') = LC.sbEncryptChunk sb ch
+          liftIO $ B.hPut w ch'
+          encryptChunks_ get w (sb', len - chSize)
 
 decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO CryptoFile) -> ExceptT FTCryptoError IO CryptoFile
 decryptChunks _ [] _ _ _ = throwError $ FTCEInvalidHeader "empty"

src/Simplex/FileTransfer/Description.hs

@@ -9,7 +9,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module Simplex.FileTransfer.Description
@@ -242,9 +241,9 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
 instance (Integral a, Show a) => IsString (FileSize a) where
   fromString = either error id . strDecode . B.pack
 
-instance (FromField a) => FromField (FileSize a) where fromField f = FileSize <$> fromField f
+instance FromField a => FromField (FileSize a) where fromField f = FileSize <$> fromField f
 
-instance (ToField a) => ToField (FileSize a) where toField (FileSize s) = toField s
+instance ToField a => ToField (FileSize a) where toField (FileSize s) = toField s
 
 groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
 groupReplicasByServer defChunkSize =

src/Simplex/FileTransfer/Server.hs

@@ -169,17 +169,17 @@ processRequest :: HTTP2Request -> M ()
 processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
   | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing
   | otherwise = do
-    case xftpDecodeTransmission sessionId bodyHead of
-      Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do
-        case cmdOrErr of
-          Right cmd -> do
-            verifyXFTPTransmission sig_ signed fId cmd >>= \case
-              VRVerified req -> uncurry send =<< processXFTPRequest body req
-              VRFailed -> send (FRErr AUTH) Nothing
-          Left e -> send (FRErr e) Nothing
-        where
-          send resp = sendXFTPResponse (corrId, fId, resp)
-      Left e -> sendXFTPResponse ("", "", FRErr e) Nothing
+      case xftpDecodeTransmission sessionId bodyHead of
+        Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do
+          case cmdOrErr of
+            Right cmd -> do
+              verifyXFTPTransmission sig_ signed fId cmd >>= \case
+                VRVerified req -> uncurry send =<< processXFTPRequest body req
+                VRFailed -> send (FRErr AUTH) Nothing
+            Left e -> send (FRErr e) Nothing
+          where
+            send resp = sendXFTPResponse (corrId, fId, resp)
+        Left e -> sendXFTPResponse ("", "", FRErr e) Nothing
   where
     sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M ()
     sendXFTPResponse (corrId, fId, resp) serverFile_ = do

src/Simplex/FileTransfer/Server/Env.hs

@@ -26,7 +26,7 @@ import Simplex.FileTransfer.Server.StoreLog
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (BasicAuth, RcvPublicVerifyKey)
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams, TransportServerConfig)
+import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
 import Simplex.Messaging.Util (tshow)
 import System.IO (IOMode (..))
 import UnliftIO.STM

src/Simplex/FileTransfer/Server/Main.hs

@@ -19,7 +19,7 @@ import Options.Applicative
 import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Description (FileSize (..))
 import Simplex.FileTransfer.Server (runXFTPServer)
-import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defFileExpirationHours)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
@@ -143,9 +143,10 @@ xftpServerCLI cfgPath logPath = do
               allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini,
               newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
               fileExpiration =
-                Just defaultFileExpiration
-                  { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
-                  },
+                Just
+                  defaultFileExpiration
+                    { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
+                    },
               caCertificateFile = c caCrtFile,
               privateKeyFile = c serverKeyFile,
               certificateFile = c serverCrtFile,

src/Simplex/FileTransfer/Transport.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.FileTransfer.Transport
@@ -26,8 +25,8 @@ import Data.Word (Word32)
 import Simplex.FileTransfer.Protocol (XFTPErrorType (..))
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
-import Simplex.Messaging.Version
 import Simplex.Messaging.Transport.HTTP2.File
+import Simplex.Messaging.Version
 import System.IO (Handle, IOMode (..), withFile)
 
 data XFTPRcvChunkSpec = XFTPRcvChunkSpec
@@ -64,8 +63,8 @@ receiveEncFile getBody = receiveFile_ . receive
       ch <- getBody fileBlockSize
       let chSize = fromIntegral $ B.length ch
       if
-          | chSize > sz + authSz -> pure $ Left SIZE
-          | chSize > 0 -> do
+        | chSize > sz + authSz -> pure $ Left SIZE
+        | chSize > 0 -> do
             let (ch', rest) = B.splitAt (fromIntegral sz) ch
                 (decCh, sbState') = LC.sbDecryptChunk sbState ch'
                 sz' = sz - fromIntegral (B.length ch')
@@ -78,7 +77,7 @@ receiveEncFile getBody = receiveFile_ . receive
                     tag = LC.sbAuth sbState'
                 tag'' <- if tagSz == C.authTagSize then pure tag' else (tag' <>) <$> getBody (C.authTagSize - tagSz)
                 pure $ if BA.constEq tag'' tag then Right () else Left CRYPTO
-          | otherwise -> pure $ Left SIZE
+        | otherwise -> pure $ Left SIZE
     authSz = fromIntegral C.authTagSize
 
 receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()