diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,70 @@ +# Hsftp: a SFTP client tool for secure file transfer operations. + +[![Release](https://github.com/mdusi/hsftp/actions/workflows/release.yml/badge.svg)](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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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." diff --git a/hsftp.cabal b/hsftp.cabal new file mode 100644 --- /dev/null +++ b/hsftp.cabal @@ -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 diff --git a/src/CmdOptions.hs b/src/CmdOptions.hs new file mode 100644 --- /dev/null +++ b/src/CmdOptions.hs @@ -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" diff --git a/src/Commands.hs b/src/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Commands.hs @@ -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 diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -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 diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -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) diff --git a/src/Reader.hs b/src/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Reader.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -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 "" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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] diff --git a/test/TestCommands.hs b/test/TestCommands.hs new file mode 100644 --- /dev/null +++ b/test/TestCommands.hs @@ -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 + ] diff --git a/test/TestReader.hs b/test/TestReader.hs new file mode 100644 --- /dev/null +++ b/test/TestReader.hs @@ -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 + ] diff --git a/test/TestUtil.hs b/test/TestUtil.hs new file mode 100644 --- /dev/null +++ b/test/TestUtil.hs @@ -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 + ]