-- | A streaming parser for the NAR format

{-# language GeneralizedNewtypeDeriving #-}
{-# language ScopedTypeVariables        #-}
{-# language TypeFamilies               #-}

module System.Nix.Internal.Nar.Parser
  ( runParser
  , parseNar
  , testParser
  , testParser'
  )
where

import qualified Relude.Unsafe as Unsafe
import qualified Algebra.Graph                   as Graph
import qualified Algebra.Graph.ToGraph           as Graph
import qualified Control.Concurrent              as Concurrent
import qualified Control.Exception.Lifted        as Exception.Lifted
import qualified Control.Monad.Except            as Except
import qualified Control.Monad.Fail              as Fail
import qualified Control.Monad.IO.Class          as IO
import qualified Control.Monad.Reader            as Reader
import qualified Control.Monad.State             as State
import qualified Control.Monad.Trans             as Trans
import qualified Control.Monad.Trans.Control     as Base
import qualified Data.ByteString                 as Bytes
import qualified Data.List                       as List
import qualified Data.Map                        as Map
import qualified Data.Serialize                  as Serialize
import qualified Data.Text                       as Text
import qualified System.Directory                as Directory
import           System.FilePath                 as FilePath
import qualified System.IO                       as IO

import qualified System.Nix.Internal.Nar.Effects as Nar


-- | NarParser is a monad for parsing a Nar file as a byte stream
--   and reconstructing the file system objects inside
--   See the definitions of @NarEffects@ for a description
--   of the actions the parser can take, and @ParserState@ for the
--   internals of the parser
newtype NarParser m a = NarParser
  { forall (m :: * -> *) a.
NarParser m a
-> StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
runNarParser ::
      State.StateT
        ParserState
        (Except.ExceptT
          String
          (Reader.ReaderT
            (Nar.NarEffects m)
            m
          )
        )
        a
  }
  deriving ( forall a b. a -> NarParser m b -> NarParser m a
forall a b. (a -> b) -> NarParser m a -> NarParser m b
forall (m :: * -> *) a b.
Functor m =>
a -> NarParser m b -> NarParser m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NarParser m a -> NarParser m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> NarParser m b -> NarParser m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> NarParser m b -> NarParser m a
fmap :: forall a b. (a -> b) -> NarParser m a -> NarParser m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NarParser m a -> NarParser m b
Functor, forall a. a -> NarParser m a
forall a b. NarParser m a -> NarParser m b -> NarParser m a
forall a b. NarParser m a -> NarParser m b -> NarParser m b
forall a b. NarParser m (a -> b) -> NarParser m a -> NarParser m b
forall a b c.
(a -> b -> c) -> NarParser m a -> NarParser m b -> NarParser m c
forall {m :: * -> *}. Monad m => Functor (NarParser m)
forall (m :: * -> *) a. Monad m => a -> NarParser m a
forall (m :: * -> *) a b.
Monad m =>
NarParser m a -> NarParser m b -> NarParser m a
forall (m :: * -> *) a b.
Monad m =>
NarParser m a -> NarParser m b -> NarParser m b
forall (m :: * -> *) a b.
Monad m =>
NarParser m (a -> b) -> NarParser m a -> NarParser m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> NarParser m a -> NarParser m b -> NarParser m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. NarParser m a -> NarParser m b -> NarParser m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
NarParser m a -> NarParser m b -> NarParser m a
*> :: forall a b. NarParser m a -> NarParser m b -> NarParser m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
NarParser m a -> NarParser m b -> NarParser m b
liftA2 :: forall a b c.
(a -> b -> c) -> NarParser m a -> NarParser m b -> NarParser m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> NarParser m a -> NarParser m b -> NarParser m c
<*> :: forall a b. NarParser m (a -> b) -> NarParser m a -> NarParser m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
NarParser m (a -> b) -> NarParser m a -> NarParser m b
pure :: forall a. a -> NarParser m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> NarParser m a
Applicative, forall a. a -> NarParser m a
forall a b. NarParser m a -> NarParser m b -> NarParser m b
forall a b. NarParser m a -> (a -> NarParser m b) -> NarParser m b
forall (m :: * -> *). Monad m => Applicative (NarParser m)
forall (m :: * -> *) a. Monad m => a -> NarParser m a
forall (m :: * -> *) a b.
Monad m =>
NarParser m a -> NarParser m b -> NarParser m b
forall (m :: * -> *) a b.
Monad m =>
NarParser m a -> (a -> NarParser m b) -> NarParser m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> NarParser m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> NarParser m a
>> :: forall a b. NarParser m a -> NarParser m b -> NarParser m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
NarParser m a -> NarParser m b -> NarParser m b
>>= :: forall a b. NarParser m a -> (a -> NarParser m b) -> NarParser m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
NarParser m a -> (a -> NarParser m b) -> NarParser m b
Monad, forall a. String -> NarParser m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall {m :: * -> *}. MonadFail m => Monad (NarParser m)
forall (m :: * -> *) a. MonadFail m => String -> NarParser m a
fail :: forall a. String -> NarParser m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> NarParser m a
Fail.MonadFail
           , forall a. IO a -> NarParser m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (NarParser m)
forall (m :: * -> *) a. MonadIO m => IO a -> NarParser m a
liftIO :: forall a. IO a -> NarParser m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> NarParser m a
Trans.MonadIO, State.MonadState ParserState
           , Except.MonadError String
           , Reader.MonadReader (Nar.NarEffects m)
           )

-- | Run a @NarParser@ over a byte stream
--   This is suitable for testing the top-level NAR parser, or any of the
--   smaller utilities parsers, if you have bytes appropriate for them
runParser
  :: forall m a
   . (IO.MonadIO m, Base.MonadBaseControl IO m)
  => Nar.NarEffects m
     -- ^ Provide the effects set, usually @narEffectsIO@
  -> NarParser m a
     -- ^ A parser to run, such as @parseNar@
  -> IO.Handle
     -- ^ A handle the stream containg the NAR. It should already be
     --   open and in @ReadMode@
  -> FilePath
     -- ^ The root file system object to be created by the NAR
  -> m (Either String a)
runParser :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
NarEffects m
-> NarParser m a -> Handle -> String -> m (Either String a)
runParser NarEffects m
effs (NarParser StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
action) Handle
h String
target = do
  Either String a
unpackResult <-
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
action ParserState
state0) NarEffects m
effs
      forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`Exception.Lifted.catch` SomeException -> m (Either String a)
exceptionHandler
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a b. Either a b -> Bool
isLeft Either String a
unpackResult) m ()
cleanup
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String a
unpackResult

 where
  state0 :: ParserState
  state0 :: ParserState
state0 =
    ParserState
      { tokenStack :: [Text]
tokenStack     = []
      , handle :: Handle
handle         = Handle
h
      , directoryStack :: [String]
directoryStack = [String
target]
      , links :: [LinkInfo]
links          = []
      }

  exceptionHandler :: Exception.Lifted.SomeException -> m (Either String a)
  exceptionHandler :: SomeException -> m (Either String a)
exceptionHandler SomeException
e =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Exception while unpacking NAR file: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show SomeException
e

  cleanup :: m ()
  cleanup :: m ()
cleanup =
    (\NarEffects m
ef String
trg -> do
      Bool
isDir <- forall (m :: * -> *). NarEffects m -> String -> m Bool
Nar.narIsDir NarEffects m
ef String
trg
      forall a. a -> a -> Bool -> a
bool
        (forall (m :: * -> *). NarEffects m -> String -> m ()
Nar.narDeleteFile NarEffects m
ef String
trg)
        (forall (m :: * -> *). NarEffects m -> String -> m ()
Nar.narDeleteDir NarEffects m
ef String
trg)
        Bool
isDir
    ) NarEffects m
effs String
target


instance Trans.MonadTrans NarParser where
  lift :: forall (m :: * -> *) a. Monad m => m a -> NarParser m a
lift m a
act = forall (m :: * -> *) a.
StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
-> NarParser m a
NarParser forall a b. (a -> b) -> a -> b
$ (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) m a
act


data ParserState = ParserState
  { ParserState -> [Text]
tokenStack     :: ![Text]
    -- ^ The parser can push tokens (words or punctuation)
    --   onto this stack. We use this for a very limited backtracking
    --   where the Nar format requires it
  , ParserState -> [String]
directoryStack :: ![String]
    -- ^ The parser knows the name of the current FSO it's targeting,
    --   and the relative directory path leading there
  , ParserState -> Handle
handle         :: IO.Handle
    -- ^ Handle of the input byte stream
  , ParserState -> [LinkInfo]
links          :: [LinkInfo]
    -- ^ Unlike with files and directories, we collect symlinks
    --   from the NAR on
  }


------------------------------------------------------------------------------
-- * Parsers for NAR components

-- | Parse a NAR byte string, producing @()@.
--   Parsing a NAR is mostly used for its side-effect: producing
--   the file system objects packed in the NAR. That's why we pure @()@
parseNar :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
parseNar :: forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseNar = do
  forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"nix-archive-1"
  forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
NarParser m a -> NarParser m a
parens forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseFSO
  forall (m :: * -> *). MonadIO m => NarParser m ()
createLinks


parseFSO :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
parseFSO :: forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseFSO = do
  forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"type"
  forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
[(Text, NarParser m a)] -> NarParser m a
matchStr
    [ (Text
"symlink"  , forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseSymlink  )
    , (Text
"regular"  , forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseFile     )
    , (Text
"directory", forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseDirectory)
    ]


-- | Parse a symlink from a NAR, storing the link details in the parser state
--   We remember links rather than immediately creating file system objects
--   from them, because we might encounter a link in the NAR before we
--   encountered its target, and in this case, creating the link will fail
--   The final step of creating links is handle by @createLinks@
parseSymlink :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
parseSymlink :: forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseSymlink = do
  forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"target"
  Text
target      <- forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr
  (String
dir, String
file) <- forall (m :: * -> *). Monad m => NarParser m (String, String)
currentDirectoryAndFile
  forall (m :: * -> *). Monad m => LinkInfo -> NarParser m ()
pushLink forall a b. (a -> b) -> a -> b
$
    LinkInfo
      { linkTarget :: String
linkTarget = forall a. ToString a => a -> String
toString Text
target
      , linkFile :: String
linkFile   = String
file
      , linkPWD :: String
linkPWD    = String
dir
      }
 where
  currentDirectoryAndFile :: Monad m => NarParser m (FilePath, FilePath)
  currentDirectoryAndFile :: forall (m :: * -> *). Monad m => NarParser m (String, String)
currentDirectoryAndFile = do
    [String]
dirStack <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ParserState -> [String]
directoryStack
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 String -> String -> String
(</>) (forall a. [a] -> [a]
List.reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 [String]
dirStack), forall a. [a] -> a
Unsafe.head [String]
dirStack)


