FileType.hs

{-# LANGUAGE OverloadedStrings #-}
module Network.Spacecookie.FileType
  ( PathError (..)
  , gopherFileType
  -- exposed for tests
  , lookupSuffix
  ) where

import Control.Applicative ((<|>))
import qualified Data.ByteString as B
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)

fileTypeMap :: M.Map RawFilePath 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)
  ]

lookupSuffix :: RawFilePath -> GopherFileType
lookupSuffix = fromMaybe File
  . (flip M.lookup) fileTypeMap
  . B.map asciiToLower

data PathError
  = PathDoesNotExist
  | PathIsNotAllowed
  deriving (Show, Eq, Ord, Enum)

-- | 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 ()

-- | 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 path = (checkNoDotFiles path >>) <$> do
  let pathWide = decodeFilePath path
  isDir <- doesDirectoryExist pathWide
  if isDir
    then pure $ Right Directory
    else do
      fileExists <- doesFileExist pathWide
      pure $
        if fileExists
          then Right $ lookupSuffix $ takeExtension path
          else Left  $ PathDoesNotExist