-- | 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
  { 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 ( a -> NarParser m b -> NarParser m a
(a -> b) -> NarParser m a -> NarParser m b
(forall a b. (a -> b) -> NarParser m a -> NarParser m b)
-> (forall a b. a -> NarParser m b -> NarParser m a)
-> Functor (NarParser m)
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
<$ :: a -> NarParser m b -> NarParser m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> NarParser m b -> NarParser m a
fmap :: (a -> b) -> NarParser m a -> NarParser m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NarParser m a -> NarParser m b
Functor, Functor (NarParser m)
a -> NarParser m a
Functor (NarParser m)
-> (forall a. a -> NarParser m a)
-> (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 a b. NarParser m a -> NarParser m b -> NarParser m b)
-> (forall a b. NarParser m a -> NarParser m b -> NarParser m a)
-> Applicative (NarParser m)
NarParser m a -> NarParser m b -> NarParser m b
NarParser m a -> NarParser m b -> NarParser m a
NarParser m (a -> b) -> NarParser m a -> NarParser m b
(a -> b -> c) -> NarParser m a -> NarParser m b -> NarParser m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> NarParser m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> NarParser m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (NarParser m)
Applicative, Applicative (NarParser m)
a -> NarParser m a
Applicative (NarParser m)
-> (forall a b.
    NarParser m a -> (a -> NarParser m b) -> NarParser m b)
-> (forall a b. NarParser m a -> NarParser m b -> NarParser m b)
-> (forall a. a -> NarParser m a)
-> Monad (NarParser m)
NarParser m a -> (a -> NarParser m b) -> NarParser m b
NarParser m a -> NarParser m b -> NarParser m b
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 :: a -> NarParser m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> NarParser m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (NarParser m)
Monad, Monad (NarParser m)
Monad (NarParser m)
-> (forall a. String -> NarParser m a) -> MonadFail (NarParser m)
String -> NarParser m a
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 :: String -> NarParser m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> NarParser m a
$cp1MonadFail :: forall (m :: * -> *). MonadFail m => Monad (NarParser m)
Fail.MonadFail
           , Monad (NarParser m)
Monad (NarParser m)
-> (forall a. IO a -> NarParser m a) -> MonadIO (NarParser m)
IO a -> NarParser m a
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 :: IO a -> NarParser m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> NarParser m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (NarParser m)
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 :: 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 <-
    ReaderT (NarEffects m) m (Either String a)
-> NarEffects m -> m (Either String a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ExceptT String (ReaderT (NarEffects m) m) a
-> ReaderT (NarEffects m) m (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (ReaderT (NarEffects m) m) a
 -> ReaderT (NarEffects m) m (Either String a))
-> ExceptT String (ReaderT (NarEffects m) m) a
-> ReaderT (NarEffects m) m (Either String a)
forall a b. (a -> b) -> a -> b
$ StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
-> ParserState -> ExceptT String (ReaderT (NarEffects m) m) a
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
      m (Either String a)
-> (SomeException -> m (Either String a)) -> m (Either String a)
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
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Either String a -> Bool
forall a b. Either a b -> Bool
isLeft Either String a
unpackResult) m ()
cleanup
  Either String a -> m (Either String a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String a
unpackResult

 where
  state0 :: ParserState
  state0 :: ParserState
state0 =
    ParserState :: [Text] -> [String] -> Handle -> [LinkInfo] -> ParserState
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 =
    Either String a -> m (Either String a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> m (Either String a))
-> Either String a -> m (Either String a)
forall a b. (a -> b) -> a -> b
$ String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"Exception while unpacking NAR file: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
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 <- NarEffects m -> String -> m Bool
forall (m :: * -> *). NarEffects m -> String -> m Bool
Nar.narIsDir NarEffects m
ef String
trg
      m () -> m () -> Bool -> m ()
forall a. a -> a -> Bool -> a
bool
        (NarEffects m -> String -> m ()
forall (m :: * -> *). NarEffects m -> String -> m ()
Nar.narDeleteFile NarEffects m
ef String
trg)
        (NarEffects m -> String -> m ()
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 :: m a -> NarParser m a
lift m a
act = StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
-> NarParser m a
forall (m :: * -> *) a.
StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
-> NarParser m a
NarParser (StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
 -> NarParser m a)
-> StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
-> NarParser m a
forall a b. (a -> b) -> a -> b
$ (ExceptT String (ReaderT (NarEffects m) m) a
-> StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT String (ReaderT (NarEffects m) m) a
 -> StateT
      ParserState (ExceptT String (ReaderT (NarEffects m) m)) a)
-> (m a -> ExceptT String (ReaderT (NarEffects m) m) a)
-> m a
-> StateT ParserState (ExceptT String (ReaderT (NarEffects m) m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT (NarEffects m) m a
-> ExceptT String (ReaderT (NarEffects m) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (NarEffects m) m a
 -> ExceptT String (ReaderT (NarEffects m) m) a)
-> (m a -> ReaderT (NarEffects m) m a)
-> m a
-> ExceptT String (ReaderT (NarEffects m) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (NarEffects m) m a
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 :: NarParser m ()
parseNar = do
  Text -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"nix-archive-1"
  NarParser m () -> NarParser m ()
forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
NarParser m a -> NarParser m a
parens NarParser m ()
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseFSO
  NarParser m ()
forall (m :: * -> *). MonadIO m => NarParser m ()
createLinks


parseFSO :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
parseFSO :: NarParser m ()
parseFSO = do
  Text -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"type"
  [(Text, NarParser m ())] -> NarParser m ()
forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
[(Text, NarParser m a)] -> NarParser m a
matchStr
    [ (Text
"symlink"  , NarParser m ()
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseSymlink  )
    , (Text
"regular"  , NarParser m ()
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseFile     )
    , (Text
"directory", NarParser m ()
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 :: NarParser m ()
parseSymlink = do
  Text -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"target"
  Text
target      <- NarParser m Text
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr
  (String
dir, String
file) <- NarParser m (String, String)
forall (m :: * -> *). Monad m => NarParser m (String, String)
currentDirectoryAndFile
  LinkInfo -> NarParser m ()
forall (m :: * -> *). Monad m => LinkInfo -> NarParser m ()
pushLink (LinkInfo -> NarParser m ()) -> LinkInfo -> NarParser m ()
forall a b. (a -> b) -> a -> b
$
    LinkInfo :: String -> String -> String -> LinkInfo
LinkInfo
      { linkTarget :: String
linkTarget = Text -> String
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 :: NarParser m (String, String)
currentDirectoryAndFile = do
    [String]
dirStack <- (ParserState -> [String]) -> NarParser m [String]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ParserState -> [String]
directoryStack
    (String, String) -> NarParser m (String, String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 String -> String -> String
(</>) ([String] -> [String]
forall a. [a] -> [a]
List.reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
dirStack), [String] -> String
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
(Int -> LinkInfo -> String -> String)
-> (LinkInfo -> String)
-> ([LinkInfo] -> String -> String)
-> Show LinkInfo
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 :: NarParser m ()
parseFile = do

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

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

  -- Set up for defining `getChunk`
  Handle
narHandle    <- (ParserState -> Handle) -> NarParser m Handle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ParserState -> Handle
handle
  IORef Int64
bytesLeftVar <- IO (IORef Int64) -> NarParser m (IORef Int64)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO (IORef Int64) -> NarParser m (IORef Int64))
-> IO (IORef Int64) -> NarParser m (IORef Int64)
forall a b. (a -> b) -> a -> b
$ Int64 -> IO (IORef Int64)
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 <- IO Int64 -> m Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO Int64 -> m Int64) -> IO Int64 -> m Int64
forall a b. (a -> b) -> a -> b
$ IORef Int64 -> IO Int64
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int64
bytesLeftVar
      if Int64
bytesLeft Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0
        then Maybe ByteString -> m (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
        else do
          ByteString
chunk <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
Bytes.hGetSome Handle
narHandle (Int -> IO ByteString) -> Int -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
min Int64
10000 Int64
bytesLeft
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
Bytes.null ByteString
chunk) (String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"ZERO BYTES")
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int64 -> (Int64 -> Int64) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef Int64
bytesLeftVar ((Int64 -> Int64) -> IO ()) -> (Int64 -> Int64) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int64
n -> Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int -> Int64
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
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
Concurrent.threadDelay Int
10
          Maybe ByteString -> m (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> m (Maybe ByteString))
-> Maybe ByteString -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
chunk

  String
target     <- NarParser m String
forall (m :: * -> *). Monad m => NarParser m String
currentFile
  String -> m (Maybe ByteString) -> m ()
streamFile <- (NarEffects m -> String -> m (Maybe ByteString) -> m ())
-> NarParser m (String -> m (Maybe ByteString) -> m ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks NarEffects m -> String -> m (Maybe ByteString) -> m ()
forall (m :: * -> *).
NarEffects m -> String -> m (Maybe ByteString) -> m ()
Nar.narStreamFile
  m () -> NarParser m ()
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)

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

  ByteString -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
ByteString -> NarParser m ()
expectRawString (Int -> Word8 -> ByteString
Bytes.replicate (Int -> Int
padLen (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
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 :: NarParser m ()
parseDirectory = do
  String -> m ()
createDirectory <- (NarEffects m -> String -> m ()) -> NarParser m (String -> m ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks NarEffects m -> String -> m ()
forall (m :: * -> *). NarEffects m -> String -> m ()
Nar.narCreateDir
  String
target          <- NarParser m String
forall (m :: * -> *). Monad m => NarParser m String
currentFile
  m () -> NarParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> NarParser m ()) -> m () -> NarParser m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
createDirectory String
target
  NarParser m ()
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseEntryOrFinish

 where

  parseEntryOrFinish :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
  parseEntryOrFinish :: 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
    [(Text, NarParser m ())] -> NarParser m ()
forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
[(Text, NarParser m a)] -> NarParser m a
matchStr
      [ ( Text
")"   , Text -> NarParser m ()
forall (m :: * -> *). Monad m => Text -> NarParser m ()
pushStr Text
")" )
      , (Text
"entry", NarParser m ()
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseEntry  )
      ]

  parseEntry :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
  parseEntry :: NarParser m ()
parseEntry = do
    NarParser m () -> NarParser m ()
forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
NarParser m a -> NarParser m a
parens (NarParser m () -> NarParser m ())
-> NarParser m () -> NarParser m ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"name"
      Text
fName <- NarParser m Text
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr
      String -> NarParser m ()
forall (m :: * -> *). Monad m => String -> NarParser m ()
pushFileName (Text -> String
forall a. ToString a => a -> String
toString Text
fName)
      Text -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"node"
      NarParser m () -> NarParser m ()
forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
NarParser m a -> NarParser m a
parens NarParser m ()
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseFSO
      NarParser m ()
forall (m :: * -> *). Monad m => NarParser m ()
popFileName
    NarParser m ()
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 :: NarParser m Text
parseStr = do
  Maybe Text
cachedStr <- NarParser m (Maybe Text)
forall (m :: * -> *). Monad m => NarParser m (Maybe Text)
popStr
  case Maybe Text
cachedStr of
    Just Text
str -> Text -> NarParser m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
str
    Maybe Text
Nothing  -> do
      Int64
len      <- NarParser m Int64
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Int64
parseLength
      ByteString
strBytes <- Int -> NarParser m ByteString
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> NarParser m ByteString
consume (Int -> NarParser m ByteString) -> Int -> NarParser m ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len
      ByteString -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
ByteString -> NarParser m ()
expectRawString
        (Int -> Word8 -> ByteString
Bytes.replicate (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
padLen (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len) Word8
0)
      Text -> NarParser m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> NarParser m Text) -> Text -> NarParser m Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
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 :: NarParser m Int64
parseLength = do
  ByteString
eightBytes <- Int -> NarParser m ByteString
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> NarParser m ByteString
consume Int
8
  (String -> NarParser m Int64)
-> (Int64 -> NarParser m Int64)
-> Either String Int64
-> NarParser m Int64
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (\String
e -> String -> NarParser m Int64
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> NarParser m Int64) -> String -> NarParser m Int64
forall a b. (a -> b) -> a -> b
$ String
"parseLength failed to decode int64: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e)
    Int64 -> NarParser m Int64
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Get Int64 -> ByteString -> Either String Int64
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 :: Text -> NarParser m ()
expectStr Text
expected = do
  Text
actual <- NarParser m Text
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr
  Bool -> NarParser m () -> NarParser m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
actual Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
expected) (NarParser m () -> NarParser m ())
-> NarParser m () -> NarParser m ()
forall a b. (a -> b) -> a -> b
$
    String -> NarParser m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> NarParser m ()) -> String -> NarParser m ()
forall a b. (a -> b) -> a -> b
$  String
"Expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b. IsString b => Text -> b
err Text
expected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b. IsString b => Text -> b
err Text
actual
 where
  err :: Text -> b
err Text
t =
    Text -> b
forall b a. (Show a, IsString b) => a -> b
show (Text -> b) -> Text -> b
forall a b. (a -> b) -> a -> b
$
      Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool
        Text
t
        (Int -> Text -> Text
Text.take Int
10 Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"...")
        (Text -> Int
Text.length Text
t Int -> Int -> Bool
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 :: ByteString -> NarParser m ()
expectRawString ByteString
expected = do
  ByteString
actual <- Int -> NarParser m ByteString
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> NarParser m ByteString
consume (Int -> NarParser m ByteString) -> Int -> NarParser m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
Bytes.length ByteString
expected
  Bool -> NarParser m () -> NarParser m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
actual ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
expected)
    (NarParser m () -> NarParser m ())
-> NarParser m () -> NarParser m ()
forall a b. (a -> b) -> a -> b
$  String -> NarParser m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail
    (String -> NarParser m ()) -> String -> NarParser m ()
forall a b. (a -> b) -> a -> b
$  String
"Expected "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b. IsString b => ByteString -> b
err ByteString
expected
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", got "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b. IsString b => ByteString -> b
err ByteString
actual
 where
  err :: ByteString -> b
err ByteString
bs =
    ByteString -> b
forall b a. (Show a, IsString b) => a -> b
show (ByteString -> b) -> ByteString -> b
forall a b. (a -> b) -> a -> b
$
      ByteString -> ByteString -> Bool -> ByteString
forall a. a -> a -> Bool -> a
bool
        ByteString
bs
        (Int -> ByteString -> ByteString
Bytes.take Int
10 ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"...")
        (ByteString -> Int
Bytes.length ByteString
bs Int -> Int -> Bool
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 :: [(Text, NarParser m a)] -> NarParser m a
matchStr [(Text, NarParser m a)]
parsers = do
  Text
str <- NarParser m Text
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr
  case Text -> [(Text, NarParser m a)] -> Maybe (NarParser m a)
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 ->
      String -> NarParser m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> NarParser m a) -> String -> NarParser m a
forall a b. (a -> b) -> a -> b
$ String
"Expected one of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall b a. (Show a, IsString b) => a -> b
show ((Text, NarParser m a) -> Text
forall a b. (a, b) -> a
fst ((Text, NarParser m a) -> Text)
-> [(Text, NarParser m a)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, NarParser m a)]
parsers) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" found " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
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 :: NarParser m a -> NarParser m a
parens NarParser m a
act = do
  Text -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
"("
  a
r <- NarParser m a
act
  Text -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Text -> NarParser m ()
expectStr Text
")"
  a -> NarParser m a
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 :: NarParser m ()
createLinks = do
  String -> String -> m ()
createLink  <- (NarEffects m -> String -> String -> m ())
-> NarParser m (String -> String -> m ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks NarEffects m -> String -> String -> m ()
forall (m :: * -> *). NarEffects m -> String -> String -> m ()
Nar.narCreateLink
  [LinkInfo]
allLinks    <- (ParserState -> [LinkInfo]) -> NarParser m [LinkInfo]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ParserState -> [LinkInfo]
links
  [LinkInfo]
sortedLinks <- IO [LinkInfo] -> NarParser m [LinkInfo]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO [LinkInfo] -> NarParser m [LinkInfo])
-> IO [LinkInfo] -> NarParser m [LinkInfo]
forall a b. (a -> b) -> a -> b
$ [LinkInfo] -> IO [LinkInfo]
sortLinksIO [LinkInfo]
allLinks
  [LinkInfo] -> (LinkInfo -> NarParser m ()) -> NarParser m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LinkInfo]
sortedLinks ((LinkInfo -> NarParser m ()) -> NarParser m ())
-> (LinkInfo -> NarParser m ()) -> NarParser m ()
forall a b. (a -> b) -> a -> b
$ \LinkInfo
li -> do
    String
pwd <- IO String -> NarParser m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO IO String
Directory.getCurrentDirectory
    IO () -> NarParser m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> NarParser m ()) -> IO () -> NarParser m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
Directory.setCurrentDirectory (LinkInfo -> String
linkPWD LinkInfo
li)
    m () -> NarParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> NarParser m ()) -> m () -> NarParser m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> m ()
createLink (LinkInfo -> String
linkTarget LinkInfo
li) (LinkInfo -> String
linkFile LinkInfo
li)
    IO () -> NarParser m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> NarParser m ()) -> IO () -> NarParser m ()
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 <- ([(String, LinkInfo)] -> Map String LinkInfo)
-> IO [(String, LinkInfo)] -> IO (Map String LinkInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(String, LinkInfo)] -> Map String LinkInfo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (IO [(String, LinkInfo)] -> IO (Map String LinkInfo))
-> IO [(String, LinkInfo)] -> IO (Map String LinkInfo)
forall a b. (a -> b) -> a -> b
$
      [LinkInfo]
-> (LinkInfo -> IO (String, LinkInfo)) -> IO [(String, LinkInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LinkInfo]
ls ((LinkInfo -> IO (String, LinkInfo)) -> IO [(String, LinkInfo)])
-> (LinkInfo -> IO (String, LinkInfo)) -> IO [(String, LinkInfo)]
forall a b. (a -> b) -> a -> b
$ \LinkInfo
li->
                  (,LinkInfo
li) (String -> (String, LinkInfo))
-> IO String -> IO (String, LinkInfo)
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 <- [LinkInfo]
-> (LinkInfo -> IO (String, String)) -> IO [(String, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LinkInfo]
ls ((LinkInfo -> IO (String, String)) -> IO [(String, String)])
-> (LinkInfo -> IO (String, String)) -> IO [(String, String)]
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)
      (String, String) -> IO (String, String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
fileAbsPath, String
targetAbsPath)
    let linkGraph :: Graph String
linkGraph = [(String, String)] -> Graph String
forall a. [(a, a)] -> Graph a
Graph.edges [(String, String)]
canonicalLinks
    case Graph String
-> Either
     (Cycle (ToVertex (Graph String))) [ToVertex (Graph String)]
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))
_            -> Text -> IO [LinkInfo]
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Symlinks form a loop"
      Right [ToVertex (Graph String)]
sortedNodes ->
        let
          sortedLinks :: [Maybe LinkInfo]
sortedLinks = (String -> Map String LinkInfo -> Maybe LinkInfo)
-> Map String LinkInfo -> String -> Maybe LinkInfo
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Map String LinkInfo -> Maybe LinkInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map String LinkInfo
linkLocations (String -> Maybe LinkInfo) -> [String] -> [Maybe LinkInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
[ToVertex (Graph String)]
sortedNodes
        in
          [LinkInfo] -> IO [LinkInfo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LinkInfo] -> IO [LinkInfo]) -> [LinkInfo] -> IO [LinkInfo]
forall a b. (a -> b) -> a -> b
$ [Maybe LinkInfo] -> [LinkInfo]
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 :: Int -> NarParser m ByteString
consume Int
0 = ByteString -> NarParser m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
""
consume Int
n = do
  ParserState
state0   <- NarParser m ParserState
forall s (m :: * -> *). MonadState s m => m s
State.get
  ByteString
newBytes <- IO ByteString -> NarParser m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO ByteString -> NarParser m ByteString)
-> IO ByteString -> NarParser m ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
Bytes.hGetSome (ParserState -> Handle
handle ParserState
state0) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
n)
  Bool -> NarParser m () -> NarParser m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
Bytes.length ByteString
newBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n) (NarParser m () -> NarParser m ())
-> NarParser m () -> NarParser m ()
forall a b. (a -> b) -> a -> b
$
    String -> NarParser m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> NarParser m ()) -> String -> NarParser m ()
