{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
-- | A streaming parser for the NAR format

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


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           Control.Monad                    ( forM
                                                  , when
                                                  , forM_
                                                  )
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           Data.ByteString                  (ByteString)
import qualified Data.ByteString                 as Bytes
import           Data.Bool                        ( bool )
import qualified Data.Either                     as Either
import           Data.Int                         ( Int64 )
import qualified Data.IORef                      as IORef
import qualified Data.CaseInsensitive            as CI
import qualified Data.HashMap.Strict             as HashMap
import qualified Data.List                       as List
import qualified Data.Map                        as Map
import           Data.Maybe                       ( catMaybes )
import qualified Data.Serialize                  as Serialize
import           Data.Text                        ( Text )
import qualified Data.Text                       as Text
import qualified Data.Text.Encoding              as Text
import qualified System.Directory                as Directory
import           System.FilePath                 as FilePath
import qualified System.IO                       as IO

import qualified System.Nix.Nar.Effects as Nar
import qualified System.Nix.Nar.Options 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 (ParserEnv m) m)) a
_runNarParser ::
      State.StateT
        ParserState
        (Except.ExceptT
          String
          (Reader.ReaderT (ParserEnv m) m)
        )
        a
  }
  deriving ( (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
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NarParser m a -> NarParser m b
fmap :: forall a b. (a -> b) -> NarParser m a -> NarParser m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> NarParser m b -> NarParser m a
<$ :: forall a b. a -> NarParser m b -> NarParser m a
Functor, Functor (NarParser m)
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)
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
$cpure :: forall (m :: * -> *) a. Monad m => a -> NarParser m a
pure :: forall a. a -> NarParser m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
NarParser m (a -> b) -> NarParser m a -> NarParser m b
<*> :: forall a b. NarParser m (a -> b) -> NarParser m a -> NarParser m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> NarParser m a -> NarParser m b -> NarParser m c
liftA2 :: forall a b c.
(a -> b -> c) -> NarParser m a -> NarParser m b -> NarParser m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
NarParser m a -> NarParser m b -> NarParser m b
*> :: 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 a
<* :: forall a b. NarParser m a -> NarParser m b -> NarParser m a
Applicative, Applicative (NarParser m)
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)
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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
NarParser m a -> (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 -> NarParser m b -> NarParser m b
>> :: forall a b. NarParser m a -> NarParser m b -> NarParser m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> NarParser m a
return :: forall a. a -> NarParser m a
Monad, Monad (NarParser m)
Monad (NarParser m) =>
(forall a. String -> NarParser m a) -> MonadFail (NarParser m)
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
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> NarParser m a
fail :: forall a. String -> NarParser m a
Fail.MonadFail
           , Monad (NarParser m)
Monad (NarParser m) =>
(forall a. IO a -> NarParser m a) -> MonadIO (NarParser m)
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
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> NarParser m a
liftIO :: forall a. IO a -> NarParser m a
Trans.MonadIO, State.MonadState ParserState
           , Except.MonadError String
           , Reader.MonadReader (ParserEnv m)
           )

data ParserEnv m = ParserEnv
  { forall (m :: * -> *). ParserEnv m -> NarEffects m
envNarEffects :: Nar.NarEffects m
  , forall (m :: * -> *). ParserEnv m -> NarOptions
envNarOptions :: Nar.NarOptions
  }

getNarEffects :: Monad m => NarParser m (Nar.NarEffects m)
getNarEffects :: forall (m :: * -> *). Monad m => NarParser m (NarEffects m)
getNarEffects = (ParserEnv m -> NarEffects m)
-> NarParser m (ParserEnv m) -> NarParser m (NarEffects m)
forall a b. (a -> b) -> NarParser m a -> NarParser m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParserEnv m -> NarEffects m
forall (m :: * -> *). ParserEnv m -> NarEffects m
envNarEffects NarParser m (ParserEnv m)
forall r (m :: * -> *). MonadReader r m => m r
Reader.ask