-- | Internal data type representing symlinks encountered in the NAR
data LinkInfo = LinkInfo
  { LinkInfo -> String
linkTarget :: String
    -- ^ path to the symlink target, relative to the root of the unpacking NAR
  , LinkInfo -> String
linkFile   :: String
    -- ^ file name of the link being created
  , LinkInfo -> String
linkPWD    :: String
    -- ^ directory in which to create the link (relative to unpacking root)
  }
  deriving Int -> LinkInfo -> String -> String
[LinkInfo] -> String -> String
LinkInfo -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LinkInfo] -> String -> String
$cshowList :: [LinkInfo] -> String -> String
show :: LinkInfo -> String
$cshow :: LinkInfo -> String
showsPrec :: Int -> LinkInfo -> String -> String
$cshowsPrec :: Int -> LinkInfo -> String -> String
Show


-- | When the NAR includes a file, we read from the NAR handle in chunks and
--   write the target in chunks. This lets us avoid reading the full contents
--   of the encoded file into memory
parseFile :: forall m . (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
parseFile :: forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseFile = do

  Text
s <- forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
s forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Text
"executable", Text
"contents"]) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail
      forall a b. (a -> b) -> a -> b
$ String
"Parser found " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Text
s
      forall a. Semigroup a => a -> a -> a
