|
| 1 | +{-# LANGUAGE DeriveGeneric #-} |
| 2 | +{-# LANGUAGE OverloadedStrings #-} |
| 3 | +module Distribution.Client.HookAccept |
| 4 | + ( HookAccept (..) |
| 5 | + , assertHookHash |
| 6 | + , loadHookHasheshMap |
| 7 | + , parseHooks |
| 8 | + ) where |
| 9 | + |
| 10 | +import Distribution.Client.Compat.Prelude |
| 11 | + |
| 12 | +import Data.ByteString.Char8 (ByteString) |
| 13 | +import qualified Data.ByteString.Char8 as BS |
| 14 | + |
| 15 | +import qualified Data.Map.Strict as Map |
| 16 | + |
| 17 | +import Distribution.Client.Config (getConfigFilePath) |
| 18 | +import Distribution.Client.Errors (CabalInstallException (..)) |
| 19 | +import Distribution.Client.HashValue (HashValue, hashValueFromHex, readFileHashValue, showHashValue) |
| 20 | +import Distribution.Simple.Setup (Flag(..)) |
| 21 | +import Distribution.Simple.Utils (dieWithException) |
| 22 | +import Distribution.Verbosity (normal) |
| 23 | + |
| 24 | +import System.FilePath (takeDirectory, (</>)) |
| 25 | + |
| 26 | +data HookAccept |
| 27 | + = AcceptAlways |
| 28 | + | AcceptHash HashValue |
| 29 | + deriving (Eq, Show, Generic) |
| 30 | + |
| 31 | +instance Monoid HookAccept where |
| 32 | + mempty = AcceptAlways -- Should never be needed. |
| 33 | + mappend = (<>) |
| 34 | + |
| 35 | +instance Semigroup HookAccept where |
| 36 | + AcceptAlways <> AcceptAlways = AcceptAlways |
| 37 | + AcceptAlways <> AcceptHash h = AcceptHash h |
| 38 | + AcceptHash h <> AcceptAlways = AcceptHash h |
| 39 | + AcceptHash h <> _ = AcceptHash h |
| 40 | + |
| 41 | +instance Binary HookAccept |
| 42 | +instance Structured HookAccept |
| 43 | + |
| 44 | +assertHookHash :: Map FilePath HookAccept -> FilePath -> IO () |
| 45 | +assertHookHash m fpath = do |
| 46 | + actualHash <- readFileHashValue fpath |
| 47 | + hsPath <- getHooksSecurityFilePath NoFlag |
| 48 | + case Map.lookup fpath m of |
| 49 | + Nothing -> |
| 50 | + dieWithException normal $ |
| 51 | + HookAcceptUnknown hsPath fpath (showHashValue actualHash) |
| 52 | + Just AcceptAlways -> pure () |
| 53 | + Just (AcceptHash expectedHash) -> |
| 54 | + when (actualHash /= expectedHash) $ |
| 55 | + dieWithException normal $ |
| 56 | + HookAcceptHashMismatch hsPath fpath |
| 57 | + (showHashValue expectedHash) (showHashValue actualHash) |
| 58 | + |
| 59 | +getHooksSecurityFilePath :: Flag FilePath -> IO FilePath |
| 60 | +getHooksSecurityFilePath configFileFlag = do |
| 61 | + hfpath <- getConfigFilePath configFileFlag |
| 62 | + pure $ takeDirectory hfpath </> "hooks-security" |
| 63 | + |
| 64 | +loadHookHasheshMap :: Flag FilePath -> IO (Map FilePath HookAccept) |
| 65 | +loadHookHasheshMap configFileFlag = do |
| 66 | + hookFilePath <- getHooksSecurityFilePath configFileFlag |
| 67 | + handleNotExists $ fmap parseHooks (BS.readFile hookFilePath) |
| 68 | + where |
| 69 | + handleNotExists :: IO (Map FilePath HookAccept) -> IO (Map FilePath HookAccept) |
| 70 | + handleNotExists action = catchIO action $ \ _ -> return mempty |
| 71 | + |
| 72 | +parseHooks :: ByteString -> Map FilePath HookAccept |
| 73 | +parseHooks = Map.fromList . map parse . cleanUp . BS.lines |
| 74 | + where |
| 75 | + cleanUp :: [ByteString] -> [ByteString] |
| 76 | + cleanUp = filter (not . BS.null) . map rmComments |
| 77 | + |
| 78 | + rmComments :: ByteString -> ByteString |
| 79 | + rmComments = fst . BS.breakSubstring "--" |
| 80 | + |
| 81 | +parse :: ByteString -> (FilePath, HookAccept) |
| 82 | +parse bs = |
| 83 | + case BS.words bs of |
| 84 | + [fp, "AcceptAlways"] -> (BS.unpack fp, AcceptAlways) |
| 85 | + [fp, "AcceptHash"] -> buildAcceptHash fp "00" |
| 86 | + [fp, "AcceptHash", h] -> buildAcceptHash fp h |
| 87 | + _ -> error $ "Not able to parse:" ++ show bs |
| 88 | + where |
| 89 | + buildAcceptHash :: ByteString -> ByteString -> (FilePath, HookAccept) |
| 90 | + buildAcceptHash fp h = |
| 91 | + case hashValueFromHex h of |
| 92 | + Left err -> error $ "Distribution.Client.HookAccept.parse :" ++ err |
| 93 | + Right hv -> (BS.unpack fp, AcceptHash hv) |
0 commit comments