getNarEffect :: Monad m => (Nar.NarEffects m -> a) -> NarParser m a
getNarEffect :: forall (m :: * -> *) a.
Monad m =>
(NarEffects m -> a) -> NarParser m a
getNarEffect NarEffects m -> a
eff = (NarEffects m -> a) -> NarParser m (NarEffects m) -> NarParser m a
forall a b. (a -> b) -> NarParser m a -> NarParser m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NarEffects m -> a
eff NarParser m (NarEffects m)
forall (m :: * -> *). Monad m => NarParser m (NarEffects m)
getNarEffects

getNarOptions :: Monad m => NarParser m Nar.NarOptions
getNarOptions :: forall (m :: * -> *). Monad m => NarParser m NarOptions
getNarOptions = (ParserEnv m -> NarOptions)
-> NarParser m (ParserEnv m) -> NarParser m NarOptions
forall a b. (a -> b) -> NarParser m a -> NarParser m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParserEnv m -> NarOptions
forall (m :: * -> *). ParserEnv m -> NarOptions
envNarOptions NarParser m (ParserEnv m)
forall r (m :: * -> *). MonadReader r m => m r
Reader.ask

-- | 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 m a
parser Handle
h String
target = do
  NarOptions
-> NarEffects m
-> NarParser m a
-> Handle
-> String
-> m (Either String a)
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
NarOptions
-> NarEffects m
-> NarParser m a
-> Handle
-> String
-> m (Either String a)
runParserWithOptions NarOptions
Nar.defaultNarOptions NarEffects m
effs NarParser m a
parser Handle
h String
target

runParserWithOptions
  :: forall m a
   . (IO.MonadIO m, Base.MonadBaseControl IO m)
  => Nar.NarOptions
  -> 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)
runParserWithOptions :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
NarOptions
-> NarEffects m
-> NarParser m a
-> Handle
-> String
-> m (Either String a)
runParserWithOptions NarOptions
opts NarEffects m
effs (NarParser StateT ParserState (ExceptT String (ReaderT (ParserEnv m) m)) a
action) Handle
h String
target = do
  Either String a
unpackResult <-
    ReaderT (ParserEnv m) m (Either String a)
-> ParserEnv m -> m (Either String a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT (ExceptT String (ReaderT (ParserEnv m) m) a
-> ReaderT (ParserEnv m) m (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT String (ReaderT (ParserEnv m) m) a
 -> ReaderT (ParserEnv m) m (Either String a))
-> ExceptT String (ReaderT (ParserEnv m) m) a
-> ReaderT (ParserEnv m) m (Either String a)
forall a b. (a -> b) -> a -> b
$ StateT ParserState (ExceptT String (ReaderT (ParserEnv m) m)) a
-> ParserState -> ExceptT String (ReaderT (ParserEnv m) m) a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT StateT ParserState (ExceptT String (ReaderT (ParserEnv m) m)) a
action ParserState
state0) (NarEffects m -> NarOptions -> ParserEnv m
forall (m :: * -> *). NarEffects m -> NarOptions -> ParserEnv m
ParserEnv NarEffects m
effs NarOptions
opts)
      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
Either.isLeft Either String a
unpackResult) m ()
cleanup
  Either String a -> m (Either String a)
forall a. a -> m a
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          = []
      , filePaths :: HashMap (CI String) Int
filePaths      = HashMap (CI String) Int
forall k v. HashMap k v
HashMap.empty
      }

  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 a. a -> m 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 a. Show a => a -> String
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 :: forall (m :: * -> *) a. Monad m => m a -> NarParser m a
lift m a
act = StateT ParserState (ExceptT String (ReaderT (ParserEnv m) m)) a
-> NarParser m a
forall (m :: * -> *) a.
StateT ParserState (ExceptT String (ReaderT (ParserEnv m) m)) a
-> NarParser m a
NarParser (StateT ParserState (ExceptT String (ReaderT (ParserEnv m) m)) a
 -> NarParser m a)