<> String
" when expecting element from "
      forall a. Semigroup a => a -> a -> a
<> (forall b a. (Show a, IsString b) => a -> b
show :: [String] -> String) [String
"executable", String
"contents"]
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
s forall a. Eq a => a -> a -> Bool
== Text
"executable") forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
""
    forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"contents"

  Int64
fSize        <- forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Int64
parseLength

  -- Set up for defining `getChunk`
  Handle
narHandle    <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ParserState -> Handle
handle
  IORef Int64
bytesLeftVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Int64
fSize

  let
    -- getChunk tracks the number of total bytes we still need to get from the
    -- file (starting at the file size, and decrementing by the size of the
    -- chunk we read)
    getChunk :: m (Maybe ByteString)
    getChunk :: m (Maybe ByteString)
getChunk = do
      Int64
bytesLeft <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int64
bytesLeftVar
      if Int64
bytesLeft forall a. Eq a => a -> a -> Bool
== Int64
0
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        else do
          ByteString
chunk <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
Bytes.hGetSome Handle
narHandle forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min Int64
10000 Int64
bytesLeft
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
Bytes.null ByteString
chunk) (forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"ZERO BYTES")
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef Int64
bytesLeftVar forall a b. (a -> b) -> a -> b
$ \Int64
n -> Int64
n forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
Bytes.length ByteString
chunk)

          -- This short pause is necessary for letting the garbage collector
          -- clean up chunks from previous runs. Without it, heap memory usage can
          -- quickly spike
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
Concurrent.threadDelay Int
10
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
chunk

  String
