spacecookie 1.0.0.3 → 1.1.0.0
raw patch · 20 files changed
+411/−355 lines, 20 filesdep +file-iodep +filepathdep +os-stringdep −filepath-bytestringdep −hxt-unicodedep −transformers
Dependencies added: file-io, filepath, os-string, utf8-string
Dependencies removed: filepath-bytestring, hxt-unicode, transformers
Files
- CHANGELOG.md +19/−0
- README.md +14/−2
- docs/man/spacecookie.1 +4/−4
- server/Main.hs +47/−34
- server/Network/Spacecookie/Config.hs +2/−5
- server/Network/Spacecookie/FileType.hs +79/−67
- server/Network/Spacecookie/Path.hs +29/−0
- spacecookie.cabal +35/−32
- src/Network/Gopher.hs +13/−10
- src/Network/Gopher/Log.hs +27/−6
- src/Network/Gopher/Types.hs +3/−4
- src/Network/Gopher/Util.hs +0/−101
- src/Network/Gopher/Util/Gophermap.hs +43/−25
- src/Network/Gopher/Util/Socket.hs +2/−2
- test/Test/FileTypeDetection.hs +17/−16
- test/Test/Gophermap.hs +17/−11
- test/Test/Integration.hs +6/−4
- test/Test/Sanitization.hs +51/−31
- test/integration/root/.gophermap +2/−1
- test/integration/root/dir/strange.tXT +1/−0
CHANGELOG.md view
@@ -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
README.md view
@@ -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.
docs/man/spacecookie.1 view
@@ -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
server/Main.hs view
@@ -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
server/Network/Spacecookie/Config.hs view
@@ -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
server/Network/Spacecookie/FileType.hs view
@@ -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
+ server/Network/Spacecookie/Path.hs view
@@ -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 <https://en.wikipedia.org/wiki/Directory_traversal_attack directory traversal attacks>.+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
spacecookie.cabal view
@@ -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
src/Network/Gopher.hs view
@@ -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
src/Network/Gopher/Log.hs view
@@ -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
src/Network/Gopher/Types.hs view
@@ -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
− src/Network/Gopher/Util.hs
@@ -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 <https://en.wikipedia.org/wiki/Directory_traversal_attack directory traversal attacks>.-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
src/Network/Gopher/Util/Gophermap.hs view
@@ -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")
src/Network/Gopher/Util/Socket.hs view
@@ -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
test/Test/FileTypeDetection.hs view
@@ -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|]
test/Test/Gophermap.hs view
@@ -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))
test/Test/Integration.hs view
@@ -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" ]
test/Test/Sanitization.hs view
@@ -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|]
test/integration/root/.gophermap view
@@ -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
+ test/integration/root/dir/strange.tXT view
@@ -0,0 +1,1 @@+Lorenz Westenrieder