content: {-# LANGUAGE OverloadedStrings  #-}
  import System.Device.Memory
  import System.Device.ST
  import Control.Monad.ST (stToIO)
  import System.Device.BlockDevice
  import qualified Data.ByteString.Char8 as BS
  import qualified Data.ByteString.Lazy as BL
  import Hypervisor.Debug
  import Data.Word
  import XenDevice.Disk
  import Hypervisor.XenStore
  import Halfs.CoreAPI
  import Halfs.Types
  import Halfs.Classes
  import Halfs.Errors
  import Halfs.HalfsState
  import Halfs.MonadUtils
  import Halfs.Utils
  import Halfs.Monad
  import Halfs.SuperBlock (SuperBlock)
  import Control.Monad.Reader
  import System.FilePath
  import Control.Concurrent
  import Control.Exception
  import Control.Monad
  import Hypervisor.Console
  import Hypervisor.ErrorCodes
  import Control.Concurrent (threadDelay)
  import Prelude hiding (getLine)
  
  
  {- ST-based Block Device Test
  main :: IO ()
  main = do
      mbBlockDevice <- stToIO $ newSTBlockDevice 1024 512 -- Initialize a block device as ST
      case mbBlockDevice of
          Just device -> do
              bstring <- stToIO $ do
                  let wb = bdWriteBlock device
                  wb 512 "hello world"
                  bstring <- bdReadBlock device $ 512
                  return bstring
              writeDebugConsole $ "String here: " ++ (BS.unpack bstring)
          Nothing -> writeDebugConsole "device error"
  -}
  
  {- Memory-based Block Device Test
  main :: IO ()
  main = do
      mbBlockDevice <- newMemoryBlockDevice 1024 512 -- Initialize a block device as Memory
      case mbBlockDevice of
          Just device -> do
              let wb = bdWriteBlock device
              wb 512 "hello world"
              bstring <- bdReadBlock device $ 512
              writeDebugConsole $ "String here: " ++ (BS.unpack bstring)
          Nothing -> writeDebugConsole "device error"
  -}
  
  -- A Simple FS Shell with Disk Backend
  
  -- Implement the Device Interface
  newDiskBlockDevice :: Disk -> IO (Maybe (BlockDevice IO))
  newDiskBlockDevice disk = return $! Just BlockDevice {
          bdBlockSize  = fromIntegral $ diskSectorSize disk
        , bdNumBlocks  = fromIntegral $ diskSectors disk
        , bdReadBlock  = \sector -> do
              bl <- readDisk disk (fromIntegral $ diskSectorSize disk) (fromIntegral sector)
              return $ bLtoBS bl
        , bdWriteBlock = \sector bs -> writeDisk disk (bStoBL bs) $ fromIntegral sector
        , bdFlush      = return () -- `flushDiskCaches` is not actually usable
        , bdShutdown   = return () -- not found in XenDevice.Disk
        }
  
  bLtoBS :: BL.ByteString -> BS.ByteString
  bLtoBS = BS.concat . BL.toChunks
  bStoBL :: BS.ByteString -> BL.ByteString
  bStoBL bs = BL.fromChunks [bs]
  
  rwx = [Read, Write, Execute]
  defaultPerm = FileMode rwx rwx rwx
  
  main :: IO ()
  main = do
      xs <- initXenStore
      con <- initXenConsole
      diskNames <- listDisks xs
      threadDelay (1000000)
      writeDebugConsole $ "Disks Found: " ++ show diskNames ++ "\n"
      case diskNames of
        (diskName:_) -> do -- Use the first available disk
          disk <- openDisk xs diskName
          mdiskBD <- newDiskBlockDevice disk
          case mdiskBD of
            Just diskBD -> do
              fsState <- mountFS diskBD
  
              feedback <- runHalfs fsState $ do -- Create root and return
                mkdir "/" defaultPerm
                return "/"
              case feedback of
                Right fp -> repl xs con fp fsState
                Left err -> writeDebugConsole $ "Fail: " ++ show err ++ "\n"
  
              unmountInfo <- runHalfs fsState unmount
              case unmountInfo of
                Left err -> writeDebugConsole $ "Error in unmounting: " ++ show err
                Right () -> return ()
  
            Nothing -> writeDebugConsole "Error in initializing disk block device!"
        [] -> writeDebugConsole "No available disks!"
  
  mountFS :: (Monad m, HalfsCapable b t r l m) => BlockDevice m -> m (HalfsState b r l m)
  mountFS diskBD = execNoEnv $ mount diskBD 0 0 defaultPerm
  
  execNoEnv :: Monad m => HalfsM b r l m a -> m a
  execNoEnv act = do
    runHalfsNoEnv act >>= \ea -> case ea of
      Left e  -> fail $ show e
      Right x -> return x
  
  -- The REPL shell loop
  repl xs con here fsState = do
    me <- xsGetDomId xs
    writeConsole con ("Hello! This is an interactive Unix-like file-system shell for " ++
                      show me ++ "\n")
    writeConsole con ("Valid commands: quit, ls, cd, mkdir\n\n")
    writeDebugConsole "Starting interaction loop!\n"
    info <- runHalfs fsState $ loop con here
    return ()
  
  loop con here = do
    lift $ writeConsole con (here ++ "> ")
    inquery <- lift $ getLine con
    case words inquery of
      ("quit":_) -> return ()
      ("ls"  :_) -> do
        handle <- openDir here
        dirInfo <- readDir handle
        lift $ writeConsole con $ printDir dirInfo ++ "\n"
        loop con here
      ("cd"  :x:_) -> do
        case x of
          ".." -> loop con (takeDirectory here)
          d    -> do
            handle <- openDir here
            dirInfo <- readDir handle
            if (filter (== d) $ map fst dirInfo) /= [] then
              loop con (here </> d)
              else do
                   lift $ writeConsole con "No such directory\n"
                   loop con here
      ("mkdir":x:_) -> do
        if x /= ".." then mkdir (here </> x) defaultPerm
          else lift $ writeConsole con "Invalid directory name\n"
        loop con here
      _ -> do
        lift $ writeConsole con "Unrecognized command\n"
        loop con here
  
  getLine :: Console -> IO String
  getLine con = do
    nextC <- readConsole con 1
    writeConsole con nextC
    case nextC of
      "\r" -> writeConsole con "\n" >> return ""
      [x]  -> (x:) `fmap` getLine con
      _    -> fail "More than one character back?"
  
  printDir [] = ""
  printDir (x:[]) = fst x
  printDir (x:xs) = fst x ++ "\t" ++ printDir xs
  