diff --git a/Changes.md b/Changes.md new file mode 100644 --- /dev/null +++ b/Changes.md @@ -0,0 +1,5 @@ +# Change log for the `cabal-flatpak` package + +## 0.0 + + * First experimental version inspired by `stackpak`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2019, Henning Thielemann + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,20 @@ +FLATPAK = $$FLATPAKBUILD + +%.html: %.md + pandoc --output $@ $< + +dist-newstyle/cache/plan.json: + cabal new-build --dry-run + +flatpak.json: flatpak.cabal.json dist-newstyle/cache/plan.json + cabal run -- --cabal-install --arch x86_64 --arch i386 $< $@ + +repo-%: flatpak.json + flatpak-builder --force-clean --arch=$* --repo=$(FLATPAK)/repository --state-dir=$(FLATPAK)/builder/ $(FLATPAK)/build/cabal-flatpak $< + touch $@ + +cabal-flatpak.%.flatpak: repo-% + flatpak build-bundle --arch=$* $(FLATPAK)/repository $@ com.github.thielema.cabal-flatpak \ + --runtime-repo=https://flathub.org/repo/flathub.flatpakrepo + +flatpak-all: cabal-flatpak.x86_64.flatpak cabal-flatpak.i386.flatpak diff --git a/ReadMe.md b/ReadMe.md new file mode 100644 --- /dev/null +++ b/ReadMe.md @@ -0,0 +1,172 @@ +## Scope + +This program generates a large Flatpak manifest in JSON format +with the versions of all transitively imported Haskell packages. +This is required by Flathub +since this platform downloads all source files for you +and lets you build only in a sandbox without access to the internet. +The detailed version information can also be useful for you +for reproducible builds. +However, for maintaining your own Flatpak repository +or for distributing Flatpak bundles +it is not strictly necessary to have such a verbose manifest. +You may get results quicker by writing you own manifest +which simply runs `cabal-install` or `stack`. +`stack` should give you reproducible builds +but its package database contains only a subset of Hackage. +`cabal-install` gives you access to more Haskell packages, +but the build may fail at a later point due to lax version bounds +in dependent packages. + + +## Usage + +### Create a Flatpak manifest + +The usage is a bit cumbersome, +because for Flathub you may only build manifests +for released versions of your package, +whereas you certainly want to manage manifests +in the working copy of your repository. + +First let `cabal` build a `plan.json` for your released package: + +~~~~ +$ cd /tmp +$ cabal unpack my-package-0.1.2 +$ cd my-package-0.1.2 +$ cabal new-build --dry-run --disable-tests --disable-benchmarks +~~~~ + +`cabal-flatpak` reads `plan.json` via the `cabal-plan` library. + +Now create a `flatpak.cabal.json` file in your working copy. +It contains a custom JSON object with information needed by `cabal-flatpak` +and also a template for the generated manifest. +For an example see the configuration file for `cabal-flatpak`. + +~~~~ +$ cd /path/to/my-package +$ cabal-flatpak --directory=/tmp/my-package-0.1.2 flatpak.cabal.json flatpak.json +~~~~ + +The `--arch` option allows you to put build information +for one or more architectures into one manifest. +Usually, only `ghc` and `cabal-install` binaries depend on the architecture +and the whole lot of Haskell packages can be build with the same commands. + +There are two build modes: +One builds all modules individually using plain `Cabal`, +the other one builds all modules in one go using `cabal-install`. +You can enable the second mode using the `--cabal-install` option. +These are the differences: + +* `Cabal` mode needs less dependencies. + `cabal-install` needs a pre-built binary for your architecture. + +* `Cabal` mode can pass options to the build of specific packages. + `cabal-install` can only pass options to all packages at once. + If `-fbuildExamples` means something different to different Haskell packages, + then this will fail. + Even in `cabal-install` mode we need to preprocess each package + and in this stage we could alter flag switches by patching Cabal files. + We could also build packages with requested flags in separate stages. + Currently, we don't try any of these strategies. + +* `cabal-install` enables parallel builds. + This builds significantly faster. + `Cabal` mode on the other hand allows Flatpak to cache build results + of individual packages. + This can accelerate re-builds. + However, Flatpak does not know the dependency graph + and thus simply rebuilds anything after a module that must be rebuilt. + +Unfortunately, you cannot simply switch between the two modes +simply by adding or removing the `--cabal-install` option. +The reason is that you must maintain the data for the main package +manually in the `"main-sources"` object +and `Cabal` requires the source tarball unpacked +whereas `cabal-install` needs it packed. +Thus `Cabal` needs `"type": "archive"` +and `cabal-install` needs `"type": "file"`. + +For some packages you need to build dependencies on external C packages. +`cabal-flatpak` cannot generate according build instructions for you. +However, you can re-use build instructions you found useful. +Flatpak-builder supports this itself. +In the `"modules"` list you cannot only put module JSON objects, +but also plain strings. +Such a string is interpreted as path to a separate file +containing a Flatpak module JSON object. +I add such JSON files to the FFI packages I maintain. + + +### Build the Flatpak package + +You may refer to the `Makefile` that is shipped with `cabal-flatpak` +for how to eventually build the Flatpak package. +The command line is: + +~~~~ +$ flatpak-builder --force-clean --repo=$FLATPAK/repository --state-dir=$FLATPAK/builder/ $FLATPAK/build/my-package $< +~~~~ + +Flatpak consumes pretty much storage +thus I set $FLATPAK to a directory on a separate harddisk partition. +The `--repo` option points to your Flatpak repository. +This is where `flatpak-builder` stores the compiled package. +The Flatpak repository contains all versions of all your Flatpak packages. +If another user has access to it, +she can easily install and update Flatpak packages. +The `--state-dir` option points to a directory +that caches all downloads and build artifacts of Flatpak. +You may share it between different projects. +The `DIRECTORY` argument names the path +to where Flatpak builds your project. +It may not be shared between projects, +but you can safely delete it after a build +and the `--force-clean` option triggers exactly this +when you re-build your project. +The directories specified by `--state-dir` and `DIRECTORY` +must reside on the same file system. + +You may also extract a single package file +for a certain version of your package from the repository. +This can be handy for a one-time install +but disallows the user to easily get updates of your program. + +~~~~ +$ flatpak build-bundle $FLATPAK/repository \ + my-package-0.1.2.flatpak com.my_domain.my-package \ + --runtime-repo=https://flathub.org/repo/flathub.flatpakrepo +~~~~ + + +## Known issues + +### Cabal revisions + +Cabal package description files can be updated on Hackage +without altering the package version. +Every update increases the Cabal file revision. +Unfortunately, `plan.json` does not contain the revision number, +it just refers to the currently most recent Cabal file for each Haskell package. +This is a fundamental problem since Flatpak builds must be reproducible. + +We have currently no solution for that problem. +If someone updates the Cabal file of one of your dependencies, +then the Flatpak build will break with an error due to a SHA256 hash mismatch. +In this case you should find out the original revision +and add that to the Hackage path in the Flatpak manifest. +E.g. if the path to a Cabal file is say +`https://hackage.haskell.org/package/cabal-flatpak-0.0/cabal-flatpak.cabal` +then the path to revision 1 is: +`https://hackage.haskell.org/package/cabal-flatpak-0.0/revision/1.cabal`. + +We could try to solve the problem by downloading Cabal file revisions +from Hackage for every imported package +until we find the one with a matching SHA256 hash. +We could try to do this offline and scan Cabal's local package database +using a program like: +https://github.com/haskell-hvr/hackage-index . +None of these ideas is implemented, yet. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/cabal-flatpak.cabal b/cabal-flatpak.cabal new file mode 100644 --- /dev/null +++ b/cabal-flatpak.cabal @@ -0,0 +1,59 @@ +Name: cabal-flatpak +Version: 0.0 +License: BSD3 +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://hub.darcs.net/thielema/cabal-flatpak/ +Category: Distribution +Synopsis: Generate a FlatPak manifest from a Cabal package description +Description: + Generate a FlatPak manifest from a Cabal package description. + . + Inspired by Richard Szibele's stackpak: + + . + See also David Lettier's post on Flatpak for Haskell: + +Tested-With: GHC==8.6.5 +Cabal-Version: >=1.6 +Build-Type: Simple +Extra-Source-Files: + Makefile + ReadMe.md + Changes.md + flatpak.cabal.json + +Source-Repository this + Tag: 0.0 + Type: darcs + Location: http://hub.darcs.net/thielema/cabal-flatpak/ + +Source-Repository head + Type: darcs + Location: http://hub.darcs.net/thielema/cabal-flatpak/ + +Executable cabal-flatpak + Build-Depends: + cabal-plan >=0.5 && <0.6, + http-client-tls >=0.3.5.3 && <0.4, + http-client >=0.5.12 && <0.7, + http-types >=0.10 && <0.13, + aeson-pretty >=0.8.7 && <0.9, + aeson >=1.2 && <1.5, + shell-utility >=0.0 && <0.1, + optparse-applicative >=0.11 && <0.16, + pathtype >=0.8 && <0.9, + text >=1.2 && <1.3, + bytestring >=0.9 && <0.11, + containers >=0.4.2 && <0.7, + utility-ht >=0.0.12 && <0.1, + base >=4.5 && <5 + + GHC-Options: -Wall + Hs-Source-Dirs: src + Main-Is: Main.hs + Other-Modules: + Generate + Flatpak + Option diff --git a/flatpak.cabal.json b/flatpak.cabal.json new file mode 100644 --- /dev/null +++ b/flatpak.cabal.json @@ -0,0 +1,31 @@ +{ + "base": + { + "app-id": "com.github.thielema.cabal-flatpak", + "runtime": "org.freedesktop.Platform", + "runtime-version": "18.08", + "sdk": "org.freedesktop.Sdk", + "command": "cabal-flatpak", + "finish-args": [ + "--share=network", + "--filesystem=host" + ], + "cleanup": [], + "cleanup-commands": [], + "modules": [] + }, + + "main-package": "cabal-flatpak", + "main-sources": [ + { + "url": "https://hackage.haskell.org/package/cabal-flatpak-0.0/candidate/cabal-flatpak-0.0.tar.gz", + "type": "file", + "sha256": "112e0dee2ffa9e71855ac5350ce26121867434c507c4e660734a885511683f1c" + }, + { + "url": "https://hackage.haskell.org/package/cabal-flatpak-0.0/candidate/cabal-flatpak.cabal", + "type": "file", + "sha256": "f4d54935b16f55a406a3844990990347e5ddfdfd147ac647791aebda244d64be" + } + ] +} diff --git a/src/Flatpak.hs b/src/Flatpak.hs new file mode 100644 --- /dev/null +++ b/src/Flatpak.hs @@ -0,0 +1,283 @@ +module Flatpak ( + SourceType(..), archive, Source(..), + Module(..), ModuleItem(ModuleEmbed), + Arch(..), archString, T(..), + PackageHook(..), Cabal(..), + ) where + +import qualified Shell.Utility.ParseArgument as ParseArg + +import qualified Cabal.Plan as Plan + +import qualified Data.Aeson as Json +import qualified Data.Text as Text +import qualified Data.Monoid.HT as Mn +import Data.Aeson.Types (Parser, Pair) +import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON, withObject) +import Data.Tuple.HT (mapFst) +import Data.Monoid (mempty, (<>)) + +import Text.Printf (printf) + +import Control.Monad (mzero) +import Control.Applicative (pure, (<*>), (<$>), (<|>)) + + +infixr 8 .:, .:?, .:* + +(.:) :: FromJSON a => Json.Object -> String -> Parser a +o .: field = o Json..: Text.pack field + +(.:?) :: FromJSON a => Json.Object -> (String, a) -> Parser a +o .:? (field, deflt) = o Json..:? Text.pack field Json..!= deflt + +(.:*) :: FromJSON a => Json.Object -> String -> Parser [a] +o .:* field = o .:? (field, []) + + +infixr 8 .=, .=* + +(.=) :: ToJSON a => String -> (object -> a) -> object -> [Pair] +(field .= a) obj = [Text.pack field Json..= a obj] + +(.=*) :: (ToJSON a) => String -> (object -> [a]) -> object -> [Pair] +(field .=* a) obj = Mn.when (not $ null $ a obj) ((field .= a) obj) + +object :: (object -> [Pair]) -> object -> Json.Value +object fields = Json.object . fields + + +parseEnum :: + (Enum a, Bounded a) => (a -> String) -> String -> Json.Value -> Parser a +parseEnum fmt nm = + Json.withText nm $ \txt -> + case Text.unpack txt of + str -> + case ParseArg.enumMaybe fmt str of + Just x -> return x + Nothing -> fail $ printf "unknown %s type: %s" nm str + + +data SourceType = + Archive {stripComponents :: Int} | + Git | Bzr | File | Dir | Script | Shell | Patch | ExtraData + deriving (Show) + +archive :: SourceType +archive = Archive {stripComponents = 1} + +pairsFromSourceType :: SourceType -> [Pair] +pairsFromSourceType t = + let simple str = [("type", Json.toJSON str)] + in map (mapFst Text.pack) $ + case t of + Archive {stripComponents = strip} -> + simple "archive" ++ + Mn.when (strip/=1) [("strip-components", Json.toJSON strip)] + Git -> simple "git" + Bzr -> simple "bzr" + File -> simple "file" + Dir -> simple "dir" + Script -> simple "script" + Shell -> simple "shell" + Patch -> simple "patch" + ExtraData -> simple "extra-data" + +parseSourceType :: Json.Object -> String -> Parser SourceType +parseSourceType obj t = + case t of + "archive" -> fmap Archive $ obj .:? ("strip-components", 1) + "git" -> return Git + "bzr" -> return Bzr + "file" -> return File + "dir" -> return Dir + "script" -> return Script + "shell" -> return Shell + "patch" -> return Patch + "extra-data" -> return ExtraData + _ -> mzero + +data Source = + Source { + typ :: SourceType, + url :: String, + sha256 :: Maybe Plan.Sha256 + } deriving (Show) + +instance FromJSON Source where + parseJSON = + withObject "Source" $ \o -> pure Source + <*> (parseSourceType o =<< o .: "type") + <*> o .: "url" + <*> o .: "sha256" + +instance ToJSON Source where + toJSON = object $ + (pairsFromSourceType . typ) <> + ("url" .= url) <> + ("sha256" .= sha256) <> + mempty + + +data Arch = I386 | X86_64 | ARM | AArch64 + deriving (Show, Enum, Bounded) + +archString :: Arch -> String +archString arch = + case arch of + I386 -> "i386" + X86_64 -> "x86_64" + ARM -> "arm" + AArch64 -> "aarch64" + +instance FromJSON Arch where + parseJSON = parseEnum archString "arch" + +instance ToJSON Arch where + toJSON = Json.toJSON . archString + + +data Module = + Module { + name :: String, + onlyArches :: [Arch], + buildsystem :: String, + builddir :: Bool, + configOpts :: [String], + buildCommands :: [String], + postInstall :: [String], + cleanupModule :: [String], + sources :: [Source] + } deriving (Show) + +instance FromJSON Module where + parseJSON = + withObject "Module" $ \o -> pure Module + <*> o .: "name" + <*> o .:* "only-arches" + <*> o .: "buildsystem" + <*> o .: "builddir" + <*> o .:* "config-opts" + <*> o .:* "build-commands" + <*> o .:* "post-install" + <*> o .:* "cleanup" + <*> o .:* "sources" + +instance ToJSON Module where + toJSON = object $ + ("name" .= name) <> + ("only-arches" .=* onlyArches) <> + ("buildsystem" .= buildsystem) <> + ("builddir" .= builddir) <> + ("config-opts" .=* configOpts) <> + ("build-commands" .=* buildCommands) <> + ("post-install" .=* postInstall) <> + ("cleanup" .=* cleanupModule) <> + ("sources" .=* sources) <> + mempty + + +data ModuleItem = ModuleEmbed Module | ModuleInclude String + deriving (Show) + +instance FromJSON ModuleItem where + parseJSON v = + ModuleInclude <$> parseJSON v + <|> + ModuleEmbed <$> parseJSON v + +instance ToJSON ModuleItem where + toJSON m = + case m of + ModuleEmbed modu -> toJSON modu + ModuleInclude path -> toJSON path + + +data T = + Cons { + appId :: String, + runtime :: String, + runtimeVersion :: String, + sdk :: String, + command :: String, + finishArgs :: [String], + cleanup :: [String], + cleanupCommands :: [String], + modules :: [ModuleItem] + } deriving (Show) + +instance FromJSON T where + parseJSON = + withObject "Flatpak" $ \o -> pure Cons + <*> o .: "app-id" + <*> o .: "runtime" + <*> o .: "runtime-version" + <*> o .: "sdk" + <*> o .: "command" + <*> o .: "finish-args" + <*> o .:* "cleanup" + <*> o .:* "cleanup-commands" + <*> o .: "modules" + +instance ToJSON T where + toJSON = object $ + ("app-id" .= appId) <> + ("runtime" .= runtime) <> + ("runtime-version" .= runtimeVersion) <> + ("sdk" .= sdk) <> + ("command" .= command) <> + ("finish-args" .= finishArgs) <> + ("cleanup" .=* cleanup) <> + ("cleanup-commands" .=* cleanupCommands) <> + ("modules" .= modules) <> + mempty + + + +data PackageHook = + PackageHook { + nameHook :: String, + postInstallHook :: [String] + } deriving (Show) + +instance FromJSON PackageHook where + parseJSON = + withObject "PackageHook" $ \o -> pure PackageHook + <*> o .: "name" + <*> o .:* "post-install" + +instance ToJSON PackageHook where + toJSON = object $ + ("name" .= nameHook) <> + ("post-install" .=* postInstallHook) <> + mempty + + +data Cabal = + Cabal { + base :: T, + mainPackage :: String, + mainSources :: [Source], + packageHooks :: [PackageHook], + cabalConfigureOptions, ghcOptions :: [String] + } deriving (Show) + +instance FromJSON Cabal where + parseJSON = + withObject "Cabal" $ \o -> pure Cabal + <*> o .: "base" + <*> o .: "main-package" + <*> o .: "main-sources" + <*> o .:* "package-hooks" + <*> o .:* "cabal-configure-options" + <*> o .:* "ghc-options" + +instance ToJSON Cabal where + toJSON = object $ + ("base" .= base) <> + ("main-package" .= mainPackage) <> + ("main-sources" .= mainSources) <> + ("package-hooks" .= packageHooks) <> + ("cabal-configure-options" .=* cabalConfigureOptions) <> + ("ghc-options" .=* ghcOptions) <> + mempty diff --git a/src/Generate.hs b/src/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Generate.hs @@ -0,0 +1,324 @@ +module Generate where + +import qualified Flatpak +import Flatpak (ModuleItem(ModuleEmbed)) + +import qualified Cabal.Plan as Plan +import qualified Shell.Utility.Quote as Quote + +import qualified Data.Map as Map +import qualified Data.Text as Text +import Data.Foldable (foldMap) +import Data.Map (Map) +import Data.Bool.HT (if') + +import Text.Printf (printf) + + +archGHC :: Flatpak.Arch -> String +archGHC arch = + case arch of + Flatpak.I386 -> "i386" + Flatpak.X86_64 -> "x86_64" + Flatpak.ARM -> "armv7" + Flatpak.AArch64 -> "aarch64" + +formatVersion :: Plan.Ver -> String +formatVersion = Text.unpack . Plan.dispVer + +ghcDirUrl :: Plan.PkgId -> String +ghcDirUrl (Plan.PkgId (Plan.PkgName compName) compVersion) = + printf + "https://downloads.haskell.org/%s/%s/" + (Text.unpack compName) + (formatVersion compVersion) + +{- | +ghc-8.4.4-x86_64-deb9 is available but fails due to missing libnuma.so.1 +-} +ghcNameScheme :: Plan.Ver -> String +ghcNameScheme ghcVer = + if' (ghcVer >= Plan.Ver [8, 6,1]) "%s-%s-deb9-linux.tar.xz" $ + if' (ghcVer >= Plan.Ver [7,10,3]) "%s-%s-deb8-linux.tar.xz" $ + if' (ghcVer >= Plan.Ver [7, 8,1]) "%s-%s-unknown-linux-deb7.tar.xz" $ + "%s-%s-unknown-linux.tar.bz2" + +ghcArchive :: Plan.PkgId -> Flatpak.Arch -> String +ghcArchive compiler@(Plan.PkgId _ compVersion) arch = + printf (ghcNameScheme compVersion) + (Text.unpack $ Plan.dispPkgId compiler) + (archGHC arch) + +tinfoPath :: Flatpak.Arch -> String +tinfoPath arch = + case arch of + Flatpak.I386 -> "/usr/lib/i386-linux-gnu/libtinfo.so" + Flatpak.X86_64 -> "/usr/lib/x86_64-linux-gnu/libtinfo.so" + Flatpak.ARM -> "/lib/arm-linux-gnueabihf/libtinfo.so" + -- FixMe: What is the correct path? + Flatpak.AArch64 -> "/lib/arm???-linux-gnueabihf/libtinfo.so" + + +projectMain :: Flatpak.Cabal -> (String, [Flatpak.Source]) +projectMain project = + (Flatpak.mainPackage project, Flatpak.mainSources project) + +matchName :: String -> Plan.Unit -> Bool +matchName expected unit = + case Plan.uPId unit of + Plan.PkgId (Plan.PkgName name) _version -> expected == Text.unpack name + + +type Options = ([String], [String]) + +projectOptions :: Flatpak.Cabal -> Options +projectOptions project = + (Flatpak.cabalConfigureOptions project, Flatpak.ghcOptions project) + + +ghcPkgCleanup :: Plan.PlanJson -> Flatpak.Arch -> [String] +ghcPkgCleanup plan arch = + let archLinux = + archGHC arch ++ "-linux-" ++ + Text.unpack (Plan.dispPkgId (Plan.pjCompilerId plan)) + in map (++ archLinux) $ + "/lib/" : + "/share/doc/" : + [] + +ghcCleanup :: Plan.PlanJson -> [String] +ghcCleanup plan = + let (Plan.PkgId _ ghcVer) = Plan.pjCompilerId plan + withVersion prg = prg ++ "-" ++ formatVersion ghcVer + in map ("/" ++) $ + concat [ + map ("bin/" ++) $ + "ghc" : withVersion "ghc" : + "ghc-pkg" : withVersion "ghc-pkg" : + "ghci" : withVersion "ghci" : + "haddock" : withVersion "haddock-ghc" : + "runghc" : withVersion "runghc" : + "runhaskell" : + "hp2ps" : + "hpc" : + "hsc2hs" : + [], + map ("lib/" ++) $ + "libtinfo.so.5" : + "debug" : + withVersion "ghc" : + [], + map ("share/" ++) $ + "man" : + ("doc/" ++ withVersion "ghc") : + [] + ] + +-- | Generate the module to download, compile and install GHC. +ghcModule :: Plan.PlanJson -> Flatpak.Arch -> Plan.Sha256 -> Flatpak.Module +ghcModule plan arch hash = + let compiler = Plan.pjCompilerId plan + in Flatpak.Module { + Flatpak.name = + Text.unpack (Plan.dispPkgId compiler) ++ + "-" ++ Flatpak.archString arch, + Flatpak.onlyArches = [arch], + Flatpak.buildsystem = "simple", + Flatpak.builddir = False, + Flatpak.configOpts = [], + Flatpak.buildCommands = + "mkdir -p /app/lib" : + printf "ln -s %s /app/lib/libtinfo.so.5" (tinfoPath arch) : + "./configure --prefix=/app" : + "make install" : + [], + Flatpak.postInstall = [], + Flatpak.cleanupModule = ghcCleanup plan, + Flatpak.sources = + [Flatpak.Source { + Flatpak.typ = Flatpak.archive, + Flatpak.url = ghcDirUrl compiler ++ ghcArchive compiler arch, + Flatpak.sha256 = Just hash + }] + } + +packageURLs :: Plan.Unit -> (String, String) +packageURLs pkg = + let pkgId@(Plan.PkgId (Plan.PkgName name) _version) = Plan.uPId pkg + pkgName = Text.unpack name + pkgNameVer = Text.unpack $ Plan.dispPkgId pkgId + in (printf "https://hackage.haskell.org/package/%s/%s.tar.gz" + pkgNameVer pkgNameVer, + printf "https://hackage.haskell.org/package/%s/%s.cabal" + pkgNameVer pkgName) + +packageSources :: + (String, [Flatpak.Source]) -> Flatpak.SourceType -> + Plan.Unit -> [Flatpak.Source] +packageSources (mainPkg, mainSrcs) typ pkg = + let (pkgUrl, cabalUrl) = packageURLs pkg + in if' (matchName mainPkg pkg) mainSrcs $ + Flatpak.Source { + Flatpak.typ = typ, + Flatpak.url = pkgUrl, + Flatpak.sha256 = Plan.uSha256 pkg + } : + Flatpak.Source { + Flatpak.typ = Flatpak.File, + Flatpak.url = cabalUrl, + Flatpak.sha256 = Plan.uCabalSha256 pkg + } : + [] + +ghcOption :: String -> String +ghcOption opt = "--ghc-option=" ++ Quote.minimal opt + +{- | +Generate a module to download, build and install a package from Hackage. +Due to the Cabal package "revision" not being part of a package, +we have to download the package, +extract and then overwrite the .cabal file with the latest revision. +-} +modul :: + (String, [Flatpak.Source]) -> Options -> Map String Flatpak.PackageHook -> + Plan.Unit -> Flatpak.Module +modul main (cabalCfgOptions, ghcOptions) hookMap pkg = + let (Plan.PkgId (Plan.PkgName name) _version) = Plan.uPId pkg + nameStr = Text.unpack name + in Flatpak.Module { + Flatpak.name = nameStr, + Flatpak.onlyArches = [], + Flatpak.buildsystem = "simple", + Flatpak.builddir = False, + Flatpak.configOpts = [], + Flatpak.buildCommands = + "echo '#! /usr/bin/env runhaskell' >Setup.txt" : + "echo '> import Distribution.Simple' >>Setup.txt" : + "echo '> main = defaultMain' >>Setup.txt" : + "ln -s Setup.txt Setup.lhs || true" : + unwords ("runhaskell Setup configure --prefix=/app" : + cabalCfgOptions) : + unwords ("runhaskell Setup build" : map ghcOption ghcOptions) : + "runhaskell Setup install" : + [], + Flatpak.postInstall = + foldMap Flatpak.postInstallHook $ Map.lookup nameStr hookMap, + Flatpak.cleanupModule = [], + Flatpak.sources = packageSources main Flatpak.archive pkg + } + +manifest :: + Plan.PlanJson -> + [(Flatpak.Arch, Plan.Sha256)] -> [Plan.Unit] -> Flatpak.Cabal -> Flatpak.T +manifest plan archs units project = + let base = Flatpak.base project + hookMap = + Map.fromList $ map (\hook -> (Flatpak.nameHook hook, hook)) $ + Flatpak.packageHooks project + in + base { + Flatpak.cleanup = + concatMap (ghcPkgCleanup plan . fst) archs ++ Flatpak.cleanup base, + Flatpak.modules = + map (ModuleEmbed . uncurry (ghcModule plan)) archs ++ + Flatpak.modules base ++ + map + (ModuleEmbed . + modul (projectMain project) (projectOptions project) hookMap) + units + } + + + +cabalHash :: Flatpak.Arch -> Maybe String +cabalHash arch = + case arch of + Flatpak.I386 -> Just $ + "b2da736cc27609442b10f77fc1a687aba603a7a33045b722dbf1a0066fade198" + Flatpak.X86_64 -> Just $ + "6136c189ffccaa39916f9cb5788f757166444a2d0c473b987856a79ecbf0c714" + _ -> Nothing + +cabalInstallModule :: Flatpak.Arch -> Flatpak.Module +cabalInstallModule arch = + let cabalVerName = "cabal-install-2.4.1.0" + url = + printf + "https://downloads.haskell.org/cabal/%s/%s-%s-unknown-linux.tar.xz" + cabalVerName cabalVerName (archGHC arch) + in Flatpak.Module { + Flatpak.name = cabalVerName ++ "-" ++ Flatpak.archString arch, + Flatpak.onlyArches = [arch], + Flatpak.buildsystem = "simple", + Flatpak.builddir = False, + Flatpak.configOpts = [], + Flatpak.buildCommands = ["install cabal /app/bin"], + Flatpak.postInstall = [], + Flatpak.cleanupModule = ["/bin/cabal"], + Flatpak.sources = + [Flatpak.Source { + Flatpak.typ = + Flatpak.Archive {Flatpak.stripComponents = 0}, + Flatpak.url = url, + Flatpak.sha256 = Plan.parseSha256 . Text.pack =<< cabalHash arch + }] + } + +allInOneModule :: + (String, [Flatpak.Source]) -> Options -> [String] -> + [Plan.Unit] -> Flatpak.Module +allInOneModule main (cabalCfgOptions, ghcOptions) postInstall pkgs = + let dispPkgId = Text.unpack . Plan.dispPkgId + in Flatpak.Module { + Flatpak.name = "haskell-parts", + Flatpak.onlyArches = [], + Flatpak.buildsystem = "simple", + Flatpak.builddir = False, + Flatpak.configOpts = [], + Flatpak.buildCommands = + (flip concatMap pkgs $ \pkg -> + let pkgId@(Plan.PkgId (Plan.PkgName name) _version) = + Plan.uPId pkg + pkgName = Text.unpack name + pkgVerName = dispPkgId pkgId + in printf "gunzip %s.tar.gz" pkgVerName : + printf "mkdir %s" pkgVerName : + printf "mv %s.cabal %s/" pkgName pkgVerName : + printf "tar rf %s.tar %s/%s.cabal" + pkgVerName pkgVerName pkgName : + printf "gzip %s.tar" pkgVerName : + []) ++ + "mkdir .cabal" : + "touch .cabal/config" : + unwords + ("cabal --config-file=.cabal/config install" : + "--offline --prefix=/app" : + cabalCfgOptions ++ map ghcOption ghcOptions ++ + map (printf "%s.tar.gz" . dispPkgId . Plan.uPId) pkgs) : + [], + Flatpak.postInstall = postInstall, + Flatpak.cleanupModule = [], + Flatpak.sources = concatMap (packageSources main Flatpak.File) pkgs + } + +manifestCabalInstall :: + Plan.PlanJson -> + [(Flatpak.Arch, Plan.Sha256)] -> [Plan.Unit] -> Flatpak.Cabal -> Flatpak.T +manifestCabalInstall plan archs pkgs project = + let base = Flatpak.base project in + base { + Flatpak.cleanup = + concatMap (ghcPkgCleanup plan . fst) archs ++ Flatpak.cleanup base, + Flatpak.modules = + (map ModuleEmbed $ + concatMap + (\(arch,ghcHash) -> + [ghcModule plan arch ghcHash, cabalInstallModule arch]) + archs) ++ + Flatpak.modules base ++ + (ModuleEmbed $ + allInOneModule (projectMain project) (projectOptions project) + (concatMap Flatpak.postInstallHook $ Flatpak.packageHooks project) + pkgs) : + [] + } diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,142 @@ +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 diff --git a/src/Option.hs b/src/Option.hs new file mode 100644 --- /dev/null +++ b/src/Option.hs @@ -0,0 +1,67 @@ +module Option where + +import qualified Flatpak + +import qualified System.Path.PartClass as PathC +import qualified System.Path as Path + +import qualified Shell.Utility.ParseArgument as ParseArg +import qualified Options.Applicative as OP +import Options.Applicative (help, metavar, argument, option, long, value, flag) + +import Control.Applicative (pure, (<*>)) + +import Data.Monoid ((<>)) + + +data T = + Cons { + cabalInstall :: Bool, + archs :: [Flatpak.Arch], + projectDir :: Maybe Path.AbsRelDir, + input, output :: Path.AbsRelFile + } deriving (Show) + + +path :: (PathC.FileDir fd) => OP.ReadM (Path.AbsRel fd) +path = OP.eitherReader Path.parse + +arch :: OP.ReadM Flatpak.Arch +arch = + OP.eitherReader $ \str -> + maybe (Left $ "unknown architecture: " ++ str) Right $ + ParseArg.enumMaybe Flatpak.archString str + + +parseFlags :: OP.Parser T +parseFlags = + pure Cons + <*> flag False True + (long "cabal-install" + <> help "Build with one cabal-install (default: build module-wise using Cabal)") + <*> OP.many + (option arch + (metavar "ARCH" + <> long "arch" + <> help "Architecture to build for")) + <*> option (fmap Just path) + (metavar "DIR" + <> value Nothing + <> long "directory" + <> help "Cabal package directory (default: PWD)") + <*> argument path + (metavar "INPUT" + <> help "base FlatPak manifest") + <*> argument path + (metavar "OUTPUT" + <> help "full FlatPak manifest to generate") + + +desc :: OP.InfoMod a +desc = + OP.fullDesc + <> + OP.progDesc "Generate a FlatPak manifest from a Cabal package description" + +info :: OP.ParserInfo T +info = OP.info (OP.helper <*> parseFlags) desc