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
189
|
{-# 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 qualified Conduit as Cond
import Control.Concurrent
import qualified Control.Concurrent.Async as Async
import Control.Monad
import qualified Data.Aeson.BetterErrors as Json
import Data.Bifunctor
import Data.ByteString (ByteString)
import qualified Data.Conduit.Binary as Conduit.Binary
import qualified Data.Conduit.Combinators 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 qualified Data.Text as Text
import qualified Data.Text.Encoding
import qualified Data.Text.Encoding.Error
import Data.Text.IO (hPutStrLn)
import PyF
import qualified System.Directory as Dir
import qualified System.Environment as Env
import qualified System.Exit as Exit
import System.FilePath (takeDirectory)
import qualified System.FilePath.Posix as FilePath
import System.IO (stderr)
import qualified System.Posix as Posix
import Prelude hiding (log)
data LorriEvent = LorriEvent
{ nixFile :: Text,
eventType :: LorriEventType
}
deriving stock (Show)
data ChanToken a
= -- | so we can see that the lorri thread has been initialized
NoEventYet
| ChanEvent a
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 -> pure Nothing
go 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
|
