|
| 1 | +{-# LANGUAGE FlexibleContexts #-} |
| 2 | +{-# LANGUAGE KindSignatures #-} |
| 3 | +{-# LANGUAGE RankNTypes #-} |
| 4 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 5 | + |
| 6 | +module System.Nix.Internal.Nar.Effects |
| 7 | + ( NarEffects(..) |
| 8 | + , narEffectsIO |
| 9 | + ) where |
| 10 | + |
| 11 | +import qualified Control.Exception.Lifted as Lifted |
| 12 | +import qualified Control.Monad.Fail as MonadFail |
| 13 | +import qualified Control.Monad.IO.Class as IO |
| 14 | +import Control.Monad.Trans.Control (MonadBaseControl) |
| 15 | +import qualified Data.ByteString as BS |
| 16 | +import qualified Data.ByteString.Lazy as BSL |
| 17 | +import Data.Int (Int64) |
| 18 | +import qualified System.Directory as Directory |
| 19 | +import qualified System.Directory as Directory |
| 20 | +import qualified System.IO as IO |
| 21 | +import System.Posix.Files (createSymbolicLink, fileSize, |
| 22 | + getFileStatus, isDirectory, |
| 23 | + readSymbolicLink) |
| 24 | + |
| 25 | +data NarEffects (m :: * -> *) = NarEffects { |
| 26 | + narReadFile :: FilePath -> m BSL.ByteString |
| 27 | + , narWriteFile :: FilePath -> BSL.ByteString -> m () |
| 28 | + , narStreamFile :: FilePath -> m (Maybe BS.ByteString) -> m () |
| 29 | + , narListDir :: FilePath -> m [FilePath] |
| 30 | + , narCreateDir :: FilePath -> m () |
| 31 | + , narCreateLink :: FilePath -> FilePath -> m () |
| 32 | + , narGetPerms :: FilePath -> m Directory.Permissions |
| 33 | + , narSetPerms :: FilePath -> Directory.Permissions -> m () |
| 34 | + , narIsDir :: FilePath -> m Bool |
| 35 | + , narIsSymLink :: FilePath -> m Bool |
| 36 | + , narFileSize :: FilePath -> m Int64 |
| 37 | + , narReadLink :: FilePath -> m FilePath |
| 38 | + , narDeleteDir :: FilePath -> m () |
| 39 | + , narDeleteFile :: FilePath -> m () |
| 40 | +} |
| 41 | + |
| 42 | + |
| 43 | +-- | A particular @NarEffects@ that uses regular POSIX for file manipulation |
| 44 | +-- You would replace this with your own @NarEffects@ if you wanted a |
| 45 | +-- different backend |
| 46 | +narEffectsIO |
| 47 | + :: (IO.MonadIO m, |
| 48 | + MonadFail.MonadFail m, |
| 49 | + MonadBaseControl IO m |
| 50 | + ) => NarEffects m |
| 51 | +narEffectsIO = NarEffects { |
| 52 | + narReadFile = IO.liftIO . BSL.readFile |
| 53 | + , narWriteFile = \a b -> IO.liftIO $ BSL.writeFile a b |
| 54 | + , narStreamFile = streamStringOutIO |
| 55 | + , narListDir = IO.liftIO . Directory.listDirectory |
| 56 | + , narCreateDir = IO.liftIO . Directory.createDirectory |
| 57 | + , narCreateLink = \f t -> IO.liftIO $ createSymbolicLink f t |
| 58 | + , narGetPerms = IO.liftIO . Directory.getPermissions |
| 59 | + , narSetPerms = \f p -> IO.liftIO $ Directory.setPermissions f p |
| 60 | + , narIsDir = \d -> fmap isDirectory $ IO.liftIO (getFileStatus d) |
| 61 | + , narIsSymLink = IO.liftIO . Directory.pathIsSymbolicLink |
| 62 | + , narFileSize = \n -> fmap (fromIntegral . fileSize) $ IO.liftIO (getFileStatus n) |
| 63 | + , narReadLink = IO.liftIO . readSymbolicLink |
| 64 | + , narDeleteDir = IO.liftIO . Directory.removeDirectoryRecursive |
| 65 | + , narDeleteFile = IO.liftIO . Directory.removeFile |
| 66 | + } |
| 67 | + |
| 68 | + |
| 69 | +-- | This default implementation for @narStreamFile@ requires @IO.MonadIO@ |
| 70 | +streamStringOutIO |
| 71 | + :: forall m |
| 72 | + .(IO.MonadIO m, |
| 73 | + MonadFail.MonadFail m, |
| 74 | + MonadBaseControl IO m |
| 75 | + ) => FilePath |
| 76 | + -> m (Maybe BS.ByteString) |
| 77 | + -> m () |
| 78 | +streamStringOutIO f getChunk = |
| 79 | + Lifted.bracket |
| 80 | + (IO.liftIO (IO.openFile f IO.WriteMode)) (IO.liftIO . IO.hClose) go |
| 81 | + `Lifted.catch` |
| 82 | + cleanupException |
| 83 | + where |
| 84 | + go :: IO.Handle -> m () |
| 85 | + go handle = do |
| 86 | + chunk <- getChunk |
| 87 | + case chunk of |
| 88 | + Nothing -> return () |
| 89 | + Just c -> do |
| 90 | + IO.liftIO $ BS.hPut handle c |
| 91 | + go handle |
| 92 | + cleanupException (e :: Lifted.SomeException) = do |
| 93 | + IO.liftIO $ Directory.removeFile f |
| 94 | + MonadFail.fail $ |
| 95 | + "Failed to stream string to " ++ f ++ ": " ++ show e |
0 commit comments