-> StateT ParserState (ExceptT String (ReaderT (ParserEnv m) m)) a
-> NarParser m a
forall a b. (a -> b) -> a -> b
$ (ExceptT String (ReaderT (ParserEnv m) m) a
-> StateT ParserState (ExceptT String (ReaderT (ParserEnv m) m)) a
forall (m :: * -> *) a. Monad m => m a -> StateT ParserState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (ExceptT String (ReaderT (ParserEnv m) m) a
 -> StateT ParserState (ExceptT String (ReaderT (ParserEnv m) m)) a)
-> (m a -> ExceptT String (ReaderT (ParserEnv m) m) a)
-> m a
-> StateT ParserState (ExceptT String (ReaderT (ParserEnv m) m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT (ParserEnv m) m a
-> ExceptT String (ReaderT (ParserEnv m) m) a
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (ReaderT (ParserEnv m) m a
 -> ExceptT String (ReaderT (ParserEnv m) m) a)
-> (m a -> ReaderT (ParserEnv m) m a)
-> m a
-> ExceptT String (ReaderT (ParserEnv m) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (ParserEnv m) m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT (ParserEnv m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.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
  , ParserState -> HashMap (CI String) Int
filePaths      :: HashMap.HashMap (CI.CI FilePath) Int
    -- ^ A map of case-insensitive files paths to the number of collisions encountered.
    -- See @Nar.NarOptions.optUseCaseHack@ for details.
  }

------------------------------------------------------------------------------
-- * 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
  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 :: forall (m :: * -> *). (MonadIO m, MonadFail m) => 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 :: forall (m :: * -> *). (MonadIO m, MonadFail m) => 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
      { linkTarget :: String
linkTarget = Text -> String
Text.unpack 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 <- (ParserState -> [String]) -> NarParser m [String]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ParserState -> [String]
directoryStack
    case [String]
dirStack of
      (String
x:[String]
xs) -> (String, String) -> NarParser m (String, String)
forall a. a -> NarParser m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> String -> String) -> [String] -> String
forall a. (a -> a -> a) -> [a] -> a
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]
xs), String
x)
      [String]
_ -> String -> NarParser m (String, String)
forall a. HasCallStack => String -> a
error String
"currentDirectoryAndFile: empty 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
$cshowsPrec :: Int -> LinkInfo -> String -> String
showsPrec :: Int -> LinkInfo -> String -> String
$cshow :: LinkInfo -> String
show :: LinkInfo -> String
$cshowList :: [LinkInfo] -> String -> String
showList :: [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 <- 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t 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 a. String -> NarParser m a
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 a. Show a => a -> String
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 a. Show a => a -> String
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 a. IO a -> NarParser m a
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 a. a -> IO (IORef a)
IORef.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 a. IO a -> m a
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 a. IORef a -> IO a
IORef.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 a. a -> m a
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 a. IO a -> m a
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 a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"ZERO BYTES")
          IO () -> m ()
forall a. IO a -> m a
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 a. IORef a -> (a -> a) -> IO ()
IORef.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 a. IO a -> m a
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 a. a -> m a
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 -> IsExecutable -> m (Maybe ByteString) -> m ()
streamFile <- (NarEffects m
 -> String -> IsExecutable -> m (Maybe ByteString) -> m ())
-> NarParser
     m (String -> IsExecutable -> m (Maybe ByteString) -> m ())
forall (m :: * -> *) a.
Monad m =>
(NarEffects m -> a) -> NarParser m a
getNarEffect NarEffects m
-> String -> IsExecutable -> m (Maybe ByteString) -> m ()
forall (m :: * -> *).
NarEffects m
-> String -> IsExecutable -> m (Maybe ByteString) -> m ()
Nar.narStreamFile
  let isExecutable :: IsExecutable
isExecutable = IsExecutable -> IsExecutable -> Bool -> IsExecutable
forall a. a -> a -> Bool -> a
bool IsExecutable
Nar.NonExecutable IsExecutable
Nar.Executable (Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"executable")
  m () -> NarParser m ()
forall (m :: * -> *) a. Monad m => m a -> NarParser m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (String -> IsExecutable -> m (Maybe ByteString) -> m ()
streamFile String
target IsExecutable
isExecutable m (Maybe ByteString)
getChunk)

  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 :: forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m ()
parseDirectory = do
  String -> m ()
createDirectory <- (NarEffects m -> String -> m ()) -> NarParser m (String -> m ())
forall (m :: * -> *) a.
Monad m =>
(NarEffects m -> a) -> NarParser m a
getNarEffect 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 (m :: * -> *) a. Monad m => m a -> NarParser m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> NarParser m ()) -> m () -> NarParser m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
createDirectory String
target
  String -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
