{-# 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
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)
)
runParser
:: forall m a.(IO.MonadIO m, Base.MonadBaseControl IO m)
=> Nar.NarEffects m
-> NarParser m a
-> IO.Handle
-> FilePath
-> 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]
, ParserState -> [String]
directoryStack :: ![String]
, ParserState -> Handle
handle :: IO.Handle
, ParserState -> [LinkInfo]
links :: [LinkInfo]
}
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)
]
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)
data LinkInfo = LinkInfo
{ LinkInfo -> String
linkTarget :: String
, LinkInfo -> String
linkFile :: String
, LinkInfo -> String
linkPWD :: String
} 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)
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
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 :: 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))
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)
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
[(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
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
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
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
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
matchStr
:: (IO.MonadIO m, Fail.MonadFail m)
=> [(T.Text, NarParser m a)]
-> 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
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
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
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
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
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
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 ->
ParserState
s { tokenStack :: [Text]
tokenStack = Text
str Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ParserState -> [Text]
tokenStack ParserState
s }
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 })
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 )})
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)
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 })
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"
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)