{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module System.Nix.Nar (
FileSystemObject(..)
, IsExecutable (..)
, Nar(..)
, getNar
, localPackNar
, localUnpackNar
, narEffectsIO
, putNar
) where
import Control.Applicative
import Control.Monad (replicateM, replicateM_, (<=<))
import qualified Data.Binary as B
import qualified Data.Binary.Get as B
import qualified Data.Binary.Put as B
import Data.Bool (bool)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable (forM_)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Traversable (forM)
import GHC.Int (Int64)
import System.Directory
import System.FilePath
import System.Posix.Files (createSymbolicLink, fileSize, getFileStatus,
isDirectory, readSymbolicLink)
import System.Nix.Path
data NarEffects (m :: * -> *) = NarEffects {
narReadFile :: FilePath -> m BSL.ByteString
, narWriteFile :: FilePath -> BSL.ByteString -> m ()
, narListDir :: FilePath -> m [FilePath]
, narCreateDir :: FilePath -> m ()
, narCreateLink :: FilePath -> FilePath -> m ()
, narGetPerms :: FilePath -> m Permissions
, narSetPerms :: FilePath -> Permissions -> m ()
, narIsDir :: FilePath -> m Bool
, narIsSymLink :: FilePath -> m Bool
, narFileSize :: FilePath -> m Int64
, narReadLink :: FilePath -> m FilePath
}
data Nar = Nar { narFile :: FileSystemObject }
deriving (Eq, Show)
data FileSystemObject =
Regular IsExecutable Int64 BSL.ByteString
| Directory (Map.Map FilePathPart FileSystemObject)
| SymLink T.Text
deriving (Eq, Show)
data IsExecutable = NonExecutable | Executable
deriving (Eq, Show)
instance B.Binary Nar where
get = getNar
put = putNar
putNar :: Nar -> B.Put
putNar (Nar file) = header <> parens (putFile file)
where
header = str "nix-archive-1"
putFile (Regular isExec fSize contents) =
strs ["type", "regular"]
>> (if isExec == Executable
then strs ["executable", ""]
else return ())
>> putContents fSize contents
putFile (SymLink target) =
strs ["type", "symlink", "target", BSL.fromStrict $ E.encodeUtf8 target]
putFile (Directory entries) =
strs ["type", "directory"]
<> mapM_ putEntry (Map.toList entries)
putEntry (FilePathPart name, fso) = do
str "entry"
parens $ do
str "name"
str (BSL.fromStrict name)
str "node"
parens (putFile fso)
parens m = str "(" >> m >> str ")"
str :: BSL.ByteString -> B.Put
str t = let len = BSL.length t
in int len <> pad len t
putContents :: Int64 -> BSL.ByteString -> B.Put
putContents fSize bs = str "contents" <> int fSize <> (pad fSize bs)
int :: Integral a => a -> B.Put
int n = B.putInt64le $ fromIntegral n
pad :: Int64 -> BSL.ByteString -> B.Put
pad strSize bs = do
B.putLazyByteString bs
B.putLazyByteString (BSL.replicate (padLen strSize) 0)
strs :: [BSL.ByteString] -> B.Put
strs = mapM_ str
getNar :: B.Get Nar
getNar = fmap Nar $ header >> parens getFile
where
header = assertStr "nix-archive-1"
getFile = getRegularFile <|> getDirectory <|> getSymLink
getRegularFile = do
assertStr "type"
assertStr "regular"
mExecutable <- optional $ Executable <$ (assertStr "executable"
>> assertStr "")
assertStr "contents"
(fSize, contents) <- sizedStr
return $ Regular (fromMaybe NonExecutable mExecutable) fSize contents
getDirectory = do
assertStr "type"
assertStr "directory"
fs <- many getEntry
return $ Directory (Map.fromList fs)
getSymLink = do
assertStr "type"
assertStr "symlink"
assertStr "target"
fmap (SymLink . E.decodeUtf8 . BSL.toStrict) str
getEntry = do
assertStr "entry"
parens $ do
assertStr "name"
name <- E.decodeUtf8 . BSL.toStrict <$> str
assertStr "node"
file <- parens getFile
maybe (fail $ "Bad FilePathPart: " ++ show name)
(return . (,file))
(filePathPart $ E.encodeUtf8 name)
str = fmap snd sizedStr
sizedStr = do
n <- B.getInt64le
s <- B.getLazyByteString n
p <- B.getByteString . fromIntegral $ padLen n
return (n,s)
parens m = assertStr "(" *> m <* assertStr ")"
assertStr s = do
s' <- str
if s == s'
then return s
else fail "No"
padLen :: Int64 -> Int64
padLen n = (8 - n) `mod` 8
localUnpackNar :: Monad m => NarEffects m -> FilePath -> Nar -> m ()
localUnpackNar effs basePath (Nar fso) = localUnpackFSO basePath fso
where
localUnpackFSO basePath fso = case fso of
Regular isExec _ bs -> do
(narWriteFile effs) basePath bs
p <- narGetPerms effs basePath
(narSetPerms effs) basePath (p {executable = isExec == Executable})
SymLink targ -> narCreateLink effs (T.unpack targ) basePath
Directory contents -> do
narCreateDir effs basePath
forM_ (Map.toList contents) $ \(FilePathPart path', fso) ->
localUnpackFSO (basePath </> BSC.unpack path') fso
localPackNar :: Monad m => NarEffects m -> FilePath -> m Nar
localPackNar effs basePath = Nar <$> localPackFSO basePath
where
localPackFSO path' = do
fType <- (,) <$> narIsDir effs path' <*> narIsSymLink effs path'
case fType of
(_, True) -> SymLink . T.pack <$> narReadLink effs path'
(False, _) -> Regular <$> isExecutable effs path'
<*> narFileSize effs path'
<*> narReadFile effs path'
(True , _) -> fmap (Directory . Map.fromList) $ do
fs <- narListDir effs path'
forM fs $ \fp ->
(FilePathPart (BSC.pack $ fp),) <$> localPackFSO (path' </> fp)
narEffectsIO :: NarEffects IO
narEffectsIO = NarEffects {
narReadFile = BSL.readFile
, narWriteFile = BSL.writeFile
, narListDir = listDirectory
, narCreateDir = createDirectory
, narCreateLink = createSymbolicLink
, narGetPerms = getPermissions
, narSetPerms = setPermissions
, narIsDir = fmap isDirectory <$> getFileStatus
, narIsSymLink = pathIsSymbolicLink
, narFileSize = fmap (fromIntegral . fileSize) <$> getFileStatus
, narReadLink = readSymbolicLink
}
isExecutable :: Functor m => NarEffects m -> FilePath -> m IsExecutable
isExecutable effs fp =
bool NonExecutable Executable . executable <$> narGetPerms effs fp