0 | module Pack.Core.IO

  2 | import public Control.Monad.Either

  3 | import Pack.Config.Environment.Variable

  4 | import Pack.Config.Types

  5 | import Pack.Core.Logging

  6 | import Pack.Core.Types

  7 | import System

  8 | import System.Directory

  9 | import System.File

 11 | %default total

 18 | mapMaybeM : Monad m => (a -> m (Maybe b)) -> List a -> m (List b)

 19 | mapMaybeM f []        = pure []

 20 | mapMaybeM f (x :: xs) = do

 21 |   Just vb <- f x | Nothing => mapMaybeM f xs

 22 |   (vb ::) <$> mapMaybeM f xs

 25 | filterM : Monad m => (a -> m Bool) -> List a -> m (List a)

 26 | filterM f []        = pure []

 27 | filterM f (x :: xs) = do

 28 |   True <- f x | False => filterM f xs

 29 |   (x ::) <$> filterM f xs

 32 | ignoreError : Monad m => EitherT err m () -> m ()

 33 | ignoreError = ignore . runEitherT

 38 | eitherIO :

 39 |      {auto _ : HasIO io}

 40 |   -> (toErr : err -> PackErr)

 41 |   -> (act : io (Either err a))

 42 |   -> EitherT PackErr io a

 43 | eitherIO toErr = MkEitherT . map (mapFst toErr)

 48 | finally :

 49 |      {auto _ : Monad m}

 50 |   -> (cleanup : EitherT err m ())

 51 |   -> (act     : EitherT err m a)

 52 |   -> EitherT err m a

 53 | finally cleanup act = MkEitherT $ do

 54 |   res <- runEitherT act

 55 |   ignoreError cleanup

 56 |   pure res

 60 | run : EitherT PackErr IO () -> IO ()

 61 | run (MkEitherT io) = io >>= either fatal pure

 70 | dispEnv : List EnvVar -> String

 71 | dispEnv = unwords . map interpolate

 75 | sys : HasIO io => (cmd : CmdArgList) -> EitherT PackErr io ()

 76 | sys cmd = do

 77 |   0 <- system $ escapeCmd cmd | n => throwE (Sys cmd n)

 78 |   pure ()

 80 | logCmdOutput :

 81 |      {auto _   : HasIO io}

 82 |   -> {auto ref : LogRef}

 83 |   -> (lvl : LogLevel)

 84 |   -> (msg : String)

 85 |   -> io ()

 86 | logCmdOutput lvl msg =

 87 |   when (msg /= "") $ log ref lvl msg

 89 | lineBufferedCmd : Env => CmdArgList -> CmdArgList

 90 | lineBufferedCmd args = lineBufferingCmd %search ++ args

 93 | export covering

 94 | sysAndLog :

 95 |      {auto _ : HasIO io}

 96 |   -> {auto _ : Env}

 97 |   -> (lvl : LogLevel)

 98 |   -> (cmd : CmdArgList)

 99 |   -> EitherT PackErr io ()

100 | sysAndLog lvl cmd = do

101 |   0 <- runProcessingOutput

102 |          (logCmdOutput lvl)

103 |          (escapeCmd $ lineBufferedCmd cmd)

104 |     | n => throwE (Sys cmd n)

105 |   pure ()

107 | cmdWithEnv : CmdArgList -> List EnvVar -> String

108 | cmdWithEnv cmd []  = escapeCmd cmd

109 | cmdWithEnv cmd env = "\{dispEnv env} \{escapeCmd cmd}"

120 | sysWithEnv :

121 |      {auto _ : HasIO io}

122 |   -> (cmd : CmdArgList)

123 |   -> (env : List EnvVar)

124 |   -> EitherT PackErr io ()

125 | sysWithEnv cmd env = do

126 |   0 <- system (cmdWithEnv cmd env) | n => throwE (Sys cmd n)

127 |   pure ()

129 | export covering

130 | sysWithEnvAndLog :

131 |      {auto _ : HasIO io}

132 |   -> {auto _ : Env}

133 |   -> (lvl : LogLevel)

134 |   -> (cmd : CmdArgList)

135 |   -> (env : List EnvVar)

136 |   -> EitherT PackErr io ()

137 | sysWithEnvAndLog lvl cmd env = do

138 |   0 <- runProcessingOutput

139 |          (logCmdOutput lvl)

140 |          (cmdWithEnv (lineBufferedCmd cmd) env)

