1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
module Main where
import Conduit
import Conduit qualified as Cond
import Control.Concurrent
import Control.Concurrent.Async qualified as Async
import Control.Monad
import Data.Aeson.BetterErrors qualified as Json
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Conduit.Binary qualified as Conduit.Binary
import Data.Conduit.Combinators qualified as Cond
import Data.Conduit.Process
import Data.Error
import Data.Function
import Data.Functor
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified
import Data.Text.Encoding.Error qualified
import Data.Text.IO (hPutStrLn)
import PyF
import System.Directory qualified as Dir
import System.Environment qualified as Env
import System.Exit qualified as Exit
import System.FilePath (takeDirectory)
import System.FilePath.Posix qualified as FilePath
import System.IO (stderr)
import System.Posix qualified as Posix
import Prelude hiding (log)
data LorriEvent = LorriEvent
{ nixFile :: Text,
eventType :: LorriEventType
}
deriving stock (Show)
data LorriEventType
= Completed
| Started
| Failure
deriving stock (Show)
main :: IO ()
main = do
argv <- Env.getArgs <&> nonEmpty
dir <- Dir.getCurrentDirectory
shellNix <-
findShellNix dir >>= \case
Nothing -> Exit.die [fmt|could not find any shell.nix in or above the directory {dir}|]
Just s -> pure s
getEventChan :: MVar (Chan LorriEvent) <- newEmptyMVar
Async.race_
( do
sendEventChan :: Chan LorriEvent <- newChan
(exitCode, ()) <-
sourceProcessWithConsumer
(proc "lorri" ["internal", "stream-events"])
$
-- first, we want to send a message over the chan that the process is running (for timeout)
liftIO (putMVar getEventChan sendEventChan)
*> Conduit.Binary.lines
.| Cond.mapC
( \jsonBytes ->
(jsonBytes :: ByteString)
& Json.parseStrict
( Json.key
"Completed"
( do
nixFile <- Json.key "nix_file" Json.asText
pure LorriEvent {nixFile, eventType = Completed}
)
Json.<|> Json.key
"Started"
( do
nixFile <- Json.key "nix_file" Json.asText
pure LorriEvent {nixFile, eventType = Started}
)
Json.<|> Json.key
"Failure"
( do
nixFile <- Json.key "nix_file" Json.asText
pure LorriEvent {nixFile, eventType = Failure}
)
)
& first Json.displayError'
& first (map newError)
& first (smushErrors [fmt|Cannot parse line returned by lorri: {jsonBytes & bytesToTextUtf8Lenient}|])
& unwrapError
)
.| (Cond.mapM_ (\ev -> writeChan sendEventChan ev))
log [fmt|lorri internal stream-events exited {show exitCode}|]
)
( do
let waitMs ms = threadDelay (ms * 1000)
-- log [fmt|Waiting for lorri event for {shellNix}|]
eventChan <- takeMVar getEventChan
let isOurEvent ev = FilePath.normalise (ev & nixFile & textToString) == FilePath.normalise shellNix
let handleEvent ev =
case ev & eventType of
Started ->
log [fmt|waiting for lorri build to finish|]
Completed -> do
log [fmt|build completed|]
exec (inDirenvDir (takeDirectory shellNix) <$> argv)
Failure -> do
log [fmt|evaluation failed! for path {ev & nixFile}|]
Exit.exitWith (Exit.ExitFailure 111)
-- wait for 100ms for the first message from lorri,
-- or else assume lorri is not building the project yet
Async.race
(waitMs 100)
( do
-- find the first event that we can use
let go = do
ev <- readChan eventChan
if isOurEvent ev then pure ev else go
go
)
>>= \case
Left () -> do
log [fmt|No event received from lorri, assuming this is the first evaluation|]
exec argv
Right ch -> handleEvent ch
runConduit $
repeatMC (readChan eventChan)
.| filterC isOurEvent
.| mapM_C handleEvent
)
where
inDirenvDir dir' argv' = ("direnv" :| ["exec", dir']) <> argv'
exec = \case
Just (exe :| args') -> Posix.executeFile exe True args' Nothing
Nothing -> Exit.exitSuccess
log :: Text -> IO ()
log msg = hPutStrLn stderr [fmt|lorri-wait-for-eval: {msg}|]
-- | Searches from the current directory upwards, until it finds the `shell.nix`.
findShellNix :: FilePath -> IO (Maybe FilePath)
findShellNix curDir = do
let go :: (FilePath -> IO (Maybe FilePath))
go dir = do
let file = dir FilePath.</> "shell.nix"
Dir.doesFileExist file >>= \case
True -> pure (Just file)
False -> do
let parent = FilePath.takeDirectory dir
if parent == dir
then pure Nothing
else go parent
go (FilePath.normalise curDir)
textToString :: Text -> String
textToString = Text.unpack
smushErrors :: Foldable t => Text -> t Error -> Error
smushErrors msg errs =
errs
-- hrm, pretty printing and then creating a new error is kinda shady
& foldMap (\err -> "\n- " <> prettyError err)
& newError
& errorContext msg
-- | decode a Text from a ByteString that is assumed to be UTF-8,
-- replace non-UTF-8 characters with the replacment char U+FFFD.
bytesToTextUtf8Lenient :: Data.ByteString.ByteString -> Data.Text.Text
bytesToTextUtf8Lenient =
Data.Text.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode
|