forall a b. (a -> b) -> a -> b
$
    String
"consume: Not enough bytes in handle. Wanted "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show (ByteString -> Int
Bytes.length ByteString
newBytes)
  ByteString -> NarParser m ByteString
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 :: NarParser m (Maybe Text)
popStr = do
  ParserState
s <- NarParser m ParserState
forall s (m :: * -> *). MonadState s m => m s
State.get
  case [Text] -> Maybe (Text, [Text])
forall a. [a] -> Maybe (a, [a])
uncons (ParserState -> [Text]
tokenStack ParserState
s) of
    Maybe (Text, [Text])
Nothing      -> Maybe Text -> NarParser m (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
    Just (Text
x, [Text]
xs) -> do
      ParserState -> NarParser m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (ParserState -> NarParser m ()) -> ParserState -> NarParser m ()
forall a b. (a -> b) -> a -> b
$ ParserState
s { tokenStack :: [Text]
tokenStack = [Text]
xs }
      Maybe Text -> NarParser m (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> NarParser m (Maybe Text))
-> Maybe Text -> NarParser m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x


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


-- | Push a level onto the directory stack
pushFileName :: Monad m => FilePath -> NarParser m ()
pushFileName :: String -> NarParser m ()
pushFileName String
fName =
  (ParserState -> ParserState) -> NarParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\ParserState
s -> ParserState
s { directoryStack :: [String]
directoryStack = String
fName String -> [String] -> [String]
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 :: NarParser m ()
popFileName =
  (ParserState -> ParserState) -> NarParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\ParserState
s -> ParserState
s { directoryStack :: [String]
directoryStack = Int -> [String] -> [String]
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 :: NarParser m String
currentFile = do
  [String]
dirStack <- (ParserState -> [String]) -> NarParser m [String]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ParserState -> [String]
directoryStack
  String -> NarParser m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> NarParser m String) -> String -> NarParser m String
forall a b. (a -> b) -> a -> b
$ (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 String -> String -> String
(</>) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
List.reverse [String]
dirStack


-- | Add a link to the collection of encountered symlinks
pushLink :: Monad m => LinkInfo -> NarParser m ()
pushLink :: LinkInfo -> NarParser m ()
pushLink LinkInfo
linkInfo = (ParserState -> ParserState) -> NarParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\ParserState
s -> ParserState
s { links :: [LinkInfo]
links = LinkInfo
linkInfo LinkInfo -> [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 :: 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
  String
-> IOMode
-> (Handle -> IO (Either String a))
-> IO (Either String a)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
tmpFileName IOMode
ReadMode ((Handle -> IO (Either String a)) -> IO (Either String a))
-> (Handle -> IO (Either String a)) -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
    NarEffects m
-> NarParser m a -> Handle -> String -> m (Either String a)
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
NarEffects m
-> NarParser m a -> Handle -> String -> m (Either String a)
runParser NarEffects m
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' :: String -> IO (Either String ())
testParser' String
fp =
  String
-> IOMode
-> (Handle -> IO (Either String ()))
-> IO (Either String ())
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
ReadMode ((Handle -> IO (Either String ())) -> IO (Either String ()))
-> (Handle -> IO (Either String ())) -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ \Handle
h -> NarEffects IO
-> NarParser IO () -> Handle -> String -> IO (Either String ())
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
NarEffects m
-> NarParser m a -> Handle -> String -> m (Either String a)
runParser NarEffects IO
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m) =>
NarEffects m
Nar.narEffectsIO NarParser IO ()
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8


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