hsftp (empty) → 1.3.1
raw patch · 16 files changed
+1085/−0 lines, 16 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, cmdargs, directory, filepath, filepath-bytestring, hsftp, libssh2, mtl, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, temporary, time, yaml
Files
- CHANGELOG.md +41/−0
- LICENSE +26/−0
- README.md +70/−0
- Setup.hs +2/−0
- app/Main.hs +79/−0
- hsftp.cabal +122/−0
- src/CmdOptions.hs +41/−0
- src/Commands.hs +94/−0
- src/Config.hs +103/−0
- src/Options.hs +51/−0
- src/Reader.hs +48/−0
- src/Util.hs +63/−0
- test/Spec.hs +31/−0
- test/TestCommands.hs +201/−0
- test/TestReader.hs +51/−0
- test/TestUtil.hs +62/−0
+ CHANGELOG.md view
@@ -0,0 +1,41 @@+## v1.3.1 (2024-11-12)++### Fix++- **config**: always create known_hosts file if it does not exist++## v1.3.0 (2024-11-06)++### Feat++- **commands**: only connect to server if there are files to upload+- **options**: show what would transfer on dry-run++### Refactor++- **commands**: retrieve files before connecting to server for upload++## v1.2.0 (2024-11-04)++### Feat++- **commands**: return number of files that were transferred+- **commands**: select all regular files when no extension is provided++## v1.1.0 (2024-10-28)++### Feat++- **option**: added dry-run++### Fix++- **cabal**: added dependency for tests++## v1.0.1 (2024-10-10)++### Fix++- **config**: create known_hosts file if it doesn't exist++## v1.0.0 (2024-09-27)
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2024 Maurizio Dusi++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,70 @@+# Hsftp: a SFTP client tool for secure file transfer operations.++[](https://github.com/mdusi/hsftp/actions/workflows/release.yml)++Usage of hsftp+--------------++```+Hsftp 1.3.1. Usage: hsftp OPTION++hsftp [OPTIONS] [ITEM]++Common flags:+ -c --conf=FILE Load conf from file+ --from-date=DATE Filter files by date (YYYY-MM-DD HH:MM UTC|PST|...)+ -e --extensions=ITEM Filter files by extensions+ -u --up upload+ -d --down download+ --transfer-from=DIR Folder to transfer from+ --transfer-to=ITEM Folder to transfer to+ --archive-to=DIR Folder to archive to after upload++Miscellaneous:+ --verbose=INT Verbose level: 1, 2 or 3+ -n --dry-run Do a dry-run ("No-op") transfer.+ -? --help Display help message+ -V --version Print version information+ --numeric-version Print just the version number+```++Example of conf.yaml+--------------------++```+remote:+ hostname: sftp.domain.com+ port: 22+ username: username+ password: password+ known_hosts: /home/user/.ssh/known_hosts+```++# Usage++## Download from remote to local - filter by date++```+hsftp -c conf.yaml -d \+ --transfer-from /path/to/remote/folder \+ --transfer-to /path/to/local/folder \+ --from-date "2024-06-14 12:15 PDT"+```++## Upload from local to remote - filter by extension++```+hsftp -c conf.yaml -u \+ --transfer-from /path/to/local/folder \+ --transfer-to /path/to/remote/folder \+ -e xml -e Xml+```++## Upload from local to remote - archive files locally after upload++```+hsftp -c conf.yaml -u \+ --transfer-from /path/to/local/folder \+ --transfer-to /path/to/remote/folder \+ --archive-to /path/to/local/archive/folder+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,79 @@+module Main+ ( main+ ) where++import CmdOptions ( options )++import Commands ( download, upload )++import Config++import Control.Monad ( when )+import Control.Monad.Reader++import qualified Data.ByteString.Char8 as C+import qualified Data.Yaml as Y++import Options ( Direction (..), Options (..) )++import Reader ( Env (..) )++import System.Console.CmdArgs ( cmdArgsRun )++import Util ( createFile, toDate, toEpoch )+++-- | Loads the environment configuration from a file.+--+-- The function reads the configuration file specified by the given file path,+-- decodes it using the `decodeFileEither` function from the `yaml` library,+-- and constructs an `Env` value based on the decoded configuration.+--+-- If the configuration file cannot be parsed, an error is thrown with a+-- pretty-printed parse exception.+--+-- Returns the constructed `Env` value.+loadEnv :: FilePath -> Bool -> IO Env+loadEnv cfile dryRun = do+ config <- Y.decodeFileEither cfile+ Config {..} <- case config of+ Left e -> error $ Y.prettyPrintParseException e+ Right yconf -> mkConfig yconf+ createFile configKnownHosts++ return Env { hostName = configHost+ , port = configPort+ , knownHosts = configKnownHosts+ , user = configUser+ , password = configPassword+ , transferFrom = ""+ , transferTo = ""+ , transferExtensions = []+ , archiveTo = Nothing+ , date = 0+ , noOp = dryRun+ }++main :: IO ()+main = do+ Options{..} <- cmdArgsRun options+ env <- loadEnv conf dryRun+ let date = toEpoch . toDate $ fromDate+ env' = env { date = date+ , transferFrom = src+ , transferTo = dst+ , transferExtensions = map C.pack extensions+ , archiveTo = archive+ }++ when (direction == Down) $ do+ numFiles <- runReaderT download env'+ if dryRun+ then putStrLn $ "Would download " ++ show numFiles ++ " file(s)."+ else putStrLn $ "Download completed. " ++ show numFiles ++ " file(s) downloaded."++ when (direction == Up) $ do+ numFiles <- runReaderT upload env'+ if dryRun+ then putStrLn $ "Would upload " ++ show numFiles ++ " file(s)."+ else putStrLn $ "Upload completed. " ++ show numFiles ++ " file(s) uploaded."
+ hsftp.cabal view
@@ -0,0 +1,122 @@+cabal-version: 2.2+name: hsftp+version: 1.3.1+license: BSD-3-Clause+license-file: LICENSE+copyright: (c) 2024 Maurizio Dusi+maintainer: Maurizio Dusi+author: Maurizio Dusi+homepage: https://mdusi.github.io/hsftp/+bug-reports: https://github.com/mdusi/hsftp/issues+synopsis: A SFTP client tool for secure file transfer operations+description:+ Hsftp is a command-line tool for secure file transfer operations++category: Utils, Network+build-type: Simple+extra-source-files: README.md+extra-doc-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/mdusi/hsftp++library+ exposed-modules:+ CmdOptions+ Commands+ Config+ Options+ Reader+ Util++ pkgconfig-depends: libssh2+ hs-source-dirs: src+ other-modules: Paths_hsftp+ autogen-modules: Paths_hsftp+ default-language: Haskell2010+ default-extensions: RecordWildCards+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wmissing-export-lists+ -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints++ build-depends:+ aeson >=2.1.2.1 && <2.2,+ base >=4.7 && <5,+ bytestring >=0.11.5.3 && <0.12,+ cmdargs >=0.10.22 && <0.11,+ directory >=1.3.8.4 && <1.4,+ filepath >=1.4.300.1 && <1.5,+ filepath-bytestring >=1.4.2.1.13 && <1.5,+ libssh2 >=0.2.0.9 && <0.3,+ mtl >=2.3.1 && <2.4,+ time >=1.12.2 && <1.13,+ yaml >=0.11.11.2 && <0.12++executable hsftp+ main-is: Main.hs+ pkgconfig-depends: libssh2+ hs-source-dirs: app+ other-modules: Paths_hsftp+ autogen-modules: Paths_hsftp+ default-language: Haskell2010+ default-extensions: RecordWildCards+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wmissing-export-lists+ -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ -threaded -rtsopts -with-rtsopts=-N++ build-depends:+ aeson >=2.1.2.1 && <2.2,+ base >=4.7 && <5,+ bytestring >=0.11.5.3 && <0.12,+ cmdargs >=0.10.22 && <0.11,+ directory >=1.3.8.4 && <1.4,+ filepath >=1.4.300.1 && <1.5,+ filepath-bytestring >=1.4.2.1.13 && <1.5,+ hsftp,+ libssh2 >=0.2.0.9 && <0.3,+ mtl >=2.3.1 && <2.4,+ time >=1.12.2 && <1.13,+ yaml >=0.11.11.2 && <0.12++test-suite hsftp-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ pkgconfig-depends: libssh2+ hs-source-dirs: test+ other-modules:+ TestCommands+ TestReader+ TestUtil+ Paths_hsftp++ autogen-modules: Paths_hsftp+ default-language: Haskell2010+ default-extensions: RecordWildCards+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wmissing-export-lists+ -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ -threaded -rtsopts -with-rtsopts=-N++ build-depends:+ aeson >=2.1.2.1 && <2.2,+ base >=4.7 && <5,+ bytestring >=0.11.5.3 && <0.12,+ cmdargs >=0.10.22 && <0.11,+ directory >=1.3.8.4 && <1.4,+ filepath >=1.4.300.1 && <1.5,+ filepath-bytestring >=1.4.2.1.13 && <1.5,+ hsftp,+ libssh2 >=0.2.0.9 && <0.3,+ mtl >=2.3.1 && <2.4,+ tasty >=1.4.3 && <1.5,+ tasty-hunit >=0.10.1 && <0.11,+ tasty-quickcheck >=0.10.2 && <0.11,+ tasty-smallcheck >=0.8.2 && <0.9,+ temporary >=1.3 && <1.4,+ time >=1.12.2 && <1.13,+ yaml >=0.11.11.2 && <0.12
+ src/CmdOptions.hs view
@@ -0,0 +1,41 @@+{-|+Module : CmdOptions+Description : Command-line options.+Copyright : (c) Maurizio Dusi, 2024+License : BSD+Maintainer : Maurizio Dusi+Stability : stable+Portability : POSIX++This module holds the command-line options accepted by executable.+-}++module CmdOptions+ ( options+ ) where++import Data.Version ( showVersion )++import Options ( Direction (..), Options (..) )++import Paths_hsftp ( version )++import System.Console.CmdArgs ( CmdArgs, Mode, args, cmdArgsMode,+ enum, explicit, groupname, help, name,+ program, summary, typ, (&=) )+++-- | Defines the command line options for the `hsftp` program.+options :: Mode (CmdArgs Options)+options = cmdArgsMode $ Options+ { conf = "" &= typ "FILE" &= help "Load conf from file"+ , fromDate = "" &= typ "DATE" &= help "Filter files by date (YYYY-MM-DD HH:MM UTC|PST|...)" &= explicit &= name "from-date"+ , extensions = [] &= help "Filter files by extensions"+ , direction = enum [Up &= help "upload", Down &= help "download"]+ , src = "" &= typ "DIR" &= help "Folder to transfer from" &= explicit &= name "transfer-from"+ , dst = "" &= typ "DIR" &= help "Folder to transfer to" &= explicit &= name "transfer-to"+ , archive = Nothing &= typ "DIR" &= help "Folder to archive to after upload" &= explicit &= name "archive-to"+ , verbose = 0 &= groupname "\nMiscellaneous" &= help "Verbose level: 1, 2 or 3" &= explicit &= name "verbose"+ , dryRun = False &= help "Do a dry-run (\"No-op\") transfer." &= explicit &= name "dry-run" &= name "n"+ , others = [] &= args+ } &= summary ("Hsftp " <> showVersion version <> ". Usage: hsftp OPTION") &= program "hsftp"
+ src/Commands.hs view
@@ -0,0 +1,94 @@+{-|+Module : Commands+Description : Supported commands.+Copyright : (c) Maurizio Dusi, 2024+License : BSD+Maintainer : Maurizio Dusi+Stability : stable+Portability : POSIX++This module holds a collection of supported commands.+-}+++module Commands+ ( download+ , upload+ ) where+++import Control.Monad ( filterM, unless )+import Control.Monad.Reader++import Data.Bits ( (.&.) )+import qualified Data.ByteString.Char8 as C++import Network.SSH.Client.LibSSH2+import Network.SSH.Client.LibSSH2.Foreign ( SftpAttributes (..) )++import Reader ( Env (..), ReaderIO )++import System.Directory ( copyFileWithMetadata,+ doesFileExist,+ getModificationTime,+ listDirectory,+ removeFile )+import System.FilePath ( (</>) )+import System.FilePath.ByteString ( encodeFilePath,+ isExtensionOf )++import Util ( toEpoch )+++{-|+ Download files from a remote server using SFTP.+ Both remote and local folders must exist.+ The function returns the number of files downloaded.+-}+download :: ReaderIO Int+download = do+ Env{..} <- ask++ liftIO $ withSFTPUser knownHosts user password hostName port $ \sftp -> do+ allFiles <- sftpListDir sftp transferFrom+ let byDate x = (toInteger . saMtime . snd) x >= date+ byExtension x = null transferExtensions || or [extension `isExtensionOf` fst x | extension <- transferExtensions]+ isFile = (== 0o100000) . (.&. 0o170000) . saPermissions . snd+ files = filter (\x -> byDate x && byExtension x && isFile x) allFiles+ getFile f = do+ let f' = C.unpack f+ src = transferFrom </> f'+ dst = transferTo </> f'+ sftpReceiveFile sftp dst src+ unless noOp $ mapM_ (getFile . fst) files+ return $ length files++{-|+ Upload files to a remote server using SFTP.+ Both remote and local folders must exist.+ The function returns the number of files uploaded.+-}+upload :: ReaderIO Int+upload = do+ Env{..} <- ask+ let byExtension x = null transferExtensions || or [extension `isExtensionOf` encodeFilePath x | extension <- transferExtensions]+ byDate = fmap ( (>= date) . toEpoch ) . getModificationTime+ allFiles <- liftIO $ listDirectory transferFrom >>=+ filterM ( doesFileExist . (transferFrom </>) ) >>=+ filterM ( byDate . (transferFrom </>) )+ let files = filter byExtension allFiles++ unless (noOp || null files) $+ liftIO $ withSFTPUser knownHosts user password hostName port $ \sftp -> do+ let putFile f = do+ let src = transferFrom </> f+ dst = transferTo </> f+ sftpSendFile sftp src dst 0o664+ archiveFile f = case archiveTo of+ Nothing -> return ()+ Just d -> do+ let src = transferFrom </> f+ dst = d </> f+ copyFileWithMetadata src dst >> removeFile src+ mapM_ (\x -> putFile x >> archiveFile x) files+ return $ length files
+ src/Config.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : Config+Description : Process the YAML configuration file.+Copyright : (c) Maurizio Dusi, 2024+License : BSD+Maintainer : Maurizio Dusi+Stability : stable+Portability : POSIX++This module parses a YAML file with configuration options.++__Example of conf.yaml:__++@+ remote:+ hostname: sftp.domain.com+ port: 22+ username: username+ password: password+ known_hosts: \/home\/user\/.ssh\/known_hosts+@++-}++module Config+ ( Config (..)+ , mkConfig+ ) where++import Control.Monad ( MonadPlus (mzero) )++import Data.Aeson ( FromJSON (parseJSON), (.!=), (.:) )+import qualified Data.Yaml as Y+++-- | Represents the configuration settings for the application.+data Config+ = Config { -- | The host address of the server.+ configHost :: String+ -- | The port number to connect to.+ , configPort :: Int+ -- | The username for authentication.+ , configUser :: String+ -- | The password for authentication.+ , configPassword :: String+ -- | The file path to the known hosts file.+ , configKnownHosts :: FilePath+ }+ deriving (Show)++-- | Represents a YAML configuration with a remote value.+newtype YamlConfig+ = YamlConfig { yamlRemote :: Remote }+ deriving (Show)++-- | Represents a remote SFTP configuration.+data Remote+ = Remote { remoteHost :: String+ -- ^ SFTP site+ , remotePort :: Int+ -- ^ SFTP port+ , remoteUser :: String+ -- ^ SFTP username+ , remotePassword :: String+ -- ^ SFTP password+ , remoteKnownHosts :: FilePath+ -- ^ Path to the known_hosts file+ }+ deriving (Show)++-- | Create a 'Config' from a 'YamlConfig'.+--+-- This function takes a 'YamlConfig' and extracts the necessary fields to create a 'Config' object.+-- It returns an 'IO' action that produces the resulting 'Config'.+mkConfig :: YamlConfig -> IO Config+mkConfig YamlConfig{..} = do+ let Remote {..} = yamlRemote+ return $+ Config { configHost = remoteHost+ , configPort = remotePort+ , configUser = remoteUser+ , configPassword = remotePassword+ , configKnownHosts = remoteKnownHosts+ }+++-- | Parses a JSON object into a 'YamlConfig' value.+instance FromJSON YamlConfig where+ parseJSON (Y.Object v) =+ YamlConfig <$> v .: "remote"+ parseJSON _ = mzero++-- | Parses a JSON object into a 'Remote' data type.+instance FromJSON Remote where+ parseJSON (Y.Object v) =+ Remote <$> v .: "hostname"+ <*> v .: "port" .!= 22+ <*> v .: "username"+ <*> v .: "password"+ <*> v .: "known_hosts"+ parseJSON _ = mzero
+ src/Options.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-}++{-|+Module : Options+Description : Holds the options for the hedictl utility.+Copyright : (c) Maurizio Dusi, 2024+License : BSD+Maintainer : Maurizio Dusi+Stability : stable+Portability : POSIX++This module holds the available options for the hedictl utility.+-}++module Options+ ( Direction (..)+ , Options (..)+ ) where++import Data.Data ( Data, Typeable )++data Direction+ = Up+ | Down+ deriving (Data, Eq, Show)++-- | Represents the options for the program.+data Options+ = Options { conf :: FilePath+ -- ^ Path to the configuration file.+ , fromDate :: String+ -- ^ Filter files by date (see 'toDate' for details on supported formats).+ , extensions :: [String]+ -- ^ Filter files by extensions.+ , direction :: Direction+ -- ^ Direction of the transfer.+ , src :: FilePath+ -- ^ Transfer from this folder (folder must exist).+ , dst :: FilePath+ -- ^ Transfer to this folder (folder must exist).+ , archive :: Maybe FilePath+ -- ^ Archive into this folder after successful upload (folder must exist).+ , verbose :: Int+ -- ^ Verbose level.+ , dryRun :: Bool+ -- ^ Do a dry-run (no-op) transfer.+ , others :: [FilePath]+ -- ^ List of files and/or folders.+ }+ deriving stock (Data, Show, Typeable)
+ src/Reader.hs view
@@ -0,0 +1,48 @@+{-|+Module : Reader+Description : Holds environment variables.+Copyright : (c) Maurizio Dusi, 2024+License : BSD+Maintainer : Maurizio Dusi+Stability : stable+Portability : POSIX++This module holds the environment variables used by the program.+-}++module Reader+ ( Env (..)+ , ReaderIO+ ) where++import Control.Monad.Reader ( ReaderT )++import qualified Data.ByteString as B++-- | Represents the environment configuration for the SFTP client.+data Env+ = Env { hostName :: String+ -- ^ The hostname of the SFTP server.+ , port :: Int+ -- ^ The port number to connect to.+ , user :: String+ -- ^ The username for authentication.+ , password :: String+ -- ^ The password for authentication.+ , knownHosts :: FilePath+ -- ^ The path to the known hosts file.+ , transferFrom :: FilePath+ -- ^ The source file path for transfer.+ , transferTo :: FilePath+ -- ^ The destination file path for transfer.+ , transferExtensions :: [B.ByteString]+ -- ^ The list of file extensions to transfer.+ , archiveTo :: Maybe FilePath+ -- ^ Optional path to archive transferred files.+ , date :: Integer+ -- ^ The date for filtering files to transfer.+ , noOp :: Bool+ -- ^ Whether or not to perform the actual transfer.+ }++type ReaderIO = ReaderT Env IO
+ src/Util.hs view
@@ -0,0 +1,63 @@+{-|+Module : Util+Description : Collections of utility functions.+Copyright : (c) Maurizio Dusi, 2024+License : BSD+Maintainer : Maurizio Dusi+Stability : stable+Portability : POSIX++This module provides utility functions for file, date and time manipulation.++-}+++module Util+ ( createFile+ , toDate+ , toEpoch+ ) where++import Control.Monad ( unless )++import Data.Time++import System.Directory ( doesFileExist )++{-|+ Convert a string to seconds since Epoch.+ The input string should be in the format %F %R %Z (YYYY-MM-DD HH-mm and abbreviated time zone name).+ If the parsing fails, it defaults to the beginning of Epoch (i.e., zero).++ Example usage:++ >>> toDate "2022-01-01 12:00 UTC"+ 2022-01-01 12:00:00 UTC+-}+toDate :: String -> UTCTime+toDate d = case parseTimeM True defaultTimeLocale "%F %R %Z" d of+ Just x -> x+ Nothing -> UTCTime (fromGregorian 1970 01 01) (secondsToDiffTime 0)++{-|+ Convert a 'UTCTime' value to seconds since Epoch.++ Example usage:++ >>> toEpoch (UTCTime (fromGregorian 2022 01 01) (secondsToDiffTime 0))+ 1640995200+-}+toEpoch :: UTCTime -> Integer+toEpoch d = read $ formatTime defaultTimeLocale "%s" d++{-|+ Create a file if it does not exist.++ Example usage:++ >>> createFile "test.txt"+-}+createFile :: FilePath -> IO ()+createFile cfile = do+ fileExists <- doesFileExist cfile+ unless fileExists $ writeFile cfile ""
+ test/Spec.hs view
@@ -0,0 +1,31 @@+{-|+Module : Main+Description : Main entry point for the test suite for SFTP actions.+Copyright : (c) Maurizio Dusi, 2024+License : BSD+Maintainer : Maurizio Dusi+Stability : stable+Portability : POSIX++This module defines the main entry point for the test suite, including+setup and teardown operations for testing SFTP commands such as downloading+and uploading files.+-}++module Main+ ( main+ ) where++import Test.Tasty ( TestTree, defaultMain, testGroup )++import TestCommands ( sftpDownloadTests, sftpUploadTests )++import TestReader ( readerTests )++import TestUtil ( utilTests )++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [sftpDownloadTests, sftpUploadTests, utilTests, readerTests]
+ test/TestCommands.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : TestCommands+Description : Test functions for SFTP actions.+Copyright : (c) Maurizio Dusi, 2024+License : BSD+Maintainer : Maurizio Dusi+Stability : stable+Portability : POSIX++This module defines functions for testing SFTP actions such as downloading+and uploading files.+-}++module TestCommands+ ( sftpDownloadTests+ , sftpUploadTests+ ) where++import Commands ( download, upload )++import Control.Monad ( filterM )+import Control.Monad.Reader++import Reader ( Env (..) )++import System.Directory ( createDirectoryIfMissing,+ doesFileExist, listDirectory,+ removeDirectoryRecursive )+import System.FilePath ( (</>) )+import System.FilePath.ByteString ( encodeFilePath, isExtensionOf )+import System.IO ( hClose, openTempFile )++import Test.Tasty ( TestTree, testGroup,+ withResource )+import Test.Tasty.HUnit+++-- | Represents the test environment configuration.+data TestEnv+ = TestEnv { sftpHost :: String+ , sftpPort :: Int+ , sftpUser :: String+ , sftpPass :: String+ , repoLocalDir :: String+ , sftpRemoteDir :: String+ , sftpLocalBaseDir :: String+ }+ deriving (Show)++uploadConfs :: TestEnv+uploadConfs = TestEnv { sftpHost = "0.0.0.0"+ , sftpPort = 9988+ , sftpUser = "demo"+ , sftpPass = "demo"+ , repoLocalDir = "./test/files/upload"+ , sftpRemoteDir = "/upload"+ , sftpLocalBaseDir = "/tmp/hsftp-u"+ }++downloadConfs :: TestEnv+downloadConfs = TestEnv { sftpHost = "0.0.0.0"+ , sftpPort = 9988+ , sftpUser = "demo"+ , sftpPass = "demo"+ , repoLocalDir = "./test/files/download"+ , sftpRemoteDir = "/download"+ , sftpLocalBaseDir = "/tmp/hsftp-d"+ }++-- | Acquires a resource and returns an 'Env' configuration.+-- The resource is acquired by creating a directory if it doesn't exist,+-- and opening a temporary file in the specified directory.+-- The 'Env' configuration includes details such as host name, port, user credentials,+-- and the path to the known hosts file.+acquireResource :: TestEnv -> IO Env+acquireResource teConfs = do+ let TestEnv {..} = teConfs+ createDirectoryIfMissing True sftpLocalBaseDir++ (knownHostsFile, hKnownHostsFile) <- openTempFile sftpLocalBaseDir "known_hosts"+ hClose hKnownHostsFile+ let env = Env { hostName = sftpHost+ , port = sftpPort+ , user = sftpUser+ , password = sftpPass+ , date = 0+ , archiveTo = Nothing+ , knownHosts = knownHostsFile+ , transferFrom = ""+ , transferTo = ""+ , transferExtensions = []+ , noOp = False+ }+ return env+++-- | Release the resource by removing the local base directory and its contents.+--+-- This function takes a 'TestEnv' configuration and an 'Env' configuration.+-- It removes the local base directory and all its contents using the 'removeDirectoryRecursive' function.+releaseResource :: TestEnv -> Env -> IO ()+releaseResource teConfs _env = do+ removeDirectoryRecursive $ sftpLocalBaseDir teConfs+++-- | This function defines the test tree for the SFTP upload command.+sftpUploadTests :: TestTree+sftpUploadTests =+ withResource (acquireResource uploadConfs) (releaseResource uploadConfs) $ \getResource ->+ testGroup "SFTP Upload tests" $+ let TestEnv {..} = uploadConfs+ in+ [ testCase "Filter by extension" $ do+ env <- getResource+ let extensions = ["log"]+ byExtension x = null extensions || or [extension `isExtensionOf` encodeFilePath x | extension <- extensions]+ env' = env { transferFrom = repoLocalDir+ , transferTo = sftpRemoteDir </> "byext"+ , transferExtensions = extensions+ }++ numFiles <- runReaderT upload env'+ allFiles <- listDirectory repoLocalDir >>= filterM ( doesFileExist . (repoLocalDir </>) )+ let expectedFiles = filter byExtension allFiles+ expectedNumFiles = length expectedFiles+ numFiles @?= expectedNumFiles++ , testCase "Any extension" $ do+ env <- getResource+ let env' = env { transferFrom = repoLocalDir+ , transferTo = sftpRemoteDir </> "anyext"+ }++ numFiles <- runReaderT upload env'+ expectedFiles <- listDirectory repoLocalDir >>= filterM ( doesFileExist . (repoLocalDir </>) )+ numFiles @?= length expectedFiles++ , testCase "Upload and archive" $ do+ env <- getResource+ let archiveFromDir = sftpLocalBaseDir </> "toarchive"+ archiveToDir = sftpLocalBaseDir </> "archived"+ mapM_ (createDirectoryIfMissing False) [archiveFromDir, archiveToDir]+ (_archiveFile, hArchiveFile) <- openTempFile archiveFromDir "testfile.ark"+ hClose hArchiveFile++ let extensions = ["ark"]+ byExtension x = null extensions || or [extension `isExtensionOf` encodeFilePath x | extension <- extensions]+ env' = env { transferFrom = archiveFromDir+ , transferTo = sftpRemoteDir </> "archive"+ , archiveTo = Just archiveToDir+ , transferExtensions = extensions+ }++ numFiles <- runReaderT upload env'+ allFiles <- listDirectory archiveToDir >>= filterM ( doesFileExist . (archiveToDir </>) )+ let expectedFiles = filter byExtension allFiles+ expectedNumFiles = length expectedFiles+ numFiles @?= expectedNumFiles+ ]+++-- | This function defines the test tree for the SFTP download command.+sftpDownloadTests :: TestTree+sftpDownloadTests =+ withResource (acquireResource downloadConfs) (releaseResource downloadConfs) $ \getResource ->+ testGroup "SFTP Download tests" $+ let TestEnv {..} = downloadConfs+ in+ [ testCase "Filter by extension" $ do+ env <- getResource+ let testFolder = sftpLocalBaseDir </> "byext"+ createDirectoryIfMissing False testFolder++ let extensions = ["log"]+ env' = env { transferFrom = sftpRemoteDir+ , transferTo = testFolder+ , transferExtensions = extensions+ }+ byExtension x = null extensions || or [extension `isExtensionOf` encodeFilePath x | extension <- extensions]++ numFiles <- runReaderT download env'+ allFiles <- listDirectory repoLocalDir >>= filterM ( doesFileExist . (repoLocalDir </>) )+ let expectedFiles = filter byExtension allFiles+ expectedNumFiles = length expectedFiles+ numFiles @?= expectedNumFiles++ , testCase "Any extension" $ do+ env <- getResource+ let testFolder = sftpLocalBaseDir </> "anyext"+ createDirectoryIfMissing False testFolder++ let env' = env { transferFrom = sftpRemoteDir+ , transferTo = testFolder+ }+ numFiles <- runReaderT download env'+ expectedFiles <- listDirectory repoLocalDir >>= filterM ( doesFileExist . (repoLocalDir </>) )+ numFiles @?= length expectedFiles+ ]
+ test/TestReader.hs view
@@ -0,0 +1,51 @@+{-|+Module : TestReader+Description : Test functions for the Reader module.+Copyright : (c) Maurizio Dusi, 2024+License : BSD+Maintainer : Maurizio Dusi+Stability : stable+Portability : POSIX++This module defines functions for testing functions within the Reader module.+-}++module TestReader+ ( readerTests+ ) where++import Reader ( Env (..) )++import Test.Tasty ( TestTree, testGroup )+import Test.Tasty.HUnit ( testCase, (@?=) )+++readerTests :: TestTree+readerTests =+ testGroup "Reader tests"+ [ testCase "Environment initialization" $ do+ let env = Env { hostName = "localhost"+ , port = 22+ , user = "testuser"+ , password = "testpass"+ , knownHosts = "/path/to/known_hosts"+ , transferFrom = "/path/to/source"+ , transferTo = "/path/to/destination"+ , transferExtensions = []+ , archiveTo = Nothing+ , date = 0+ , noOp = False+ }++ hostName env @?= "localhost"+ port env @?= 22+ user env @?= "testuser"+ password env @?= "testpass"+ knownHosts env @?= "/path/to/known_hosts"+ transferFrom env @?= "/path/to/source"+ transferTo env @?= "/path/to/destination"+ transferExtensions env @?= []+ archiveTo env @?= Nothing+ date env @?= 0+ noOp env @?= False+ ]
+ test/TestUtil.hs view
@@ -0,0 +1,62 @@+{-|+Module : TestUtil+Description : Test functions for the Util module.+Copyright : (c) Maurizio Dusi, 2024+License : BSD+Maintainer : Maurizio Dusi+Stability : stable+Portability : POSIX++This module defines functions for testing functions within the Util module.+-}++module TestUtil+ ( utilTests+ ) where++import Data.Time++import System.Directory ( doesFileExist )+import System.IO.Temp ( withTempFile )++import Test.Tasty ( TestTree, testGroup )+import Test.Tasty.HUnit ( testCase, (@?=) )++import Util ( createFile, toDate, toEpoch )++utilTests :: TestTree+utilTests =+ testGroup "Util tests"+ [ testCase "epoch zero" $ do+ let date = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0)+ -- Expected epoch time for the above date is 0+ toEpoch date @?= 0++ , testCase "toEpoch" $ do+ let date2020 = UTCTime (fromGregorian 2020 1 1) (secondsToDiffTime 0)+ -- Expected epoch time for January 1, 2020.+ let expectedEpoch2020 = 1577836800+ toEpoch date2020 @?= expectedEpoch2020++ , testCase "createFile" $ do+ withTempFile "/tmp" "known_hosts" $ \tmpFile _ -> do+ -- Create a temporary file+ createFile tmpFile+ -- Check if the file exists+ exists <- doesFileExist tmpFile+ exists @?= True++ , testCase "toDate - correct format" $ do+ let date = "2022-01-01 00:00 UTC"+ -- Expected date for the above string is January 1, 2022, 00:00:00 UTC+ let expectedDate = UTCTime (fromGregorian 2022 1 1) (secondsToDiffTime 0)+ -- Convert the string to a UTCTime value+ toDate date @?= expectedDate++ , testCase "toDate - incorrect format" $ do+ let date = "2022-01-01 UTC"+ -- Expected date for the above string is January 1, 2022, 00:00:00 UTC+ let expectedDate = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0)+ -- Convert the string to a UTCTime value+ toDate date @?= expectedDate+ ]