haskus-system-build (empty) → 0.7.0.0
raw patch · 15 files changed
+1385/−0 lines, 15 filesdep +basedep +directorydep +filepathsetup-changed
Dependencies added: base, directory, filepath, hashable, haskus-utils, optparse-applicative, optparse-simple, process, simple-download, temporary, text, yaml
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- haskus-system-build.cabal +51/−0
- src/apps/Haskus/Apps/System/Build/CmdLine.hs +87/−0
- src/apps/Haskus/Apps/System/Build/Config.hs +177/−0
- src/apps/Haskus/Apps/System/Build/Disk.hs +93/−0
- src/apps/Haskus/Apps/System/Build/GMP.hs +58/−0
- src/apps/Haskus/Apps/System/Build/ISO.hs +49/−0
- src/apps/Haskus/Apps/System/Build/Linux.hs +181/−0
- src/apps/Haskus/Apps/System/Build/Main.hs +214/−0
- src/apps/Haskus/Apps/System/Build/QEMU.hs +76/−0
- src/apps/Haskus/Apps/System/Build/Ramdisk.hs +55/−0
- src/apps/Haskus/Apps/System/Build/Stack.hs +54/−0
- src/apps/Haskus/Apps/System/Build/Syslinux.hs +135/−0
- src/apps/Haskus/Apps/System/Build/Utils.hs +126/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2013-2017, Haskus organization+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.++ * Neither the name of Sylvain Henry nor the names of other contributors + may 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 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskus-system-build.cabal view
@@ -0,0 +1,51 @@+name: haskus-system-build+version: 0.7.0.0+synopsis: Haskus system build tool+license: BSD3+license-file: LICENSE+author: Sylvain Henry+maintainer: sylvain@haskus.fr+homepage: http://www.haskus.org/system+copyright: Sylvain Henry 2017+category: System+build-type: Simple+cabal-version: >=1.20++description:+ Build tool to use with haskus-system.++source-repository head+ type: git+ location: git://github.com/haskus/haskus-system-build.git++executable haskus-system-build+ main-is: Haskus/Apps/System/Build/Main.hs+ hs-source-dirs: src/apps+ other-modules:+ Haskus.Apps.System.Build.Config+ Haskus.Apps.System.Build.Linux+ Haskus.Apps.System.Build.Ramdisk+ Haskus.Apps.System.Build.Syslinux+ Haskus.Apps.System.Build.Stack+ Haskus.Apps.System.Build.CmdLine+ Haskus.Apps.System.Build.Utils+ Haskus.Apps.System.Build.GMP+ Haskus.Apps.System.Build.QEMU+ Haskus.Apps.System.Build.ISO+ Haskus.Apps.System.Build.Disk+ build-depends:+ base >= 4.9 && < 4.10+ , process >= 1.4 && < 1.5+ , yaml >= 0.8 && < 0.9+ , text >= 1.2 && < 1.3+ , haskus-utils >= 0.7 && < 0.8+ , optparse-simple >= 0.0 && < 0.1+ , optparse-applicative >= 0.13 && < 0.14+ , temporary >= 1.2 && < 1.3+ , directory >= 1.2 && < 1.4+ , simple-download >= 0.0 && < 0.1+ , filepath >= 1.4 && < 1.5+ , hashable >= 1.2 && < 1.3++ default-language: Haskell2010+ ghc-options: -Wall -threaded
+ src/apps/Haskus/Apps/System/Build/CmdLine.hs view
@@ -0,0 +1,87 @@+module Haskus.Apps.System.Build.CmdLine+ ( InitOptions(..)+ , BuildOptions (..)+ , TestOptions (..)+ , MakeDiskOptions (..)+ , MakeDeviceOptions (..)+ , initOptions+ , buildOptions+ , testOptions+ , makeDiskOptions+ , makeDeviceOptions+ )+where++import Options.Applicative+import Data.Monoid++data InitOptions = InitOptions+ { initOptTemplate :: String+ }++initOptions :: Parser InitOptions+initOptions =+ InitOptions+ <$> strOption+ ( long "template"+ <> short 't'+ <> metavar "TEMPLATE"+ <> value "default"+ <> help "Template to use"+ )++data TestOptions = TestOptions+ { testOptInit :: String+ }++testOptions :: Parser TestOptions+testOptions =+ TestOptions+ <$> strOption+ ( long "init"+ <> metavar "INIT-PROGRAM"+ <> value ""+ <> help "Init program to use"+ )++data BuildOptions = BuildOptions+ { buildOptInit :: String+ }++buildOptions :: Parser BuildOptions+buildOptions =+ BuildOptions+ <$> strOption+ ( long "init"+ <> metavar "INIT-PROGRAM"+ <> value ""+ <> help "Init program to use"+ )++data MakeDiskOptions = MakeDiskOptions+ { diskOptPath :: String+ }++makeDiskOptions :: Parser MakeDiskOptions+makeDiskOptions =+ MakeDiskOptions+ <$> strOption+ ( long "output"+ <> short 'o'+ <> metavar "OUTPUT-DIRECTORY"+ <> help "Output disk directory"+ )++data MakeDeviceOptions = MakeDeviceOptions+ { deviceOptPath :: String+ }++makeDeviceOptions :: Parser MakeDeviceOptions+makeDeviceOptions =+ MakeDeviceOptions+ <$> strOption+ ( long "device"+ <> short 'd'+ <> metavar "DEVICE"+ <> help "Device path"+ )
+ src/apps/Haskus/Apps/System/Build/Config.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}++module Haskus.Apps.System.Build.Config+ ( readSystemConfig+ , SystemConfig (..)+ , LinuxConfig (..)+ , linuxConfigHash+ , linuxConfigVersion+ , LinuxSource (..)+ , LinuxOptions (..)+ , SyslinuxConfig (..)+ , syslinuxConfigHash+ , RamdiskConfig (..)+ , QEMUConfig (..)+ )+where++import Data.Yaml as Yaml+import Data.Text (Text)+import Data.Hashable+import GHC.Generics++-- | System configuration+data SystemConfig = SystemConfig+ { linuxConfig :: LinuxConfig -- ^ Linux configuration+ , syslinuxConfig :: SyslinuxConfig -- ^ Syslinux configuration+ , ramdiskConfig :: RamdiskConfig -- ^ Ramdisk configuration+ , qemuConfig :: QEMUConfig -- ^ QEMU configuration+ }+ deriving (Show)++instance FromJSON SystemConfig where+ parseJSON (Yaml.Object v) =+ SystemConfig+ <$> (v .: "linux")+ <*> (v .:? "syslinux" .!= defaultSyslinuxConfig)+ <*> (v .: "ramdisk")+ <*> (v .:? "qemu" .!= defaultQEMUConfig)++ parseJSON _ = fail "Invalid config file"++readSystemConfig :: FilePath -> IO (Maybe SystemConfig)+readSystemConfig = Yaml.decodeFile++-------------------------------------------------------------+-- Linux+-------------------------------------------------------------+++-- | Linux source+data LinuxSource+ = LinuxTarball Text -- ^ Linux x.y.z from kernel.org tarballs+ | LinuxGit Text Text -- ^ repository/commit hash+ deriving (Show,Generic,Hashable)++data LinuxOptions = LinuxOptions+ { enableOptions :: [Text]+ , disableOptions :: [Text]+ , moduleOptions :: [Text]+ }+ deriving (Show,Generic,Hashable)++-- | Linux configuration+data LinuxConfig = LinuxConfig+ { linuxSource :: LinuxSource -- ^ How to retrieve Linux+ , linuxOptions :: LinuxOptions -- ^ Configuration options+ , linuxMakeArgs :: Text -- ^ Make arguments+ }+ deriving (Show,Generic,Hashable)++-- | Hash Linux config+linuxConfigHash :: LinuxConfig -> Int+linuxConfigHash = hash++-- | Linux version+linuxConfigVersion :: LinuxConfig -> Text+linuxConfigVersion config = case linuxSource config of+ LinuxTarball t -> t+ LinuxGit {} -> "git"++instance FromJSON LinuxConfig where+ parseJSON (Yaml.Object v) = do+ src <- parseSource <$> (v .:? "source" .!= "tarball")+ options <- parseOptions <$> (v .:? "options")+ LinuxConfig+ <$> src+ <*> options+ <*> (v .:? "make-args" .!= "-j8")+ where+ parseSource :: Text -> Parser LinuxSource+ parseSource s = case s of+ "tarball" -> LinuxTarball <$> v .: "version"+ "git" -> LinuxGit <$> v .: "repository" <*> v .: "commit"+ r -> fail $ "Invalid Linux source: " ++ show r++ parseOptions :: Maybe Yaml.Value -> Parser LinuxOptions+ parseOptions s = case s of+ Nothing -> pure (LinuxOptions [] [] [])+ Just (Yaml.Object opt) ->+ LinuxOptions+ <$> (opt .:? "enable" .!= [])+ <*> (opt .:? "disable" .!= [])+ <*> (opt .:? "module" .!= [])+ Just _ -> fail "Invalid Linux options"++ + parseJSON _ = fail "Invalid Linux configuration"++-------------------------------------------------------------+-- Syslinux+-------------------------------------------------------------++-- | Syslinux configuration+data SyslinuxConfig = SyslinuxConfig+ { syslinuxVersion :: Text -- ^ Syslinux version+ }+ deriving (Show,Generic,Hashable)++-- | Hash Syslinux config+syslinuxConfigHash :: SyslinuxConfig -> Int+syslinuxConfigHash = hash++-- | Default Syslinux configuration+defaultSyslinuxConfig :: SyslinuxConfig+defaultSyslinuxConfig = SyslinuxConfig "6.03"++instance FromJSON SyslinuxConfig where+ parseJSON (Yaml.Object v) =+ SyslinuxConfig+ <$> (v .:? "version" .!= "6.03")++ parseJSON _ = fail "Invalid Syslinux configuration"+++-------------------------------------------------------------+-- Ramdisk+-------------------------------------------------------------++-- | Ramdisk configuration+data RamdiskConfig = RamdiskConfig+ { ramdiskInit :: Text -- ^ Init program+ }+ deriving (Show)++instance FromJSON RamdiskConfig where+ parseJSON (Yaml.Object v) = do+ RamdiskConfig+ <$> v .: "init"++ parseJSON _ = fail "Invalid Ramdisk configuration"++-------------------------------------------------------------+-- QEMU+-------------------------------------------------------------++-- | QEMU configuration+data QEMUConfig = QEMUConfig+ { qemuProfile :: Text -- ^ QEMU profile+ , qemuOptions :: Text -- ^ QEMU additional options+ , qemuKernelArgs :: Text -- ^ kernel args (-append)+ }+ deriving (Show)++defaultQEMUConfig :: QEMUConfig+defaultQEMUConfig = QEMUConfig "default" "" ""++instance FromJSON QEMUConfig where+ parseJSON (Yaml.Object v) = do+ QEMUConfig+ <$> v .: "profile" .!= "default"+ <*> v .:? "options" .!= ""+ <*> v .:? "kernel-args" .!= ""++ parseJSON _ = fail "Invalid QEMU configuration"+
+ src/apps/Haskus/Apps/System/Build/Disk.hs view
@@ -0,0 +1,93 @@+module Haskus.Apps.System.Build.Disk+ ( withDisk+ , makeDisk+ , makeDevice+ )+where++import Haskus.Apps.System.Build.Config+import Haskus.Apps.System.Build.Utils+import Haskus.Apps.System.Build.Ramdisk+import Haskus.Apps.System.Build.Linux+import Haskus.Apps.System.Build.Syslinux++import System.IO.Temp+import System.FilePath+import System.Directory+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Control.Exception (finally)+++-- | Create a temp directory containing the system and call the callback+withDisk :: SystemConfig -> (FilePath -> IO a) -> IO a+withDisk config callback = do++ withSystemTempDirectory "haskus-system-build" $ \tmpfp -> do+ -- create the disk+ makeDisk config tmpfp++ -- call the callback+ callback tmpfp++-- | Mount a device and install a system in it+makeDevice :: SystemConfig -> FilePath -> IO ()+makeDevice config dev = do+ -- TODO: allow the selection of another boot partition+ -- TODO: ensure that the partition is bootable+ -- TODO: check filesystem + let dev' = dev ++ "1"+ showStep $ "Installing in partition " ++ dev' ++"..."+ withDisk config $ \disk -> do+ withSystemTempDirectory "haskus-system-build" $ \tmpfp -> do+ shellWaitErr ("sudo mount "++dev'++" "++tmpfp++" -o rw")+ $ failWith "Unable to mount device"+ (do+ shellWaitErr ("sudo cp -r " ++ disk ++"/* "++tmpfp)+ (failWith "Cannot copy files on the mounted device")+ syslinuxInstall (syslinuxConfig config) dev tmpfp+ ) `finally`+ shellWaitErr ("sudo umount "++tmpfp)+ (failWith "Unable to umount device")+ +++-- | Create a disk in the given folder+makeDisk :: SystemConfig -> FilePath -> IO ()+makeDisk config tmpfp = do+ showStep "Creating system disk..."++ -- create directories+ let syslinuxfp = tmpfp </> "boot" </> "syslinux"+ createDirectoryIfMissing True syslinuxfp++ -- copy Syslinux+ syslinuxPath <- syslinuxMain (syslinuxConfig config)+ -- copy *.c32 files+ copyDirectory (syslinuxPath </> "bios") syslinuxfp True+ (return . (== ".c32") . takeExtension)+ -- copy isolinux.bin+ copyFile (syslinuxPath </> "bios" </> "core" </> "isolinux.bin")+ (syslinuxfp </> "isolinux.bin")++ -- copy linux+ srcLinuxFile <- linuxKernelFile (linuxConfig config)+ let+ kernelPath = "boot" </> takeFileName srcLinuxFile+ linuxFile = tmpfp </> kernelPath+ copyFile srcLinuxFile linuxFile++ -- copy the ramdisk+ srcRamdiskFile <- ramdiskGetPath (ramdiskConfig config)+ let+ ramdiskPath = "boot" </> takeFileName srcRamdiskFile+ ramdiskFile = tmpfp </> ramdiskPath+ copyFile srcRamdiskFile ramdiskFile++ -- configure Syslinux+ let + cfg = syslinuxConfigFile config (Text.pack kernelPath)+ (Text.pack ramdiskPath)+ cfgPath = syslinuxfp </> "syslinux.cfg"+ Text.writeFile cfgPath cfg+
+ src/apps/Haskus/Apps/System/Build/GMP.hs view
@@ -0,0 +1,58 @@+module Haskus.Apps.System.Build.GMP+ ( gmpMain+ )+where++import Haskus.Apps.System.Build.Utils+import Haskus.Utils.Flow++import System.IO.Temp+import System.Directory+import System.FilePath++gmpMain :: IO ()+gmpMain = do++ appDir <- getAppDir+ let+ usrDir = appDir </> "usr"+ gmpVer = "6.1.2"+ libFile = usrDir </> "lib" </> "libgmp.a"+ ++ createDirectoryIfMissing True usrDir++ unlessM (doesFileExist libFile) $ do++ withSystemTempDirectory "haskus-system-build" $ \fp -> do++ showStep $ "Downloading libgmp " ++ gmpVer ++"..."+ let fp2 = fp </> "gmp.tar.lz"+ download+ ("https://gmplib.org/download/gmp/gmp-"++gmpVer++".tar.lz")+ fp2++ showStep "Unpacking libgmp..."+ untar fp2 fp++ let fp3 = fp </> ("gmp-"++gmpVer)++ showStep "Configuring libgmp..."+ shellInErr fp3 ("./configure --prefix=" ++ usrDir)+ $ failWith "Cannot configure libgmp"++ showStep "Building libgmp..."+ shellInErr fp3 "make -j8"+ $ failWith "Cannot build libgmp"++ showStep "Installing libgmp..."+ shellInErr fp3 "make install"+ $ failWith "Cannot install libgmp"++ workDir <- getWorkDir+ let libDir = workDir </> "lib"+ createDirectoryIfMissing True libDir++ unlessM (doesFileExist (libDir </> "libgmp.a")) $ do+ showStep "Copying libgmp.a into .system-work"+ copyFile libFile (libDir </> "libgmp.a")
+ src/apps/Haskus/Apps/System/Build/ISO.hs view
@@ -0,0 +1,49 @@+module Haskus.Apps.System.Build.ISO+ ( isoMake+ )+where++import Haskus.Apps.System.Build.Config+import Haskus.Apps.System.Build.Utils+import Haskus.Apps.System.Build.Disk+import Haskus.Apps.System.Build.Syslinux++import System.FilePath+import System.Directory+import qualified Data.Text as Text+import qualified Data.List as List+++isoMake :: SystemConfig -> IO FilePath+isoMake config = do+ + wd <- getWorkDir+ let+ isoPath = wd </> "iso"+ isoFile = isoPath </> Text.unpack (ramdiskInit (ramdiskConfig config)) <.> "iso"++ -- get hybrid MBR file path+ syslinuxpath <- syslinuxMain (syslinuxConfig config)+ let mbrfile = syslinuxpath </> "bios" </> "mbr" </> "isohdpfx_c.bin"++ createDirectoryIfMissing True isoPath++ withDisk config $ \fp -> do+ showStep "Building ISO image..."+ shellWaitErr+ (mconcat $ List.intersperse " "+ [ "xorriso -as mkisofs"+ , "-R -J" -- use rock-ridge/joliet extensions+ , "-o ", isoFile+ , "-c boot/syslinux/boot.cat" -- create boot catalog+ , "-b boot/syslinux/isolinux.bin" -- bootable binary file+ , "-no-emul-boot" -- don't use legacy floppy emulation+ , "-boot-info-table" -- write additional boot info table + -- (required by Sylinux)+ , "-boot-load-size 4"+ , "-isohybrid-mbr", mbrfile+ , fp+ ])+ (failWith "Unable to create ISO image")+ putStrLn $ "ISO image: " ++ isoFile+ return isoFile
+ src/apps/Haskus/Apps/System/Build/Linux.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE LambdaCase #-}++module Haskus.Apps.System.Build.Linux+ ( linuxMain+ , linuxBuild+ , linuxKernelFile+ , linuxDownloadTarball+ , linuxCheckTarball+ , linuxMakeTarballName+ , linuxMakeTarballPath+ )+where++import Data.Text (Text)+import qualified Data.Text as Text+import Control.Monad+import System.FilePath+import System.Directory+import System.IO.Temp+import Numeric (showHex)+import Data.Word++import Haskus.Apps.System.Build.Config+import Haskus.Apps.System.Build.Utils+import Haskus.Utils.Flow++linuxMain :: LinuxConfig -> IO ()+linuxMain config = do+ + case linuxSource config of+ LinuxGit {} -> do+ failWith "Building Linux from GIT is not supported for now"++ LinuxTarball version -> do+ tgtfp <- linuxMakeReleasePath config+ tgtker <- linuxKernelFile config+ let+ tgtmod = tgtfp </> "modules"+ tgtmod' = tgtfp </> "modules_tmp"+ tgtfw = tgtfp </> "firmwares"++ -- check if we already have the built kernel+ unlessM (doesFileExist tgtker) $ do++ -- check if we already have the tarball; otherwise download it+ linuxCheckTarball version >>= \case+ False -> do+ linuxDownloadTarball version+ -- re-check (for safety)+ linuxCheckTarball version >>= \case+ False -> failWith "Unable to download Linux sources"+ True -> return ()+ True -> return ()++ tarballPath <- linuxMakeTarballPath version++ withSystemTempDirectory "haskus-system-build" $ \fp -> do+ -- untar+ showStep "Unpacking Linux archive..."+ untar tarballPath fp+ let fp2 = fp </> ("linux-"++Text.unpack version)++ -- configure+ showStep "Configuring Linux..."+ linuxConfigure config fp2++ -- build+ showStep "Building Linux..."+ linuxBuild config fp2++ createDirectoryIfMissing True tgtmod'+ createDirectoryIfMissing True tgtfw++ -- copy the kernel, modules and firmwares+ showStep "Copying kernel..."+ copyFile (fp2 </> "arch" </> "x86" </> "boot" </> "bzImage") tgtker++ showStep "Copying modules..."+ shellInErr fp2 ("make modules_install INSTALL_MOD_PATH="++tgtmod') $+ failWith "Cannot copy Linux modules"+ renameDirectory+ (tgtmod' </> "lib" </> "modules" </> Text.unpack version)+ tgtmod+ removeDirectory (tgtmod' </> "lib" </> "modules")+ removeDirectory (tgtmod' </> "lib")+ removeDirectory tgtmod'+ removeFile (tgtmod </> "source")+ removeFile (tgtmod </> "build")++ showStep "Copying firmwares..."+ shellInErr fp2 ("make firmware_install INSTALL_FW_PATH="++tgtfw) $+ failWith "Cannot copy Linux firmwares"++ showStep "Copying .config file..."+ copyFile (fp2 </> ".config") (tgtfp </> ".config")+++-- | Build Linux tree in the given directory+linuxBuild :: LinuxConfig -> FilePath -> IO ()+linuxBuild config path = do+ let shell' = shellInErr path++ shell' ("make " ++ Text.unpack (linuxMakeArgs config))+ $ fail "Unable to build Linux"++-- | Configure Linux tree in the given directory+linuxConfigure :: LinuxConfig -> FilePath -> IO ()+linuxConfigure config path = do+ let shell' = shellInErr path++ -- make default configuration for the arch+ shell' "make x86_64_defconfig"+ $ fail "Unable to build Linux default configuration"++ -- enable/disable/module options+ let opts = linuxOptions config+ forM_ (enableOptions opts) $ \opt ->+ shell' ("./scripts/config -e "++ Text.unpack opt)+ $ fail $ "Unable to enable Linux option: " ++ Text.unpack opt+ forM_ (disableOptions opts) $ \opt ->+ shell' ("./scripts/config -d "++ Text.unpack opt)+ $ fail $ "Unable to disable Linux option: " ++ Text.unpack opt+ forM_ (moduleOptions opts) $ \opt ->+ shell' ("./scripts/config -m "++ Text.unpack opt)+ $ fail $ "Unable to modularize Linux option: " ++ Text.unpack opt++ -- fixup config+ shell' "make olddefconfig"+ $ fail "Unable to adjust Linux configuration"+++-- | Make Linux archive name+linuxMakeTarballName :: Text -> FilePath+linuxMakeTarballName version = "linux-"++Text.unpack version++".tar.xz"++-- | Make Linux archive path+linuxMakeTarballPath :: Text -> IO FilePath+linuxMakeTarballPath version = do+ p <- getDownloadPath+ return (p </> linuxMakeTarballName version)++-- | Make Linux release path+linuxMakeReleasePath :: LinuxConfig -> IO FilePath+linuxMakeReleasePath config = do+ p <- getAppDir+ let hash = showHex (fromIntegral (linuxConfigHash config) :: Word64) ""+ let d = p </> "linux" </> hash+ createDirectoryIfMissing True d+ return d++linuxKernelFile :: LinuxConfig -> IO FilePath+linuxKernelFile config = do+ rp <- linuxMakeReleasePath config+ return (rp </> "linux.bin")+++-- | Download a Linux tarball from kernel.org+linuxDownloadTarball :: Text -> IO ()+linuxDownloadTarball version = do+ let+ src = "https://cdn.kernel.org/pub/linux/kernel/v"+ ++ Text.unpack (head (Text.splitOn (Text.pack ".") version))+ ++ ".x/linux-"+ ++ Text.unpack version+ ++ ".tar.xz"+ + -- download+ showStep $ "Downloading Linux "++Text.unpack version++"..."+ tgtDir <- getDownloadPath+ download src (tgtDir </> linuxMakeTarballName version)++ -- check signature+ -- TODO++-- | Check if we already have a tarball+linuxCheckTarball :: Text -> IO Bool+linuxCheckTarball version = do+ tgtDir <- getDownloadPath+ doesFileExist (tgtDir </> linuxMakeTarballName version)++
+ src/apps/Haskus/Apps/System/Build/Main.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE LambdaCase #-}++import Haskus.Apps.System.Build.Config+import Haskus.Apps.System.Build.Linux+import Haskus.Apps.System.Build.Syslinux+import Haskus.Apps.System.Build.CmdLine+import Haskus.Apps.System.Build.Utils+import Haskus.Apps.System.Build.Ramdisk+import Haskus.Apps.System.Build.Stack+import Haskus.Apps.System.Build.GMP+import Haskus.Apps.System.Build.QEMU+import Haskus.Apps.System.Build.ISO+import Haskus.Apps.System.Build.Disk++import qualified Data.Text as Text+import Haskus.Utils.Flow+import Options.Applicative.Simple+import Paths_haskus_system_build+import Data.Version+import System.IO.Temp+import System.Directory+import System.FilePath+ ++main :: IO ()+main = do++ -- read command-line options+ (_,runCmd) <-+ simpleOptions (showVersion version)+ "haskus-system-build"+ "This tool lets you build systems using haskus-system framework. It manages Linux/Syslinux (download and build), it builds ramdisk, it launches QEMU, etc."+ (pure ()) $ do+ addCommand "init"+ "Create a new project from a template"+ initCommand+ initOptions+ addCommand "build"+ "Build a project"+ buildCommand+ buildOptions+ addCommand "test"+ "Test a project with QEMU"+ testCommand+ testOptions+ addCommand "make-iso"+ "Create an ISO image"+ (const makeISOCommand)+ (pure ())+ addCommand "test-iso"+ "Test an ISO image"+ (const testISOCommand)+ (pure ())+ addCommand "make-disk"+ "Create a disk directory"+ makeDiskCommand+ (makeDiskOptions)+ addCommand "make-device"+ "Create a bootable device (WARNING: IT ERASES IT). You must be in the sudoers list"+ makeDeviceCommand+ (makeDeviceOptions)+ runCmd++initCommand :: InitOptions -> IO ()+initCommand opts = do+ let+ template = initOptTemplate opts++ cd <- getCurrentDirectory++ withSystemTempDirectory "haskus-system-build" $ \fp -> do+ -- get latest templates+ showStep "Retrieving templates..."+ shellInErr fp "git clone --depth=1 https://github.com/haskus/haskus-system-templates.git" $+ failWith "Cannot retrieve templates. Check that `git` is installed and that github is reachable using https."++ let fp2 = fp </> "haskus-system-templates"+ dirs <- listDirectory fp2+ unless (any (== template) dirs) $+ failWith $ "Cannot find template \"" ++ template ++"\""++ -- copy template+ showStep $ "Copying \"" ++ template ++ "\" template..."+ shellInErr fp2+ ("cp -i -r ./" ++ template ++ "/* " ++ cd) $+ failWith "Cannot copy the selected template"++readConfig :: IO SystemConfig+readConfig = do+ let configFile = "system.yaml"+ + unlessM (doesFileExist configFile) $+ failWith $ "Cannot find \"" ++ configFile ++ "\""++ mconfig <- readSystemConfig configFile++ case mconfig of+ Nothing -> failWith $ "Cannot parse \"" ++ configFile ++ "\""+ Just c -> return c++buildCommand :: BuildOptions -> IO ()+buildCommand opts = do+ config' <- readConfig++ -- override config+ let config = if buildOptInit opts /= ""+ -- TODO: use lenses+ then config'+ { ramdiskConfig = (ramdiskConfig config')+ { ramdiskInit = Text.pack (buildOptInit opts)+ }+ }+ else config'++ showStatus config+ gmpMain+ linuxMain (linuxConfig config)+ _ <- syslinuxMain (syslinuxConfig config)+ stackBuild+++testCommand :: TestOptions -> IO ()+testCommand opts = do+ config' <- readConfig++ -- override config+ let config = if testOptInit opts /= ""+ -- TODO: use lenses+ then config'+ { ramdiskConfig = (ramdiskConfig config')+ { ramdiskInit = Text.pack (testOptInit opts)+ }+ }+ else config'++ showStatus config+ gmpMain+ linuxMain (linuxConfig config)+ stackBuild+ ramdiskMain (ramdiskConfig config)+ qemuExecRamdisk config++showStatus :: SystemConfig -> IO ()+showStatus config = do+ let linuxVersion' = Text.unpack (linuxConfigVersion (linuxConfig config))++ let syslinuxVersion' = config+ |> syslinuxConfig+ |> syslinuxVersion+ |> Text.unpack+ let initProgram = config+ |> ramdiskConfig+ |> ramdiskInit+ |> Text.unpack++ ghcVersion <- stackGetGHCVersion+ stackResolver <- stackGetResolver++ putStrLn "==================================================="+ putStrLn " Haskus system - build config"+ putStrLn "---------------------------------------------------"+ putStrLn ("GHC version: " ++ ghcVersion)+ putStrLn ("Stack resolver: " ++ stackResolver)+ putStrLn ("Linux version: " ++ linuxVersion')+ putStrLn ("Syslinux version: " ++ syslinuxVersion')+ putStrLn ("Init program: " ++ initProgram)+ putStrLn "==================================================="+++makeISOCommand :: IO ()+makeISOCommand = do+ config <- readConfig++ showStatus config+ gmpMain+ linuxMain (linuxConfig config)+ stackBuild+ ramdiskMain (ramdiskConfig config)+ _ <- isoMake config+ return ()++makeDiskCommand :: MakeDiskOptions -> IO ()+makeDiskCommand opts = do+ config <- readConfig++ showStatus config+ gmpMain+ linuxMain (linuxConfig config)+ stackBuild+ ramdiskMain (ramdiskConfig config)+ makeDisk config (diskOptPath opts)++testISOCommand :: IO ()+testISOCommand = do+ config <- readConfig++ showStatus config+ gmpMain+ linuxMain (linuxConfig config)+ stackBuild+ ramdiskMain (ramdiskConfig config)+ isoFile <- isoMake config+ qemuExecISO config isoFile++makeDeviceCommand :: MakeDeviceOptions -> IO ()+makeDeviceCommand opts = do+ config <- readConfig++ showStatus config+ gmpMain+ linuxMain (linuxConfig config)+ stackBuild+ ramdiskMain (ramdiskConfig config)+ makeDevice config (deviceOptPath opts)
+ src/apps/Haskus/Apps/System/Build/QEMU.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}++module Haskus.Apps.System.Build.QEMU+ ( qemuExecRamdisk+ , qemuExecISO+ , qemuGetProfileConfig+ , qemuExec+ )+where++import Haskus.Apps.System.Build.Config+import Haskus.Apps.System.Build.Utils+import Haskus.Apps.System.Build.Ramdisk+import Haskus.Apps.System.Build.Linux++import Data.List+import qualified Data.Text as Text++-- | Execute (ramdisk + kernel)+qemuExecRamdisk :: SystemConfig -> IO ()+qemuExecRamdisk config = do+ + (args,kargs) <- qemuGetProfileConfig (qemuConfig config)++ kernel <- linuxKernelFile (linuxConfig config)+ ramdisk <- ramdiskGetPath (ramdiskConfig config)+ let rdinit = Text.unpack (ramdiskInit (ramdiskConfig config))++ let kerRdArgs = concat $ intersperse " "+ [ "-kernel", kernel+ , "-initrd", ramdisk+ , "-append", ("\"rdinit=/" ++ rdinit ++ " " ++ kargs ++ "\"")+ ]++ qemuExec (args ++ " " ++ kerRdArgs)++-- | Execute ISO+qemuExecISO :: SystemConfig -> FilePath -> IO ()+qemuExecISO config isoPath = do+ + (args,kargs) <- qemuGetProfileConfig (qemuConfig config)++ let kerRdArgs = concat $ intersperse " "+ [ "-cdrom", isoPath+ , "-append", "\""++kargs++"\""+ ]++ qemuExec (args ++ " " ++ kerRdArgs)+++qemuExec :: String -> IO ()+qemuExec args = do+ let cmd = "qemu-system-x86_64 " ++ args++ showStep "Launching QEMU..."+ shellWaitErr cmd $ failWith "Cannot execute QEMU"+++qemuGetProfileConfig :: QEMUConfig -> IO (String,String)+qemuGetProfileConfig config =+ case qemuProfile config of+ "vanilla" -> return ("", "")+ "default" -> return $+ (concat $ intersperse " "+ [ "-enable-kvm"+ , "-machine q35"+ , "-soundhw hda"+ , "-serial stdio"+ , "-vga std"+ --, "-show-cursor"+ , "-usbdevice tablet"+ ]+ , "console=ttyS0 atkbd.softraw=0 quiet"+ )+ p -> failWith $ "Invalid QEMU profile: " ++ Text.unpack p+
+ src/apps/Haskus/Apps/System/Build/Ramdisk.hs view
@@ -0,0 +1,55 @@+module Haskus.Apps.System.Build.Ramdisk+ ( ramdiskMain+ , ramdiskGetPath+ , ramdiskInitPath+ )+where++import Haskus.Apps.System.Build.Config+import Haskus.Apps.System.Build.Utils+import Haskus.Apps.System.Build.Stack++import System.IO.Temp+import System.FilePath+import System.Directory+import qualified Data.Text as Text+import Data.Text (Text)++ramdiskMain :: RamdiskConfig -> IO ()+ramdiskMain config = do+ rd <- ramdiskGetPath config+ let+ rdinit = Text.unpack (ramdiskInitPath config)++ binfp <- stackGetBinPath rdinit++ withSystemTempDirectory "haskus-system-build" $ \tmpfp -> do+ showStep "Building ramdisk..."+ let rdfile = tmpfp </> rdinit++ -- create directories+ createDirectoryIfMissing True (dropFileName rdfile)++ -- copy ramdisk files+ copyFile binfp (tmpfp </> rdinit)++ -- create ramdisk+ -- TODO: use our own `cpio` and `gzip`+ shellInErr tmpfp+ ("(find . | cpio -o -H newc | gzip) > " ++ rd)+ $ failWith "Cannot build ramdisk"+++-- | Get ramdisk+ramdiskGetPath :: RamdiskConfig -> IO FilePath+ramdiskGetPath config = do+ workDir <- getWorkDir+ let rdDir = workDir </> "ramdisk"+ createDirectoryIfMissing True rdDir+ return (rdDir </> Text.unpack (ramdiskInit config) <.> "img")++-- | Path of the init program in the ramdisk+-- TODO: add support for custom path+ramdiskInitPath :: RamdiskConfig -> Text+ramdiskInitPath config =+ ramdiskInit config
+ src/apps/Haskus/Apps/System/Build/Stack.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE LambdaCase #-}++module Haskus.Apps.System.Build.Stack+ ( stackGetBinPath+ , stackGetResolver+ , stackGetGHCVersion+ , stackBuild+ )+where++import System.Process+import System.FilePath+import Data.List++import Haskus.Apps.System.Build.Utils+import Haskus.Utils.Flow++-- | Get GHC version (using stack exec)+stackGetGHCVersion :: IO String+stackGetGHCVersion =+ -- FIXME+ last . words <$> readProcess "stack" ["exec", "--", "ghc", "--version"] ""++-- | Get stack resolver+stackGetResolver :: IO String+stackGetResolver =+ -- FIXME+ last . words . head . filter ("resolver:" `isPrefixOf`) . lines <$> readFile "stack.yaml"++stackGetBinPath :: FilePath -> IO FilePath+stackGetBinPath x = do+ -- read GHC version+ ghcVersion <- stackGetGHCVersion++ -- read stack resolver+ stackResolver <- stackGetResolver++ return $ ".stack-work/install/x86_64-linux"+ </> stackResolver+ </> ghcVersion+ </> "bin"+ </> x+++stackBuild :: IO ()+stackBuild = do+ showStep "Configuring Stack..."+ shellWaitErr "stack setup"+ <| failWith "Error during `stack setup`"++ showStep "Building with Stack..."+ shellWaitErr "stack build"+ <| failWith "Error during `stack build`"+
+ src/apps/Haskus/Apps/System/Build/Syslinux.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Haskus.Apps.System.Build.Syslinux+ ( syslinuxMain+ , syslinuxDownloadTarball+ , syslinuxCheckTarball+ , syslinuxMakeTarballName+ , syslinuxMakeTarballPath+ , syslinuxConfigFile+ , syslinuxInstall+ )+where++import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.List as List+import System.FilePath+import System.Directory+import System.IO.Temp++import Haskus.Apps.System.Build.Config+import Haskus.Apps.System.Build.Utils+import Haskus.Apps.System.Build.Ramdisk+import Haskus.Utils.Flow++-- | Download and unpack syslinux. Return its path.+syslinuxMain :: SyslinuxConfig -> IO FilePath+syslinuxMain config = do+ + p <- getAppDir+ let+ tgtfp = p </> "syslinux" </> Text.unpack (syslinuxVersion config)+ version = syslinuxVersion config++ -- check if we already have the built syslinux+ unlessM (doesDirectoryExist tgtfp) $ do++ -- check if we already have the tarball; otherwise download it+ syslinuxCheckTarball version >>= \case+ False -> do+ syslinuxDownloadTarball version+ -- re-check (for safety)+ syslinuxCheckTarball version >>= \case+ False -> failWith "Unable to download Syslinux"+ True -> return ()+ True -> return ()++ tarballPath <- syslinuxMakeTarballPath version++ -- use a temp directory close to the target one so that we can rename+ -- after unpacking+ let tmpfp = p </> "syslinux"+ createDirectoryIfMissing True tmpfp++ withTempDirectory tmpfp "download" $ \fp -> do+ -- untar+ showStep "Unpacking Syslinux archive..."+ untar tarballPath fp++ -- copy Syslinux files+ showStep "Copying Syslinux..."+ let fp2 = fp </> ("syslinux-"++Text.unpack version)+ renameDirectory fp2 tgtfp++ return tgtfp++-- | Make Syslinux archive name+syslinuxMakeTarballName :: Text -> FilePath+syslinuxMakeTarballName version = "syslinux-"++Text.unpack version++".tar.xz"++-- | Make Syslinux archive path+syslinuxMakeTarballPath :: Text -> IO FilePath+syslinuxMakeTarballPath version = do+ p <- getDownloadPath+ return (p </> syslinuxMakeTarballName version)++-- | Download Syslinux tarball from kernel.org+syslinuxDownloadTarball :: Text -> IO ()+syslinuxDownloadTarball version = do+ let+ src = "https://cdn.kernel.org/pub/linux/utils/boot/syslinux/"+ ++ syslinuxMakeTarballName version+ + -- download+ showStep $ "Downloading Syslinux "++Text.unpack version++"..."+ tgtDir <- getDownloadPath+ download src (tgtDir </> syslinuxMakeTarballName version)++ -- check signature+ -- TODO++-- | Check if we already have a tarball+syslinuxCheckTarball :: Text -> IO Bool+syslinuxCheckTarball version = do+ tgtDir <- getDownloadPath+ doesFileExist (tgtDir </> syslinuxMakeTarballName version)+++syslinuxConfigFile :: SystemConfig -> Text -> Text -> Text+syslinuxConfigFile config ker rd = mconcat $ List.intersperse "\n"+ [ "DEFAULT main"+ , "PROMPT 0"+ , "TIMEOUT 50"+ , "UI vesamenu.c32"+ , ""+ , "LABEL main"+ , "MENU LABEL " `Text.append` ramdiskInit (ramdiskConfig (config))+ , "LINUX /" `Text.append` ker+ , "INITRD /" `Text.append` rd+ , mconcat+ [ "APPEND rdinit=\""+ , ramdiskInitPath (ramdiskConfig config)+ , "\""+ -- TODO: support custom kernel-args+ ]+ ]+++syslinuxInstall :: SyslinuxConfig -> FilePath -> FilePath -> IO ()+syslinuxInstall config dev mntDir = do+ showStep $ "Installing Syslinux on "++dev++" device..."++ syslinuxPath <- syslinuxMain config+ let+ -- TODO: allow MBR selection+ -- TODO: support UEFI+ mbr = syslinuxPath </> "bios" </> "mbr" </> "mbr.bin"+ cmd = "sudo dd bs=440 if=" ++ mbr ++ " of=" ++ dev+ shellWaitErr cmd $ failWith "Error while copying the MBR"++ -- use syslinux installer+ let installer = syslinuxPath </> "bios" </> "extlinux" </> "extlinux"+ shellWaitErr ("sudo " ++ installer ++ " --install " ++ (mntDir </> "boot" </> "syslinux"))+ $ failWith "Error while installing Syslinux"
+ src/apps/Haskus/Apps/System/Build/Utils.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE LambdaCase #-}++module Haskus.Apps.System.Build.Utils+ ( shellWait+ , shellWaitErr+ , shellIn+ , shellInErr+ , untar+ , subTitle+ , showStep+ , failWith+ , download+ , getAppDir+ , getWorkDir+ , getDownloadPath+ , copyDirectory+ )+where++import System.Process+import System.Exit+import System.Directory+import System.FilePath+import System.IO.Temp+import qualified Network.HTTP.Client.Conduit.Download as D+import Haskus.Utils.Flow++-- | Execute a command+shellWait :: String -> IO ExitCode +shellWait cmd = do+ (_,_,_,hdl) <- createProcess (shell cmd)+ waitForProcess hdl++-- | Execute a command, call callback on error+shellWaitErr :: String -> IO () -> IO () +shellWaitErr cmd err = do+ shellWait cmd >>= \case+ ExitSuccess -> return ()+ ExitFailure _ -> err++-- | Execute a command in the given directory+shellIn :: FilePath -> String -> IO ExitCode +shellIn fp cmd = do+ (_,_,_,hdl) <- createProcess ((shell cmd) { cwd = Just fp })+ waitForProcess hdl+++-- | Execute a command in the given directory, call callback on error+shellInErr :: FilePath -> String -> IO () -> IO ()+shellInErr fp cmd err = do+ shellIn fp cmd >>= \case+ ExitSuccess -> return ()+ ExitFailure _ -> err++-- | Uncompress an archive+untar :: FilePath -> FilePath -> IO ()+untar src tgt = shellInErr tgt ("tar xf " ++ src) $+ failWith "Cannot uncompress archive"++-- | Add a subline to a text+subTitle :: String -> String+subTitle t = t ++ "\n" ++ replicate (length t) '-' ++ "\n"++-- | Show progress step+showStep :: String -> IO ()+showStep t = putStrLn $ "==> " ++ t++-- | Print error message+failWith :: String -> IO a+failWith s = die $ "Error: " ++ s++-- | Download a file+download :: String -> FilePath -> IO ()+download url tgt = do+ withSystemTempDirectory "haskus-system-build" $ \fp -> do+ let fp2 = fp </> "download.tmp"+ D.download url fp2+ copyFile fp2 tgt++-- | Return app directory+getAppDir :: IO FilePath+getAppDir = do+ fp <- getAppUserDataDirectory "haskus"+ let d = fp </> "system" </> "build"+ createDirectoryIfMissing True d+ return d++-- | Return work directory+getWorkDir :: IO FilePath+getWorkDir = do+ fp <- getCurrentDirectory+ let d = fp </> ".system-work"+ createDirectoryIfMissing True d+ return d++-- | Return download path+getDownloadPath :: IO FilePath+getDownloadPath = do+ fp <- getAppDir+ let d = fp </> "downloads"+ createDirectoryIfMissing True d+ return d++-- | Copy a directory (optionally keeping the structure). Use a predicate to filter+copyDirectory :: FilePath -> FilePath -> Bool -> (FilePath -> IO Bool) -> IO ()+copyDirectory src dst flattenDirs filt = go src+ where+ go currentDir = do+ fs <- listDirectory currentDir+ forM_ fs $ \f -> do+ let fileAbs = currentDir </> f+ isDir <- doesDirectoryExist fileAbs+ if isDir+ then go (currentDir </> f)+ else do+ -- filter+ whenM (filt fileAbs) $ do+ let+ fileRel = makeRelative src fileAbs+ dstAbs = if flattenDirs+ then dst </> takeFileName (fileAbs)+ else dst </> fileRel+ createDirectoryIfMissing True (dropFileName dstAbs)+ copyFile fileAbs dstAbs++