String -> NarParser m ()
parseEntryOrFinish String
target

 where

  parseEntryOrFinish :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> NarParser m ()
  parseEntryOrFinish :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
String -> NarParser m ()
parseEntryOrFinish String
path =
    -- 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", String -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
String -> NarParser m ()
parseEntry String
path  )
      ]

  parseEntry :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> NarParser m ()
  parseEntry :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
String -> NarParser m ()
parseEntry String
path = do
    NarOptions
opts <- NarParser m NarOptions
forall (m :: * -> *). Monad m => NarParser m NarOptions
getNarOptions
    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 <-
        if NarOptions -> Bool
Nar.optUseCaseHack NarOptions
opts then
          String -> Text -> NarParser m Text
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
String -> Text -> NarParser m Text
addCaseHack String
path (Text -> NarParser m Text) -> NarParser m Text -> NarParser m Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NarParser m Text
forall (m :: * -> *). (MonadIO m, MonadFail m) => NarParser m Text
parseStr
        else
          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
Text.unpack 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
    String -> NarParser m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
String -> NarParser m ()
parseEntryOrFinish String
path

  addCaseHack :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> Text -> NarParser m Text
  addCaseHack :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
String -> Text -> NarParser m Text
addCaseHack String
path Text
fName = do
    let key :: String
key = String
path String -> String -> String
</> Text -> String
Text.unpack Text
fName
    String -> NarParser m ()
forall (m :: * -> *). Monad m => String -> NarParser m ()
recordFilePath String
key
    Int
conflictCount <- String -> NarParser m Int
forall (m :: * -> *). Monad m => String -> NarParser m Int
getFilePathConflictCount String
key
    Text -> NarParser m Text
forall a. a -> NarParser m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> NarParser m Text) -> Text -> NarParser m Text
forall a b. (a -> b) -> a -> b
$
      if Int
conflictCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then
        Text
fName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
Nar.caseHackSuffix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
conflictCount)
      else
        Text
fName

------------------------------------------------------------------------------
-- * 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 <- 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 a. a -> NarParser m a
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 a. a -> NarParser m a
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
Text.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 <- 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 a. String -> NarParser m a
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 a. a -> NarParser m a
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 :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
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 a. String -> NarParser m a
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
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
err Text
actual
 where
  err :: Text -> String
err Text
t =
    Text -> String
forall a. Show a => a -> String
show (Text -> String) -> Text -> String
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 :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
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 a. String -> NarParser m a
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
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
err ByteString
actual
 where
  err :: ByteString -> String
