{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module System.Nix.Internal.Nar.Effects
  ( NarEffects(..)
  , narEffectsIO
  ) where

import qualified Control.Exception.Lifted    as Lifted
import qualified Control.Monad.Fail          as MonadFail
import qualified Control.Monad.IO.Class      as IO
import           Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.ByteString             as BS
import qualified Data.ByteString.Lazy        as BSL
import           Data.Int                    (Int64)
import qualified System.Directory            as Directory
import qualified System.IO                   as IO
import           System.Posix.Files          (createSymbolicLink, fileSize,
                                              getFileStatus, isDirectory,
                                              readSymbolicLink)

data NarEffects (m :: * -> *) = NarEffects {
    NarEffects m -> FilePath -> m ByteString
narReadFile   :: FilePath -> m BSL.ByteString
  , NarEffects m -> FilePath -> ByteString -> m ()
narWriteFile  :: FilePath -> BSL.ByteString -> m ()
  , NarEffects m -> FilePath -> m (Maybe ByteString) -> m ()
narStreamFile :: FilePath -> m (Maybe BS.ByteString) -> m ()
  , NarEffects m -> FilePath -> m [FilePath]
narListDir    :: FilePath -> m [FilePath]
  , NarEffects m -> FilePath -> m ()
narCreateDir  :: FilePath -> m ()
  , NarEffects m -> FilePath -> FilePath -> m ()
narCreateLink :: FilePath -> FilePath -> m ()
  , NarEffects m -> FilePath -> m Permissions
narGetPerms   :: FilePath -> m Directory.Permissions
  , NarEffects m -> FilePath -> Permissions -> m ()
narSetPerms   :: FilePath -> Directory.Permissions ->  m ()
  , NarEffects m -> FilePath -> m Bool
narIsDir      :: FilePath -> m Bool
  , NarEffects m -> FilePath -> m Bool
narIsSymLink  :: FilePath -> m Bool
  , NarEffects m -> FilePath -> m Int64
narFileSize   :: FilePath -> m Int64
  , NarEffects m -> FilePath -> m FilePath
narReadLink   :: FilePath -> m FilePath
  , NarEffects m -> FilePath -> m ()
narDeleteDir  :: FilePath -> m ()
  , NarEffects m -> FilePath -> m ()
narDeleteFile :: FilePath -> m ()
}


-- | A particular @NarEffects@ that uses regular POSIX for file manipulation
--   You would replace this with your own @NarEffects@ if you wanted a
--   different backend
narEffectsIO
  :: (IO.MonadIO m,
      MonadFail.MonadFail m,
      MonadBaseControl IO m
     ) => NarEffects m
narEffectsIO :: NarEffects m
narEffectsIO = NarEffects :: forall (m :: * -> *).
(FilePath -> m ByteString)
-> (FilePath -> ByteString -> m ())
-> (FilePath -> m (Maybe ByteString) -> m ())
-> (FilePath -> m [FilePath])
-> (FilePath -> m ())
-> (FilePath -> FilePath -> m ())
-> (FilePath -> m Permissions)
-> (FilePath -> Permissions -> m ())
-> (FilePath -> m Bool)
-> (FilePath -> m Bool)
-> (FilePath -> m Int64)
-> (FilePath -> m FilePath)
-> (FilePath -> m ())
-> (FilePath -> m ())
-> NarEffects m
NarEffects {
    narReadFile :: FilePath -> m ByteString
narReadFile   = IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO ByteString -> m ByteString)
-> (FilePath -> IO ByteString) -> FilePath -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BSL.readFile
  , narWriteFile :: FilePath -> ByteString -> m ()
narWriteFile  = \FilePath
a ByteString
b -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BSL.writeFile FilePath
a ByteString
b
  , narStreamFile :: FilePath -> m (Maybe ByteString) -> m ()
narStreamFile = FilePath -> m (Maybe ByteString) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m) =>
FilePath -> m (Maybe ByteString) -> m ()
streamStringOutIO
  , narListDir :: FilePath -> m [FilePath]
narListDir    = IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO [FilePath] -> m [FilePath])
-> (FilePath -> IO [FilePath]) -> FilePath -> m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO [FilePath]
Directory.listDirectory
  , narCreateDir :: FilePath -> m ()
