-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2015-2017  Daniel Gröber <cabal-helper@dxld.at>
--
-- SPDX-License-Identifier: Apache-2.0
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0

{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, CPP #-}

{-|
Module      : CabalHelper.Compiletime.Data
Description : Embeds source code for runtime component using TH
License     : Apache-2.0
-}

module CabalHelper.Compiletime.Data where

import Control.Monad
import Control.Monad.IO.Class
import Data.Digest.Pure.SHA
import Data.Functor
import Data.List
import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.UTF8 as LUTF8
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (addDependentFile)
import System.Directory
import System.FilePath
import System.IO.Temp
import System.PosixCompat.Files
import System.PosixCompat.Time
import System.PosixCompat.Types
import Prelude

import CabalHelper.Compiletime.Compat.Environment

withSystemTempDirectoryEnv :: String -> (FilePath -> IO b) -> IO b
withSystemTempDirectoryEnv :: String -> (String -> IO b) -> IO b
withSystemTempDirectoryEnv tpl :: String
tpl f :: String -> IO b
f = do
  Maybe String
m <- IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv "CABAL_HELPER_KEEP_SOURCEDIR"
  case Maybe String
m of
    Nothing -> String -> (String -> IO b) -> IO b
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
tpl String -> IO b
f
    Just _  -> do
           String
tmpdir <- IO String
getCanonicalTemporaryDirectory
           String -> IO b
f (String -> IO b) -> IO String -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> IO String
createTempDirectory String
tmpdir String
tpl

createHelperSources :: FilePath -> IO ()
createHelperSources :: String -> IO ()
createHelperSources dir :: String
dir = do
    let chdir :: String
chdir = String
dir String -> String -> String
</> "CabalHelper"
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
chdir String -> String -> String
</> "Runtime"
      Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
chdir String -> String -> String
</> "Shared"

    let modtime :: EpochTime
        modtime :: EpochTime
modtime = Integer -> EpochTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> EpochTime) -> Integer -> EpochTime
forall a b. (a -> b) -> a -> b
$ (String -> Integer
forall a. Read a => String -> a
read :: String -> Integer)
          -- See https://reproducible-builds.org/specs/source-date-epoch/
          $(runIO $ do
             msde :: Maybe Integer
                  <- fmap read <$> lookupEnv "SOURCE_DATE_EPOCH"
             (current_time :: Integer) <- round . toRational <$> epochTime
             return $ LitE . StringL $ show $ maybe current_time id msde)

    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> ((String, String) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, String)]
sourceFiles (((String, String) -> IO ()) -> IO ())
-> ((String, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(fn :: String
fn, src :: String
src) -> do
        let path :: String
path = String
chdir String -> String -> String
</> String
fn
        String -> ByteString -> IO ()
BS.writeFile String
path (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString
UTF8.fromString String
src
        String -> EpochTime -> EpochTime -> IO ()
setFileTimes String
path EpochTime
modtime EpochTime
modtime

sourceHash :: String
sourceHash :: String
sourceHash  = (String, [(String, String)]) -> String
forall a b. (a, b) -> a
fst (String, [(String, String)])
runtimeSources

sourceFiles :: [(FilePath, String)]
sourceFiles :: [(String, String)]
sourceFiles = (String, [(String, String)]) -> [(String, String)]
forall a b. (a, b) -> b
snd (String, [(String, String)])
runtimeSources

runtimeSources :: (String, [(FilePath, FilePath)])
runtimeSources :: (String, [(String, String)])
runtimeSources = $(
  let files = map (\f -> (f, ("src/CabalHelper" </> f))) $ sort $
        [ ("Runtime/Main.hs")
        , ("Runtime/HelperMain.hs")
        , ("Runtime/Compat.hs")
        , ("Shared/Common.hs")
        , ("Shared/InterfaceTypes.hs")
        ]
  in do
    contents <- forM (map snd files) $ \lf -> do
      addDependentFile lf
      runIO (LBS.readFile lf)
    let hashes = map (bytestringDigest . sha256) contents
    let top_hash = showDigest $ sha256 $ LBS.concat hashes

    let exprWrapper =
#if MIN_VERSION_template_haskell(2,16,0)
          Just
#else
          id
#endif


    thfiles <- forM (map fst files `zip` contents) $ \(f, xs) -> do
      return $ TupE [exprWrapper (LitE (StringL f)), exprWrapper (LitE (StringL (LUTF8.toString xs)))]


    return $ TupE [exprWrapper (LitE (StringL top_hash)), exprWrapper (ListE thfiles)]

  )

-- - $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile