@@ -0,0 +1,46 @@
1+module Obelisk.Asset.TH where
2+
3+import Language.Haskell.TH.Syntax
4+import System.FilePath
5+import qualified Data.Text as T
6+import qualified Data.ByteString as BS
7+import qualified Data.ByteString.Lazy as LBS
8+import qualified Data.ByteString.Lazy.Builder as LBS
9+import Data.Digest.Pure.SHA
10+import Data.Text.Encoding
11+import Data.Monoid
12+import Data.Bits
13+import qualified Data.Vector.Unboxed as UV
14+import Data.Char
15+import Data.Word
16+
17+-- | Warning: does not support negative numbers (will result in infinite loop)
18+toNixBase32 :: LBS.ByteString -> LBS.ByteString
19+toNixBase32 x = LBS.toLazyByteString $ mconcat $ map (LBS.word8 . (symbols UV.!) . fromIntegral) vals
20+ where vals = byteStringToQuintets x
21+ symbols = UV.fromList $ map (fromIntegral . ord) $ filter (`notElem` "eotu") $ ['0'..'9'] <> ['a'..'z']
22+
23+
24+-- See https://github.com/NixOS/nix/blob/6f1743b1a5116ca57a60b481ee4083c891b7a334/src/libutil/hash.cc#L109
25+byteStringToQuintets :: LBS.ByteString -> [Word8]
26+byteStringToQuintets hash = map f [len-1, len-2 .. 0]
27+ where hashSize = fromIntegral $ LBS.length hash
28+ len = (hashSize * 8 - 1) `div` 5 + 1
29+ f n = let b = n * 5
30+ (i, j) = b `divMod` 8
31+ j' = fromIntegral j
32+ c = ((hash `LBS.index` i) `shift` (-j')) .|. (if i >= hashSize - 1 then 0 else (hash `LBS.index` (i + 1)) `shift` (8 - j')) --TODO: This is probably pretty slow; replace with something that doesn't use LBS.index
33+ in c .&. 0x1f
34+
35+assetPath' :: FilePath -> FilePath -> Q FilePath
36+assetPath' root relativePath = do
37+ let path = root </> relativePath
38+ qAddDependentFile path
39+ contents <- fmap LBS.fromStrict $ runIO $ BS.readFile path
40+ let hashPrefix = T.unpack $ decodeUtf8 $ LBS.toStrict $ toNixBase32 $ bytestringDigest $ sha256 contents
41+ (dir, filename) = splitFileName relativePath
42+ return $ dir </> (hashPrefix <> "-" <> filename)
43+
44+assetPath :: FilePath -> FilePath -> Q Exp
45+assetPath root relativePath =
46+ LitE . StringL <$> assetPath' root relativePath