{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Axel.Test.Monad.FileSystemMock where import Axel.Monad.Console as Console import Axel.Monad.FileSystem as FS import Axel.Monad.Process as Proc import Axel.Monad.Resource as Res import Axel.Test.MockUtils import Control.Lens hiding (children) import Control.Monad.Except import Control.Monad.State.Lazy import Data.List.Split import Data.Maybe import System.FilePath data FSNode = Directory FilePath [FSNode] | File FilePath String deriving (Eq, Show) fsPath :: Lens' FSNode FilePath fsPath = lens (\case Directory path _ -> path File path _ -> path) (\node newPath -> case node of Directory _ children -> Directory newPath children File _ contents -> File newPath contents) data FSState = FSState { _fsCurrentDirectory :: FilePath , _fsRoot :: FSNode , _fsTempCounter :: Int } deriving (Eq, Show) makeFieldsNoPrefix ''FSState mkFSState :: [FSNode] -> FSState mkFSState rootContents = FSState { _fsCurrentDirectory = "/" , _fsRoot = Directory "/" rootContents , _fsTempCounter = 0 } lookupNode :: [FilePath] -> FSNode -> Maybe FSNode lookupNode _ (File _ _) = Nothing lookupNode [] _ = Nothing lookupNode ["."] rootNode = pure rootNode lookupNode [segment] (Directory _ rootChildren) = let matchingChildren = filter (\child -> child ^. fsPath == segment) rootChildren in case matchingChildren of [child] -> pure child _ -> Nothing lookupNode (segment:xs) rootNode@(Directory _ _) = do child@(Directory _ _) <- lookupNode [segment] rootNode lookupNode xs child deleteNode :: [FilePath] -> FSNode -> Maybe FSNode deleteNode _ (File _ _) = Nothing deleteNode [] _ = Nothing deleteNode [segment] rootNode@(Directory rootPath rootChildren) = do child <- lookupNode [segment] rootNode let rootChildren' = filter (/= child) rootChildren pure $ Directory rootPath rootChildren' deleteNode (segment:xs) rootNode@(Directory rootPath rootChildren) = do needle <- lookupNode [segment] rootNode rootChildren' <- mapM (\child -> case child of File _ _ -> pure child _ -> if child == needle then deleteNode xs child else pure child) rootChildren pure $ Directory rootPath rootChildren' insertNode :: [FilePath] -> FSNode -> FSNode -> Maybe FSNode insertNode _ _ (File _ _) = Nothing insertNode [] _ _ = Nothing insertNode [segment] newNode (Directory rootPath rootChildren) = if newNode ^. fsPath == segment then let rootChildren' = filter (\child -> child ^. fsPath /= newNode ^. fsPath) rootChildren in pure $ Directory rootPath (newNode : rootChildren') else Nothing insertNode (segment:xs) newNode rootNode@(Directory rootPath rootChildren) = do needle <- lookupNode [segment] rootNode rootChildren' <- mapM (\child -> case child of File _ _ -> pure child _ -> if child == needle then insertNode xs newNode child else pure child) rootChildren pure $ Directory rootPath rootChildren' type instance Index FSNode = FilePath type instance IxValue FSNode = FSNode instance Ixed FSNode where ix :: (Applicative f) => FilePath -> (FSNode -> f FSNode) -> FSNode -> f FSNode ix path f root = case lookupNode pathSegments root of Just node -> f node <&> \newNode -> fromJust $ insertNode pathSegments newNode root Nothing -> pure root where pathSegments :: [FilePath] pathSegments = splitDirectories path instance At FSNode where at :: FilePath -> Lens' FSNode (Maybe FSNode) at path = let setter :: FSNode -> Maybe FSNode -> FSNode setter root = fromMaybe root . \case Just newNode -> insertNode pathSegments newNode root Nothing -> deleteNode pathSegments root in lens (lookupNode pathSegments) setter where pathSegments :: [FilePath] pathSegments = splitDirectories path absifyPath :: FilePath -> FilePath -> FilePath absifyPath relativePath currentDirectory = let absolutePath = case relativePath of '/':_ -> relativePath _ -> "/" currentDirectory relativePath normalizedSegments = concatMap (\case [_, ".."] -> [] ["."] -> [] xs -> xs) $ chunksOf 2 $ dropLeadingSlash $ splitDirectories absolutePath in case joinPath normalizedSegments of "" -> "/" path -> path where dropLeadingSlash ("/":xs) = xs dropLeadingSlash xs = xs absify :: (MonadState FSState f) => FilePath -> f FilePath absify relativePath = absifyPath relativePath <$> gets (^. fsCurrentDirectory) newtype FileSystemT m a = FileSystemT (StateT FSState (ExceptT String m) a) deriving ( Functor , Applicative , Monad , MonadConsole , MonadProcess , MonadResource ) type FileSystem = FileSystemT Identity instance Eq (FileSystemT m a) where _ == _ = False instance Show (FileSystemT m a) where show _ = "" instance MonadTrans FileSystemT where lift = FileSystemT . lift . lift instance (Monad m) => MonadFileSystem (FileSystemT m) where copyFile src dest = do contents <- FS.readFile src FS.writeFile contents dest createDirectoryIfMissing createParents relativePath = FileSystemT $ do path <- absify relativePath parentNode <- gets (^. fsRoot . at (takeDirectory path)) case parentNode of Just _ -> fsRoot . at path ?= Directory (takeFileName path) [] Nothing -> if createParents then fsRoot %= \origRoot -> fst (foldl (\(root, segments) pathSegment -> let newSegments = segments <> [pathSegment] newRoot = case root ^. at (joinPath newSegments) of Just _ -> root Nothing -> root & at (joinPath newSegments) ?~ Directory pathSegment [] in (newRoot, newSegments)) (origRoot, []) (splitDirectories path)) else throwInterpretError "createDirectoryIfMissing" ("Missing parents for directory: " <> path) doesDirectoryExist relativePath = FileSystemT $ do path <- absify relativePath directoryNode <- gets (^. fsRoot . at path) pure $ case directoryNode of Just (Directory _ _) -> True _ -> False getCurrentDirectory = FileSystemT $ gets (^. fsCurrentDirectory) getDirectoryContents relativePath = FileSystemT $ do path <- absify relativePath directoryNode <- gets (^. fsRoot . at path) case directoryNode of Just (Directory _ children) -> pure $ map (^. fsPath) children _ -> throwInterpretError "getDirectoryContents" ("No such directory: " <> path) getTemporaryDirectory = do tempCounter <- FileSystemT $ fsTempCounter <<+= 1 let tempDirName = "/tmp" show tempCounter FS.createDirectoryIfMissing True tempDirName pure tempDirName readFile relativePath = FileSystemT $ do path <- absify relativePath fileNode <- gets (^. fsRoot . at path) case fileNode of Just (File _ contents) -> pure contents _ -> throwInterpretError "readFile" ("No such file: " <> path) removeFile relativePath = FileSystemT $ do path <- absify relativePath gets (deleteNode (splitDirectories path) . (^. fsRoot)) >>= \case Just newRoot -> fsRoot .= newRoot Nothing -> throwInterpretError "removeFile" ("No such file: " <> path) setCurrentDirectory relativePath = FileSystemT $ do path <- absify relativePath fsCurrentDirectory .= path writeFile relativePath contents = FileSystemT $ do path <- absify relativePath fsRoot . at path ?= File (takeFileName path) contents runFileSystemT :: FSState -> FileSystemT m a -> ExceptT String m (a, FSState) runFileSystemT origState (FileSystemT x) = runStateT x origState runFileSystem :: FSState -> FileSystem a -> Either String (a, FSState) runFileSystem origState x = runExcept $ runFileSystemT origState x