-- | A streaming parser for the NAR format

{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeFamilies               #-}

module System.Nix.Internal.Nar.Parser 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 ExceptionLifted
import           Control.Monad                   (forM, when)
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 BS
import qualified Data.Either                     as Either
import           Data.Int                        (Int64)
import qualified Data.IORef                      as IORef
import qualified Data.List                       as List
import qualified Data.Map                        as Map
import           Data.Maybe                      (catMaybes)
import qualified Data.Serialize                  as S
import qualified Data.Text                       as T
import qualified Data.Text.Encoding              as E
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 @IO.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
Reader.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)
Except.runExceptT (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
`ExceptionLifted.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 (m :: * -> *) a. Monad m => a -> m a
return 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 :: ExceptionLifted.SomeException -> m (Either String a)
    exceptionHandler :: SomeException -> m (Either String a)
exceptionHandler SomeException
e = do
      Either String a -> m (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (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. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)

    cleanup :: m ()
    cleanup :: m ()
cleanup = do
      Bool
isDir <- NarEffects m -> String -> m Bool
forall (m :: * -> *). NarEffects m -> String -> m Bool
Nar.narIsDir NarEffects m
effs String
target
      if Bool
isDir
        then NarEffects m -> String -> m ()
forall (m :: * -> *). NarEffects m -> String -> m ()
Nar.narDeleteDir  NarEffects m
effs String
target
        else NarEffects m -> String -> m ()
forall (m :: * -> *). NarEffects m -> String -> m ()
Nar.narDeleteFile 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
Trans.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
Trans.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
Trans.lift) m a
act


data ParserState = ParserState
  { ParserState -> [Text]
tokenStack     :: ![T.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 return @()@
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 () -> NarParser m ())
-> NarParser m () -> NarParser m ()
forall a b. (a -> b) -> a -> b
$ 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
T.unpack 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 (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> NarParser m (String, String))
-> (String, String) -> NarParser m (String, 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]
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
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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"executable", Text
"contents"])
       (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. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
s String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    String
" when expecting element from " String -> String -> String
forall 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 (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 BS.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 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 (m :: * -> *) a. Monad m => a -> m a
return 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
BS.hGetSome Handle
narHandle (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
BS.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 a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef IORef Int64
bytesLeftVar (\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
BS.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 (m :: * -> *) a. Monad m => a -> m a
return (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
Reader.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
Trans.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
Reader.ask
    m () -> NarParser m ()
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
$ 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
BS.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
Reader.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
Trans.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 = do
        -- 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
T.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 () -> NarParser m ())
-> NarParser m () -> NarParser m ()
forall a b. (a -> b) -> a -> b
$ 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 T.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 -> do
      Text -> NarParser m Text
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (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
BS.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 (m :: * -> *) a. Monad m => a -> m a
return (Text -> NarParser m Text) -> Text -> NarParser m Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
E.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
  case Get Int64 -> ByteString -> Either String Int64
forall a. Get a -> ByteString -> Either String a
S.runGet Get Int64
S.getInt64le ByteString
eightBytes of
    Left 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. [a] -> [a] -> [a]
++ String
e
    Right Int64
n -> Int64 -> NarParser m Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
n


-- | Consume a NAR string and assert that it matches an expectation
expectStr :: (IO.MonadIO m, Fail.MonadFail m) => T.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)
    (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. [a] -> [a] -> [a]
++ Text -> String
err Text
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
err Text
actual )
  where
    err :: Text -> String
err Text
t =
      if Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10
      then Text -> String
forall a. Show a => a -> String
show (Int -> Text -> Text
T.take Int
10 Text
t)
      else Text -> String
forall a. Show a => a -> String
show Text
t


-- | 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) => BS.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 (ByteString -> Int
BS.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. [a] -> [a] -> [a]
++ ByteString -> String
err ByteString
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
err ByteString
actual
  where
    err :: ByteString -> String
err ByteString
bs =
      if   ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10
      then ByteString -> String
forall a. Show a => a -> String
show (Int -> ByteString -> ByteString
BS.take Int
10 ByteString
bs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
      else ByteString -> String
forall a. Show a => a -> String
show ByteString
bs


-- | Consume a NAR string, and dispatch to a parser depending on which string
--   matched
matchStr
  :: (IO.MonadIO m, Fail.MonadFail m)
  => [(T.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. [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. [a] -> [a] -> [a]
++ String
" found " String -> String -> String
forall 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return 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
Reader.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 -> NarParser m ()) -> [LinkInfo] -> NarParser m ())
-> [LinkInfo] -> (LinkInfo -> NarParser m ()) -> NarParser m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (LinkInfo -> NarParser m ()) -> [LinkInfo] -> NarParser m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [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 -> NarParser m String)
-> IO String -> NarParser m String
forall a b. (a -> b) -> a -> b
$ 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
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 (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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return ([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 BS.ByteString
consume :: Int -> NarParser m ByteString
consume Int
0 = ByteString -> NarParser m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return 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
BS.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
BS.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. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
newBytes)
  ByteString -> NarParser m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
newBytes


-- | Pop a string off the token stack
popStr :: Monad m => NarParser m (Maybe T.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])
List.uncons (ParserState -> [Text]
tokenStack ParserState
s) of
    Maybe (Text, [Text])
Nothing     -> Maybe Text -> NarParser m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return (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 => T.Text -> NarParser m ()
pushStr :: Text -> NarParser m ()
pushStr Text
str = do
  (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 = do
  (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 (m :: * -> *) a. Monad m => a -> m a
return (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]
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 -> BS.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 ()
BS.writeFile String
"tmp" 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
"tmp" 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 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
"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
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


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. Show a => a -> IO ()
print (ParserState -> [Text]
tokenStack ParserState
s, ParserState -> [String]
directoryStack ParserState
s)