git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/asset/manifest/src/Obelisk/Asset/Gather.hs
70 lines 3.2 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE BangPatterns #-}
3-- | Functions for collecting up files to be processed by the asset pipeline
4module Obelisk.Asset.Gather
5 ( gatherHashedPaths
6 , toHashedPath
7 ) where
9import Control.DeepSeq
10import Control.Monad (forM)
11import Data.Bits
12import qualified Data.ByteString.Lazy as LBS
13import qualified Data.ByteString.Lazy.Builder as LBS
14import Data.Char
15import Data.Digest.Pure.SHA
16import Data.Map (Map)
17import qualified Data.Map as Map
18import qualified Data.Text as T
19import Data.Text.Encoding
20import qualified Data.Vector.Unboxed as UV
21import Data.Word
22import System.FilePath.Posix
23import System.Directory
25-- | Given a path, recursively explore it, creating hashed paths for all files found
26gatherHashedPaths
27 :: FilePath -- ^ The root of the directory to process
28 -> IO (Map FilePath FilePath) -- ^ A mapping of original paths to hashed paths (all relative to the root)
29gatherHashedPaths root = go ""
30 where
31 go :: FilePath -> IO (Map FilePath FilePath)
32 go subdir = do
33 subs <- listDirectory $ root </> subdir
34 fmap mconcat $ forM subs $ \sub -> do
35 let relativePath = subdir </> sub
36 isFile <- doesFileExist $ root </> relativePath
37 if isFile
38 then do !hashedRelativePath <- force <$> toHashedPath root relativePath
39 return $ Map.singleton relativePath hashedRelativePath
40 else go relativePath
42-- | Given a root path and path relative to it, construct a hashed version of the relative path
43toHashedPath
44 :: FilePath -- ^ Root path
45 -> FilePath -- ^ Relative path within root
46 -> IO FilePath
47toHashedPath root relativePath = do
48 let path = root </> relativePath
49 contents <- LBS.readFile path
50 let hashPrefix = T.unpack $ decodeUtf8 $ LBS.toStrict $ toNixBase32 $ bytestringDigest $ sha256 contents
51 (dir, filename) = splitFileName relativePath
52 !hashedRelativePath = force $ normalise $ dir </> (hashPrefix <> "-" <> filename)
53 return hashedRelativePath
55-- | Convert a ByteString to base 32 in the way that Nix does
56toNixBase32 :: LBS.ByteString -> LBS.ByteString
57toNixBase32 x = LBS.toLazyByteString $ mconcat $ map (LBS.word8 . (symbols UV.!) . fromIntegral) vals
58 where vals = byteStringToQuintets x
59 symbols = UV.fromList $ map (fromIntegral . ord) $ filter (`notElem` ("eotu" :: String)) $ ['0'..'9'] <> ['a'..'z']
60 -- See https://github.com/NixOS/nix/blob/6f1743b1a5116ca57a60b481ee4083c891b7a334/src/libutil/hash.cc#L109
61 byteStringToQuintets :: LBS.ByteString -> [Word8]
62 byteStringToQuintets hash = map f [len-1, len-2 .. 0]
63 where hashSize = fromIntegral $ LBS.length hash
64 len = (hashSize * 8 - 1) `div` 5 + 1
65 f n = let b = n * 5
66 (i, j) = b `divMod` 8
67 j' = fromIntegral j
68 --TODO: This is probably pretty slow; replace with something that doesn't use LBS.index
69 c = ((hash `LBS.index` i) `shift` (-j')) .|. (if i >= hashSize - 1 then 0 else (hash `LBS.index` (i + 1)) `shift` (8 - j'))
70 in c .&. 0x1f