diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,24 @@ # Revision history for spacecookie +## 1.1.0.0 + +2026-04-06 + +* **API BREAKING CHANGE**: Remove `Network.Gopher.Util`. + Previous users of these utilities are encouraged to copy the utilities + from 1.0.0.3 into their own code and adapt them to their needs. +* Migrate from `filepath-bytestring` to `filepath >= 1.5.2` and + `os-string >= 2.0.6`. These changes have been tested with GHC 9.10.3, + GHC 9.12.3 and 9.14.1. + + - **API BREAKING CHANGE**: `GophermapFilePath` now uses `PosixPath` + for `GophermapAbsolute` and `GophermapRelative`. + - Added `ToGopherLogStr` instance for `PosixString` +* Fix crash on malformed port values when parsing a gophermap using + `Network.Gopher.Util.Gophermap`. +* Fix crashes if encoding assumptions are violated in `GopherLogStr` + when converting to `String` or the `Text` types. + ## 1.0.0.3 2025-05-03 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,9 +2,20 @@ Haskell gopher server daemon and library. +## Status + +* The author doesn't run spacecookie in production (anymore). + In this sense it can be considered unproven software. +* A known issue is that spacecookie [doesn't use text file + transactions for ASCII files](https://github.com/sternenseemann/spacecookie/issues/46). + which works well with all tested clients. It should + still be fixed, but it is unclear what the best approach + for detecting the correct transaction type would be. +* Development is essentially in maintenance mode. + ## Features -* implements RFC1436 +* (mostly) implements RFC1436 * optionally supports common protocol extensions: * informational entries via the `i`-type * [`h`-type and URL entries](http://gopher.quux.org:70/Archives/Mailing%20Lists/gopher/gopher.2002-02%7C/MBOX-MESSAGE/34) @@ -129,4 +140,5 @@ Windows support would be possible, but could be tricky as gopher expects Unix-style directory separators in paths. I personally don't want to invest time into it, but would accept patches adding -Windows support. +Windows support. For now, spacecookie will fail to compile on non-POSIX +platforms. diff --git a/docs/man/spacecookie.1 b/docs/man/spacecookie.1 --- a/docs/man/spacecookie.1 +++ b/docs/man/spacecookie.1 @@ -48,7 +48,7 @@ Allowed files are returned to clients unfiltered. For directories, .Nm checks if they contain a -.Ql .gophermap +.Pa .gophermap file: If they contain one, it is used to generate the directory response, otherwise one is generated automatically which involves guessing all file types from file extensions. @@ -56,7 +56,7 @@ .Ql 0 , text file. The file format of the -.Ql gophermap +.Pa .gophermap files and its use are explained in .Xr spacecookie.gophermap 5 . .Sh SYSTEMD INTEGRATION @@ -123,7 +123,7 @@ file are provided in the .Nm source distribution in the -.Ql etc +.Pa etc directory. .Sh SEE ALSO .Xr spacecookie.json 5 , @@ -162,7 +162,7 @@ supports. .Pp TLS-enabled gopher, like the -.Ql gophers +.Ql gophers:// protocol supported by .Xr curl 1 is not natively supported by diff --git a/server/Main.hs b/server/Main.hs --- a/server/Main.hs +++ b/server/Main.hs @@ -1,18 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} import Network.Spacecookie.Config import Network.Spacecookie.FileType +import Network.Spacecookie.Path import Network.Spacecookie.Systemd import Paths_spacecookie (version) import Network.Gopher -import Network.Gopher.Util (sanitizePath, boolToMaybe, dropPrivileges) import Network.Gopher.Util.Gophermap import qualified Data.ByteString as B -import Control.Applicative ((<|>)) +import Data.ByteString.Short (fromShort) import Control.Exception (catches, Handler (..)) import Control.Monad (when, unless) -import Data.Aeson (eitherDecodeFileStrict') +import Data.Aeson (eitherDecodeStrict') import Data.Attoparsec.ByteString (parseOnly) import Data.Bifunctor (first) import Data.ByteString.Builder (Builder ()) @@ -20,15 +21,19 @@ import Data.Maybe (fromMaybe) import Data.Version (showVersion) import System.Console.GetOpt -import System.Directory (doesFileExist, getDirectoryContents) +import System.Directory.OsPath (doesFileExist, listDirectory) import System.Environment import System.Exit -import System.FilePath.Posix.ByteString ( RawFilePath, takeFileName, () - , dropDrive, decodeFilePath - , encodeFilePath) +import qualified System.File.OsPath as F +import qualified System.OsPath as OP +import System.OsPath.Posix ( PosixPath, takeFileName, () + , dropDrive, normalise) +import qualified System.OsString.Posix as Posix +import System.OsString.Internal.Types (PosixString (..), OsString (..)) import qualified System.Log.FastLogger as FL import System.Posix.Directory (changeWorkingDirectory) import System.Socket (SocketException ()) +import System.Posix.User data Flags = Version | Usage @@ -42,18 +47,18 @@ main = do args <- getArgs case getOpt Permute options args of - ([], [configFile], []) -> runServer configFile + ([], [configFile], []) -> runServer =<< OP.encodeUtf configFile -- this works because we only have two flags atm ([Version], _, []) -> putStrLn $ showVersion version (_, _, []) -> printUsage (_, _, es) -> die . mconcat $ "errors occurred while parsing options:\n":es -runServer :: FilePath -> IO () +runServer :: OP.OsPath -> IO () runServer configFile = do doesFileExist configFile >>= (flip unless) (die "could not open config file") - config' <- eitherDecodeFileStrict' configFile + config' <- eitherDecodeStrict' <$> F.readFile' configFile case config' of Left err -> die $ "failed to parse config: " ++ err Right config -> do @@ -89,13 +94,22 @@ cfg (spacecookie logIO) +-- | If 'runUserName' is configured, call 'setGroupID' and 'setUserID' +-- to switch to the given user and their primary group. +-- Requires special privileges (usually root). Will raise an exception if +-- either the user does not exist or the current user has no permission to +-- change UID/GID. +-- +-- After that, notify systemd that we are ready if applicable. afterSocketSetup :: GopherLogHandler -> Config -> IO () afterSocketSetup logIO cfg = do case runUserName cfg of Nothing -> pure () - Just u -> do - dropPrivileges u - logIO GopherLogLevelInfo $ "Changed to user " <> toGopherLogStr u + Just username -> do + user <- getUserEntryForName username + setGroupID $ userGroupID user + setUserID $ userID user + logIO GopherLogLevelInfo $ "Changed to user " <> toGopherLogStr username _ <- notifyReady pure () @@ -106,7 +120,9 @@ mconcat [ "Usage: ", n, " CONFIG\n" ] makeLogHandler :: LogConfig -> IO (Maybe (GopherLogHandler, IO ())) -makeLogHandler lc = +makeLogHandler lc + | not (logEnable lc) = pure Nothing + | otherwise = let wrapTimedLogger :: FL.TimedFastLogger -> FL.FastLogger wrapTimedLogger logger str = logger $ (\t -> "[" <> FL.toLogStr t <> "]" <> str) @@ -125,14 +141,14 @@ <> ((FL.toLogStr :: Builder -> FL.LogStr) . fromGopherLogStr . processMsg $ msg) <> "\n" logType = FL.LogStderr FL.defaultBufSize - in sequenceA . boolToMaybe (logEnable lc) $ do + in do (logger, cleanup) <- if logHideTime lc then FL.newFastLogger logType else first wrapTimedLogger <$> do timeCache <- FL.newTimeCache FL.simpleTimeFormat FL.newTimedFastLogger timeCache logType - pure (logHandler logger, cleanup) + pure $ Just (logHandler logger, cleanup) noLog :: GopherLogHandler noLog = const . const $ pure () @@ -140,7 +156,7 @@ spacecookie :: GopherLogHandler -> GopherRequest -> IO GopherResponse spacecookie logger req = do let selector = requestSelector req - path = "." dropDrive (sanitizePath selector) + path = normalise $ dropDrive $ sanitizePath (Posix.fromBytestring selector) pt <- gopherFileType path case pt of @@ -165,37 +181,34 @@ Directory -> gophermapResponse logger path _ -> fileResponse logger path -fileResponse :: GopherLogHandler -> RawFilePath -> IO GopherResponse -fileResponse _ path = FileResponse <$> B.readFile (decodeFilePath path) - -makeAbsolute :: RawFilePath -> RawFilePath -makeAbsolute x = fromMaybe x - $ boolToMaybe ("./" `B.isPrefixOf` x) (B.tail x) - <|> boolToMaybe ("." == x) "/" +fileResponse :: GopherLogHandler -> PosixPath -> IO GopherResponse +fileResponse _ path = FileResponse <$> F.readFile' (OsString path) -directoryResponse :: GopherLogHandler -> RawFilePath -> IO GopherResponse +directoryResponse :: GopherLogHandler -> PosixPath -> IO GopherResponse directoryResponse _ path = - let makeItem :: Either a GopherFileType -> RawFilePath -> Either a GopherMenuItem + let makeItem :: Either a GopherFileType -> PosixPath -> Either a GopherMenuItem makeItem t file = do fileType <- t pure $ - Item fileType (takeFileName file) file Nothing Nothing + Item fileType (pathToBS $ takeFileName file) (pathToBS file) Nothing Nothing in do - dir <- map ((path ) . encodeFilePath) - <$> getDirectoryContents (decodeFilePath path) + dir <- map ((path ) . getOsString) + <$> listDirectory (OsString path) fileTypes <- mapM gopherFileType dir pure . MenuResponse . rights $ zipWith makeItem fileTypes (map makeAbsolute dir) + where + pathToBS :: PosixPath -> B.ByteString + pathToBS = fromShort . getPosixString -gophermapResponse :: GopherLogHandler -> RawFilePath -> IO GopherResponse +gophermapResponse :: GopherLogHandler -> PosixPath -> IO GopherResponse gophermapResponse logger path = do - let gophermap = path ".gophermap" - gophermapWide = decodeFilePath gophermap - exists <- doesFileExist gophermapWide + let gophermap = path [Posix.pstr|.gophermap|] + exists <- doesFileExist $ OsString gophermap parsed <- if exists - then parseOnly parseGophermap <$> B.readFile gophermapWide + then parseOnly parseGophermap <$> F.readFile' (OsString gophermap) else pure $ Left "Gophermap file does not exist" case parsed of Left err -> do diff --git a/server/Network/Spacecookie/Config.hs b/server/Network/Spacecookie/Config.hs --- a/server/Network/Spacecookie/Config.hs +++ b/server/Network/Spacecookie/Config.hs @@ -10,9 +10,9 @@ import Data.Aeson import Data.Aeson.Types (Parser ()) import Data.ByteString (ByteString ()) +import qualified Data.ByteString.UTF8 as UTF8 import Data.Text (toLower, Text ()) import Network.Gopher (GopherLogLevel (..)) -import Network.Gopher.Util data Config = Config @@ -84,8 +84,5 @@ parseJSON _ = mzero instance FromJSON ByteString where - parseJSON s@(String _) = uEncode <$> parseJSON s + parseJSON s@(String _) = UTF8.fromString <$> parseJSON s parseJSON _ = mzero - -instance ToJSON ByteString where - toJSON = toJSON . uDecode diff --git a/server/Network/Spacecookie/FileType.hs b/server/Network/Spacecookie/FileType.hs --- a/server/Network/Spacecookie/FileType.hs +++ b/server/Network/Spacecookie/FileType.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Network.Spacecookie.FileType ( PathError (..) , gopherFileType @@ -7,65 +7,84 @@ , checkNoDotFiles ) where -import Control.Applicative ((<|>)) -import qualified Data.ByteString as B +import Network.Spacecookie.Path (containsDotFiles) + +import Data.Char (ord, toLower) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Network.Gopher (GopherFileType (..)) -import Network.Gopher.Util (boolToMaybe, asciiToLower) -import System.Directory (doesDirectoryExist, doesFileExist) -import System.FilePath.Posix.ByteString ( RawFilePath, takeExtension - , splitDirectories, decodeFilePath) +import System.Directory.OsPath (doesDirectoryExist, doesFileExist) +import System.OsPath.Posix (PosixPath, takeExtension) +import System.OsString.Posix (PosixString, pstr) +import qualified System.OsString.Posix as Posix +import System.OsString.Internal.Types (OsString (..), PosixChar (..)) -fileTypeMap :: M.Map RawFilePath GopherFileType +fileTypeMap :: M.Map PosixString GopherFileType fileTypeMap = M.fromList - [ (".gif", GifFile) - , (".png", ImageFile) - , (".jpg", ImageFile) - , (".jpeg", ImageFile) - , (".tiff", ImageFile) - , (".tif", ImageFile) - , (".bmp", ImageFile) - , (".webp", ImageFile) - , (".apng", ImageFile) - , (".mng", ImageFile) - , (".heif", ImageFile) - , (".heifs", ImageFile) - , (".heic", ImageFile) - , (".heics", ImageFile) - , (".avci", ImageFile) - , (".avcs", ImageFile) - , (".avif", ImageFile) - , (".avifs", ImageFile) - , (".ico", ImageFile) - , (".svg", ImageFile) - , (".raw", ImageFile) -- TODO: RAW files should maybe be binary files? - , (".cr2", ImageFile) - , (".nef", ImageFile) - , (".json", File) - , (".txt", File) - , (".text", File) - , (".md", File) - , (".mdown", File) - , (".mkdn", File) - , (".mkd", File) - , (".markdown", File) - , (".adoc", File) - , (".rst", File) - , (".zip", BinaryFile) - , (".tar", BinaryFile) - , (".gz", BinaryFile) - , (".bzip2", BinaryFile) - , (".xz", BinaryFile) - , (".tgz", BinaryFile) - , (".doc", BinaryFile) - , (".hqx", BinHexMacintoshFile) + [ ([pstr|.gif|], GifFile) + , ([pstr|.png|], ImageFile) + , ([pstr|.jpg|], ImageFile) + , ([pstr|.jpeg|], ImageFile) + , ([pstr|.tiff|], ImageFile) + , ([pstr|.tif|], ImageFile) + , ([pstr|.bmp|], ImageFile) + , ([pstr|.webp|], ImageFile) + , ([pstr|.apng|], ImageFile) + , ([pstr|.mng|], ImageFile) + , ([pstr|.heif|], ImageFile) + , ([pstr|.heifs|], ImageFile) + , ([pstr|.heic|], ImageFile) + , ([pstr|.heics|], ImageFile) + , ([pstr|.avci|], ImageFile) + , ([pstr|.avcs|], ImageFile) + , ([pstr|.avif|], ImageFile) + , ([pstr|.avifs|], ImageFile) + , ([pstr|.ico|], ImageFile) + , ([pstr|.svg|], ImageFile) + , ([pstr|.raw|], ImageFile) -- TODO: RAW files should maybe be binary files? + , ([pstr|.cr2|], ImageFile) + , ([pstr|.nef|], ImageFile) + , ([pstr|.json|], File) + , ([pstr|.txt|], File) + , ([pstr|.text|], File) + , ([pstr|.md|], File) + , ([pstr|.mdown|], File) + , ([pstr|.mkdn|], File) + , ([pstr|.mkd|], File) + , ([pstr|.markdown|], File) + , ([pstr|.adoc|], File) + , ([pstr|.rst|], File) + , ([pstr|.zip|], BinaryFile) + , ([pstr|.tar|], BinaryFile) + , ([pstr|.gz|], BinaryFile) + , ([pstr|.bzip2|], BinaryFile) + , ([pstr|.xz|], BinaryFile) + , ([pstr|.tgz|], BinaryFile) + , ([pstr|.doc|], BinaryFile) + , ([pstr|.hqx|], BinHexMacintoshFile) ] -lookupSuffix :: RawFilePath -> GopherFileType +-- | Transform a 'Word8' to lowercase if the solution is in bounds. +-- +-- >>> asciiToLower 65 +-- 97 +-- >>> asciiToLower 97 +-- 97 +-- >>> asciiToLower 220 +-- 220 +-- >>> asciiToLower 252 +-- 252 +asciiToLower :: PosixChar -> PosixChar +asciiToLower orig + | getPosixChar orig > 127 || ord lower > 127 = orig + | otherwise = Posix.unsafeFromChar lower + where lower :: Char + lower = toLower $ Posix.toChar orig + +lookupSuffix :: PosixPath -> GopherFileType lookupSuffix = fromMaybe File . (flip M.lookup) fileTypeMap - . B.map asciiToLower + . Posix.map asciiToLower data PathError = PathDoesNotExist @@ -75,31 +94,24 @@ -- | Action in the 'Either' monad which causes a -- failure if there's any dot files or directory -- in the given path -checkNoDotFiles :: RawFilePath -> Either PathError () -checkNoDotFiles path = do - -- this prevents relative directories from being - -- forbidden while singular '.' in the path somewhere - -- get flagged and "." stays allowed. - let segments = splitDirectories $ fromMaybe path - $ boolToMaybe ("./" `B.isPrefixOf` path) (B.tail path) - <|> boolToMaybe ("." == path) "" - - if any ((== ".") . B.take 1) segments - then Left PathIsNotAllowed - else Right () +checkNoDotFiles :: PosixPath -> Either PathError () +checkNoDotFiles path + | containsDotFiles path = Left PathIsNotAllowed + | otherwise = Right () -- | calculates the file type identifier used in the Gopher -- protocol for a given file and returns a descriptive error -- if the file is not accessible or a dot file (and thus not -- allowed to access) -gopherFileType :: RawFilePath -> IO (Either PathError GopherFileType) +gopherFileType :: PosixPath -> IO (Either PathError GopherFileType) gopherFileType path = (checkNoDotFiles path >>) <$> do - let pathWide = decodeFilePath path - isDir <- doesDirectoryExist pathWide + -- we only support Posix for now, so failing to compile on Windows is not an issue + let os = OsString path + isDir <- doesDirectoryExist os if isDir then pure $ Right Directory else do - fileExists <- doesFileExist pathWide + fileExists <- doesFileExist os pure $ if fileExists then Right $ lookupSuffix $ takeExtension path diff --git a/server/Network/Spacecookie/Path.hs b/server/Network/Spacecookie/Path.hs new file mode 100644 --- /dev/null +++ b/server/Network/Spacecookie/Path.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE QuasiQuotes #-} +module Network.Spacecookie.Path + ( sanitizePath + , makeAbsolute + , containsDotFiles + ) where + +import System.OsPath.Posix (PosixPath, normalise, joinPath, splitPath, equalFilePath, ()) +import System.OsString.Posix (isPrefixOf, pstr) + +-- | Normalise a path and prevent . +sanitizePath :: PosixPath -> PosixPath +sanitizePath = + joinPath + . filter (\p -> not (equalFilePath p [pstr|..|])) + . splitPath . normalise + +-- | Convert a given path to an absolute path, treating it as if the current directory were the +-- root directory. The result is 'normalise'd. Absolute paths are not changed (except for the +-- normalisation). +makeAbsolute :: PosixPath -> PosixPath +makeAbsolute x = normalise $ [pstr|/|] x + +-- | Wether any components of the given path begin with a dot, although @.@ is +-- allowed. +containsDotFiles :: PosixPath -> Bool +containsDotFiles = + any (\p -> [pstr|.|] `isPrefixOf` p && not (equalFilePath p [pstr|.|])) + . splitPath diff --git a/spacecookie.cabal b/spacecookie.cabal --- a/spacecookie.cabal +++ b/spacecookie.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: spacecookie -version: 1.0.0.3 +version: 1.1.0.0 synopsis: Gopher server library and daemon description: Simple gopher library that allows writing custom gopher applications. Also includes a fully-featured gopher server @@ -29,20 +29,18 @@ test/integration/root/dir/another/.git-hello test/integration/root/dir/macintosh.hqx test/integration/root/dir/mystery-file + test/integration/root/dir/strange.tXT test/integration/root/plain.txt test/integration/spacecookie.json -common common-settings +common common default-language: Haskell2010 - build-depends: base >=4.9 && <5 - , bytestring >= 0.10 - , attoparsec >= 0.13 - , directory >= 1.3 - , filepath-bytestring >=1.4 - , containers >= 0.6 - ghc-options: - -Wall - -Wno-orphans + build-depends: base >= 4.9 && <5 + , bytestring >= 0.10 && < 0.13 + , attoparsec >= 0.13 && < 0.15 + , containers >= 0.6 && < 0.9 + , filepath >= 1.5.2.0 && < 1.6 + , os-string >= 2.0.6 && < 2.1 common common-executables ghc-options: @@ -53,41 +51,45 @@ -rtsopts -with-rtsopts=-I10 -common gopher-dependencies - build-depends: unix >= 2.7 - , socket >= 0.8.2 - , mtl >= 2.2 - , transformers >= 0.5 - , text >= 1.2 +common lib-exec-deps + build-depends: socket >= 0.8.2 && < 0.9 + , text >= 1.2 && < 2.2 + , utf8-string >= 1.0 && < 1.1 +common exec-test-deps + build-depends: directory >= 1.3 && < 1.4 + executable spacecookie - import: common-settings, common-executables, gopher-dependencies + import: common, common-executables + , lib-exec-deps, exec-test-deps main-is: Main.hs build-depends: spacecookie - , aeson >= 1.5 - , systemd >= 2.1.0 - , fast-logger >= 2.4.0 + , aeson >= 1.5 && < 2.3 + , systemd >= 2.1.0 && < 2.5 + , fast-logger >= 2.4.0 && < 3.3 + , unix >= 2.7 && < 2.9 + , file-io >= 0.1.0 && < 0.3 hs-source-dirs: server other-modules: Network.Spacecookie.Config , Network.Spacecookie.Systemd , Network.Spacecookie.FileType + , Network.Spacecookie.Path , Paths_spacecookie autogen-modules: Paths_spacecookie library - import: common-settings, gopher-dependencies + import: common, lib-exec-deps hs-source-dirs: src exposed-modules: Network.Gopher , Network.Gopher.Util.Gophermap - , Network.Gopher.Util other-modules: Network.Gopher.Types , Network.Gopher.Log , Network.Gopher.Util.Socket - build-depends: hxt-unicode >= 9.0 - , async >= 2.2 + build-depends: async >= 2.2 && < 2.3 + , mtl >= 2.2 && < 2.4 test-suite test - import: common-settings, common-executables + import: common, common-executables, exec-test-deps type: exitcode-stdio-1.0 main-is: EntryPoint.hs hs-source-dirs: test, server @@ -96,12 +98,13 @@ , Test.Integration , Test.Sanitization , Network.Spacecookie.FileType - build-depends: tasty >=1.2 - , tasty-hunit >=0.10 - , tasty-expected-failure >=0.11 + , Network.Spacecookie.Path + build-depends: tasty >= 1.2 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + , tasty-expected-failure >= 0.11 && < 0.13 , spacecookie - , process >=1.2.0 - , download-curl >=0.1 + , process >= 1.2.0 && < 1.7 + , download-curl >= 0.1 && < 0.2 source-repository head type: git @@ -109,4 +112,4 @@ source-repository head type: git - location: https://code.sterni.lv/spacecookie + location: https://git.sterni.lv/spacecookie diff --git a/src/Network/Gopher.hs b/src/Network/Gopher.hs --- a/src/Network/Gopher.hs +++ b/src/Network/Gopher.hs @@ -85,22 +85,23 @@ import Network.Gopher.Log import Network.Gopher.Types -import Network.Gopher.Util import Network.Gopher.Util.Gophermap import Network.Gopher.Util.Socket import Control.Concurrent (forkIO, ThreadId (), threadDelay) import Control.Concurrent.Async (race) import Control.Exception (bracket, catch, throw, SomeException (), Exception ()) -import Control.Monad (forever, when, void) +import Control.Monad (forever, void) import Control.Monad.IO.Class (liftIO, MonadIO (..)) import Control.Monad.Reader (ask, runReaderT, MonadReader (..), ReaderT (..)) import Data.Bifunctor (second) import Data.ByteString (ByteString ()) +import Data.Char (ord) import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.UTF8 as UTF8 import Data.Maybe (fromMaybe) -import Data.Word (Word16 ()) +import Data.Word (Word8 (), Word16 ()) import System.Socket hiding (Error (..)) import System.Socket.Family.Inet6 import System.Socket.Type.Stream (Stream, sendAllBuilder) @@ -240,15 +241,16 @@ (r, "\n") -> Right r (_, "") -> Left "Request too big or unterminated" _ -> Left "Unexpected data after newline" - where newline = (||) - <$> (== asciiOrd '\n') - <*> (== asciiOrd '\r') + where cr, lf :: Word8 + lf = fromIntegral $ ord '\n' + cr = fromIntegral $ ord '\r' + newline = (||) <$> (== lf) <*> (== cr) reqTimeout = 10000000 -- 10s maxSize = 1024 * 1024 loop bs size = do part <- receive sock maxSize msgNoSignal let newSize = size + B.length part - if newSize >= maxSize || part == mempty || B.elem (asciiOrd '\n') part + if newSize >= maxSize || part == mempty || B.elem lf part then pure $ bs `mappend` part else loop (bs `mappend` part) newSize @@ -267,14 +269,15 @@ Nothing -> pure $ SocketAddressInet6 inet6Any (fromInteger (cServerPort cfg)) 0 0 Just a -> do - let port = uEncode . show $ cServerPort cfg + let port = UTF8.fromString . show $ cServerPort cfg let flags = aiV4Mapped <> aiNumericService addrs <- (getAddressInfo (Just a) (Just port) flags :: IO [AddressInfo Inet6 Stream TCP]) -- should be done by getAddressInfo already - when (null addrs) $ throw eaiNoName + case addrs of + [] -> throw eaiNoName + (firstAddr:_) -> pure $ socketAddress firstAddr - pure . socketAddress $ head addrs bind sock addr listen sock 5 pure sock diff --git a/src/Network/Gopher/Log.hs b/src/Network/Gopher/Log.hs --- a/src/Network/Gopher/Log.hs +++ b/src/Network/Gopher/Log.hs @@ -10,18 +10,19 @@ , FromGopherLogStr (..) ) where -import Network.Gopher.Util (uEncode, uDecode) - import Data.ByteString.Builder (Builder ()) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.Sequence as S import Data.String (IsString (..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL +import System.OsString.Internal.Types (PosixString (..)) import System.Socket.Family.Inet6 -- | Indicates the log level of a 'GopherLogStr' to a @@ -44,6 +45,12 @@ -- 'Semigroup' and 'IsString' instances to construct -- 'GopherLogStr's and 'FromGopherLogStr' to convert to the -- commonly used Haskell string types. +-- +-- Note that encoding isn't checked for conversions from +-- encoding agnostic types, e.g. 'BB.ByteString'. +-- In 'FromGopherLogStr', invalid encoding is retained when converting to +-- encoding agnostic types (e.g. 'BB.ByteString'), but will be replaced by +-- replacement characters for types that enforce encoding (e.g. 'T.Text'). newtype GopherLogStr = GopherLogStr { unGopherLogStr :: S.Seq GopherLogStrChunk } @@ -108,14 +115,21 @@ instance FromGopherLogStr B.ByteString where fromGopherLogStr = BL.toStrict . fromGopherLogStr +-- | Any non-UTF-8 portions (introduced e.g. via @'ToGopherLogStr' +-- 'BB.ByteString'@) are replaced with U+FFFD. instance FromGopherLogStr T.Text where - fromGopherLogStr = T.decodeUtf8 . fromGopherLogStr + -- text >= 2.0 introduces a shortcut for this, but we support a wider range + fromGopherLogStr = T.decodeUtf8With T.lenientDecode . fromGopherLogStr +-- | Any non-UTF-8 portions (introduced e.g. via @'ToGopherLogStr' +-- 'BB.ByteString'@) are replaced with U+FFFD. instance FromGopherLogStr TL.Text where - fromGopherLogStr = TL.decodeUtf8 . fromGopherLogStr + fromGopherLogStr = TL.decodeUtf8With T.lenientDecode . fromGopherLogStr +-- | Any non-UTF-8 portions (introduced e.g. via @'ToGopherLogStr' +-- 'BB.ByteString'@) are replaced with U+FFFD. instance FromGopherLogStr [Char] where - fromGopherLogStr = uDecode . fromGopherLogStr + fromGopherLogStr = UTF8.toString . fromGopherLogStr -- | Convert something to a 'GopherLogStr'. In terms of -- performance it is best to implement a 'Builder' for @@ -127,6 +141,7 @@ instance ToGopherLogStr GopherLogStr where toGopherLogStr = id +-- | UTF-8 encoding is not checked, needs to be ensured by the user. instance ToGopherLogStr Builder where toGopherLogStr b = GopherLogStr . S.singleton @@ -135,14 +150,16 @@ , glscBuilder = b } +-- | UTF-8 encoding is not checked, needs to be ensured by the user. instance ToGopherLogStr B.ByteString where toGopherLogStr = toGopherLogStr . BB.byteString +-- | UTF-8 encoding is not checked, needs to be ensured by the user. instance ToGopherLogStr BL.ByteString where toGopherLogStr = toGopherLogStr . BB.lazyByteString instance ToGopherLogStr [Char] where - toGopherLogStr = toGopherLogStr . uEncode + toGopherLogStr = toGopherLogStr . UTF8.fromString instance ToGopherLogStr GopherLogLevel where toGopherLogStr l = @@ -166,3 +183,7 @@ BB.word16HexFixed b7 <> BB.charUtf8 ':' <> BB.word16HexFixed b8 <> BB.charUtf8 ']' <> BB.charUtf8 ':' <> BB.intDec (fromIntegral port) + +-- | UTF-8 encoding is not checked, needs to be ensured by the user. +instance ToGopherLogStr PosixString where + toGopherLogStr = toGopherLogStr . BB.shortByteString . getPosixString diff --git a/src/Network/Gopher/Types.hs b/src/Network/Gopher/Types.hs --- a/src/Network/Gopher/Types.hs +++ b/src/Network/Gopher/Types.hs @@ -10,9 +10,8 @@ import Prelude hiding (lookup) -import Network.Gopher.Util - import Data.ByteString (ByteString ()) +import Data.Char (chr, ord) import Data.Word (Word8 ()) -- | entry in a gopher menu @@ -49,7 +48,7 @@ deriving (Show, Eq, Ord, Enum) fileTypeToChar :: GopherFileType -> Word8 -fileTypeToChar t = asciiOrd $ +fileTypeToChar t = fromIntegral . ord $ case t of File -> '0' Directory -> '1' @@ -70,7 +69,7 @@ charToFileType :: Word8 -> GopherFileType charToFileType c = - case asciiChr c of + case chr (fromIntegral c) of '0' -> File '1' -> Directory '2' -> PhoneBookServer diff --git a/src/Network/Gopher/Util.hs b/src/Network/Gopher/Util.hs deleted file mode 100644 --- a/src/Network/Gopher/Util.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-| -Module : Network.Gopher.Util -Stability : experimental -Portability : POSIX - -Helper utilities used within the library and the server which also could be useful for other application code. --} -{-# LANGUAGE OverloadedStrings #-} -module Network.Gopher.Util ( - -- * Security - sanitizePath - , sanitizeIfNotUrl - , dropPrivileges - -- * String Encoding - , asciiOrd - , asciiChr - , asciiToLower - , uEncode - , uDecode - -- * Misc Helpers - , stripNewline - , boolToMaybe - ) where - -import Data.ByteString (ByteString ()) -import qualified Data.ByteString as B -import Data.Char (ord, chr, toLower) -import qualified Data.String.UTF8 as U -import Data.Word (Word8 ()) -import System.FilePath.Posix.ByteString (RawFilePath, normalise, joinPath, splitPath, equalFilePath) -import System.Posix.User - --- | 'chr' a 'Word8' -asciiChr :: Word8 -> Char -asciiChr = chr . fromIntegral - --- | 'ord' a 'Word8' -asciiOrd :: Char -> Word8 -asciiOrd = fromIntegral . ord - --- | Transform a 'Word8' to lowercase if the solution is in bounds. -asciiToLower :: Word8 -> Word8 -asciiToLower w = - if inBounds lower - then fromIntegral lower - else w - where inBounds i = i >= fromIntegral (minBound :: Word8) && - i <= fromIntegral (maxBound :: Word8) - lower :: Int - lower = ord . toLower . asciiChr $ w - --- | Encode a 'String' to a UTF-8 'ByteString' -uEncode :: String -> ByteString -uEncode = B.pack . U.encode - --- | Decode a UTF-8 'ByteString' to a 'String' -uDecode :: ByteString -> String -uDecode = fst . U.decode . B.unpack - --- | Strip @\\r@ and @\\n@ from 'ByteString's -stripNewline :: ByteString -> ByteString -stripNewline s - | B.null s = B.empty - | B.head s `elem` - (map (fromIntegral . ord) "\n\r") = stripNewline (B.tail s) - | otherwise = B.head s `B.cons` stripNewline (B.tail s) - --- | Normalise a path and prevent . -sanitizePath :: RawFilePath -> RawFilePath -sanitizePath = - -- To retain prior behavior @"."@ after normalisation is mapped to @""@ - (\p -> if p == "." then "" else p) - . joinPath - . filter (\p -> not (equalFilePath p "..")) - . splitPath . normalise - --- | Use 'sanitizePath' except if the path starts with @URL:@ --- in which case the original string is returned. -sanitizeIfNotUrl :: RawFilePath -> RawFilePath -sanitizeIfNotUrl path = - if "URL:" `B.isPrefixOf` path - then path - else sanitizePath path - --- | prop> boolToMaybe True x == Just x --- prop> boolToMaybe False x == Nothing -boolToMaybe :: Bool -> a -> Maybe a -boolToMaybe True a = Just a -boolToMaybe False _ = Nothing - --- | Call 'setGroupID' and 'setUserID' to switch to --- the given user and their primary group. --- Requires special privileges. --- Will raise an exception if either the user --- does not exist or the current user has no --- permission to change UID/GID. -dropPrivileges :: String -> IO () -dropPrivileges username = do - user <- getUserEntryForName username - setGroupID $ userGroupID user - setUserID $ userID user diff --git a/src/Network/Gopher/Util/Gophermap.hs b/src/Network/Gopher/Util/Gophermap.hs --- a/src/Network/Gopher/Util/Gophermap.hs +++ b/src/Network/Gopher/Util/Gophermap.hs @@ -32,32 +32,38 @@ import Prelude hiding (take, takeWhile) import Network.Gopher.Types -import Network.Gopher.Util import Control.Applicative ((<|>)) import Data.Attoparsec.ByteString +import Data.Attoparsec.ByteString.Char8 (isDigit_w8) import Data.ByteString (ByteString (), pack, unpack, isPrefixOf) +import Data.ByteString.Short (fromShort) +import Data.Char (chr) import Data.Maybe (fromMaybe) -import qualified Data.String.UTF8 as U import Data.Word (Word8 ()) -import System.FilePath.Posix.ByteString (RawFilePath, (), isAbsolute, normalise) +import System.OsPath.Posix (PosixPath, (), isAbsolute, normalise) +import qualified System.OsString.Posix as Posix +import System.OsString.Internal.Types (PosixString (..)) +import Text.Read (readEither) -- | Given a directory and a Gophermap contained within it, -- return the corresponding gopher menu response. -gophermapToDirectoryResponse :: RawFilePath -> Gophermap -> GopherResponse +gophermapToDirectoryResponse :: PosixPath -> Gophermap -> GopherResponse gophermapToDirectoryResponse dir entries = MenuResponse (map (gophermapEntryToMenuItem dir) entries) -gophermapEntryToMenuItem :: RawFilePath -> GophermapEntry -> GopherMenuItem +gophermapEntryToMenuItem :: PosixPath -> GophermapEntry -> GopherMenuItem gophermapEntryToMenuItem dir (GophermapEntry ft desc path host port) = Item ft desc (fromMaybe desc (realPath <$> path)) host port where realPath p = case p of - GophermapAbsolute p' -> p' + GophermapAbsolute p' -> pathToBS p' -- TODO: `..` should be resolved textually for linking to the -- parent directory (if possible) - GophermapRelative p' -> dir p' + GophermapRelative p' -> pathToBS $ dir p' GophermapUrl u -> u + pathToBS :: PosixString -> ByteString + pathToBS = fromShort . getPosixString fileTypeChars :: [Char] fileTypeChars = "0123456789+TgIih" @@ -65,26 +71,30 @@ -- | Wrapper around 'RawFilePath' to indicate whether it is -- relative or absolute. data GophermapFilePath - = GophermapAbsolute RawFilePath -- ^ Absolute path starting with @/@ - | GophermapRelative RawFilePath -- ^ Relative path - | GophermapUrl RawFilePath -- ^ URL to another protocol starting with @URL:@ + = GophermapAbsolute PosixPath -- ^ Absolute path starting with @/@ + | GophermapRelative PosixPath -- ^ Relative path + | GophermapUrl ByteString -- ^ URL to another protocol starting with @URL:@ deriving (Show, Eq) --- | Take 'ByteString' from gophermap, decode it, --- sanitize and determine path type. +-- | Take selector 'ByteString' from gophermap and +-- determine its 'GophermapFilePath' type. +-- Relative and absolute paths are 'normalised', +-- URLs passed on as is. -- --- * Gophermap paths that start with a slash are --- considered to be absolute. --- * Gophermap paths that start with "URL:" are --- considered as an external URL and left as-is. --- * everything else is considered a relative path +-- * Selectors that start with @"URL:"@ are considered +-- an external URL and left as-is. +-- * Absolute paths are identified by 'isAbsolute'. +-- * Everything else is considered a relative path. +-- +-- Paths are 'normalise'-d, but not subject to any other +-- processing. makeGophermapFilePath :: ByteString -> GophermapFilePath makeGophermapFilePath b | "URL:" `isPrefixOf` b = GophermapUrl b - | isAbsolute b = GophermapAbsolute normalisedPath + | isAbsolute normalisedPath = GophermapAbsolute normalisedPath | otherwise = GophermapRelative normalisedPath where - normalisedPath = normalise b + normalisedPath = normalise $ Posix.fromBytestring b -- | A gophermap entry makes all values of a gopher menu item optional except for file type and description. When converting to a 'GopherMenuItem', appropriate default values are used. data GophermapEntry = GophermapEntry @@ -123,13 +133,13 @@ _ <- satisfy (inClass "\t") pathString <- option Nothing $ Just <$> itemValue host <- optionalValue - portString <- optionalValue + port <- optional portValue endOfLineOrInput return $ GophermapEntry (charToFileType fileTypeChar) text (makeGophermapFilePath <$> pathString) host - (byteStringToPort <$> portString) + port emptyGophermapline :: Parser GophermapEntry emptyGophermapline = do @@ -137,13 +147,21 @@ return emptyInfoLine where emptyInfoLine = GophermapEntry InfoLine (pack []) Nothing Nothing Nothing -byteStringToPort :: ByteString -> Integer -byteStringToPort s = read . fst . U.decode . unpack $ s +portValue :: Parser Integer +portValue = do + digits <- takeWhile1 isDigit_w8 + -- we know digits is just ASCII characters ([0-9]) + case readEither (map (chr . fromIntegral) (unpack digits)) of + Left e -> fail e + Right p -> pure p optionalValue :: Parser (Maybe ByteString) -optionalValue = option Nothing $ do +optionalValue = optional itemValue + +optional :: Parser a -> Parser (Maybe a) +optional parser = option Nothing $ do _ <- satisfy (inClass "\t") - Just <$> itemValue + Just <$> parser itemValue :: Parser ByteString itemValue = takeWhile1 (notInClass "\t\r\n") diff --git a/src/Network/Gopher/Util/Socket.hs b/src/Network/Gopher/Util/Socket.hs --- a/src/Network/Gopher/Util/Socket.hs +++ b/src/Network/Gopher/Util/Socket.hs @@ -13,7 +13,7 @@ import Data.Functor ((<&>)) import Foreign.C.Error (Errno (..), getErrno) import Foreign.C.Types (CInt (..)) -import System.Socket (receive, msgNoSignal, SocketException (..), close, Family ()) +import System.Socket (receive, msgNoSignal, SocketException (..), close) import System.Socket.Type.Stream (Stream ()) import System.Socket.Protocol.TCP (TCP ()) import System.Socket.Unsafe (Socket (..)) @@ -48,7 +48,7 @@ -- of time to clean up on its end before closing -- the connection to avoid a broken pipe on the -- other side. -gracefulClose :: Family f => Socket f Stream TCP -> IO () +gracefulClose :: Socket f Stream TCP -> IO () gracefulClose sock = do -- send TCP FIN shutdown sock ShutdownWrite diff --git a/test/Test/FileTypeDetection.hs b/test/Test/FileTypeDetection.hs --- a/test/Test/FileTypeDetection.hs +++ b/test/Test/FileTypeDetection.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Test.FileTypeDetection (fileTypeDetectionTests) where import Network.Gopher (GopherFileType (..)) import Network.Spacecookie.FileType -import System.FilePath.Posix.ByteString (takeExtension) +import System.OsPath.Posix (takeExtension) +import System.OsString.Posix (pstr) import Test.Tasty import Test.Tasty.HUnit @@ -17,43 +18,43 @@ ioTests :: TestTree ioTests = testCase "gopherFileType tests" $ do assertEqual "Fallback to File without extension" (Right File) - =<< gopherFileType "LICENSE" + =<< gopherFileType [pstr|LICENSE|] assertEqual "non-existent dot files are forbidden" (Left PathIsNotAllowed) - =<< gopherFileType ".dot-file-missing" + =<< gopherFileType [pstr|.dot-file-missing|] assertEqual "dot file along the path" (Left PathIsNotAllowed) - =<< gopherFileType ".git/HEAD" + =<< gopherFileType [pstr|.git/HEAD|] assertEqual "dot file along the path" (Left PathIsNotAllowed) - =<< gopherFileType "./foo/.git/HEAD" + =<< gopherFileType [pstr|./foo/.git/HEAD|] assertEqual ".. is disallowed" (Left PathIsNotAllowed) - =<< gopherFileType "/lol/../../doing/directory/traversal.txt" + =<< gopherFileType [pstr|/lol/../../doing/directory/traversal.txt|] assertEqual "\".\" is allowed" (Right Directory) - =<< gopherFileType "." + =<< gopherFileType [pstr|.|] assertEqual "txt files" (Right File) - =<< gopherFileType "./docs/rfc1436.txt" + =<< gopherFileType [pstr|./docs/rfc1436.txt|] assertEqual "missing file" (Left PathDoesNotExist) - =<< gopherFileType "missing/this.txt" + =<< gopherFileType [pstr|missing/this.txt|] suffixTests :: TestTree suffixTests = testCase "correct mapping of suffixes" $ do assertEqual "BinHexMacintoshFile" BinHexMacintoshFile $ - lookupSuffix $ takeExtension "test.hqx" + lookupSuffix $ takeExtension [pstr|test.hqx|] assertEqual "tar.gz is BinaryFile" BinaryFile $ - lookupSuffix $ takeExtension "/releases/spacecookie-0.3.0.0.tar.gz" + lookupSuffix $ takeExtension [pstr|/releases/spacecookie-0.3.0.0.tar.gz|] assertEqual "gif file" GifFile $ - lookupSuffix $ takeExtension "funny.gif" + lookupSuffix $ takeExtension [pstr|funny.gif|] mapM_ (assertEqual "image file" ImageFile . lookupSuffix . takeExtension) - [ "hello.png", "/my/beautiful.jpg", "./../lol.jpeg" - , "../bar.tif", "my.tiff", ".hidden.svg", "my.bmp" ] + [ [pstr|hello.png|], [pstr|/my/beautiful.jpg|], [pstr|./../lol.jpeg|] + , [pstr|../bar.tif|], [pstr|my.tiff|], [pstr|.hidden.svg|], [pstr|my.bmp|] ] assertEqual "fallback to File" File $ - lookupSuffix $ takeExtension "my/unknown.strange-extension" + lookupSuffix $ takeExtension [pstr|my/unknown.strange-extension|] diff --git a/test/Test/Gophermap.hs b/test/Test/Gophermap.hs --- a/test/Test/Gophermap.hs +++ b/test/Test/Gophermap.hs @@ -1,17 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Test.Gophermap (gophermapTests) where import Control.Monad (forM_) +import Control.Applicative ((<|>)) import Data.Attoparsec.ByteString (parseOnly) import qualified Data.ByteString as B import Data.Either +import Data.Maybe (fromMaybe) import Network.Gopher (GopherFileType (..)) -import Network.Gopher.Util (stripNewline) import Network.Gopher.Util.Gophermap -import System.FilePath.Posix.ByteString (RawFilePath) +import System.OsPath.Posix (PosixPath ()) +import System.OsString.Posix (pstr) import Test.Tasty import Test.Tasty.HUnit +stripNewline :: B.ByteString -> B.ByteString +stripNewline s = fromMaybe s $ B.stripSuffix "\r\n" s <|> B.stripSuffix "\n" s + withFileContents :: FilePath -> (IO B.ByteString -> TestTree) -> TestTree withFileContents path = withResource (B.readFile path) (const (pure ())) @@ -29,7 +35,7 @@ infoLine :: B.ByteString -> GophermapEntry infoLine b = GophermapEntry InfoLine b Nothing Nothing Nothing -absDir :: B.ByteString -> RawFilePath -> B.ByteString -> GophermapEntry +absDir :: B.ByteString -> PosixPath -> B.ByteString -> GophermapEntry absDir n p s = GophermapEntry Directory n (Just (GophermapAbsolute p)) (Just s) $ Just 70 @@ -43,10 +49,10 @@ , infoLine "" , infoLine "Some links to get you started:" , infoLine "" - , absDir "Pygopherd Home" "/devel/gopher/pygopherd" "gopher.quux.org" - , absDir "Quux.Org Mega Server" "/" "gopher.quux.org" - , absDir "The Gopher Project" "/Software/Gopher" "gopher.quux.org" - , absDir "Traditional UMN Home Gopher" "/" "gopher.tc.umn.edu" + , absDir "Pygopherd Home" [pstr|/devel/gopher/pygopherd|] "gopher.quux.org" + , absDir "Quux.Org Mega Server" [pstr|/|] "gopher.quux.org" + , absDir "The Gopher Project" [pstr|/Software/Gopher|] "gopher.quux.org" + , absDir "Traditional UMN Home Gopher" [pstr|/|] "gopher.tc.umn.edu" , infoLine "" , infoLine "Welcome to the world of Gopher and enjoy!" ] @@ -89,11 +95,11 @@ GophermapEntry t name (Just path) Nothing Nothing menuLines = [ ("1/somedir\t", GophermapEntry Directory "/somedir" Nothing Nothing Nothing) - , ("0file\tfile.txt\n", menuEntry File "file" (GophermapRelative "file.txt")) - , ("ggif\t/pic.gif", menuEntry GifFile "gif" (GophermapAbsolute "/pic.gif")) + , ("0file\tfile.txt\n", menuEntry File "file" (GophermapRelative [pstr|file.txt|])) + , ("ggif\t/pic.gif", menuEntry GifFile "gif" (GophermapAbsolute [pstr|/pic.gif|])) , ("hcode\tURL:https://code.sterni.lv\n", menuEntry Html "code" (GophermapUrl "URL:https://code.sterni.lv")) - , ("1foo\tfoo\tsterni.lv", GophermapEntry Directory "foo" (Just $ GophermapRelative "foo") (Just "sterni.lv") Nothing) - , ("Ibar\t/bar.png\tsterni.lv\t7070\n", GophermapEntry ImageFile "bar" (Just $ GophermapAbsolute "/bar.png") (Just "sterni.lv") (Just 7070)) + , ("1foo\tfoo\tsterni.lv", GophermapEntry Directory "foo" (Just $ GophermapRelative [pstr|foo|]) (Just "sterni.lv") Nothing) + , ("Ibar\t/bar.png\tsterni.lv\t7070\n", GophermapEntry ImageFile "bar" (Just $ GophermapAbsolute [pstr|/bar.png|]) (Just "sterni.lv") (Just 7070)) , ("imanual info line\t", infoLine "manual info line") ] in [ testCase "info lines" $ forM_ infoLines (\l -> lineEqual l $ infoLine (stripNewline l)) diff --git a/test/Test/Integration.hs b/test/Test/Integration.hs --- a/test/Test/Integration.hs +++ b/test/Test/Integration.hs @@ -7,10 +7,10 @@ import Control.Monad (forM_) import Data.ByteString (ByteString) import qualified Data.ByteString as B -import Data.List +import Data.Char (ord) +import Data.List (sort) import Data.Maybe (isNothing, isJust, fromJust) import Network.Curl.Download (openURI) -import Network.Gopher.Util (asciiOrd) import System.Directory (findExecutable) import System.Environment (lookupEnv) import System.Exit (ExitCode (..)) @@ -76,7 +76,7 @@ -- ignore ordering for the purpose of this test assertEqual "directory menu contains expected entries" (Right expectedDir) - $ sort . filter (not . B.null) . B.split (asciiOrd '\n') <$> dir + $ sort . filter (not . B.null) . B.split (fromIntegral $ ord '\n') <$> dir step "sanity check not found error messages" @@ -123,13 +123,15 @@ , "0normal text file\t/plain.txt\tlocalhost\t7000\r\n" , "1normal dir\t/dir\tlocalhost\t7000\r\n" , "i\t\tlocalhost\t7000\r\n" - , "1external\t/\tsterni.lv\t7000\r\n" + , "1external 1\t/\tthis.is.bogus.org\t7000\r\n" + , "1external 2\t/\tsdf.org\t70\r\n" ] expectedDir :: [ByteString] expectedDir = sort [ "1another\t/dir/another\tlocalhost\t7000\r" , "0mystery-file\t/dir/mystery-file\tlocalhost\t7000\r" + , "0strange.tXT\t/dir/strange.tXT\tlocalhost\t7000\r" , "4macintosh.hqx\t/dir/macintosh.hqx\tlocalhost\t7000\r" ] diff --git a/test/Test/Sanitization.hs b/test/Test/Sanitization.hs --- a/test/Test/Sanitization.hs +++ b/test/Test/Sanitization.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Test.Sanitization (sanitizationTests) where -import Network.Gopher.Util (uEncode, sanitizePath) import Network.Spacecookie.FileType (checkNoDotFiles, PathError (..)) +import Network.Spacecookie.Path (sanitizePath, makeAbsolute) import Control.Monad (forM_) +import System.OsPath.Posix (isAbsolute) +import System.OsString.Posix (pstr) import Test.Tasty import Test.Tasty.HUnit @@ -12,53 +14,71 @@ sanitizationTests = testGroup "Sanitization of user input" [ pathSanitization , dotFileDetectionTest + , makeAbsoluteTest ] pathSanitization :: TestTree pathSanitization = testCase "sanitizePath behavior" $ do - let assertSanitize e p = assertEqual p e $ sanitizePath (uEncode p) - assertSanitize "/root" "/root" - assertSanitize "/home/alice/.emacs.d/init.el" "/home/alice/.emacs.d/init.el" + let assertSanitize e p = assertEqual (show p) e $ sanitizePath p + assertSanitize [pstr|/root|] [pstr|/root|] + assertSanitize [pstr|/home/alice/.emacs.d/init.el|] [pstr|/home/alice/.emacs.d/init.el|] - assertSanitize "root" "./root" - assertSanitize"/tools/magrathea" "//tools/magrathea" - assertSanitize "/home/bob/Documents/important.txt" "/home/bob//Documents/important.txt" + assertSanitize [pstr|root|] [pstr|./root|] + assertSanitize [pstr|/tools/magrathea|] [pstr|//tools/magrathea|] + assertSanitize [pstr|/home/bob/Documents/important.txt|] [pstr|/home/bob//Documents/important.txt|] - assertSanitize "foo/bar/baz.txt" "./foo/bar/./baz.txt" - assertSanitize "/var/www/index..html" "/var/www/.///index..html" - assertSanitize "./" "./." - assertSanitize "/" "/." - assertSanitize "home/eve/" "./home/./././eve////./." + assertSanitize [pstr|foo/bar/baz.txt|] [pstr|./foo/bar/./baz.txt|] + assertSanitize [pstr|/var/www/index..html|] [pstr|/var/www/.///index..html|] + assertSanitize [pstr|./|] [pstr|./.|] + assertSanitize [pstr|/|] [pstr|/.|] + assertSanitize [pstr|home/eve/|] [pstr|./home/./././eve////./.|] - assertSanitize "/home/bob/alice/private.txt" "/home/bob/../alice/private.txt" + assertSanitize [pstr|/home/bob/alice/private.txt|] [pstr|/home/bob/../alice/private.txt|] dotFileDetectionTest :: TestTree dotFileDetectionTest = testCase "spacecookie server detects dot files in paths" $ do let assertDot p hasDot = forM_ - [ (p, uEncode p) - , (p ++ " (sanitized)", sanitizePath (uEncode p)) + [ (show p, p) + , (show p ++ " (sanitized)", sanitizePath p) ] $ \(title, path) -> assertEqual title (if hasDot then Left PathIsNotAllowed else Right ()) $ checkNoDotFiles path - assertDot "./normal/relative/path" False - assertDot "." False - assertDot "/some/absolute/path" False - assertDot "file.txt" False - assertDot "/foo.html" False - assertDot "./tmp/scratch.txt" False + assertDot [pstr|./normal/relative/path|] False + assertDot [pstr|.|] False + assertDot [pstr|/some/absolute/path|] False + assertDot [pstr|file.txt|] False + assertDot [pstr|/foo.html|] False + assertDot [pstr|./tmp/scratch.txt|] False + assertDot [pstr|./.|] False + assertDot [pstr|relative/./path|] False - assertDot ".emacs.d/init.el" True - assertDot ".gophermap" True - assertDot "/home/bob/.vimrc" True - assertDot "/home/alice/.config/foot" True - assertDot "./nixpkgs/.git/config" True + assertDot [pstr|.emacs.d/init.el|] True + assertDot [pstr|.gophermap|] True + assertDot [pstr|/home/bob/.vimrc|] True + assertDot [pstr|/home/alice/.config/foot|] True + assertDot [pstr|./nixpkgs/.git/config|] True -- only fail prior to sanitization forM_ - [ "./.", "relative/./path", "dir/../traversal/../attack", "../../../actual/traversal" ] + [ [pstr|dir/../traversal/../attack|], [pstr|../../../actual/traversal|] ] $ \p -> do - let p' = uEncode p - assertEqual p (Left PathIsNotAllowed) $ checkNoDotFiles p' - assertEqual p (Right ()) $ checkNoDotFiles (sanitizePath p') + assertEqual (show p) (Left PathIsNotAllowed) $ checkNoDotFiles p + assertEqual (show p) (Right ()) $ checkNoDotFiles (sanitizePath p) + +makeAbsoluteTest :: TestTree +makeAbsoluteTest = testCase "relative paths are correctly converted to absolute ones" $ do + let assertAbsolute expected given = do + assertEqual (show given) expected $ makeAbsolute given + assertBool ("makeAbsolute " ++ show given ++ " is absolute") + $ isAbsolute (makeAbsolute given) + + assertAbsolute [pstr|/foo/bar|] [pstr|/foo/bar|] + assertAbsolute [pstr|/foo/bar|] [pstr|./foo/bar|] + assertAbsolute [pstr|/foo/bar|] [pstr|foo/bar|] + assertAbsolute [pstr|/|] [pstr|.|] + assertAbsolute [pstr|/|] [pstr|./|] + assertAbsolute [pstr|/bar/foo|] [pstr|././bar/foo|] + assertAbsolute [pstr|/../bar/foo|] [pstr|./../bar/foo|] + assertAbsolute [pstr|/../bar/foo|] [pstr|../bar/foo|] diff --git a/test/integration/root/.gophermap b/test/integration/root/.gophermap --- a/test/integration/root/.gophermap +++ b/test/integration/root/.gophermap @@ -3,4 +3,5 @@ 0normal text file plain.txt 1normal dir dir -1external / sterni.lv +1external 1 / this.is.bogus.org +1external 2 / sdf.org 70 diff --git a/test/integration/root/dir/strange.tXT b/test/integration/root/dir/strange.tXT new file mode 100644 --- /dev/null +++ b/test/integration/root/dir/strange.tXT @@ -0,0 +1,1 @@ +Lorenz Westenrieder