cabal-flatpak-0.0: src/Main.hs

module Main where

import qualified Flatpak
import qualified Generate

import qualified Cabal.Plan as Plan

import qualified System.Path.Directory as PathDir
import qualified System.Path as Path

import qualified Option
import qualified Options.Applicative as OP
import qualified Shell.Utility.ParseArgument as ParseArg
import qualified Shell.Utility.Verbosity as Verbosity
import qualified Shell.Utility.Log as Log

import qualified Network.HTTP.Client as Http
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (statusCode)

import Control.Monad (when)

import qualified Data.Aeson.Encode.Pretty as JsonPretty
import qualified Data.Aeson as Json
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as B
import qualified Data.Text.Encoding as TextEnc
import qualified Data.Text as Text
import qualified Data.Traversable as Trav
import qualified Data.Graph as Graph
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List.HT as ListHT
import Data.Tuple.HT (mapFst, snd3)
import Data.Map (Map)
import Data.Set (Set)

import Text.Printf (printf)


topSort :: Ord a => Map a (Set a) -> [a]
topSort m =
   reverse $
   (\(graph, lookupVertex, _) ->
      map (snd3 . lookupVertex) $ Graph.topSort graph) $
   Graph.graphFromEdges $ Map.elems $
   Map.mapWithKey (\k v -> ((), k, Set.toList v)) m

httpsGet :: String -> IO BL.ByteString
httpsGet url = do
   response <- do
      request <- Http.parseRequest url
      manager <- Http.newManager tlsManagerSettings
      Http.httpLbs request manager
   case statusCode $ Http.responseStatus response of
      200  -> return $ Http.responseBody response
      code -> fail $ "HTTPS get failed with status code: " ++ show code


main :: IO ()
main = do
   opt <- OP.execParser Option.info
   dir <-
      maybe (fmap Path.toAbsRel PathDir.getCurrentDirectory) return $
      Option.projectDir opt
   plan <-
      Plan.findAndDecodePlanJson $
      Plan.ProjectRelativeToDir $ Path.toString dir
   projectJson <-
      either fail return . Json.eitherDecode
      =<< (BL.readFile $ Path.toString $ Option.input opt)

   {-
   Only cabal >= 2.4.1.0 provides the SHA 256 hashes.
   see: https://hackage.haskell.org/package/cabal-plan-0.5.0.0/docs/Cabal-Plan.html#v:uCabalSha256
   -}
   let minVersion = Plan.Ver [2,4,1,0]
       curVersion = Plan.pjCabalVersion plan
   when (curVersion < minVersion) $ Log.warn Verbosity.normal $
      printf
         ("plan.json is from Cabal-%s, " ++
          "but only version %s and higher provide SHA256 hashes for Cabal files.")
         (Generate.formatVersion curVersion)
         (Generate.formatVersion minVersion)

   let matchExe name comp =
         case comp of Plan.CompNameExe nameExe -> name == nameExe; _ -> False
   let mainExe = Text.pack $ Flatpak.command $ Flatpak.base projectJson
   let units =
         filter
            (\unit ->
               if Generate.matchName (Flatpak.mainPackage projectJson) unit
                  then any (matchExe mainExe) $ Map.keys $ Plan.uComps unit
                  else Map.member Plan.CompNameLib $ Plan.uComps unit) $
         filter ((Plan.UnitTypeBuiltin /=) . Plan.uType) $
         map (Plan.pjUnits plan Map.!) $ topSort $ Plan.planJsonIdGraph plan

   archs <-
      case Option.archs opt of
         [] ->
            let archStr = Text.unpack $ Plan.pjArch plan
            in maybe
                  (fail $ printf "unsupported architecture: %s" archStr)
                  (return . (:[])) $
               ParseArg.enumMaybe Generate.archGHC archStr
         archs -> return archs

   let compiler = Plan.pjCompilerId plan
   let sha256Url = Generate.ghcDirUrl compiler ++ "SHA256SUMS"
   ghcSha256s <- httpsGet sha256Url
   let (ghcSha256Map, ghcSha256Corrupts) =
         mapFst Map.fromList $
         ListHT.partitionMaybe
            (\line ->
               case BL.words line of
                  [hash,archive] -> Just (archive,hash)
                  _ -> Nothing)
            (BL.lines ghcSha256s)
   when (not $ null ghcSha256Corrupts) $ fail $ unlines $
      (printf "corrupt lines in %s:" sha256Url) :
      map BL.unpack ghcSha256Corrupts
   archHashes <-
      Trav.forM archs $ \arch -> do
         let ghcName = Generate.ghcArchive compiler arch
         hashStr <-
            maybe
               (fail $
                printf "could not find SHA256 checksum for %s in %s"
                  ghcName sha256Url) return $
            Map.lookup (BL.pack $ "./"++ghcName) ghcSha256Map
         sha256 <-
            maybe
               (fail $ "could not parse SHA256 checksum " ++ BL.unpack hashStr)
               return $
            Plan.parseSha256 $
            TextEnc.decodeLatin1 $ B.concat $ BL.toChunks hashStr
         return (arch, sha256)

   BL.writeFile (Path.toString $ Option.output opt) $ JsonPretty.encodePretty $
      if Option.cabalInstall opt
         then Generate.manifestCabalInstall plan archHashes units projectJson
         else Generate.manifest plan archHashes units projectJson