Disk.hs

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