target     <- forall (m :: * -> *). Monad m => NarParser m String
currentFile
  String -> m (Maybe ByteString) -> m ()
streamFile <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (m :: * -> *).
NarEffects m -> String -> m (Maybe ByteString) -> m ()
Nar.narStreamFile
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> m (Maybe ByteString) -> m ()
streamFile String
target m (Maybe ByteString)
getChunk)

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
s forall a. Eq a => a -> a -> Bool
== Text
"executable") forall a b. (a -> b) -> a -> b
$ do
    NarEffects m
effs :: Nar.NarEffects m <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
      Permissions
p <- forall (m :: * -> *). NarEffects m -> String -> m Permissions
Nar.narGetPerms NarEffects m
effs String
target
      forall (m :: * -> *). NarEffects m -> String -> Permissions -> m ()
Nar.narSetPerms NarEffects m
effs String
target (Permissions
p { executable :: Bool
Directory.executable = Bool
True })

  forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
ByteString -> NarParser m ()
expectRawString (Int -> Word8 -> ByteString
Bytes.replicate (Int -> Int
padLen forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
fSize) Word8
0)


-- | Parse a NAR encoded directory, being careful not to hold onto file
--   handles for target files longer than needed
parseDirectory :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
parseDirectory :: forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseDirectory = do
  String -> m ()
createDirectory <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (m :: * -> *). NarEffects m -> String -> m ()
Nar.narCreateDir
  String
target          <- forall (m :: * -> *). Monad m => NarParser m String
currentFile
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> m ()
createDirectory String
target
  forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseEntryOrFinish

 where

  parseEntryOrFinish :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
  parseEntryOrFinish :: forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseEntryOrFinish =
    -- If we reach a ")", we finished the directory's entries, and we have
    -- to put ")" back into the stream, because the outer call to @parens@
    -- expects to consume it.
    -- Otherwise, parse an entry as a fresh file system object
    forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
[(Text, NarParser m a)] -> NarParser m a
matchStr
      [ ( Text
")"   , forall (m :: * -> *). Monad m => Text -> NarParser m ()
pushStr Text
")" )
      , (Text
"entry", forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseEntry  )
      ]

  parseEntry :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
  parseEntry :: forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseEntry = do
    forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
NarParser m a -> NarParser m a
parens forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"name"
      Text
fName <- forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr
      forall (m :: * -> *). Monad m => String -> NarParser m ()
pushFileName (forall a. ToString a => a -> String
toString Text
fName)
      forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"node"
      forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
NarParser m a -> NarParser m a
parens forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseFSO
      forall (m :: * -> *). Monad m => NarParser m ()
popFileName
    forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseEntryOrFinish



------------------------------------------------------------------------------
-- * Utility parsers


-- | Short strings guiding the NAR parsing are prefixed with their
--   length, then encoded in ASCII, and padded to 8 bytes. @parseStr@
--   captures this logic
parseStr :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m Text
parseStr :: forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr = do
  Maybe Text
cachedStr <- forall (m :: * -> *). Monad m => NarParser m (Maybe Text)
popStr
  case Maybe Text
cachedStr of
    Just Text
str -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
str
    Maybe Text
Nothing  -> do
      Int64
len      <- forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Int64
parseLength
      ByteString
strBytes <- forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> NarParser m ByteString
consume forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len
      forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
ByteString -> NarParser m ()
expectRawString
        (Int -> Word8 -> ByteString
Bytes.replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int -> Int
padLen forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len) Word8
0)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
strBytes