narCreateDir  = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> (FilePath -> IO ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
Directory.createDirectory
  , narCreateLink :: FilePath -> FilePath -> m ()
narCreateLink = \FilePath
f FilePath
t -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createSymbolicLink FilePath
f FilePath
t
  , narGetPerms :: FilePath -> m Permissions
narGetPerms   = IO Permissions -> m Permissions
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO Permissions -> m Permissions)
-> (FilePath -> IO Permissions) -> FilePath -> m Permissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Permissions
Directory.getPermissions
  , narSetPerms :: FilePath -> Permissions -> m ()
narSetPerms   = \FilePath
f Permissions
p -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Permissions -> IO ()
Directory.setPermissions FilePath
f Permissions
p
  , narIsDir :: FilePath -> m Bool
narIsDir      = \FilePath
d -> (FileStatus -> Bool) -> m FileStatus -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileStatus -> Bool
isDirectory (m FileStatus -> m Bool) -> m FileStatus -> m Bool
forall a b. (a -> b) -> a -> b
$ IO FileStatus -> m FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (FilePath -> IO FileStatus
getFileStatus FilePath
d)
  , narIsSymLink :: FilePath -> m Bool
narIsSymLink  = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO Bool -> m Bool) -> (FilePath -> IO Bool) -> FilePath -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Bool
Directory.pathIsSymbolicLink
  , narFileSize :: FilePath -> m Int64
narFileSize   = \FilePath
n -> (FileStatus -> Int64) -> m FileStatus -> m Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FileOffset -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset -> Int64)
-> (FileStatus -> FileOffset) -> FileStatus -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> FileOffset
fileSize) (m FileStatus -> m Int64) -> m FileStatus -> m Int64
forall a b. (a -> b) -> a -> b
$ IO FileStatus -> m FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (FilePath -> IO FileStatus
getFileStatus FilePath
n)
  , narReadLink :: FilePath -> m FilePath
narReadLink   = IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO FilePath -> m FilePath)
-> (FilePath -> IO FilePath) -> FilePath -> m FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
readSymbolicLink
  , narDeleteDir :: FilePath -> m ()
narDeleteDir  = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> (FilePath -> IO ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
Directory.removeDirectoryRecursive
  , narDeleteFile :: FilePath -> m ()
narDeleteFile = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> (FilePath -> IO ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
Directory.removeFile
  }


-- | This default implementation for @narStreamFile@ requires @IO.MonadIO@
streamStringOutIO
  :: forall m
  .(IO.MonadIO m,
    MonadFail.MonadFail m,
    MonadBaseControl IO m
  ) => FilePath
  -> m (Maybe BS.ByteString)
  -> m ()
streamStringOutIO :: FilePath -> m (Maybe ByteString) -> m ()
streamStringOutIO FilePath
f m (Maybe ByteString)
getChunk =
  m Handle -> (Handle -> m ()) -> (Handle -> m ()) -> m ()
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
Lifted.bracket
    (IO Handle -> m Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (FilePath -> IOMode -> IO Handle
IO.openFile FilePath
f IOMode
IO.WriteMode)) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> (Handle -> IO ()) -> Handle -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ()
IO.hClose) Handle -> m ()
go
  m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`Lifted.catch`
    SomeException -> m ()
forall (m :: * -> *) b.
(MonadIO m, MonadFail m) =>
SomeException -> m b
cleanupException
  where
    go :: IO.Handle -> m ()
    go :: Handle -> m ()
go Handle
handle = do
      Maybe ByteString
chunk <- m (Maybe ByteString)
getChunk
      case Maybe ByteString
chunk of
        Maybe ByteString
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ByteString
c  -> do
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPut Handle
handle ByteString
c
          Handle -> m ()
go Handle
handle
    cleanupException :: SomeException -> m b
cleanupException (SomeException
e :: Lifted.SomeException) = do
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
Directory.removeFile FilePath
f
      FilePath -> m b
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
MonadFail.fail (FilePath -> m b) -> FilePath -> m b
forall a b. (a -> b) -> a -> b
$
        FilePath
"Failed to stream string to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e