err ByteString
bs =
    ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
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 :: forall (m :: * -> *) a.
(MonadIO m, MonadFail m) =>
[(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 a. 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 a. Show a => a -> String
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 a. Show a => a -> String
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
  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 a. 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 :: forall (m :: * -> *). MonadIO m => NarParser m ()
createLinks = do
  String -> String -> m ()
createLink  <- (NarEffects m -> String -> String -> m ())
-> NarParser m (String -> String -> m ())
forall (m :: * -> *) a.
Monad m =>
(NarEffects m -> a) -> NarParser m a
getNarEffect 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 a. IO a -> NarParser m a
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 a. IO a -> NarParser m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO IO String
Directory.getCurrentDirectory
    IO () -> NarParser m ()
forall a. IO a -> NarParser m a
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 (m :: * -> *) a. Monad m => m a -> NarParser m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.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 a. IO a -> NarParser m a
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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO a
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))
_            -> String -> IO [LinkInfo]
forall a. HasCallStack => String -> a
error String
"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 a. a -> IO a
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 :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> NarParser m ByteString
consume Int
0 = ByteString -> NarParser m ByteString
forall a. a -> NarParser m a
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 a. IO a -> NarParser m a
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.hGet (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 a. String -> NarParser m a
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 a. Show a => a -> String
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 a. Show a => a -> String
show (ByteString -> Int
Bytes.length ByteString
newBytes)
  ByteString -> NarParser m ByteString
forall a. a -> NarParser m a
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 <- NarParser m ParserState
forall s (m :: * -> *). MonadState s m => m s
State.get
  case [Text] -> Maybe (Text, [Text])
forall a. [a] -> Maybe (a, [a])
List.uncons (ParserState -> [Text]
tokenStack ParserState
s) of
    Maybe (Text, [Text])
Nothing      -> Maybe Text -> NarParser m (Maybe Text)
forall a. a -> NarParser m a
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 = xs }
      Maybe Text -> NarParser m (Maybe Text)
forall a. a -> NarParser m a
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 :: forall (m :: * -> *). Monad m => 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 = str : tokenStack 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 =
  (ParserState -> ParserState) -> NarParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\ParserState
s -> ParserState
s { directoryStack = fName : directoryStack s })

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

-- | Add a file path to the collection of encountered file paths
recordFilePath :: Monad m => FilePath -> NarParser m ()
recordFilePath :: forall (m :: * -> *). Monad m => String -> NarParser m ()
recordFilePath String
fPath =
  (ParserState -> ParserState) -> NarParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\ParserState
s -> ParserState
s { filePaths = HashMap.insertWith (\Int
_ Int
v -> Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (CI.mk fPath) 0 (filePaths s) })

getFilePathConflictCount :: Monad m => FilePath -> NarParser m Int
getFilePathConflictCount :: forall (m :: * -> *). Monad m => String -> NarParser m Int
getFilePathConflictCount String
fPath = do
  HashMap (CI String) Int
fileMap <- (ParserState -> HashMap (CI String) Int)
-> NarParser m (HashMap (CI String) Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ParserState -> HashMap (CI String) Int
filePaths
  Int -> NarParser m Int
forall a. a -> NarParser m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> NarParser m Int) -> Int -> NarParser m Int
forall a b. (a -> b) -> a -> b
$ Int -> CI String -> HashMap (CI String) Int -> Int
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.findWithDefault Int
0 (String -> CI String
forall s. FoldCase s => s -> CI s
CI.mk String
fPath) HashMap (CI String) Int
fileMap

------------------------------------------------------------------------------
-- * 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
  String
-> IOMode
-> (Handle -> IO (Either String a))
-> IO (Either String a)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
tmpFileName IOMode
IO.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 IO
-> NarParser IO a -> Handle -> String -> IO (Either String a)
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 m a
NarParser IO 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 =
  String
-> IOMode
-> (Handle -> IO (Either String ()))
-> IO (Either String ())
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
fp IOMode
IO.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

-- | Debugging helper
_dbgState :: IO.MonadIO m => NarParser m ()
_dbgState :: forall (m :: * -> *). MonadIO m => NarParser m ()
_dbgState = do
  ParserState
s <- NarParser m ParserState
forall s (m :: * -> *). MonadState s m => m s
State.get
  IO () -> NarParser m ()
forall a. IO a -> NarParser m a
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. Show a => a -> IO ()
print (ParserState -> [Text]
tokenStack ParserState
s, ParserState -> [String]
directoryStack ParserState
s)