-- | Get an Int64 describing the length of the upcoming string,
--   according to NAR's encoding of ints
parseLength :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m Int64
parseLength :: forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Int64
parseLength = do
  ByteString
eightBytes <- forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> NarParser m ByteString
consume Int
8
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (\String
e -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ String
"parseLength failed to decode int64: " forall a. Semigroup a => a -> a -> a
<> String
e)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (forall a. Get a -> ByteString -> Either String a
Serialize.runGet Get Int64
Serialize.getInt64le ByteString
eightBytes)


-- | Consume a NAR string and assert that it matches an expectation
expectStr :: (IO.MonadIO m, Fail.MonadFail m) => Text -> NarParser m ()
expectStr :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
expected = do
  Text
actual <- forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
actual forall a. Eq a => a -> a -> Bool
/= Text
expected) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$  String
"Expected " forall a. Semigroup a => a -> a -> a
<> forall {b}. IsString b => Text -> b
err Text
expected forall a. Semigroup a => a -> a -> a
<> String
", got " forall a. Semigroup a => a -> a -> a
<> forall {b}. IsString b => Text -> b
err Text
actual
 where
  err :: Text -> b
err Text
t =
    forall b a. (Show a, IsString b) => a -> b
show forall a b. (a -> b) -> a -> b
$
      forall a. a -> a -> Bool -> a
bool
        Text
t
        (Int -> Text -> Text
Text.take Int
10 Text
t forall a. Semigroup a => a -> a -> a
<> Text
"...")
        (Text -> Int
Text.length Text
t forall a. Ord a => a -> a -> Bool
> Int
10)


-- | Consume a raw string and assert that it equals some expectation.
--   This is usually used when consuming padding 0's
expectRawString
  :: (IO.MonadIO m, Fail.MonadFail m) => ByteString -> NarParser m ()
expectRawString :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
ByteString -> NarParser m ()
expectRawString ByteString
expected = do
  ByteString
actual <- forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> NarParser m ByteString
consume forall a b. (a -> b) -> a -> b
$ ByteString -> Int
Bytes.length ByteString
expected
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
actual forall a. Eq a => a -> a -> Bool
/= ByteString
expected)
    forall a b. (a -> b) -> a -> b
$  forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail
    forall a b. (a -> b) -> a -> b
$  String
"Expected "
    forall a. Semigroup a => a -> a -> a
<> forall {b}. IsString b => ByteString -> b
err ByteString
expected
    forall a. Semigroup a => a -> a -> a
<> String
", got "
    forall a. Semigroup a => a -> a -> a
<> forall {b}. IsString b => ByteString -> b
err ByteString
actual
 where
  err :: ByteString -> b
err ByteString
bs =
    forall b a. (Show a, IsString b) => a -> b
show forall a b. (a -> b) -> a -> b
$
      forall a. a -> a -> Bool -> a
bool
        ByteString
bs
        (Int -> ByteString -> ByteString
Bytes.take Int
10 ByteString
bs forall a. Semigroup a => a -> a -> a
<> ByteString
"...")
        (ByteString -> Int
Bytes.length ByteString
bs forall a. Ord a => a -> a -> Bool
> Int
10)


-- | Consume a NAR string, and dispatch to a parser depending on which string
--   matched
matchStr
  :: (IO.MonadIO m, Fail.MonadFail m)
  => [(Text, NarParser m a)]
     -- ^ List of expected possible strings and the parsers they should run
  -> NarParser m a
matchStr :: forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
[(Text, NarParser m a)] -> NarParser m a
matchStr [(Text, NarParser m a)]
parsers = do
  Text
str <- forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr
  case forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Text
str [(Text, NarParser m a)]
parsers of
    Just NarParser m a
p -> NarParser m a
p
    Maybe (NarParser m a)
Nothing ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ String
"Expected one of " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, NarParser m a)]
parsers) forall a. Semigroup a => a -> a -> a
<> String
" found " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Text
str


-- | Wrap any parser in NAR formatted parentheses
--   (a parenthesis is a NAR string, so it needs length encoding and padding)
parens :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m a -> NarParser m a
parens :: forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
NarParser m a -> NarParser m a
parens NarParser m a
act = do
  forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"("
  a
r <- NarParser m a
act
  forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
")"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r


-- | Sort links in the symlink stack according to their connectivity
--   (Targets must be created before the links that target them)
createLinks :: IO.MonadIO m => NarParser m ()
createLinks :: forall (m :: * -> *). MonadIO m => NarParser m ()
createLinks = do
  String -> String -> m ()
