Syslinux.hs

{-# 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"