141 |     | n => throwE (Sys cmd n)

142 |   pure ()

145 | export covering

146 | sysRun : HasIO io => (cmd : CmdArgList) -> EitherT PackErr io String

147 | sysRun cmd = do

148 |   (res,0) <- run (escapeCmd cmd) | (_,n) => throwE (Sys cmd n)

149 |   pure res

159 | export covering

160 | sysRunWithEnv :

161 |      {auto _ : HasIO io}

162 |   -> (cmd : CmdArgList)

163 |   -> (env : List EnvVar)

164 |   -> EitherT PackErr io String

165 | sysRunWithEnv cmd env = do

166 |   (res,0) <- System.run (cmdWithEnv cmd env) | (_,n) => throwE (Sys cmd n)

167 |   pure res

174 | export %inline

175 | exists : HasIO io => (dir : Path Abs) -> io Bool

176 | exists = exists . interpolate

179 | export %inline

180 | fileExists : HasIO io => (f : File Abs) -> io Bool

181 | fileExists = exists . interpolate

185 | missing : HasIO io => (dir : Path Abs) -> io Bool

186 | missing = map not . exists

190 | fileMissing : HasIO io => (f : File Abs) -> io Bool

191 | fileMissing = map not . fileExists

195 | mkDir : HasIO io => (dir : Path Abs) -> EitherT PackErr io ()

196 | mkDir (PAbs _ [<]) = pure ()

197 | mkDir d            = sys ["mkdir", "-p", d]

201 | mkParentDir : HasIO io => (p : Path Abs) -> EitherT PackErr io ()

202 | mkParentDir p = whenJust (parentDir p) mkDir

206 | rmDir : HasIO io => (dir : Path Abs) -> EitherT PackErr io ()

207 | rmDir dir = when !(exists dir) $ sys ["rm", "-rf", dir]

211 | curDir : HasIO io => EitherT PackErr io (Path Abs)

212 | curDir = do

213 |   Just s <- currentDir | Nothing => throwE NoCurDir

214 |   case the FilePath (fromString s) of

215 |     FP (PAbs u sx) => pure (PAbs u sx)

216 |     FP (PRel _)    => throwE NoCurDir

220 | chgDir : HasIO io => (dir : Path Abs) -> EitherT PackErr io ()

221 | chgDir dir = do

222 |   True <- changeDir "\{dir}" | False => throwE (ChangeDir dir)

223 |   pure ()

228 | inDir :

229 |      {auto _ : HasIO io}

230 |   -> (dir : Path Abs)

231 |   -> (act : Path Abs -> EitherT PackErr io a)

232 |   -> EitherT PackErr io a

233 | inDir dir act =

234 |   curDir >>= \cur => finally (chgDir cur) (chgDir dir >> act dir)

238 | entries :

239 |      {auto _ : HasIO io}

240 |   -> (dir : Path Abs)

241 |   -> EitherT PackErr io (List Body)

242 | entries dir = do

243 |   ss <- eitherIO (DirEntries dir) (listDir "\{dir}")

244 |   pure (mapMaybe parse ss)

248 | tomlFiles :  {auto _ : HasIO io}

249 |   -> (dir : Path Abs)

250 |   -> EitherT PackErr io (List Body)

251 | tomlFiles dir = filter isTomlBody <$> entries dir

255 | htmlFiles :  {auto _ : HasIO io}

256 |   -> (dir : Path Abs)

257 |   -> EitherT PackErr io (List Body)

258 | htmlFiles dir = filter isHtmlBody <$> entries dir

262 | currentEntries : HasIO io => EitherT PackErr io (List Body)

263 | currentEntries = curDir >>= entries

267 | copyDir : HasIO io => (from,to : Path Abs) -> EitherT PackErr io ()

268 | copyDir from to = do

269 |   mkParentDir to

270 |   sys ["cp", "-r", from, to]

274 | copyDirInto : HasIO io => (from,parent : Path Abs) -> EitherT PackErr io ()

275 | copyDirInto from parent = do

276 |   mkDir parent

277 |   sys ["cp", "-r", from, "\{parent}/"]

282 | findInParentDirs :  {auto _ : HasIO io}

283 |   -> (Body -> Bool)

284 |   -> Path Abs

285 |   -> EitherT PackErr io (Maybe (File Abs))

286 | findInParentDirs p (PAbs d sb) = go sb