createLink  <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (m :: * -> *). NarEffects m -> String -> String -> m ()
Nar.narCreateLink
  [LinkInfo]
allLinks    <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ParserState -> [LinkInfo]
links
  [LinkInfo]
sortedLinks <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ [LinkInfo] -> IO [LinkInfo]
sortLinksIO [LinkInfo]
allLinks
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LinkInfo]
sortedLinks forall a b. (a -> b) -> a -> b
$ \LinkInfo
li -> do
    String
pwd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO IO String
Directory.getCurrentDirectory
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
Directory.setCurrentDirectory (LinkInfo -> String
linkPWD LinkInfo
li)
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> String -> m ()
createLink (LinkInfo -> String
linkTarget LinkInfo
li) (LinkInfo -> String
linkFile LinkInfo
li)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
Directory.setCurrentDirectory String
pwd

 where

  -- Convert every target and link file to a filepath relative
  -- to NAR root, then @Graph.topSort@ it, and map from the
  -- relative filepaths back to the original @LinkInfo@.
  -- Relative paths are needed for sorting, but @LinkInfo@s
  -- are needed for creating the link files
  sortLinksIO :: [LinkInfo] -> IO [LinkInfo]
  sortLinksIO :: [LinkInfo] -> IO [LinkInfo]
sortLinksIO [LinkInfo]
ls = do
    Map String LinkInfo
linkLocations <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LinkInfo]
ls forall a b. (a -> b) -> a -> b
$ \LinkInfo
li->
                  (,LinkInfo
li) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
Directory.canonicalizePath (LinkInfo -> String
linkFile LinkInfo
li)
    [(String, String)]
canonicalLinks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LinkInfo]
ls forall a b. (a -> b) -> a -> b
$ \LinkInfo
l -> do
      String
targetAbsPath <- String -> IO String
Directory.canonicalizePath
                        (LinkInfo -> String
linkPWD LinkInfo
l String -> String -> String
</> LinkInfo -> String
linkTarget LinkInfo
l)
      String
fileAbsPath   <- String -> IO String
Directory.canonicalizePath
                        (LinkInfo -> String
linkFile LinkInfo
l)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
fileAbsPath, String
targetAbsPath)
    let linkGraph :: Graph String
linkGraph = forall a. [(a, a)] -> Graph a
Graph.edges [(String, String)]
canonicalLinks
    case forall t.
(ToGraph t, Ord (ToVertex t)) =>
t -> Either (Cycle (ToVertex t)) [ToVertex t]
Graph.topSort Graph String
linkGraph of
      Left Cycle (ToVertex (Graph String))
_            -> forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Symlinks form a loop"
      Right [ToVertex (Graph String)]
sortedNodes ->
        let
          sortedLinks :: [Maybe LinkInfo]
sortedLinks = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map String LinkInfo
linkLocations forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ToVertex (Graph String)]
sortedNodes
        in
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe LinkInfo]
sortedLinks


------------------------------------------------------------------------------
-- * State manipulation

-- | Pull n bytes from the underlying handle, failing if fewer bytes
--   are available
consume
  :: (IO.MonadIO m, Fail.MonadFail m)
  => Int
  -> NarParser m ByteString
consume :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> NarParser m ByteString
consume Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
""
consume Int
n = do
  ParserState
state0   <- forall s (m :: * -> *). MonadState s m => m s
State.get
  ByteString
newBytes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
Bytes.hGetSome (ParserState -> Handle
handle ParserState
state0) (forall a. Ord a => a -> a -> a
max Int
0 Int
n)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
Bytes.length ByteString
newBytes forall a. Ord a => a -> a -> Bool
< Int
n) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$
    String
"consume: Not enough bytes in handle. Wanted "
    forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Int
n forall a. Semigroup a => a -> a -> a
<> String
" got " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (ByteString -> Int
Bytes.length ByteString
newBytes)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
newBytes


-- | Pop a string off the token stack
popStr :: Monad m => NarParser m (Maybe Text)
popStr :: forall (m :: * -> *). Monad m => NarParser m (Maybe Text)
popStr = do
  ParserState
s <- forall s (m :: * -> *). MonadState s m => m s
State.get
  case forall a. [a] -> Maybe (a, [a])
