diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,10 @@ +0.0.16 + move from versions in Workspace8 2019 + 0.0.8 for use in litText + 0.0.11 fixed callIO and use callIO everywhere + 0.0.12 changed to use path library for filnames + 0.0.14.2 changed copyFile' to copyOneFile renameOneFile + 0.0.14.3 path without wrapper + 0.0.14.6 fix fileExtension confusion + 0.0.15.0 fix building issue with time + 0.0.15.2 lts 16.0 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,23 @@ +Uniform methods to access data in files. + +Goals: + +- same functions with identical semantics independent of representation + +- all functions are total (or become so using `Maybe` or `Either`) + +- performance is NOT a goal - once the program logic is confirmed and tested, performance improvements can be achieved based on observations. The goal for "uniform" is reducing the complexity for the designer of a program - performance improvement come when the logic is correct. + +Specifically: + +- a file path can be given as `Filepath` (which is a string) or as a `Path`, which different types for directories and files and for absolute and relative path, to reduce confusing. + +- functions to work on file path independent of representation + +- functions to access file with either type of path representation + +- operations are total; failures of file operations are signaled by ErrorT or Either returns. + +Experimentally: + +- `TypedFile.hs` tries to extend a type concept from the representation in memory to a representation on file (indicated by the file extension). It proposes a set of functions to read structured files into structured data - selected by the extensions. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/Uniform/FileIO.hs b/Uniform/FileIO.hs new file mode 100644 --- /dev/null +++ b/Uniform/FileIO.hs @@ -0,0 +1,32 @@ +---------------------------------------------------------------------- +-- +-- Module : FileIO +-- Copyright : andrew u frank - +-- +-- | the basic file io - translated for the Either or ErrorT signaling style +-- uses the Path and Path.IO framework + +-- this is the general export + +---------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Uniform.FileIO ( + module Uniform.Filenames + , module Uniform.FileStatus + , module Uniform.FileIOalgebra + , module Uniform.TypedFile + , module Uniform.FileStrings + , module Uniform.Piped + , Path.IO.getAppUserDataDir + , Path.IO.doesFileExist --works in IO, not ErrIO + ) where + +import Uniform.FileIOalgebra -- hiding ((<.>), ()) +import Uniform.Filenames +import Uniform.FileStatus +import Uniform.FileStrings +import Uniform.Piped +import Uniform.TypedFile +import qualified Path.IO (makeAbsolute, getAppUserDataDir, doesFileExist) diff --git a/Uniform/FileIOalgebra.hs b/Uniform/FileIOalgebra.hs new file mode 100644 --- /dev/null +++ b/Uniform/FileIOalgebra.hs @@ -0,0 +1,168 @@ +---------------------------------------------------------------------- +-- +-- Module : Uniform.FileIO +-- Copyright : andrew u frank - +-- +-- reduced oct 2016 to small set +-- separate the operations from the OS and the operations which check for +-- undesirable characters in the filename and extension +-- approach: addExtension checks for bad extension characters +-- checks for filenames in the instances which use legalPathname +-- +---------------------------------------------------------------------- +{-# LANGUAGE MultiParamTypeClasses #-} + +module Uniform.FileIOalgebra + ( module Uniform.FileIOalgebra, + -- module Uniform.Error, + module Uniform.Zero, + module System.IO, + ) +where + +import qualified System.Directory as D +import System.IO (Handle, IOMode (..)) +import Uniform.Error (ErrIO) +import Uniform.FileStatus (EpochTime, FileStatus) +import Uniform.Time (UTCTime, epochTime2UTCTime) +import Uniform.Zero (Zeros(..)) +import Uniform.Strings (Text) + +class FileHandles t where + write2handle :: Handle -> t -> ErrIO () + + -- write a string or text to a handle + readLine4handle :: Handle -> ErrIO t + +-- read a lline from a handle - used? + +--class ListDir d f where +-- listDir' :: d -> ErrIO ([d],[f]) +class FileSystemOps fp where + getPermissions' :: fp -> ErrIO D.Permissions + + checkSymbolicLink :: fp -> ErrIO Bool + -- ^ check if the fp points to a symbolic link + -- better use isSimbolicLink (from FileStatus) + +class DirOps fp where + doesDirExist' :: fp -> ErrIO Bool + createDir' :: fp -> ErrIO () + + -- | write in a dir a new file with content + -- getDirPermissions :: fp -> ErrIO D.Permissions + createDirIfMissing' :: fp -> ErrIO () + + -- | creates the directory, if missing, recursive for path + -- noop if dir exist + renameDir' :: fp -> fp -> ErrIO () + -- ^ rename directory old to new + -- signals: getFileStatus: does not exist (No such file or directory) + + getDirectoryDirs' :: fp -> ErrIO [fp] + + -- get the directories (but not . and ..) + -- getDirectoryDirs' dir = filterM f =<< getDirCont dir + -- where f = doesDirExist' + getDirectoryDirsNonHidden' :: fp -> ErrIO [fp] + + copyDirRecursive :: fp -> fp -> ErrIO () + + -- | copy the directory content recursively, does not follow symlink + -- implemented only for Path n Dir, not FilePath + deleteDirRecursive :: fp -> ErrIO () + -- ^ delete a directory (even non empty), no error if not existing + +class (Show fp) => FileOps fp where + doesFileExist' :: fp -> ErrIO Bool + + copyOneFile :: fp -> fp -> ErrIO () + -- ^ copy a file from old to new + -- source must exist, target must NOT exist + + copyOneFileOver :: fp -> fp -> ErrIO () + -- ^ copy a file from old to new + -- source must exist, target may exist + + renameOneFile :: fp -> fp -> ErrIO () + -- ^ rename a file from old to new + + deleteFile :: fp -> ErrIO () + + -- assertDirNotExist :: fp -> ErrIO () + -- -- ^ delete a directory (even non empty), if exist + + -- | get the directory content - if not existing Nothing, if empty Just [] + -- not returning the special entries . and .. + -- filenames completed with the filename calling + -- check access and readable + -- returns for filepath always an absolute path + -- for Path Rel gives Path Rel results + getDirCont :: fp -> ErrIO [fp] -- (Maybe [String]) + + -- | get the directory content - if not existing Nothing, if empty Just [] + -- not returning any hidden files + -- alphabetic search to assure that equal directories have equal conten + -- independent of file system internal structure + -- filenames completed with calling fp + -- only for filepath! + getDirContNonHidden :: fp -> ErrIO [fp] + + getMD5 :: fp -> ErrIO (Maybe Text) + + -- get MD5, but why Text -- TODO + + getAppConfigDirectory :: ErrIO fp + -- ^ find the .config directory path + + getSymbolicLinkStatus :: fp -> ErrIO FileStatus + -- ^ get status if exist (else Nothing) + -- is the status of the link, does not follow the link + + getFileAccess :: fp -> (Bool, Bool, Bool) -> ErrIO Bool + -- ^ check the read, write and execute permission on file + -- dir get content needs execute, + + getFileModificationTime :: fp -> ErrIO EpochTime + -- ^ get the modification time (replaces isFileAbeforeB) + + getFileModificationUTCTime :: fp -> ErrIO UTCTime + -- ^ get the modification time in UTCTIme + getFileModificationUTCTime = fmap epochTime2UTCTime . getFileModificationTime + + -- operations on handle + + openFile2handle :: fp -> IOMode -> ErrIO Handle + +-- | operations on dir to produce file +class (Show fd, Show ff) => FileOps2a fd ff where + getDirContentFiles :: fd -> ErrIO [ff] + + getDirContentNonHiddenFiles :: fd -> ErrIO [ff] + +---- | the operations on files with content +class + (Show fp) => + FileOps2 fp fc + where + -- + writeFile2 :: fp -> fc -> ErrIO () + + -- write file if dir exist + readFile2 :: fp -> ErrIO fc + + -- read file + appendFile2 :: fp -> fc -> ErrIO () + + writeFileOrCreate2 :: fp -> fc -> ErrIO () + + -- + + readFileOrZero2 :: (FileOps fp, Zeros fc) => fp -> ErrIO fc + + -- | reads file, if not present, returns zero + readFileOrZero2 fp = do + f <- doesFileExist' fp + if f + then readFile2 fp + else return zero diff --git a/Uniform/FileStatus.hs b/Uniform/FileStatus.hs new file mode 100644 --- /dev/null +++ b/Uniform/FileStatus.hs @@ -0,0 +1,67 @@ +---------------------------------------------------------------------- +-- +-- Module : uniform-FileIO +-- Copyright : andrew u frank - +-- +---------------------------------------------------------------------- + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | the routines to take apart the file status +module Uniform.FileStatus + ( getFileStatus, + isDirectory, + isRegularFile, + getFileStatus', + isSymbolicLink, + getModificationTimeFromStatus, + getFileSize, + P.EpochTime, + P.FileStatus, + ) +where + +import qualified System.Directory as S +import qualified System.Posix as P +import Uniform.Error +-- (ErrIO, callIO, putIOwords, showT) +import Uniform.Filenames (Path, toShortFilePath) +import Uniform.Strings (putIOwords, showT) + +unL :: Path df ar -> FilePath +unL = toShortFilePath + +--getFileStatus :: Path df ra -> ErrIO P.FileStatus +-- getFileStatus :: (Control.Monad.Error.Class.MonadError m, +-- Control.Monad.IO.Class.MonadIO m, +-- Control.Monad.Error.Class.ErrorType m ~ Data.Text.Internal.Text) +-- => Path df ar -> m P.FileStatus +getFileStatus fp = callIO $ P.getFileStatus . unL $ fp + +getFileStatus' :: FilePath -> ErrIO P.FileStatus +getFileStatus' fp = callIO $ P.getFileStatus fp + +isRegularFile :: P.FileStatus -> Bool +isRegularFile = P.isRegularFile + +isDirectory :: P.FileStatus -> Bool +isDirectory = P.isDirectory + +isSymbolicLink :: P.FileStatus -> Bool +isSymbolicLink = P.isSymbolicLink + +getModificationTimeFromStatus :: P.FileStatus -> P.EpochTime +getModificationTimeFromStatus = P.modificationTime + +getFileSize = P.fileSize + +createSymbolicLink :: Show (Path df ra) => Path df ra -> Path df ra -> ErrIO () +createSymbolicLink fn tn = do + putIOwords ["createSymbolidLink", showT fn, "to", showT tn] + callIO $ P.createSymbolicLink (unL fn) (unL tn) + +renameLink :: Path df ra -> Path df ra -> ErrIO () +renameLink old new = callIO $ P.rename (unL old) (unL new) diff --git a/Uniform/FileStrings.hs b/Uniform/FileStrings.hs new file mode 100644 --- /dev/null +++ b/Uniform/FileStrings.hs @@ -0,0 +1,394 @@ +--------------------------------------------------------------------- +-- Module : FileIO.Strings +-- +---------------------------------------------------------------------- +{-# 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.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.FileIOalgebra +import Uniform.FileStatus +import Uniform.Filenames +import Uniform.Filenames as FN (toFilePath) +import Uniform.Strings -- (Text) +import Uniform.Error + + +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 + + 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] + +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 + throwErrorT + ["copyFile source not exist", showT old] + else + if t2 + then + throwErrorT + ["copyFile target exist", showT new] + else throwErrorT ["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 + throwErrorT ["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 throwErrorT ["getMD5 error file not readable", showT fn] + `catchError` \e -> do + putIOwords ["getMD5 in FileStrings.hs", showT fn, showT e] + + throwErrorT ["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 + throwErrorT + [ "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) + +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) + +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 + `catchError` \e -> do + putIOwords ["getFileAccess error", showT fp, s2t $ show e] + 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) + + -- a strict read (does cloes?) + writeFile2 fp st = callIO $ 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) + + writeFile2 fp st = writeFile2 (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 + appendFile2 fp st = callIO $ 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 + +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 + +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) diff --git a/Uniform/Filenames.hs b/Uniform/Filenames.hs new file mode 100644 --- /dev/null +++ b/Uniform/Filenames.hs @@ -0,0 +1,277 @@ +------------------------------------------------------------------- +-- +-- Module : Filenames +-- Copyright : andrew u frank - +-- +---------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | the operations on filenames and extensions +-- uses the Path library, but wraps it in Path (to construct a read) +-- is a class except for the make +module Uniform.Filenames + ( module Uniform.Filenames, + module Uniform.Error, + Abs, + Rel, + File, + Dir, + Path, + toFilePath, + ) +where + +-- for Generics +import Path + ( Abs, + Dir, + File, + Path, + Rel, + toFilePath, + ) +import qualified Path +import qualified Path.IO as PathIO +import qualified System.FilePath as S +import Uniform.Error(ErrIO, callIO) +-- import Uniform.Zero(Zeros(..)) +import Uniform.Strings +-- (Text, fromJustNote, t2s) + +takeBaseName' :: FilePath -> FilePath +takeBaseName' = S.takeBaseName + +homeDir :: Path Abs Dir +homeDir = makeAbsDir "/home/frank/" :: Path Abs Dir + +homeDir2 :: ErrIO (Path Abs Dir) +homeDir2 = callIO PathIO.getHomeDir :: ErrIO (Path Abs Dir) + +-- replace homeDir with homeDir2 - is user independent but requires IO +currentDir :: ErrIO (Path Abs Dir) +currentDir = callIO PathIO.getCurrentDir + +setCurrentDir :: Path Abs Dir -> ErrIO () +setCurrentDir path = PathIO.setCurrentDir (unPath path) + +stripProperPrefix' :: Path b Dir -> Path b t -> ErrIO (Path Rel t) +stripProperPrefix' dir fn = Path.stripProperPrefix (unPath dir) (unPath fn) + +stripProperPrefixMaybe :: Path b Dir -> Path b t -> Maybe (Path Rel t) +stripProperPrefixMaybe dir fn = Path.stripProperPrefix (unPath dir) (unPath fn) + +unPath :: a -> a +unPath = id + + + +makeRelFile :: FilePath -> Path Rel File +makeRelDir :: FilePath -> Path Rel Dir +makeAbsFile :: FilePath -> Path Abs File +makeAbsDir :: FilePath -> Path Abs Dir +makeRelFile fn = fromJustNote ("makeRelFile " ++ fn) $ Path.parseRelFile fn + +makeRelDir fn = fromJustNote ("makeRelDir " ++ fn) $ Path.parseRelDir fn + +makeAbsFile fn = fromJustNote ("makeAbsFile " ++ fn) $ Path.parseAbsFile fn + +makeAbsDir fn = fromJustNote ("makeAbsDir " ++ fn) $ Path.parseAbsDir fn + +makeRelFileT :: Text -> Path Rel File +makeRelDirT :: Text -> Path Rel Dir +makeAbsFileT :: Text -> Path Abs File +makeAbsDirT :: Text -> Path Abs Dir +makeRelFileT = makeRelFile . t2s + +makeRelDirT = makeRelDir . t2s + +makeAbsFileT = makeAbsFile . t2s + +makeAbsDirT = makeAbsDir . t2s + +toShortFilePath :: Path df ar -> FilePath +---- ^ get the filepath, but without the trailing separator +-- , necessary for systemcalls +toShortFilePath = S.dropTrailingPathSeparator . toFilePath + +instance Zeros (Path Abs Dir) where + zero = makeAbsDir "/" + +instance Zeros (Path Abs File) where + zero = makeAbsFile "/zero" + +instance Zeros (Path Rel Dir) where + zero = makeRelDir "./" + +instance Zeros (Path Rel File) where + zero = makeRelFile "zero" + +newtype Extension = Extension FilePath deriving (Show, Read, Eq, Ord) + +unExtension :: Extension -> FilePath +unExtension (Extension e) = e + +makeExtension :: FilePath -> Extension +makeExtension = Extension + +-- extension does not include a leading "." +-- would need a makeExtension in IO to catch errors here +makeExtensionT :: Text -> Extension +makeExtensionT = Extension . t2s + +class Filenames fp fr where + getFileName :: fp -> fr + +class Filenames3 fp file where + type FileResultT fp file + + -- add a filepath to a absolute dir and givev an absolte file + -- + (), addFileName :: fp -> file -> FileResultT fp file + -- fails, if file is empty does not add anything if file is empty + () = addFileName + +class Filenames5 dir fil res where + stripPrefix :: dir -> fil -> Maybe res + -- ^ strip the + +instance Filenames5 (Path b Dir) (Path b t) (Path Rel t) where + stripPrefix d f = Path.stripProperPrefix (unPath d) (unPath f) + +class Filenames4 fp file where + type FileResultT4 fp file + + -- add a filepath to a absolute dir and givev an absolte dir + -- + addDir :: fp -> file -> FileResultT4 fp file + +class Filenames1 fp where + -- instantiate only for filepath TODO do for path + getImmediateParentDir :: fp -> FilePath + -- ^ gets the name of the dir immediately above + + getParentDir :: fp -> FilePath + -- ^ the parent dir of file + + getNakedFileName :: fp -> FilePath + -- ^ filename without extension + + getNakedDir :: fp -> FilePath + -- ^ get the last dir + +instance Filenames FilePath FilePath where + getFileName = snd . S.splitFileName + +instance Filenames3 FilePath FilePath where + type FileResultT FilePath FilePath = FilePath + addFileName = S.combine + +instance Filenames (Path ar File) (Path Rel File) where + getFileName = Path.filename . unPath + +instance Filenames3 (Path b Dir) FilePath where + type FileResultT (Path b Dir) FilePath = (Path b File) + addFileName p d = + if null' d + then error ("addFileName with empty file" ++ d) + else (Path.) (unPath p) (unPath d2) + where + d2 = makeRelFile d :: Path Rel File + +instance Filenames4 FilePath FilePath where + type FileResultT4 FilePath FilePath = FilePath + addDir p d = if null' d then p else p d + +instance Filenames4 (Path b Dir) FilePath where + type FileResultT4 (Path b Dir) FilePath = (Path b Dir) + addDir p d = + if null' d + then p + else p d2 + where + d2 = makeRelDir d :: Path Rel Dir + +instance Filenames4 (Path b Dir) (Path Rel t) where + type FileResultT4 (Path b Dir) (Path Rel t) = (Path b t) + addDir p d = (Path.) (unPath p) (unPath d) + +instance Filenames3 (Path b Dir) (Path Rel t) where + type FileResultT (Path b Dir) (Path Rel t) = (Path b t) + addFileName p d = (Path.) (unPath p) (unPath d) + +instance Filenames1 (Path ar File) where + getNakedFileName = getNakedFileName . toFilePath + getImmediateParentDir = getImmediateParentDir . toFilePath + getParentDir = getParentDir . toFilePath + getNakedDir = error "getNakedDir for Filenamse1 Path ar File) not existing" + +instance Filenames1 (Path ar Dir) where + getNakedFileName = error "getNakedFileName not from Dir" + getImmediateParentDir = getImmediateParentDir . toFilePath + getParentDir = getParentDir . toFilePath + getNakedDir = getNakedDir . toFilePath + +instance Filenames1 FilePath where + getNakedFileName = removeExtension . getFileName + getImmediateParentDir = (!! 1) . reverse . S.splitDirectories + getParentDir = S.takeDirectory + getNakedDir = (!! 0) . reverse . S.splitDirectories + +class (Eq (ExtensionType fp)) => Extensions fp where + -- extension do not include a leading '.' + type ExtensionType fp + getExtension :: fp -> ExtensionType fp + removeExtension :: fp -> fp + addExtension :: ExtensionType fp -> fp -> fp + + -- must not have an extension before + (<.>) :: fp -> ExtensionType fp -> fp -- eror when not legal? + (<.>) f e = addExtension e f + setExtension :: ExtensionType fp -> fp -> fp + hasExtension :: ExtensionType fp -> fp -> Bool + hasExtension e = (e ==) . getExtension + + prop_add_has :: ExtensionType fp -> fp -> Bool + prop_add_has e f = hasExtension e (addExtension e f) + prop_add_add_has :: ExtensionType fp -> ExtensionType fp -> fp -> Bool + prop_add_add_has e1 e2 f = + hasExtension + e1 + (setExtension e1 . setExtension e2 $ f) + prop_set_get :: ExtensionType fp -> fp -> Bool + prop_set_get e f = ((e ==) . getExtension) (setExtension e f) + +instance Extensions FilePath where + type ExtensionType FilePath = FilePath + + getExtension = removeChar '.' . snd . S.splitExtension + addExtension e fp = fp S.<.> e + removeExtension = fst . S.splitExtension + setExtension e = addExtension e . removeExtension + +-- hasExtension e = (e ==) . getExtension + +instance Extensions (Path ar File) where + type ExtensionType (Path ar File) = Extension + + getExtension f = Extension e + where + -- definition of extension in path is with leading '.' + -- multiple extensions are gradually built and removed + -- split gives only the last + -- add allows only one to add + -- empty extensions throw error + + e = getExtension . toFilePath $ f + + setExtension e f = + fromJustNote "setExtension" $ Path.setFileExtension (unExtension e) f + + addExtension = setExtension + removeExtension = setExtension (Extension "") diff --git a/Uniform/Piped.hs b/Uniform/Piped.hs new file mode 100644 --- /dev/null +++ b/Uniform/Piped.hs @@ -0,0 +1,92 @@ +---------------------------------------------------------------------- +-- +-- Module : piped +-- Copyright : andrew u frank - +-- +--------------------------------------------------------------------- +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +-- | the recursive access to many files not blocking +module Uniform.Piped + ( getRecursiveContents, + -- , pipeMap, pipeStdoutLn + pipedDoIO, + ) +where + +import Data.List (sort) +import qualified Path.IO (readable, searchable) +import Pipes ((>->)) +import qualified Pipes as Pipe +import qualified Pipes.Prelude as PipePrelude +import Uniform.Error +-- ( ErrIO, +-- ErrorT, +-- Text, +-- putIOwords, +-- showT, +-- t2s, +-- when, +-- ) +import Uniform.Strings +import Uniform.FileStrings + +getRecursiveContents :: -- (Path Abs File-> Pipe.Proxy Pipe.X () () String (ErrorT Text IO) ()) + Path Abs Dir -> + Pipe.Proxy Pipe.X () () (Path Abs File) (ErrorT Text IO) () +getRecursiveContents fp = do + -- putIOwords ["recurseDir start", showT fp] + perm <- Pipe.lift $ getPermissions' fp + if not (Path.IO.readable perm && Path.IO.searchable perm) + then Pipe.lift $ putIOwords ["recurseDir not readable or not searchable", showT fp] + else do + symLink <- Pipe.lift $ checkSymbolicLink fp -- callIO $ xisSymbolicLink fp + if symLink + then Pipe.lift $ putIOwords ["recurseDir symlink", showT fp] + else do + (dirs, files) <- Pipe.lift $ listDir' fp + when False $ do + Pipe.lift $ putIOwords ["recurseDir files\n", showT files] + Pipe.lift $ putIOwords ["recurseDir directories\n", showT dirs] + + Prelude.mapM_ Pipe.yield (sort files) + -- (Path.IO.sort (map unPath files)) + Prelude.mapM_ getRecursiveContents (sort dirs) + -- (Path.IO.sort (map unPath dirs)) + return () -- where processOneFile fp = Pipe.yield fp + +-- +---- examples how to use... +-- +--pipedDo :: LegalPathname -> (LegalPathname -> Text) -> ErrIO () +--pipedDo path transf = do +-- +-- runEffect $ +-- getRecursiveContents path +-- >-> P.map (t2s . transf) +-- >-> P.stdoutLn +-- +--testDir = fromJustNote "testdir" $ makeLegalPath "/home/frank/Workspace8/uniform-fileio/testDirFileIO" +--test_getRec = do +-- res <- runErr $ pipedDo testDir (showT) +-- assertEqual (Right ()) res +-- -- check manually +-- +-- +-- +-- + +-- | a convenient function to go through a directory and +-- recursively apply a function to each +pipedDoIO :: Path Abs File -> Path Abs Dir -> (Path Abs File -> Text) -> ErrIO () +pipedDoIO file path transf = do + hand <- openFile2handle file WriteMode + Pipe.runEffect $ + getRecursiveContents path + >-> PipePrelude.map (t2s . transf) -- some IO type left? + >-> PipePrelude.toHandle hand + closeFile2 hand + return () diff --git a/Uniform/TypedFile.hs b/Uniform/TypedFile.hs new file mode 100644 --- /dev/null +++ b/Uniform/TypedFile.hs @@ -0,0 +1,292 @@ +---------------------------------------------------------------------- +-- +-- Module : uniform.TypedFile +-- Copyright : andrew u frank - +-- +-- mapping data structures to files typed with an extension +-- write and read quasi type-checked +---------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Uniform.TypedFile + ( module Uniform.TypedFile, + GZip.compress, + GZip.decompress, + EpochTime, + ) +where + +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString.Lazy as L +import qualified Path.IO (ensureDir) +import Uniform.FileIOalgebra (Handle) +import Uniform.FileStatus (EpochTime) +import Uniform.FileStrings +import Uniform.Filenames as FN (Path) +import Uniform.Strings +import Uniform.Error + +data TypedFile5 a b = TypedFile5 {tpext5 :: Extension} + +rdfGraphDebug = False + +-- | reads or writes a structured file with the specified parsers or writer +-- the first parameter is the type of file, it is the type of the +-- input data and the returned data +-- the second an arbitrary differentiation +-- to allow two file types with different extension and read +-- the b can be () if no differentiation is desired +class + (FileHandles a) => + TypedFiles5 a b + where + append5 f = errorT ["TypedFiles - no implementation for append5", showT f] + read5 f = errorT ["TypedFiles - no implementation for read5", showT f] + read6 f = errorT ["TypedFiles - no implementation for read6", showT f] + append6 f = errorT ["TypedFiles - no implementation for append6", showT f] + openHandle6 f = errorT ["TypedFiles - no implementation for openHandle6", showT f] + writeHandle6 f = errorT ["TypedFiles - no implementation for writeHandle6", showT f] + closeHandle6 f = errorT ["TypedFiles - no implementation for closeHandle6", showT f] + + write5 :: FN.Path Abs Dir -> Path Rel File -> TypedFile5 a b -> a -> ErrIO () + -- write a file, directory is created if not exist + -- file, if exist, is replaced + write5 fp fn tp ct = do + dirx <- Path.IO.ensureDir (unPath fp) + write6 (fp fn) tp ct + + append5 :: Path Abs Dir -> Path Rel File -> TypedFile5 a b -> a -> ErrIO () + read5 :: Path Abs Dir -> Path Rel File -> TypedFile5 a b -> ErrIO a + + write6 :: Path Abs File -> TypedFile5 a b -> a -> ErrIO () + -- write a file, directory is created if not exist + -- file, if exist, is replaced + write6 fp tp queryText = do + -- when rdfGraphDebug $ + putIOwords ["write6", showT fp] + -- let fn2 = fp addExt lpX fn (tpext tp) -- :: LegalPathname + let fn2 = setExtension (tpext5 tp) fp + createDirIfMissing' (getParentDir fp) -- add everywhere? + when rdfGraphDebug $ + putIOwords + [ "sparql Turtle createDIrIfMissing' ", + showT (getParentDir fp) + ] + hand <- openFile2handle fn2 WriteMode + -- when rdfGraphDebug $ putIOwords ["write6", showT fn2] + + write2handle hand queryText -- changed for Text not [] + closeFile2 hand + + openHandle6 :: Path Abs File -> TypedFile5 a b -> ErrIO Handle + + -- | create the file and open the handle + -- should attache ".tmp" to extension and when closing + -- rename to correct filename - > transaction completed + writeHandle6 :: Handle -> TypedFile5 a b -> a -> ErrIO () + + closeHandle6 :: Path Abs File -> TypedFile5 a b -> Handle -> ErrIO () + + -- | close the handle - with transaction + append6 :: Path Abs File -> TypedFile5 a b -> a -> ErrIO () + + -- append to the file, with the same methods as in write6 + read6 :: Path Abs File -> TypedFile5 a b -> ErrIO a + + exist6 :: Path Abs File -> TypedFile5 a b -> ErrIO Bool + -- ^ check whether file exist + exist6 fp tp = do + let fn2 = setExtension (tpext5 tp) fp :: Path Abs File + doesFileExist' fn2 + + modificationTime6 :: Path Abs File -> TypedFile5 a b -> ErrIO EpochTime + modificationTime6 fp tp = do + let fn2 = setExtension (tpext5 tp) fp :: Path Abs File + t :: EpochTime <- getFileModificationTime fn2 + return t + + isTyped :: Path Abs File -> TypedFile5 a b -> Bool + -- ^ check if a given file is of the right type (extenions, not mime type) + isTyped fp tp = getExtension fp == typedExtension tp + + typedExtension :: TypedFile5 a b -> Extension + -- ^ get the extension back + typedExtension tp = tpext5 tp + + makeTyped :: Extension -> TypedFile5 a b + -- make a typed file type, needs type specification! + makeTyped ext = TypedFile5 {tpext5 = ext} + +instance TypedFiles5 Text b where + -- file contains a list of lines (text) + write5 fp fn tp ct = do + dirx <- Path.IO.ensureDir (unPath fp) + let fn2 = fn <.> tpext5 tp -- :: Path ar File + writeFile2 (fp fn2) ct + + -- writeFile2 (fp (fn <.> (tpext tp) )) . unlines' + append5 fp fn tp ct = do + dirx <- Path.IO.ensureDir (unPath fp) + let fn2 = fn <.> tpext5 tp -- :: Path ar File + appendFile2 (fp fn2) ct + read5 fp fn tp = do + let fn2 = fn <.> tpext5 tp + readFile2 $ fp fn2 + + append6 fn tp ct = do + let fn2 = setExtension (tpext5 tp) fn + appendFile2 fn2 ct + write6 fn tp ct = do + let fn2 = setExtension (tpext5 tp) fn + hand <- openFile2handle fn2 WriteMode + + write2handle hand ct + + closeFile2 hand + + exist6 fn tp = do + let fn2 = setExtension (tpext5 tp) fn + doesFileExist' fn2 + + read6 fn tp = do + let fn2 = setExtension (tpext5 tp) fn + readFile2 fn2 + +instance TypedFiles5 [Text] b where + -- file contains a list of lines (text) + -- mkTypedFile5 = TypedFile5 { tpext5 = Extension "txt"} + write5 fp fn tp ct = do + dirx <- Path.IO.ensureDir (unPath fp) + let fn2 = fn <.> tpext5 tp -- :: Path ar File + writeFile2 (fp fn2) (unlines' ct) + + append5 fp fn tp ct = do + dirx <- Path.IO.ensureDir (unPath fp) + let fn2 = fn <.> tpext5 tp -- :: Path ar File + appendFile2 (fp fn2) (unlines' ct) + read5 fp fn tp = do + let fn2 = fn <.> tpext5 tp + fmap lines' . readFile2 $ fp fn2 + + append6 fn tp ct = do + let fn2 = setExtension (tpext5 tp) fn + appendFile2 fn2 (unlines' ct) + write6 fn tp ct = do + let fn2 = setExtension (tpext5 tp) fn + hand <- openFile2handle fn2 WriteMode + + write2handle hand (unlines' ct) + + closeFile2 hand + + exist6 fn tp = do + let fn2 = setExtension (tpext5 tp) fn + doesFileExist' fn2 + + read6 fn tp = do + let fn2 = setExtension (tpext5 tp) fn + fmap lines' . readFile2 $ fn2 + +data GZip + +-- | files with full triples stored as zip +instance TypedFiles5 LazyByteString GZip where + append6 fp tp jsonld = do + when rdfGraphDebug $ putIOwords ["triples append6", showT fp] + let fn2 = setExtension (tpext5 tp) fp + + appendFile2 fn2 (GZip.compress jsonld) + + openHandle6 fp tp = do + when rdfGraphDebug $ putIOwords ["openHandle6 jsonld"] + let ext = unExtension (tpext5 tp) + let tmpext = Extension (ext <.> "tmp") + let fn2 = setExtension tmpext fp + when rdfGraphDebug $ putIOwords ["openHandle6 jsonld", showT fn2] + + createDirIfMissing' (getParentDir fn2) -- add everywhere? + hand <- openFile2handle fn2 WriteMode + -- should create or truncate the file, but not when the dir not exist + --https://hackage.haskell.org/package/base-4.10.0.0/docs/System-IO.html#g:5 + when rdfGraphDebug $ putIOwords ["openHandle6 jsonld", showT fn2] + return hand + + closeHandle6 fp tp hand = do + -- when rdfGraphDebug $ + when rdfGraphDebug $ putIOwords ["closeHandle6 jsonld"] + let ext = unExtension (tpext5 tp) + let tmpext = Extension (ext <.> "tmp") + closeFile2 hand + let fn2 = setExtension tmpext fp + let fn1 = setExtension (tpext5 tp) fp + renameOneFile fn2 fn1 + when rdfGraphDebug $ putIOwords ["closeHandle6 jsonld", showT fn2] + return () + + writeHandle6 hand tp jsonld = do + r <- write2handle hand (GZip.compress jsonld) + return r + + read6 fp tp = error "read for jsonld is not easy and not required" + +-- | the a is the base type +-- which is written on file, b is the type for input and output +class FileHandles a => TypedFiles7 a b where + wrap7 :: a -> b + unwrap7 :: b -> a + +class FileHandles a => TypedFiles7a a b where + -- | the 7 have two arguments for path and file + read7 :: Path Abs Dir -> Path Rel File -> TypedFile5 a b -> ErrIO b + + write7 :: Path Abs Dir -> Path Rel File -> TypedFile5 a b -> b -> ErrIO () + + -- | the 8 versions have a single argument for path and file + read8 :: Path Abs File -> TypedFile5 a b -> ErrIO b + + write8 :: Path Abs File -> TypedFile5 a b -> b -> ErrIO () + -- ^ the createDir if missingis implied in the write + +instance (TypedFiles7 Text b) => TypedFiles7a Text b where + -- an instance for all what has text or bytestring as underlying rep + write7 fp fn tp ct = do + write8 (fp fn) tp ct + + read7 fp fn tp = do + read8 (fp fn) tp + + write8 fp tp ct = do + let fn2 = fp <.> tpext5 tp -- :: Path ar File + let parent = getParentDir fn2 + createDirIfMissing' parent + + writeFile2 fn2 (unwrap7 ct :: Text) + + read8 fp tp = do + let fp2 = fp <.> tpext5 tp + ares :: Text <- readFile2 fp2 + return . wrap7 $ ares + +instance (TypedFiles7 L.ByteString b) => TypedFiles7a L.ByteString b where + -- an instance for all what has text or bytestring as underlying rep + write7 fp fn tp ct = do + write8 (fp fn) tp ct + + read7 fp fn tp = do + read8 (fp fn) tp + + write8 fp tp ct = do + let fn2 = fp <.> tpext5 tp -- :: Path ar File + let parent = getParentDir fn2 + createDirIfMissing' parent + writeFile2 fn2 (unwrap7 ct :: L.ByteString) + + read8 fp tp = do + let fp2 = fp <.> tpext5 tp + ares :: L.ByteString <- readFile2 fp2 + return . wrap7 $ ares diff --git a/tests/Testing.hs b/tests/Testing.hs new file mode 100644 --- /dev/null +++ b/tests/Testing.hs @@ -0,0 +1,52 @@ +----------------------------------------------------------------------------- +-- +-- Module : top tests for layout +----------------------------------------------------------------------------- +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- module Testing where -- must have Main (main) or Main where + + +--import System.Exit + +import Test.Framework + +-- import {-@ HTF_TESTS @-} Uniform.FileStrings_test +-- -- import {-@ HTF_TESTS @-} Uniform.ByteString_test +import {-@ HTF_TESTS @-} Uniform.Filenames_test +-- import {-@ HTF_TESTS @-} Uniform.PathShowCase_test +-- import {-@ HTF_TESTS @-} Uniform.FileStatus_test +-- -- import {-@ HTF_TESTS @-} Uniform.Piped_test +-- import {-@ HTF_TESTS @-} Uniform.TypedFile_test + +import Uniform.Strings +import Uniform.Error +--import TestingFileIO + +test_fileio = assertBool False + +main :: IO () +main = do + + putIOwords ["HTF LayoutTest.hs:\n posTest"] +-- htfMainWithArgs ["--quiet"] htf_importedTests + htfMain htf_importedTests + putIOwords ["HTF end LayoutTest.hs:\n posTest"] + runTest test_fileio + return () + +file1test = do + putStrLn "file1test" + -- push2 + -- runErrorVoid $ do + -- test_hidden1 + return () diff --git a/tests/Uniform/FileStatus_test.hs b/tests/Uniform/FileStatus_test.hs new file mode 100644 --- /dev/null +++ b/tests/Uniform/FileStatus_test.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- +-- Module : uniform-FileIO +-- Copyright : andrew u frank - +-- +-- | the routines to take apart the file status +----------------------------------------------------------------------------- +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE + MultiParamTypeClasses + , TypeSynonymInstances + , FlexibleInstances + , FlexibleContexts +-- , DeriveFunctor + , ScopedTypeVariables +-- , UndecidableInstances + , TypeFamilies + , OverloadedStrings + + #-} +-- {-# OPTIONS_GHC -fno-warn-missing-methods #-} + +{-# OPTIONS -w #-} + +module Uniform.FileStatus_test where + +----import qualified Data.Text as T +----import Path +----import Path.IO +--import qualified System.Posix as P +--import qualified System.Directory as S +------import Basics +--import Uniform.Error +--import Uniform.Zero +--import Uniform.Strings +--import Uniform.Filenames + +import Test.Framework + + + + + diff --git a/tests/Uniform/FileStrings_test.hs b/tests/Uniform/FileStrings_test.hs new file mode 100644 --- /dev/null +++ b/tests/Uniform/FileStrings_test.hs @@ -0,0 +1,271 @@ +------------------------------------------------------------------------------ +-- +-- Module : FileIO.Strings +-- +-- | the instance for strings (was in 0.1.1) +-- filenames are Path +-- should only export the instances +-- removed -- file content can be lazy bytestring +----------------------------------------------------------------------------- +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- {-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS -w #-} + +module Uniform.FileStrings_test where + +import Uniform.FileStrings +import Uniform.FileIOalgebra +--import Uniform.FilenamesAlgebra +import Uniform.Filenames +import Uniform.FileStatus +-- import Uniform.Strings hiding ((<.>), ()) + +import Test.Framework +import Test.Invariant +import Data.List +--import Path as P +--import Path.IO as P +-- +--import Path +--import Path.IO +-- +---- what is further required? +--import qualified System.IO as SIO +--import System.Posix (FileMode) +-- +-- +--import qualified Data.ByteString as BS (readFile, writeFile) +import qualified Data.ByteString.Lazy as L +--import Data.Digest.Pure.MD5 (md5) +----import Data.Hash.MD5 (md5s) +--import Data.Maybe (catMaybes) +--import qualified Data.Text.IO as T (readFile, writeFile, appendFile) +--import qualified Data.Text.IO as TIO (hGetLine, hPutStr) +-- +--import qualified System.Directory as D +----import qualified System.Directory as D +--import qualified System.FilePath as OS +---- (addExtension, makeRelative, FilePath, combine, splitPath, +---- takeDirectory, replaceExtension, takeExtension) +--import qualified System.Posix as P +---- for fileAccess +--import Control.Arrow (second) +--import Control.DeepSeq (force, ($!!)) +--import Control.Exception (SomeException, catch) +--import Control.Monad.Catch +--import Control.Monad.IO.Class +import Data.Either (isLeft) +--import Data.List (isPrefixOf) + +----for testing: +--readFile5 :: Path ar File -> IO Text +--readFile5 = fmap s2t .readFile . toFilePath + + +--------------------------test with path + +notexisting = makeRelFile "xxxxabcd" + +test_catch_error2p = do + res <- runErr $ do + f :: Text <- readFile2 notexisting + return False + `catchError ` + \(e::Text) -> return True + assertEqual (Right True) res + +test_call_IOp = do + res <- runErr $ do + f :: String <- readFile2 notexisting -- not existing fileAccess + return False -- expect that read fials + assertEqual ( Left "xxxxabcd: openFile: does not exist (No such file or directory)") res + +test_call_IO_Lp = do + res <- runErr $ do + f :: L.ByteString <- readFile2 notexisting -- not existing fileAccess + return False -- expect that read fials + assertEqual ( Left "xxxxabcd: openBinaryFile: does not exist (No such file or directory)") res + +test_call_NotExist = do + res <- runErr $ do + f :: Bool <- doesFileExist' notexisting -- not existing fileAccess + return f + assertEqual (Right False) res + +--test_call_IO_Corrupt= do +-- res <- runErr $ callIO $ do +-- f :: L.ByteString <- L.readFile corruptJPG -- not existing fileAccess +-- putIOwords ["call_IO_Corrupt", showT . L.length $ f] -- just to enforce strictness +-- return False -- expect that read fials +-- assertEqual ( Left "/home/frank/additionalSpace/Photos_2016/sizilien2016/DSC04129.JPG: \ +-- \hGetBufSome: hardware fault (Input/output error)") res + +procFile = makeAbsFile "/proc/1/task/1/maps" +test_call_procp = do + res <- runErr $ do + f :: Text <- readFile2 procFile -- not allowed fileAccess + return False -- expect that read fials + assertBool (isLeft res) +-- assertEqual ( Left "/proc/1/task/1/maps: openBinaryFile: permission denied (Permission denied)") res + +test_createNewDirFile = do + let fn = makeAbsFile "/home/frank/test/1.test" + r <- runErr $ writeFileOrCreate2 fn ("testtext"::Text) + assertEqual (Right () ) r + +dir31 = "dir4test" :: FilePath +abs31 = "/home/frank/Workspace8/uniform/uniform-fileio" :: FilePath +abs3131 = abs31 dir31 + +res3131 = sort + ["/home/frank/Workspace8/uniform/uniform-fileio/dir4test/testghci", + "/home/frank/Workspace8/uniform/uniform-fileio/dir4test/testfile.txt", + "/home/frank/Workspace8/uniform/uniform-fileio/dir4test/Setup.lhs", + "/home/frank/Workspace8/uniform/uniform-fileio/dir4test/testgitignore"] + +res3131wh = sort $ "/home/frank/Workspace8/uniform/uniform-fileio/dir4test/.ghci" : + res3131 + +test_getDirCont1 = do + res :: ErrOrVal [FilePath] <- runErr $ getDirContentFiles (abs3131) + assertEqual (Right res3131wh) (fmap sort res ) + +test_getDirCont2 = do + res :: ErrOrVal [Path Abs File] <- + runErr $ getDirContentFiles (makeAbsDir abs3131) + assertEqual (Right (map makeAbsFile res3131wh)) (fmap sort res ) + -- (fmap makeAbsFile res3131) res + +res3132 :: [FilePath] +res3132 = sort $ "dir4test/.ghci" : + ["dir4test/testghci", "dir4test/testfile.txt", + "dir4test/Setup.lhs", "dir4test/testgitignore"] + +test_getDirCont3 = do + res :: ErrOrVal [FilePath] <- runErr $ getDirContentFiles (dir31) + assertEqual (Right res3132) (fmap sort res ) + -- gives hidden and + +test_getDirCont4 = do + res :: ErrOrVal [Path Rel File] <- + runErr $ getDirContentFiles (makeRelDir dir31) + assertEqual (Right (map makeRelFile res3132)) (fmap sort res ) + -- (fmap makeAbsFile res3131) res + +res3134 = sort -- no hidden + ["dir4test/testghci", "dir4test/testfile.txt", + "dir4test/f1", "dir4test/Setup.lhs", "dir4test/f2", + "dir4test/testgitignore"] + +res3135 = -- with hidden + "dir4test/.ghci" : res3134 + + +test_hidden1 = do -- no hidden files + res :: ErrOrVal [FilePath] <- + runErr $ getDirContNonHidden dir31 + assertEqual (Right ( res3134)) (fmap sort res ) + +test_hidden2 = do -- with hidden files + res :: ErrOrVal [FilePath] <- + runErr $ getDirCont dir31 + assertEqual (Right ( res3135)) (fmap sort res ) + -- (fmap makeAbsFile res3131) res + +--test_md5_nonReadablep = do +-- res :: ErrOrVal (Maybe Text) <- runErr $ getMD5 procFile +-- putIOwords ["test_md5_nonReadable res", showT res] +-- assertEqual (Left "getMD5 error for \"/proc/1/task/1/maps\"") res +-- +-- +--test_before = do +-- let fna = makeAbsFile "/home/frank/test/a.test" +-- let fnb = makeAbsFile "/home/frank/test/b.test" +-- r <- runErr $ isFileAbeforeB fna fnb +-- assertEqual (Right True ) r + + +--------------old test with filepath +-- +-- +--test_catch_error2 = do +-- res <- runErr $ do +-- f :: Text <- readFile2 ("xxxabcd" :: FilePath) +-- return False +-- `catchError ` +-- \(e::Text) -> return True +-- assertEqual (Right True) res +-- +--test_call_IO = do +-- res <- runErr $ do +-- f :: String <- callIO $ readFile "xxxabcd17" -- not existing fileAccess +-- return False -- expect that read fials +-- assertEqual ( Left "xxxabcd17: openFile: does not exist (No such file or directory)") res +-- +--test_call_IO_L = do +-- res <- runErr $ do +-- f :: L.ByteString <- callIO $ L.readFile "xxxabcd17" -- not existing fileAccess +-- return False -- expect that read fials +-- assertEqual ( Left "xxxabcd17: openBinaryFile: does not exist (No such file or directory)") res +-- +----test_call_IO_Corrupt= do +---- res <- runErr $ callIO $ do +---- f :: L.ByteString <- L.readFile corruptJPG -- not existing fileAccess +---- putIOwords ["call_IO_Corrupt", showT . L.length $ f] -- just to enforce strictness +---- return False -- expect that read fials +---- assertEqual ( Left "/home/frank/additionalSpace/Photos_2016/sizilien2016/DSC04129.JPG: \ +---- \hGetBufSome: hardware fault (Input/output error)") res +-- +--test_call_proc = do +-- res <- runErr $ do +-- f <- callIO $ L.readFile "/proc/1/task/1/maps" -- not existing fileAccess +-- return False -- expect that read fials +-- assertEqual ( Left "/proc/1/task/1/maps: openBinaryFile: permission denied (Permission denied)") res +-- +--test_md5_nonReadable = do +-- res :: ErrOrVal (Maybe Text) <- runErr $ getMD5 ("/proc/1/task/1/maps" ::FilePath) +-- putIOwords ["test_md5_nonReadable res", showT res] +-- assertEqual (Left "getMD5 error for \"/proc/1/task/1/maps\"") res +-- +--corruptJPG = "/home/frank/additionalSpace/Photos_2016/sizilien2016/DSC04129.JPG" ::FilePath +-- +----test_fail = assertEqual "Fail intentionally just to insure that tests are run"(""::Text) +---- readable on santafe but not oporto +----test_md5_nonReadable2 :: IO () +----test_md5_nonReadable2 = do +---- res :: ErrOrVal (Maybe Text) <- runErr $ getMD5 corruptJPG +---- putIOwords ["test_md5_nonReadable corrupt jpg file", showT res] +---- -- does not catch the error? +---- assertEqual (Left "getMD5 error for \"/home/frank/additionalSpace/Photos_2016/sizilien2016/DSC04129.JPG\"") res +------ `catch` \(e::SomeException) -> do +------ putIOwords ["caught with catch in test_md5_nonReadable2 ", showT e] +------ return () +-- +---- not corrupt on santa fe, but on oporto +----test_md5_catch :: IO () +----test_md5_catch = do +---- res3 :: ErrOrVal ByteString <- runErr $ callIO $ do +---- res1 :: L.ByteString <- L.readFile corruptJPG +---- let res2 = L.toStrict res1 +---- return $!! res2 +---- assertEqual (Left "/home/frank/additionalSpace/Photos_2016/sizilien2016/DSC04129.JPG: hGetBufSome: hardware fault (Input/output error)") res3 +------ `catch` \(e::SomeException) -> do +------ putIOwords ["caught with catch in test_md5_catch ", showT e] +------ return () +-- +--test_symlink :: IO () +--test_symlink = do +-- let t = makeAbsFile "/bin/X11/X11" +-- isSymlink1 <- D.pathIsSymbolicLink (OS.dropTrailingPathSeparator $ toFilePath t) +-- isSymlink2 <- D.pathIsSymbolicLink "/bin/X11/X11" -- (toFilePath t) +-- isSymlink3 <- D.pathIsSymbolicLink "/bin/X11/X11/" -- (toFilePath t) +-- assertEqual (True, True, False) (isSymlink1, isSymlink2, isSymlink3) +-- +-- diff --git a/tests/Uniform/Filenames_test.hs b/tests/Uniform/Filenames_test.hs new file mode 100644 --- /dev/null +++ b/tests/Uniform/Filenames_test.hs @@ -0,0 +1,299 @@ +--{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : Filenames +-- Copyright : andrew u frank - +-- +----------------------------------------------------------------------------- +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +-- {-# OPTIONS_GHC -fno-warn-missing-methods #-} + +-- | the operations on filenames and extensions +-- uses the Path library +-- is a class except for the make +module Uniform.Filenames_test where + +-- +-- +---- using uniform: + +-- import Test.Invariant + +import qualified Path -- for Generics +import Test.Framework +import Uniform.Error hiding ((<.>), ()) +import Uniform.Filenames + +-- +test_show = assertEqual "Path Rel File afile" (show g1) + +test_read = assertEqual g1 (read "Path Rel File afile") + +test_read2 = assertEqual g1 (makeRelFile "afile") + +--test_readrd = assertEqual g1 (read "afile") +test_readaf = assertEqual g3 (read "Path Abs File /somedir/more/afile.ext") + +--test_readrf = assertEqual g1 (read "afile") + +testdir1 = makeAbsDir "/home/frank/test" + +testfile1 = "file1.x" :: FilePath + +testdir2 = "files" :: FilePath + +test_addFilename = assertEqual "/home/frank/test/file1.x" (toFilePath $ addFileName testdir1 testfile1) + +--test_addFilenameEmpty = assertEqual "" (toFilePath $ addFileName testdir1 (""::FilePath)) +-- does fail + +test_addDir = assertEqual "/home/frank/test/files/" (toFilePath $ addDir testdir1 testdir2) + +test_addDirEmpty = assertEqual "/home/frank/test/" (toFilePath $ addDir testdir1 ("" :: FilePath)) + +--test_abs1 = assertEqual "" $ makeAbsDir "file://home/frank/additionalSpace/DataBig/LitTest/test" + +test_zeroAbsFile = assertEqual "/zero" (toFilePath (zero :: Path Abs File)) + +test_zeroAbsDir = assertEqual "/" (toFilePath (zero :: Path Abs Dir)) + +test_zeroRelFile = assertEqual "zero" (toFilePath (zero :: Path Rel File)) + +test_zeroRelDir = assertEqual "./" (toFilePath (zero :: Path Rel Dir)) + +testname = "/home/frank/dir1/file.ext" :: FilePath + +test_immediateParent = assertEqual "dir1" (getImmediateParentDir testname) + +test_nakedFilename = assertEqual "file" (getNakedFileName testname) + +testname2 = makeAbsFile testname + +test_immediateParent2 = assertEqual "dir1" (getImmediateParentDir testname2) + +test_nakedFilename2 = assertEqual "file" (getNakedFileName testname2) + +-------- +x1f = makeAbsFile f3 :: Path Abs File + +x1t = showT x1f + +x1s = t2s x1t + +x1ss = show x1f + +test_sp = + assertEqual + "Path Abs File /somedir/more/afile.ext" + (show x1f) + +-- test_sp1 = assertEqual ("/somedir/more/afile.ext"::String) (read x1s) +test_sp2 = assertEqual (x1f :: Path Abs File) (read x1ss) + +test_sp3 = + assertEqual + (x1f :: Path Abs File) + (read "Path Abs File /somedir/more/afile.ext") + +data Rec11 = Rec11 {date :: Path Abs File} deriving (Show, Read, Eq) + +rec1 = Rec11 x1f + +rec1s = show rec1 + +test_r1 = assertEqual "Rec11 {date = Path Abs File /somedir/more/afile.ext}" (rec1s) + +-- test_r2 = assertEqual rec1 (readNote "r2 test" rec1s :: Rec11) +-- the path reading in records does not work yet + +-- -- test_force = assertBool False + +data S2 = S2 String String deriving (Show, Read, Eq) + +--instance Read S2 where +-- readsPrec i s = [(S2 a b, r)] +-- where +-- [(b, r)] = readsPrec i s2 +-- [(a, s2)] = readsPrec i s + +test_p = assertEqual [("DREI", " someMore")] (readsPrec 0 "\"DREI\" someMore") + +s2a = S2 "eins" "zwei" + +s2as = show s2a -- "S2 \"eins\" \"zwei\"" + +test_s2aa = assertEqual "S2 \"eins\" \"zwei\"" (s2as) + +test_s2a = assertEqual s2a (read "S2 \"eins\" \"zwei\"") + +data Xt = Xt + { p :: Path Abs File, + q :: Text + } + deriving (Show, Read, Eq) + +--instance Read (Path Abs File) where +-- readsPrec i r = -- r ist "/somedir/more/afile.ext", q = "f3"} +-- [(makeAbsFile x, rem)] -- ", q = \"f3\"")] +-- where +-- [(x ::String , rem)] = readsPrec i r + +-- xt = Xt x1f "f3" +-- xt3 = Xt "/somedir/more/afile.ext" "f3" +-- xts = show xt + +-- test_xt1 = do +-- putIOwords ["xt1 - xts is:", s2t xts] +-- putIOwords ["xt1 - show xt is:", showT xt] +-- assertEqual xt (read $ xts) + +-- xt2 = Xt {p = "Path Abs File /somedir/more/afile.ext", q = "f3"} + +--test_rp = do +-- putIOwords ["rp - f3 :", s2t f3s] +-- assertEqual [(x1f, "")] (readsPrec 0 f3s :: [(Path Abs File, String)] ) +-- +--test_r2 = assertEqual x1f (readNote "r2" f3s) +--f3s = show x1f +-- +----instance Show (Path Abs File) where +---- show = toFilePath +-- +--test_xt2 = do -- ok +-- putIOwords ["xt2 - s:", x1s] +-- putIOwords ["xt1 - show p . xt is:", showT . p $ xt] +-- assertEqual x1f (readT $ x1s) +-- +--test_rp2 = do -- ok +-- putIOwords ["xt2 - x1s:", x1s] +---- putIOwords ["xt1 - show p . xt is:", showT . p $ xt] +-- assertEqual [(x1f,"")] (readsPrec 0 . t2s $ x1s) +-- +--test_rp3 = do +-- putIOwords ["xt2 - x1ss:", s2t x1ss] +---- putIOwords ["xt1 - show p . xt is:", showT . p $ xt] +-- assertEqual [(x1f,"")] (readsPrec 0 $ x1ss) +-- +-- +-- +--xt2r = readT xt2 :: Xt +--readT :: Read a => Text -> a +--readT s = readNote "readNotJust" . t2s $ s +--xt2 = showT xt :: Text +--x1ss = t2s x1s ++ ", some text" :: String +------------------tests + +-- rigerous filepath testing is difficult, +-- as many inputs are not leading to leagal path +f1 = "afile" :: FilePath + +f0 = "" :: FilePath -- not legal? + +f2 = "afile.ext" :: FilePath + +f3 = "/somedir/more/afile.ext" :: FilePath + +f4 = "afile.gut.ext" :: FilePath + +test_emptyExt = assertEqual "" (getExtension f1) + +test_emptyExt0 = assertEqual "" (getExtension f0) + +test_getExt = assertEqual "ext" (getExtension f2) + +test_hasExt = assertBool $ hasExtension "ext" f2 + +test_hasExt2 = assertBool $ hasExtension "ext" f3 + +test_addExt = assertEqual (f2) $ addExtension "ext" f1 + +test_removeExt = assertEqual f1 (removeExtension f2) + +test_setExt = assertEqual ("afile.txt") (setExtension "txt" f2) + +test_removeExt2 = assertEqual f1 (removeExtension . removeExtension $ f4) + +f4p = makeRelFile f4 + +f1p = makeRelFile f1 + +test_removeExt2path = + assertEqual + f1p + (removeExtension . removeExtension $ f4p) + +--prop_add_has_FP :: FilePath -> FilePath -> Bool +--prop_add_has_FP e f = if (isInfixOf' "." e) then True else prop_add_has e f +--prop_add_add_has_FP :: FilePath ->FilePath ->FilePath -> Bool +--prop_add_add_has_FP = prop_add_add_has +--prop_set_get_FP :: FilePath -> FilePath -> Bool +--prop_set_get_FP = prop_set_get + +g1 = makeRelFile "afile" :: Path Rel File + +--g0 = "" -- not legal? +g2 = makeRelFile "afile.ext" + +g3 = makeAbsFile "/somedir/more/afile.ext" + +g4 = makeAbsFile "/somedir/more/afile.txt" + +e1 = (Extension "ext") + +test_emptyExt_P = assertEqual (Extension "") (getExtension g1) + +--test_emptyExt0 = assertEqual "" (getExtension f0) +test_getExt_P = assertEqual e1 (getExtension g2) + +test_hasExt_P = assertBool $ hasExtension e1 g2 + +test_hasExt2_P = assertBool $ hasExtension e1 g2 + +test_addExt_P = assertEqual (g2) $ addExtension e1 g1 + +test_removeExt_P = assertEqual g1 (removeExtension g2) + +test_setExt_P = assertEqual (g4) (setExtension (Extension "txt") g3) + +d1 = makeAbsDir "/somedir/more/dir" + +test_nakedDir = assertEqual "dir" (getNakedDir d1) + +-- data TestRec = TestRec {f11:: Path Abs Dir} deriving (Show, Eq, Read) +-- inp1 = TestRec { f11 = "/home/frank/"} +-- inp2 = TestRec { f11 = makeAbsDir "/home/frank/"} +-- f11x = "/home/frank/" :: Path Abs Dir + +-- --test_read1 = assertEqual inp1 (inp1) -- must fail, reading a string into Path Abs +-- -- -- not permitted (should be detected when assign to inp1 +-- test_read12 = assertEqual "" (show inp1) +-- test_read22 = assertEqual "TestRec {f11 = \"/home/frank/\"}" (show inp2) + +test_doubleExtension = + assertEqual + ("afile.triples.gzip") + (toFilePath $ addExtension (Extension "triples.gzip") g1) + +-- test_doubleExtensionBase = assertEqual ("b2.triples.gzip") +-- (toFilePath . fromJustNote "t1" $ +-- Path.addExtension ".triples.gzip" g1) + +test_hasExtension = + assertEqual True $ + hasExtension (Extension "md") (makeRelFile "test.md") + +test_getExtension = + assertEqual (Extension "md") $ + getExtension (makeRelFile "test.md") + +test_parentDir = assertEqual ("/somedir/more") (getParentDir f3) + +test_immediateparentDir = assertEqual ("more") (getImmediateParentDir f3) diff --git a/tests/Uniform/Piped_test.hs b/tests/Uniform/Piped_test.hs new file mode 100644 --- /dev/null +++ b/tests/Uniform/Piped_test.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- +-- Module : piped +-- Copyright : andrew u frank - +-- +-- | the recursive access to many files not blocking +----------------------------------------------------------------------------- +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE + MultiParamTypeClasses +-- , TypeSynonymInstances + , FlexibleInstances + , FlexibleContexts + , ScopedTypeVariables + , UndecidableInstances + , OverloadedStrings +-- , TypeFamilies + #-} +-- {-# OPTIONS_GHC -fno-warn-missing-methods #-} + +module Uniform.Piped_test where + +import qualified Pipes as Pipe +import Pipes ((>->)) +import qualified Pipes.Prelude as PipePrelude +----import Control.Monad (forM_) +-- +----import System.Directory (doesDirectoryExist, getDirectoryContents) +--import System.Environment (getArgs) +----import System.FilePath (()) +----import System.IO (openFile, IOMode (..), hClose) +-- +------ using uniform: +--import Uniform.Error +----import Uniform.Zero +import Uniform.Strings hiding ((<.>), ()) +---- +import Uniform.Filenames +----import Uniform.FileIO +import Uniform.FileStrings (openFile2handle, closeFile2, IOMode(..)) +--import Uniform.Filenames +--import Data.List (sort) + +import Test.Framework +--import Test.Invariant +import Uniform.Piped +import qualified Path.IO as Path.IO (makeAbsolute) + + + +test_recursive = do +-- let testdir = makeRelDir "testDirFileIO" +-- let resfileN = makeRelFile "testDirResN" +-- let resfile0 = makeRelFile "testDirRes0" +-- testdir2 <- fmap Path $ Path.IO.makeAbsolute (unPath testdir) +-- runErr $ do +-- hand <- openFile2handle resfileN WriteMode +-- Pipe.runEffect $ +-- getRecursiveContents testdir2 +-- >-> PipePrelude.map toFilePath +-- ---- >-> P.stdoutLn +-- >-> PipePrelude.toHandle hand +-- closeFile2 hand +-- res0 ::Text <- readFile5 resfile0 +-- resN :: Text <- readFile5 resfileN +-- assertEqual res0 resN + assertEqual "" "" + + + +testDir = makeAbsDir "/home/frank/Workspace8/uniform-fileio/testDirFileIO" +test_getRec = do + res <- runErr $ pipedDo testDir (showT) + assertEqual (Right ()) res + -- check manually + +----for testing: +readFile5 :: Path ar File -> IO Text +readFile5 = fmap s2t .readFile . toFilePath + +pipedDo :: Path Abs Dir -> (Path Abs File -> Text) -> ErrIO () +pipedDo path transf = do + Pipe.runEffect $ + getRecursiveContents path + >-> PipePrelude.map (t2s . transf) + >-> PipePrelude.stdoutLn + +--pipedDoIO :: Path Abs File -> Path Abs Dir -> (Path Abs File -> ErrIO Text) -> ErrIO () +---- | write to the first filename the operation applied to the dir tree in the second +---- first path must not be non-readable dir or +--pipedDoIO file path transf = do +-- hand <- openFile2handle file WriteMode +-- Pipe.runEffect $ +-- getRecursiveContents path +-- >-> PipePrelude.map (fmap t2s . transf) -- some IO type left? +-- -- >-> P.stdoutLn +-- >-> PipePrelude.toHandle hand +---- >-> (\s -> PipePrelude.toHandle hand (s::String)) +-- closeFile2 hand + diff --git a/tests/Uniform/TypedFile_test.hs b/tests/Uniform/TypedFile_test.hs new file mode 100644 --- /dev/null +++ b/tests/Uniform/TypedFile_test.hs @@ -0,0 +1,74 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +--{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- {-# OPTIONS -Wall #-} +-- {-# OPTIONS -fno-warn-missing-signatures #-} +{-# OPTIONS -w #-} + +module Uniform.TypedFile_test where + +import Test.Framework + +--import Uniform.Error +import Uniform.FileIOalgebra (Handle) +import Uniform.Filenames +import Uniform.FileStrings +--import Uniform.FileIO (EpochTime, getFileModificationTime) +import Uniform.FileStatus +import Uniform.Strings +import qualified Data.ByteString.Lazy as L + +import Uniform.TypedFile + + +textLinesFile = makeTyped (Extension "txt") ::TypedFile5 [Text] () +dir1 = makeAbsDir "/home/frank/" +file1 = makeRelFile "aaa" +ct = ["eins", "zwei"] :: [Text] +test_write = do + r <- runErr $ write5 dir1 file1 textLinesFile ct + assertEqual (Right () ) r + +test_read = do + r <- runErr $ read5 dir1 file1 textLinesFile + assertEqual (Right ct ) r + +-- data CompressedByteString +-- a gzip compressed bytestring -- +gzippedTriples = TypedFile5 {tpext5 = Extension "triples.gzip"} + :: TypedFile5 L.ByteString [Text] + +test_gz4txt = do + r <- runErr $ write8 (dir1 file2) gzippedTriples ct + assertEqual (Right ()) r + +file2 = makeRelFile "b2" + +test_gz4back = do + r <- runErr $ read8 (dir1 file2) gzippedTriples + assertEqual (Right ct) r + +instance TypedFiles7 L.ByteString [Text] where + unwrap7 = compress . b2bl . t2b . showT + wrap7 = read . t2s . bb2t . bl2b . decompress + -- - | the a is the base type + -- -- which is written on file, b is the type for input and output + -- class FileHandles a => TypedFiles7 a b where + -- wrap7 :: a -> b + -- unwrap7 :: b -> a + +-- issues with extension - should not include leading '.' +-- but path operations require it +test_extension :: IO () +test_extension = assertEqual (Extension "triples.gzip") + (tpext5 gzippedTriples) + +test_fileFormed = assertEqual ("b2.txt") + (toFilePath $ file2 <.> (Extension "txt")) +test_fileFormed2 = assertEqual ("b2.triples.gzip") + (toFilePath $ file2 <.> (tpext5 gzippedTriples)) + diff --git a/uniform-fileio.cabal b/uniform-fileio.cabal new file mode 100644 --- /dev/null +++ b/uniform-fileio.cabal @@ -0,0 +1,103 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.34.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: f4d7504acb161ad2dbeebdcd82fbe61db899dc04a7bef35d0699563f9c128713 + +name: uniform-fileio +version: 0.1.0 +synopsis: Uniform file handling operations +description: Uniform operations for handling files and file path names + independent from the representation. + . + Additionally, functions to read and write files for specific + typed content (marked by extension). + . + Please see the README on GitHub at +category: Data Text Uniform +bug-reports: https://github.com/andrewufrank/uniform-fileio/issues +author: Andrew Frank +maintainer: Andrew U. Frank +copyright: 2021 Andrew U. Frank +license: GPL-2.0-only +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +library + exposed-modules: + Uniform.FileIO + Uniform.FileIOalgebra + Uniform.Filenames + Uniform.FileStatus + Uniform.FileStrings + Uniform.Piped + Uniform.TypedFile + other-modules: + Paths_uniform_fileio + hs-source-dirs: + ./. + build-depends: + base >=4.7 && <5 + , bytestring + , deepseq + , directory + , exceptions + , filepath + , monads-tf + , path + , path-io + , pipes + , pureMD5 + , safe + , text + , uniform-algebras + , uniform-error + , uniform-strings + , uniform-time + , unix + , zlib + default-language: Haskell2010 + autogen-modules: Paths_uniform_fileio + +test-suite strings-test + type: exitcode-stdio-1.0 + main-is: Testing.hs + other-modules: + Uniform.Filenames_test + Uniform.FileStatus_test + Uniform.FileStrings_test + Uniform.Piped_test + Uniform.TypedFile_test + Paths_uniform_fileio + hs-source-dirs: + tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HTF + , base >=4.7 && <5 + , bytestring + , deepseq + , directory + , exceptions + , filepath + , monads-tf + , path + , path-io + , pipes + , pureMD5 + , quickcheck-text + , safe + , test-invariant + , text + , uniform-algebras + , uniform-error + , uniform-fileio + , uniform-strings + , uniform-time + , unix + , zlib + default-language: Haskell2010