uniform-fileio-0.1.5.2: Uniform/FileStrings.hs

---------------------------------------------------------------------
-- Module      :  FileIO.Strings
-- read discussion:
-- https://hasufell.github.io/posts/2024-05-07-ultimate-string-guide.html
----------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-- {-# LANGUAGE MultiParamTypeClasses #-}
-- {-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
-- {-# LANGUAGE TypeFamilies #-}
-- {-# OPTIONS_GHC -fno-warn-missing-methods #-}

module Uniform.FileStrings
  ( module Uniform.Filenames,
    module Uniform.FilenamePath,
    module Uniform.FilenameAlgebra,
    module Uniform.FileIOalgebra,
    SIO.IOMode (..),
    closeFile2,
    listDir',
    TIO.hGetLine,
    TIO.hPutStr,
  )
where

import Control.Arrow (first, second)
import Control.DeepSeq (force, ($!!))
import Control.Exception (SomeException, catch)
import Control.Monad (filterM, when)
import Control.Monad.Catch as Catch
  ( Exception,
    MonadThrow,
    SomeException,
  )
import Control.Monad.IO.Class (MonadIO (..))
import qualified Data.ByteString as BS (readFile, writeFile)
import qualified Data.ByteString.Lazy as L
import Data.Digest.Pure.MD5 (md5)
import Data.Either (isLeft)
import Data.List (isPrefixOf)
import Data.Maybe (catMaybes)
import qualified Data.Text.IO as T (appendFile, readFile, writeFile)
import qualified Data.Text.IO as TIO (hGetLine, hPutStr)
import qualified Path
import qualified Path.IO as PathIO
-- import qualified System.Directory as D
import qualified System.FilePath as OS
import qualified System.IO as SIO
import System.Posix (FileMode)
import qualified System.Posix as Posix
import Uniform.FilenameAlgebra
import Uniform.FilenamePath
     
import Uniform.FileIOalgebra
import Uniform.FileStatus
import Uniform.Filenames
import Uniform.FilenamePath as FN  
import Uniform.Strings -- (Text)
import Uniform.Error
import qualified System.Directory as D


closeFile2 :: SIO.Handle -> ErrIO ()
-- close a handle, does not need a filepath
closeFile2 handle = callIO $ SIO.hClose handle

instance FileHandles String where
  write2handle h c = callIO $ SIO.hPutStr h c
  readLine4handle h = callIO $ SIO.hGetLine h

instance FileHandles L.ByteString where
  write2handle h c = callIO $ L.hPutStr h c
  readLine4handle h = error "readLine4handle not implemented for lazy bytestring in FileStrings"

instance FileHandles Text where
  write2handle h c = callIO $ TIO.hPutStr h c
  readLine4handle h = callIO $ TIO.hGetLine h

instance FileHandles [Text] where
  write2handle h c = callIO $ TIO.hPutStr h (unlines' c)
  readLine4handle h = do
    res <- callIO $ TIO.hGetLine h
    return . lines' $ res

listDir' ::
  (MonadIO m, MonadThrow m) =>
  -- | Directory to list
  Path b Dir ->
  -- | Sub-directories and files
  m ([Path Abs Dir], [Path Abs File])
listDir' p = do
  abList :: ([Path.Path Abs Dir], [Path.Path Abs File]) <-
    PathIO.listDir . unPath $ p
  let abPathList = abList
  return abPathList

instance FileSystemOps FilePath where
  checkSymbolicLink fp = callIO $ D.pathIsSymbolicLink fp
  getPermissions' = callIO . D.getPermissions

instance DirOps FilePath where
  doesDirExist' = callIO . D.doesDirectoryExist
  createDirIfMissing' = callIO . D.createDirectoryIfMissing True
  createDirIfMissing =  D.createDirectoryIfMissing True

  createDir' = callIO . D.createDirectory
  renameDir' old new = do
    putIOwords ["renamed start"]
    testSource <- doesDirExist' old
    testTarget <- doesDirExist' new
    if testTarget
      then
        throwErrorT . showT $ new 
      else
        if not testSource
          then
            throwErrorT . showT $ old 
          else do
            callIO $ putStrLn "renamed"
            r <- callIO $ D.renameDirectory old new
            return ()

  getDirectoryDirs' dir = filterM f =<< getDirCont dir
    where
      f = doesDirExist'
  getDirectoryDirsNonHidden' dir = filterM f =<< getDirContNonHidden dir
    where
      f = doesDirExist'

  deleteDirRecursive f =
    do
      t <- doesDirExist' f
      when t $ do
        callIO . D.removeDirectoryRecursive $ f

        putIOwords ["deleted", showT f]

  getHomeDir   =  callIO $ D.getHomeDirectory  
  createDirLink target link  = callIO $ D.createFileLink  target link  
  getSymlinkTarget link = callIO $ D.getSymbolicLinkTarget link  
  removeDirLink link = callIO $ D.removeDirectoryLink link

instance FileOps FilePath where
  doesFileExist' = callIO . D.doesFileExist

  copyOneFile old new = do
    -- source must exist, target must not exist
    t <- doesFileExist' old
    t2 <- doesFileExist' new
    if t && not t2
      then do
        let dir = getParentDir new -- was takeDir
        direxist <- doesDirExist' dir
        unless direxist $
          createDirIfMissing' dir
        callIO $ D.copyFile old new
      else
        if not t
          then
            throwErrorWords ["copyFile source not exist", showT old]
          else
            if t2
              then
                throwErrorWords ["copyFile target exist", showT new]
              else throwErrorWords ["copyOneFile", "other error"]
  copyOneFileOver old new = do
    -- may overwrite existing target
    t <- doesFileExist' old
    if t
      then do
        let dir = getParentDir new -- was takeDir
        direxist <- doesDirExist' dir
        unless direxist $
          createDirIfMissing' dir
        callIO $ D.copyFile old new
      else -- not t - not existing source
        throwErrorWords ["copyFileOver source not exist", showT old]

  getMD5 fn =
    do
      status <- getSymbolicLinkStatus fn
      let regular = isRegularFile status
      readable <- getFileAccess fn (True, False, False)
      if regular && readable
        then callIO $ do
          filedata :: L.ByteString <- L.readFile fn
          let res = showT $ md5 filedata
          return $!! (Just res)
        else throwErrorWords ["getMD5 error file not readable", showT fn]
      `catchE` \e -> do
        putIOwords ["getMD5 in FileStrings.hs", showT fn, showT e]

        throwErrorWords ["getMD5 error for", showT fn]

--   getDirCont fn = getDirContAll True fn

--   getDirContNonHidden fp = do
--     r <- getDirContAll False fp
--     return r

  deleteFile f = do
    callIO . D.removeFile $ f

  getAppConfigDirectory = error "not implemented" -- do

  getSymbolicLinkStatus fp = do
    st <- callIO $ Posix.getSymbolicLinkStatus fp
    return st

  getFileAccess fp (r, w, e) =
    callIO $
      Posix.fileAccess fp r w e

  getFileModificationTime fp = do
    stat :: Posix.FileStatus <- getFileStatus' fp
    let time = getModificationTimeFromStatus stat
    return time

  openFile2handle fp mode =
    callIO $ SIO.openFile fp mode

-- getDirContAll hiddenFlag fn = do
--   -- the hiddenFlag must be true to include them
--   testDir <- doesDirExist' fn
--   readExec <- getFileAccess fn (True, False, True)
--   if testDir && readExec
--     then do
--       r <- callIO . D.listDirectory $ fn
--       let r2 = filter (\file' -> file' /= "." && file' /= "..") r
--       let r3 =
--             if hiddenFlag
--               then r2
--               else filter (not . isPrefixOf ".") r2
--       let r4 = map (fn </>) r3
--       return r4
--     else
--       throwErrorWords
--         [ "getDirCont not exist or not readable",
--           showT fn,
--           showT testDir,
--           showT readExec
--         ]

instance FileSystemOps (Path ar df) where
  getPermissions' = PathIO.getPermissions . unPath
  checkSymbolicLink fp = callIO $ D.pathIsSymbolicLink (unL fp)

instance DirOps (Path Abs Dir) where
  doesDirExist' = PathIO.doesDirExist

  createDir' = PathIO.createDir . unPath

  renameDir' old new =
    -- :: fp -> fp ->  ErrIO Text
    PathIO.renameDir (unPath old) (unPath new)

  getDirectoryDirs' dir = do
    res <- filterM f =<< getDirCont (toFilePath dir)
    return . map makeAbsDir $ res
    where
      f = doesDirExist'
  getDirectoryDirsNonHidden' dir = do
    res <- filterM f =<< getDirContNonHidden (toFilePath dir)
    return . map makeAbsDir $ res
    where
      f = doesDirExist'

  createDirIfMissing' = PathIO.createDirIfMissing True . unPath

  copyDirRecursive old new = PathIO.copyDirRecur (unPath old) (unPath new)

  deleteDirRecursive f = deleteDirRecursive (unL f)

  getHomeDir   =  callIO $ PathIO.getHomeDir 
  createDirLink target link  = callIO $ PathIO.createDirLink  target link  
  getSymlinkTarget link = callIO $ PathIO.getSymlinkTarget link  
  removeDirLink link = callIO $ PathIO.removeDirLink link

instance DirOps (Path Rel Dir) where
  doesDirExist' = PathIO.doesDirExist

  createDir' = PathIO.createDir . unPath

  renameDir' old new =
    PathIO.renameDir (unPath old) (unPath new)

  getDirectoryDirs' dir = do
    res <- filterM f =<< getDirCont (toFilePath dir)
    return . map makeRelDir $ res
    where
      f = doesDirExist'

  getDirectoryDirsNonHidden' dir = do
    res <- filterM f =<< getDirContNonHidden (toFilePath dir)
    return . map makeRelDir $ res
    where
      f = doesDirExist'

  createDirIfMissing' = PathIO.createDirIfMissing True . unPath

  copyDirRecursive old new = PathIO.copyDirRecur (unPath old) (unPath new)

  deleteDirRecursive f = deleteDirRecursive (unL f)

-- just copied from above
--   getHomeDir   =  callIO $ PathIO.getHomeDir -- result is absolute
  createDirLink target link  = callIO $ PathIO.createDirLink  target link  
  getSymlinkTarget link = callIO $ PathIO.getSymlinkTarget link  
  removeDirLink link = callIO $ PathIO.removeDirLink link

instance (Show (Path ar File)) => FileOps (Path ar File) where
  doesFileExist' = PathIO.doesFileExist . unPath

  copyOneFile old new = copyOneFile (unL old) (unL new)
  copyOneFileOver old new = copyOneFileOver (unL old) (unL new)
  renameOneFile old new =
    PathIO.renameFile (unPath old) (unPath new)

  deleteFile f = deleteFile (unL f)

  getMD5 fp = getMD5 (unL fp)

  getDirCont fp =
    error "getDirCont cannot be implemented for Path"
  getDirContNonHidden fp =
    error "getDirContentNonHidden cannot be implemented for Path"

  getFileModificationTime fp = getFileModificationTime (unL fp)

  openFile2handle fp mode = openFile2handle (unL fp) mode

  getFileAccess fp (r, w, e) =
    callIO
      ( do
          Posix.fileAccess (unL fp) r w e
          `catch` \e -> do
            putIOwords ["getFileAccess error", showT fp, s2t $ show (e::SomeException)]
            return False
      )

    

unL = FN.toFilePath

readFileT :: Path ar File -> ErrIO Text
readFileT fp = callIO . T.readFile . unL $ fp

writeFileT :: Path ar File -> Text -> ErrIO ()
writeFileT fp st = callIO $ T.writeFile (unL fp) st

-- attention - does not create file if not existing

instance (Show (Path ar File)) => FileOps2 (Path ar File) String where
  readFile2 fp = callIO $ readFile (unL fp)
  readFile3 fp =   readFile (unL fp)

  -- a strict read (does cloes?)
  writeFile2 fp st = callIO $ writeFile (unL fp) st
  writeFile3 fp st =   writeFile (unL fp) st
  appendFile2 fp st = callIO $ appendFile (unL fp) st

instance (Show (Path ar File)) => FileOps2 (Path ar File) Text where
  readFile2 fp = readFile2 (unL fp)
  readFile3 fp =   readFile3 (unL fp)

  writeFile2 fp st = writeFile2 (unL fp) st
  writeFile3 fp st =   writeFile3 (unL fp) st
  appendFile2 fp st = appendFile2 (unL fp) st

  writeFileOrCreate2 filepath st = do
    let dir = getParentDir filepath

    createDirIfMissing' dir
    when False $ putIOwords ["writeFileOrCreate2 dir created", showT dir]
    t <- doesDirExist' dir
    when False $ putIOwords ["writeFileOrCreate2 dir test", showT t]
    writeFile2 filepath st
    when False $ putIOwords ["writeFileOrCreate2 file written", showT filepath]

instance FileOps2 FilePath Text where
  readFile2 fp = callIO $ T.readFile fp
  writeFile2 fp st = callIO $ T.writeFile fp st
  readFile3 fp =  T.readFile fp
  writeFile3 fp st =   T.writeFile fp st
  appendFile2 fp st = callIO $ T.appendFile fp st
  appendFile3 fp st =  T.appendFile fp st

instance FileOps2 FilePath L.ByteString where
  readFile2 fp = callIO $ L.readFile fp
  writeFile2 fp st = callIO $ L.writeFile fp st
  appendFile2 fp st = callIO $ L.appendFile fp st
  readFile3 fp =  L.readFile fp
  writeFile3 fp st =   L.writeFile fp st
  appendFile3 fp st =   L.appendFile fp st

instance (Show (Path ar File)) => FileOps2 (Path ar File) L.ByteString where
  readFile2 fp = callIO $ L.readFile . unL $ fp
  writeFile2 fp st = callIO $ L.writeFile (unL fp) st
  appendFile2 fp st = callIO $ L.appendFile (unL fp) st
  readFile3 fp =   L.readFile . unL $ fp
  writeFile3 fp st =   L.writeFile (unL fp) st
  appendFile3 fp st =   L.appendFile (unL fp) st

instance FileOps2a FilePath FilePath where
  getDirContentFiles dir =
    filterM doesFileExist'
      =<< getDirCont dir

  getDirContentNonHiddenFiles dir =
    filterM doesFileExist'
      =<< getDirContNonHidden dir

instance FileOps2a (Path Abs Dir) (Path Abs File) where
  getDirContentFiles dir = do
    res <- getDirContentFiles (toFilePath dir)
    return (map makeAbsFile res)
  getDirContentNonHiddenFiles dir = do
    res <- getDirContentNonHiddenFiles (toFilePath dir)
    return (map makeAbsFile res)

instance FileOps2a (Path Rel Dir) (Path Rel File) where
  getDirContentFiles dir = do
    res <- getDirContentFiles (toFilePath dir)
    return (map makeRelFile res)
  getDirContentNonHiddenFiles dir = do
    res <- getDirContentNonHiddenFiles (toFilePath dir)
    return (map makeRelFile res)