uncons (ParserState -> [Text]
tokenStack ParserState
s) of
    Maybe (Text, [Text])
Nothing      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just (Text
x, [Text]
xs) -> do
      forall s (m :: * -> *). MonadState s m => s -> m ()
State.put forall a b. (a -> b) -> a -> b
$ ParserState
s { tokenStack :: [Text]
tokenStack = [Text]
xs }
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
x


-- | Push a string onto the token stack
pushStr :: Monad m => Text -> NarParser m ()
pushStr :: forall (m :: * -> *). Monad m => Text -> NarParser m ()
pushStr Text
str =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify forall a b. (a -> b) -> a -> b
$ \ParserState
s -> -- s { loadedBytes = strBytes <> loadedBytes s }
    ParserState
s { tokenStack :: [Text]
tokenStack = Text
str forall a. a -> [a] -> [a]
: ParserState -> [Text]
tokenStack ParserState
s }


-- | Push a level onto the directory stack
pushFileName :: Monad m => FilePath -> NarParser m ()
pushFileName :: forall (m :: * -> *). Monad m => String -> NarParser m ()
pushFileName String
fName =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\ParserState
s -> ParserState
s { directoryStack :: [String]
directoryStack = String
fName forall a. a -> [a] -> [a]
: ParserState -> [String]
directoryStack ParserState
s })


-- | Go to the parent level in the directory stack
popFileName :: Monad m => NarParser m ()
popFileName :: forall (m :: * -> *). Monad m => NarParser m ()
popFileName =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\ParserState
s -> ParserState
s { directoryStack :: [String]
directoryStack = forall a. Int -> [a] -> [a]
List.drop Int
1 (ParserState -> [String]
directoryStack ParserState
s )})


-- | Convert the current directory stack into a filepath by interspersing
--   the path components with "/"
currentFile :: Monad m => NarParser m FilePath
currentFile :: forall (m :: * -> *). Monad m => NarParser m String
currentFile = do
  [String]
dirStack <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ParserState -> [String]
directoryStack
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 String -> String -> String
(</>) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
List.reverse [String]
dirStack


-- | Add a link to the collection of encountered symlinks
pushLink :: Monad m => LinkInfo -> NarParser m ()
pushLink :: forall (m :: * -> *). Monad m => LinkInfo -> NarParser m ()
pushLink LinkInfo
linkInfo = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\ParserState
s -> ParserState
s { links :: [LinkInfo]
links = LinkInfo
linkInfo forall a. a -> [a] -> [a]
: ParserState -> [LinkInfo]
links ParserState
s })


------------------------------------------------------------------------------
-- * Utilities

testParser :: (m ~ IO) => NarParser m a -> ByteString -> m (Either String a)
testParser :: forall (m :: * -> *) a.
(m ~ IO) =>
NarParser m a -> ByteString -> m (Either String a)
testParser NarParser m a
p ByteString
b = do
  String -> ByteString -> IO ()
Bytes.writeFile String
tmpFileName ByteString
b
  forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
tmpFileName IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h ->
    forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
NarEffects m
-> NarParser m a -> Handle -> String -> m (Either String a)
runParser forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m) =>
NarEffects m
Nar.narEffectsIO NarParser m a
p Handle
h String
tmpFileName
 where
  tmpFileName :: String
tmpFileName = String
"tmp"

testParser' :: (m ~ IO) => FilePath -> IO (Either String ())
testParser' :: forall (m :: * -> *). (m ~ IO) => String -> IO (Either String ())
testParser' String
fp =
  forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
NarEffects m
-> NarParser m a -> Handle -> String -> m (Either String a)
runParser forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m) =>
NarEffects m
Nar.narEffectsIO forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseNar Handle
h String
"tmp"




-- | Distance to the next multiple of 8
padLen :: Int -> Int
padLen :: Int -> Int
padLen Int
n = (Int
8 forall a. Num a => a -> a -> a
- Int
n) forall a. Integral a => a -> a -> a
`mod` Int
8


dbgState :: IO.MonadIO m => NarParser m ()
dbgState :: forall (m :: * -> *). MonadIO m => NarParser m ()
dbgState = do
  ParserState
s <- forall s (m :: * -> *). MonadState s m => m s
State.get
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (MonadIO m, Show a) => a -> m ()
print (ParserState -> [Text]
tokenStack ParserState
s, ParserState -> [String]
directoryStack ParserState
s)