287 |   where go : SnocList Body -> EitherT PackErr io (Maybe (File Abs))

288 |         go [<]       = pure Nothing

289 |         go (sb :< b) =

290 |           let dir := PAbs d (sb :< b)

291 |            in do

292 |              (h :: _) <- filter p <$> entries dir | Nil => go sb

293 |              pure $ Just (MkF dir h)

299 | findInAllParentDirs :  {auto _ : HasIO io}

300 |   -> (Body -> Bool)

301 |   -> Path Abs

302 |   -> EitherT PackErr io (List (File Abs))

303 | findInAllParentDirs p = go []

305 |   where

306 |     go : List (File Abs) -> Path Abs -> EitherT PackErr io (List (File Abs))

307 |     go presentRes currD = do

308 |       Just af <-

309 |         catchE

310 |           (findInParentDirs p currD)

311 |           (handlePermissionDenied presentRes)

312 |         | Nothing => pure presentRes

313 |       let nextRes := af::presentRes

314 |       case parentDir $ parent af of

315 |         Just parentD => go nextRes $ assert_smaller currD parentD

316 |         Nothing      => pure nextRes

318 |       where

319 |         -- If we get a PermissionDenied FileError when some `pack.toml` where

320 |         -- already found, then we simply pretend that `findInParentDirs`

321 |         -- couldn't find anything above. Otherwise we forward the error.

322 |         -- (See github #386)

323 |         handlePermissionDenied :

324 |              (presentRes : List (File Abs))

325 |           -> PackErr

326 |           -> EitherT PackErr io (Maybe (File Abs))

327 |         handlePermissionDenied (_::_) (DirEntries path PermissionDenied) =

328 |           pure Nothing

329 |         handlePermissionDenied _ err = throwE err

331 | mkTmpDir : HasIO io => (pd : PackDirs) => EitherT PackErr io TmpDir

332 | mkTmpDir = go 100 0

334 |   where

335 |     go : Nat -> Nat -> EitherT PackErr io TmpDir

336 |     go 0     _ = throwE NoTmpDir

337 |     go (S k) n =

338 |       let Just body := Body.parse ".tmp\{show n}" | Nothing => go k (S n)

339 |           dir       := pd.cache /> body

340 |        in do

341 |          False <- exists dir | True => go k (S n)

342 |          when (n > 50) $

343 |            warn {ref = MkLogRef Info}

344 |              """

349 |          mkDir dir

350 |          pure (TD dir)

353 | withTmpDir :

354 |      {auto _ : HasIO io}

355 |   -> {auto _ : PackDirs}

356 |   -> (TmpDir => EitherT PackErr io a)

357 |   -> EitherT PackErr io a

358 | withTmpDir f = do

359 |   td <- mkTmpDir

360 |   finally (rmDir tmpDir) f

362 |   --------------------------------------------------------------------------------

363 |   --         File Access

364 |   --------------------------------------------------------------------------------

368 | rmFile : HasIO io => (f : File Abs) -> EitherT PackErr io ()

369 | rmFile f = when !(fileExists f) $ sys ["rm", f]

372 | export covering

373 | read : HasIO io => File Abs -> EitherT PackErr io String

374 | read fn = eitherIO (ReadFile fn) (readFile "\{fn}")

378 | export covering

379 | readIfExists :  {auto _ : HasIO io}

380 |   -> (file : File Abs)

381 |   -> (alt  : String)

382 |   -> EitherT PackErr io String

383 | readIfExists file alt = do

384 |   True <- fileExists file | False => pure alt

385 |   read file

390 | export covering

391 | write : HasIO io => File Abs -> String -> EitherT PackErr io ()

392 | write file str = do

393 |   mkDir file.parent

394 |   eitherIO (WriteFile file) (writeFile "\{file}" str)

399 | link : HasIO io => (from : Path Abs) -> (to : File Abs) -> EitherT PackErr io ()

400 | link from to = do

401 |   rmFile to

402 |   mkDir to.parent

403 |   sys ["ln", "-s", from, to]

407 | copyFile : HasIO io => (from,to : File Abs) -> EitherT PackErr io ()

408 | copyFile from to = do

409 |   mkDir to.parent

410 |   sys ["cp", from, to]

414 | patch :  {auto _ : HasIO io}

415 |   -> (original : File Abs)

416 |   -> (patch    : File Abs)

417 |   -> EitherT PackErr io ()

418 | patch o p = sys ["patch", o, p]