From 1338e4a1c9f445e5384cdee3d65cf5a46ce03105 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Wed, 10 Nov 2021 23:21:15 +0100
Subject: [PATCH] copy map assets (and refuse if any are missing)
---
lib/CheckDir.hs | 11 ++++++--
lib/WriteRepo.hs | 67 +++++++++++++++++++++++++++++++++---------------
src/Main.hs | 2 +-
3 files changed, 57 insertions(+), 23 deletions(-)
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index 68bcefe..5540aae 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -6,7 +6,7 @@
{-# LANGUAGE TupleSections #-}
-- | Module that contains high-level checking for an entire directory
-module CheckDir (recursiveCheckDir, DirResult(..)) where
+module CheckDir (recursiveCheckDir, DirResult(..), resultIsFatal) where
import CheckMap (MapResult (mapresultProvides),
loadAndLintMap, mapresultDepends)
@@ -47,7 +47,7 @@ data DirResult = DirResult
, dirresultDeps :: [MissingDep]
-- ^ all dependencies to things outside this repository
, dirresultMissingAssets :: [MissingAsset]
- -- ^ local things that are referred to but missing
+ -- ^ entrypoints of maps which are referred to but missing
} deriving (Generic)
data MissingDep = MissingDep
@@ -57,6 +57,13 @@ data MissingDep = MissingDep
newtype MissingAsset = MissingAsset MissingDep
+
+resultIsFatal :: DirResult -> Bool
+resultIsFatal res =
+ not $ null (dirresultMissingAssets res)
+
+
+
instance ToJSON DirResult where
toJSON res = A.object
[ "missingDeps" .= dirresultDeps res
diff --git a/lib/WriteRepo.hs b/lib/WriteRepo.hs
index 5e695f5..c0bf31b 100644
--- a/lib/WriteRepo.hs
+++ b/lib/WriteRepo.hs
@@ -1,28 +1,55 @@
-
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | Module for writing an already linted map Repository back out again.
-
module WriteRepo where
-import CheckDir (DirResult (dirresultMaps))
-import CheckMap (MapResult (mapresultAdjusted))
+import CheckDir (DirResult (dirresultMaps),
+ resultIsFatal)
+import CheckMap (MapResult (mapresultAdjusted, mapresultDepends))
+import Control.Monad (forM_)
import Data.Aeson (encodeFile)
import Data.Map.Strict (toList)
-import System.Directory.Extra (createDirectoryIfMissing)
+import Data.Maybe (mapMaybe)
+import Data.Set (Set)
+import qualified Data.Set as S
+import Paths (normalise)
+import System.Directory.Extra (copyFile, createDirectoryIfMissing)
+import System.FilePath (takeDirectory)
+import qualified System.FilePath as FP
import System.FilePath.Posix ((</>))
-
-
-
-writeAdjustedRepository :: FilePath -> DirResult -> IO ()
-writeAdjustedRepository outPath result = do
-
- -- True here just means the equivalent of mkdir -p
- createDirectoryIfMissing True outPath
-
- -- write out all maps
- mapM_
- (\(path,out) -> encodeFile (outPath </> path) $ mapresultAdjusted out)
- (toList $ dirresultMaps result)
-
- -- TODO: copy all assets
+import Types (Dep (Local))
+
+
+writeAdjustedRepository :: FilePath -> FilePath -> DirResult -> IO ()
+writeAdjustedRepository inPath outPath result
+ | resultIsFatal result = pure ()
+ | otherwise = do
+ createDirectoryIfMissing True outPath
+
+ -- write out all maps
+ mapM_
+ (\(path,out) -> encodeFile (outPath </> path) $ mapresultAdjusted out)
+ (toList $ dirresultMaps result)
+
+ -- collect asset dependencies of maps
+ -- TODO: its kinda weird doing that here, tbh
+ let localdeps :: Set FilePath =
+ S.fromList . concatMap
+ (\(mappath,mapresult) ->
+ let mapdir = takeDirectory mappath in
+ mapMaybe (\case
+ Local path -> Just . normalise mapdir $ path
+ _ -> Nothing)
+ $ mapresultDepends mapresult)
+ . toList $ dirresultMaps result
+
+ -- copy all assets
+ forM_ localdeps $ \path ->
+ let
+ assetPath = FP.normalise $ inPath </> path
+ newPath = FP.normalise $ outPath </> path
+ in do
+ putStrLn $ "copying " <> assetPath <> " → " <> newPath
+ copyFile assetPath newPath
diff --git a/src/Main.hs b/src/Main.hs
index 8cbfe7d..1862c5b 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -48,7 +48,7 @@ run options = do
lints <- recursiveCheckDir repo entry
case out options of
- Just path -> writeAdjustedRepository path lints
+ Just outpath -> writeAdjustedRepository repo outpath lints
Nothing -> pure ()
if json options
--
GitLab