{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
--}

{-# OPTIONS_HADDOCK ignore-exports #-}


-- |This module provides a data type for representing directories/files
-- in a well-typed and convenient way. This is useful to gather and
-- save information about a file, so the information can be easily
-- processed in e.g. a GUI.
--
-- However, it's not meant to be used to interact with low-level
-- functions that copy files etc, since there's no guarantee that
-- the in-memory representation of the type still matches what is
-- happening on filesystem level.
--
-- If you interact with low-level libraries, you must not pattern
-- match on the `File a` type. Instead, you should only use the saved
-- `path` and make no assumptions about the file the path might or
-- might not point to.
module HSFM.FileSystem.FileType where



import Data.ByteString(ByteString)
import Data.ByteString.UTF8
  (
    toString
  )
import Data.Time.Clock.POSIX
  (
    POSIXTime
  , posixSecondsToUTCTime
  )
import Data.Time()
import HPath
  (
    Abs
  , Path
  )
import qualified HPath as P
import HPath.IO hiding (FileType(..))
import HPath.IO.Errors
import Prelude hiding(readFile)
import System.Posix.FilePath
  (
    (</>)
  )
import System.Posix.Directory.Traversals
  (
    realpath
  )
import qualified System.Posix.Files.ByteString as PF
import System.Posix.Types
  (
    DeviceID
  , EpochTime
  , FileID
  , FileMode
  , FileOffset
  , GroupID
  , LinkCount
  , UserID
  )






    ----------------------------
    --[ BASE TYPES ]--
    ----------------------------


-- |The String in the path field is always a full path.
-- The free type variable is used in the File/Dir constructor and can hold
-- Handles, Strings representing a file's contents or anything else you can
-- think of.
data File a =
  Dir {
    path :: !(Path Abs)
  , fvar :: a
  }
  | RegFile {
    path :: !(Path Abs)
  , fvar :: a
  }
  | SymLink {
    path    :: !(Path Abs)
  , fvar    :: a
  , sdest   :: Maybe (File a)  -- ^ symlink madness,
                               --   we need to know where it points to
  , rawdest :: !ByteString
  }
  | BlockDev {
    path :: !(Path Abs)
  , fvar :: a
  }
  | CharDev {
    path :: !(Path Abs)
  , fvar :: a
  }
  | NamedPipe {
    path :: !(Path Abs)
  , fvar :: a
  }
  | Socket {
    path :: !(Path Abs)
  , fvar :: a
  } deriving (Show, Eq)


-- |Low-level file information.
data FileInfo = FileInfo {
    deviceID              :: !DeviceID
  , fileID                :: !FileID
  , fileMode              :: !FileMode
  , linkCount             :: !LinkCount
  , fileOwner             :: !UserID
  , fileGroup             :: !GroupID
  , specialDeviceID       :: !DeviceID
  , fileSize              :: !FileOffset
  , accessTime            :: !EpochTime
  , modificationTime      :: !EpochTime
  , statusChangeTime      :: !EpochTime
  , accessTimeHiRes       :: !POSIXTime
  , modificationTimeHiRes :: !POSIXTime
  , statusChangeTimeHiRes :: !POSIXTime
} deriving (Show, Eq, Ord)




    ------------------------------------
    --[ ViewPatterns/PatternSynonyms ]--
    ------------------------------------




---- Filetypes ----


sfileLike :: File FileInfo -> (Bool, File FileInfo)
sfileLike f@RegFile{}   = (True, f)
sfileLike f@BlockDev{}  = (True, f)
sfileLike f@CharDev{}   = (True, f)
sfileLike f@NamedPipe{} = (True, f)
sfileLike f@Socket{}    = (True, f)
sfileLike f             = fileLikeSym f


fileLike :: File FileInfo -> (Bool, File FileInfo)
fileLike f@RegFile {}  = (True, f)
fileLike f@BlockDev{}  = (True, f)
fileLike f@CharDev{}   = (True, f)
fileLike f@NamedPipe{} = (True, f)
fileLike f@Socket{}    = (True, f)
fileLike f             = (False, f)


sdir :: File FileInfo -> (Bool, File FileInfo)
sdir f@SymLink{ sdest = (Just s@SymLink{} )}
  -- we have to follow a chain of symlinks here, but
  -- return only the very first level
  -- TODO: this is probably obsolete now
  = case sdir s of
      (True, _) -> (True, f)
      _         -> (False, f)
sdir f@SymLink{ sdest = Just Dir{} }
  = (True, f)
sdir f@Dir{} = (True, f)
sdir f       = (False, f)


-- |Matches on any non-directory kind of files, excluding symlinks.
pattern FileLike :: File FileInfo -> File FileInfo
pattern FileLike  f <- (fileLike  -> (True, f))

-- |Matches a list of directories or symlinks pointing to directories.
pattern DirList :: [File FileInfo] -> [File FileInfo]
pattern DirList fs <- (\fs -> (and . fmap (fst . sdir) $ fs, fs)
                                -> (True, fs))

-- |Matches a list of any non-directory kind of files or symlinks
-- pointing to such.
pattern FileLikeList :: [File FileInfo] -> [File FileInfo]
pattern FileLikeList fs <- (\fs -> (and
                                     . fmap (fst . sfileLike)
                                     $ fs, fs) -> (True, fs))



---- Symlinks ----


brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
brokenSymlink f = (isBrokenSymlink f, f)


fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
fileLikeSym f@SymLink{ sdest = Just s@SymLink{} }
  = case fileLikeSym s of
      (True, _) -> (True, f)
      _         -> (False, f)
fileLikeSym f@SymLink{ sdest = Just RegFile{} }   = (True, f)
fileLikeSym f@SymLink{ sdest = Just BlockDev{} }  = (True, f)
fileLikeSym f@SymLink{ sdest = Just CharDev{} }   = (True, f)
fileLikeSym f@SymLink{ sdest = Just NamedPipe{} } = (True, f)
fileLikeSym f@SymLink{ sdest = Just Socket{} }    = (True, f)
fileLikeSym f                                = (False, f)


dirSym :: File FileInfo -> (Bool, File FileInfo)
dirSym f@SymLink{ sdest = Just s@SymLink{} }
  = case dirSym s of
      (True, _) -> (True, f)
      _         -> (False, f)
dirSym f@SymLink{ sdest = Just Dir{} } = (True, f)
dirSym f = (False, f)


-- |Matches on symlinks pointing to file-like files only.
pattern FileLikeSym :: File FileInfo -> File FileInfo
pattern FileLikeSym  f <- (fileLikeSym  -> (True, f))

-- |Matches on broken symbolic links.
pattern BrokenSymlink :: File FileInfo -> File FileInfo
pattern BrokenSymlink  f <- (brokenSymlink  -> (True, f))


-- |Matches on directories or symlinks pointing to directories.
-- If the symlink is pointing to a symlink pointing to a directory, then
-- it will return True, but also return the first element in the symlink-
-- chain, not the last.
pattern DirOrSym :: File FileInfo -> File FileInfo
pattern DirOrSym  f <- (sdir  -> (True, f))

-- |Matches on symlinks pointing to directories only.
pattern DirSym :: File FileInfo -> File FileInfo
pattern DirSym   f <- (dirSym  -> (True, f))

-- |Matches on any non-directory kind of files or symlinks pointing to
-- such.
-- If the symlink is pointing to a symlink pointing to such a file, then
-- it will return True, but also return the first element in the symlink-
-- chain, not the last.
pattern FileLikeOrSym :: File FileInfo -> File FileInfo
pattern FileLikeOrSym  f <- (sfileLike  -> (True, f))





    -----------------
    --[ INSTANCES ]--
    -----------------


-- | First compare constructors: Failed < Dir < File...
-- Then compare `name`...
-- Then compare free variable parameter of `File` constructors
instance Ord (File FileInfo) where
    compare (RegFile n a) (RegFile n' a') =
        case compare n n' of
             EQ -> compare a a'
             el -> el
    compare (Dir n b) (Dir n' b') =
        case compare n n' of
             EQ -> compare b b'
             el -> el
     -- after comparing above we can hand off to shape ord function:
    compare d d' = comparingConstr d d'





    ----------------------------
    --[ HIGH LEVEL FUNCTIONS ]--
    ----------------------------



-- |Reads a file or directory Path into an `AnchoredFile`, filling the free
-- variables via the given function.
pathToFile :: (Path Abs -> IO a)
           -> Path Abs
           -> IO (File a)
pathToFile ff p = do
    fs   <- PF.getSymbolicLinkStatus (P.toFilePath p)
    fv   <- ff p
    constructFile fs fv p
  where
    constructFile fs fv p'
      | PF.isSymbolicLink    fs = do
          -- symlink madness, we need to make sure we save the correct
          -- File
          x <- PF.readSymbolicLink (P.fromAbs p')
          resolvedSyml <- handleIOError (\_ -> return Nothing) $ do
            -- watch out, we call </> from 'filepath' here, but it is safe
            let sfp = (P.fromAbs . P.dirname $ p') </> x
            rsfp <- realpath sfp
            f <- pathToFile ff =<< P.parseAbs rsfp
            return $ Just f
          return $ SymLink p' fv resolvedSyml x
      | PF.isDirectory       fs = return $ Dir       p' fv
      | PF.isRegularFile     fs = return $ RegFile   p' fv
      | PF.isBlockDevice     fs = return $ BlockDev  p' fv
      | PF.isCharacterDevice fs = return $ CharDev   p' fv
      | PF.isNamedPipe       fs = return $ NamedPipe p' fv
      | PF.isSocket          fs = return $ Socket    p' fv
      | otherwise               = ioError $ userError "Unknown filetype!"


-- |Get the contents of a given directory and return them as a list
-- of `AnchoredFile`.
readDirectoryContents :: (Path Abs -> IO a)  -- ^ fills free a variable
                      -> Path Abs            -- ^ path to read
                      -> IO [File a]
readDirectoryContents ff p = do
  files <- getDirsFiles p
  mapM (pathToFile ff) files


-- |A variant of `readDirectoryContents` where the second argument
-- is a `File`. If a non-directory is passed returns an empty list.
getContents :: (Path Abs -> IO a)
            -> File FileInfo
            -> IO [File a]
getContents ff (DirOrSym af)
  = readDirectoryContents ff (path af)
getContents _ _ = return []



-- |Go up one directory in the filesystem hierarchy.
goUp :: File FileInfo -> IO (File FileInfo)
goUp file = pathToFile getFileInfo (P.dirname . path $ file)


-- |Go up one directory in the filesystem hierarchy.
goUp' :: Path Abs -> IO (File FileInfo)
goUp' fp = pathToFile getFileInfo $ P.dirname fp




    -----------------
    --[ UTILITIES ]--
    -----------------





---- ORDERING AND EQUALITY ----


 -- HELPER: a non-recursive comparison
comparingConstr :: File FileInfo -> File FileInfo -> Ordering
comparingConstr (FileLikeOrSym _) (DirOrSym _)      = GT
comparingConstr (DirOrSym _)      (FileLikeOrSym _) = LT
 -- else compare on the names of constructors that are the same, without
 -- looking at the contents of Dir constructors:
comparingConstr t t'  = compare (path t) (path t')







    ---------------
    --[ HELPERS ]--
    ---------------


---- CONSTRUCTOR IDENTIFIERS ----

isFileC :: File a -> Bool
isFileC RegFile{} = True
isFileC _         = False


isDirC :: File a -> Bool
isDirC Dir{} = True
isDirC _     = False


isSymC :: File a -> Bool
isSymC SymLink{} = True
isSymC _         = False


isBlockC :: File a -> Bool
isBlockC BlockDev{} = True
isBlockC _          = False


isCharC :: File a -> Bool
isCharC CharDev{} = True
isCharC _         = False


isNamedC :: File a -> Bool
isNamedC NamedPipe{} = True
isNamedC _           = False


isSocketC :: File a -> Bool
isSocketC Socket{} = True
isSocketC _        = False




---- IO HELPERS: ----



-- |Gets all file information.
getFileInfo :: Path Abs -> IO FileInfo
getFileInfo fp = do
  fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
  return $ FileInfo
    (PF.deviceID fs)
    (PF.fileID fs)
    (PF.fileMode fs)
    (PF.linkCount fs)
    (PF.fileOwner fs)
    (PF.fileGroup fs)
    (PF.specialDeviceID fs)
    (PF.fileSize fs)
    (PF.accessTime fs)
    (PF.modificationTime fs)
    (PF.statusChangeTime fs)
    (PF.accessTimeHiRes fs)
    (PF.modificationTimeHiRes fs)
    (PF.statusChangeTimeHiRes fs)





---- SYMLINK HELPERS: ----


-- |Checks if a symlink is broken by examining the constructor of the
-- symlink destination.
--
-- When called on a non-symlink, returns False.
isBrokenSymlink :: File FileInfo -> Bool
isBrokenSymlink (SymLink _ _ Nothing _) = True
isBrokenSymlink _ = False




---- PACKERS: ----


-- |Pack the modification time into a string.
packModTime :: File FileInfo
            -> String
packModTime = epochToString . modificationTime . fvar


-- |Pack the modification time into a string.
packAccessTime :: File FileInfo
               -> String
packAccessTime = epochToString . accessTime . fvar


epochToString :: EpochTime -> String
epochToString =  show . posixSecondsToUTCTime . realToFrac


-- |Pack the permissions into a string, similar to what "ls -l" does.
packPermissions :: File FileInfo
                -> String
packPermissions file = (pStr . fileMode) . fvar $ file
  where
    pStr :: FileMode -> String
    pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
      where
        typeModeStr = case file of
          Dir {}       -> "d"
          RegFile {}   -> "-"
          SymLink {}   -> "l"
          BlockDev {}  -> "b"
          CharDev {}   -> "c"
          NamedPipe {} -> "p"
          Socket {}    -> "s"
        ownerModeStr =    hasFmStr PF.ownerReadMode    "r"
                       ++ hasFmStr PF.ownerWriteMode   "w"
                       ++ hasFmStr PF.ownerExecuteMode "x"
        groupModeStr =    hasFmStr PF.groupReadMode    "r"
                       ++ hasFmStr PF.groupWriteMode   "w"
                       ++ hasFmStr PF.groupExecuteMode "x"
        otherModeStr =    hasFmStr PF.otherReadMode    "r"
                       ++ hasFmStr PF.otherWriteMode   "w"
                       ++ hasFmStr PF.otherExecuteMode "x"
        hasFmStr fm str
          | hasFM fm  = str
          | otherwise = "-"
        hasFM fm = ffm `PF.intersectFileModes` fm == fm


packFileType :: File a -> String
packFileType file = case file of
  Dir {}       -> "Directory"
  RegFile {}   -> "Regular File"
  SymLink {}   -> "Symbolic Link"
  BlockDev {}  -> "Block Device"
  CharDev {}   -> "Char Device"
  NamedPipe {} -> "Named Pipe"
  Socket {}    -> "Socket"


packLinkDestination :: File a -> Maybe ByteString
packLinkDestination file = case file of
  SymLink { rawdest = dest } -> Just dest
  _                          -> Nothing




---- OTHER: ----


getFPasStr :: File a -> String
getFPasStr = toString . P.fromAbs . path