/dead-code/DevPosix.hs

------------------------------------------------------------------
-- |
-- Module      :  System.IO9.Devices.DevPosix
-- Copyright   :  (c) Dmitry Golubovsky, 2010
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  GHC >= 6.12.2
-- 
--
--
-- Implementation of virtual device to access the host filesystem
------------------------------------------------------------------

module System.IO9.Devices.DevPosix (
  devPosix
) where

import Data.Word
import Data.Bits
import Data.List
import Data.Maybe
import Data.Binary.Put
import Data.Binary.Get
import Data.Either.Unwrap
import System.FilePath
import System.Directory
import System.IO9.Device
import System.IO9.Error
import System.Posix.Types
import System.Posix.Files
import System.Posix.User
import System.Posix.IO
import System.IO
import GHC.IO.Device
import Control.Monad
import Control.Concurrent
import qualified Data.ByteString.Lazy as B
import qualified Control.Exception as E
import qualified Data.Map as M

-- | Initialization of the device. The function returns a thunk holding a host
-- path that becomes a "root" of the device. If the path does not exist, the function
-- fails.

devPosix :: Bool                   -- ^ True if device connection can be shared between threads
         -> FilePath               -- ^ Host path to access via this device (preferrably
                                   -- absolute, but will be canonicalized)
         -> IO Device9P            -- ^ Function implementing the device

devPosix shr fp = do
  cfp <- canonicalizePath fp
  ex <- doesDirectoryExist cfp
  case ex of
    True -> return $ dpvers $ newdata shr cfp
    False -> return $ devError $ "Directory " ++ fp ++ "does not exist"

-- Device internal data.

data DevPosix = DevPosix {
  hfp :: FilePath                              -- root of the host file path
 ,fidmap :: M.Map Word32 FilePath              -- map of FIDs to actual paths
 ,openmap :: M.Map Word32 (Word8, Either Handle [FilePath]) -- map of FIDs currently open
 ,uname :: String                              -- name of the (authenticated) user
 ,thrid :: Maybe ThreadId                      -- ID of the thread that attached
 ,devshr :: Bool                               -- Device connection can be shared
}

-- Initialize device data.

newdata :: Bool -> FilePath -> DevPosix

newdata shr fp = DevPosix fp M.empty M.empty "" Nothing shr

-- Process the "Version" message, then the "Auth" message. Any other
-- sequence results in error.

-- Version: ignore the message size for now, but only proceed if the protocol version
-- is "9P2000". Any message other than "Version" results in an error, but the same
-- device connection may be reused for protocol version negotiation again.

dpvers :: DevPosix -> Device9P

dpvers devd msg@(Msg TTversion tg tv@Tversion {}) | tv_version tv == "9P2000" =
  return $ Resp9P (msg {msg_typ = TRversion}) (dpatch devd)

dpvers devd msg = return $ Resp9P (errorMsg (msg_tag msg) $ 
                                             "Protocol negotiation failure" ++ show msg) 
                                  (dpvers devd)

-- Attach: afid is ignored. Fid and aname are written into the fidmap (aname is
-- prefixed with the stored root filepath, canonicalized, and checked to be within the root).
-- Uname as well as the current thread ID are stored in the device data.
-- Uname is currently ignored by this implementation. Note that aname may also represent 
-- a regular file. If aname points to a non-existent file or directory, the operation
-- fails, but the device remains in negotiated state.

dpatch :: DevPosix -> Device9P

dpatch devd msg@(Msg TTattach tg ta@Tattach {}) = do
  let norm = normalise (hfp devd ++ "/" ++ tat_aname ta)
  tree <- canonicalizePath norm 
  ex <- fileExist tree
  case ex && isSubdir (hfp devd) tree of
    False -> return $ Resp9P (errorMsg (msg_tag msg) $ "Invalid or non-existent path " ++ 
                                                      tat_aname ta) (dpatch devd)
    True -> do
      let fidmap' = M.insert (tat_fid ta) tree (fidmap devd)
      stat <- getFileStatus tree
      let qid = stat2qid stat
      tid <- myThreadId
      return $ Resp9P (Msg TRattach tg (Rattach qid)) 
                      (dpacc devd { 
                         fidmap = fidmap'
                        ,uname = tat_uname ta
                        ,thrid = Just tid})

-- This device does not require authentication.

dpatch devd msg@(Msg TTauth tg ta) = 
                  return $ Resp9P (errorMsg (msg_tag msg) $ "Authentication not reauired") 
                                  (dpvers $ newdata (devshr devd) (hfp devd))


-- Any message other than Auth throws a unnegotiated device entry to the client.

dpatch devd msg = return $ Resp9P (errorMsg (msg_tag msg) $ "Not attached") 
                                  (dpvers $ newdata (devshr devd) (hfp devd))

-- At this point we can accept walk/open/read/write/etc. messages. If the "shared" flag
-- is True, thread ID is not checked, and any thread may reuse the authenticated connection.
-- If it is False, and a request comes from the thread other authenticated thread, a fresh
-- unnegotiated device is returned. Messages like Version and Auth are not accepted at this point.
-- They will return a unnegotiated or unauthenticated device respectively.
-- The Flush message has no action as all operations are synchronous.

dpacc :: DevPosix -> Device9P

dpacc devd msg | msg_typ msg == TTversion = dpvers (newdata (devshr devd) (hfp devd)) msg

dpacc devd msg | msg_typ msg == TTauth = dpatch (newdata (devshr devd) (hfp devd)) msg
 
dpacc devd msg | msg_typ msg == TTflush = 
  return $ Resp9P (msg {msg_typ = TRflush, msg_body = Rflush}) (dpacc devd) 

dpacc devd msg = do
  let emsg x = return $ Resp9P (errorMsg (msg_tag msg) x) (dpacc devd)
  tid <- myThreadId
  if (devshr devd) && isJust (thrid devd) && (tid /= fromJust (thrid devd)) 
    then dpvers (newdata (devshr devd) (hfp devd)) msg
    else case (msg_typ msg, msg_body msg) of
      (TTstat, Tstat {}) -> do      -- if file/dir does not exist, return an error message
        let sfid = ts_fid $ msg_body msg
            spath = M.lookup sfid $ fidmap devd
        case spath of
          Nothing -> emsg $ "Incorrect fid: " ++ show sfid
          Just sfp -> do
            ex <- fileExist sfp     -- file could have disappeared
            case ex of
              False -> emsg $ "File/directory does not exist: " ++ sfp
              True -> do
                st <- getFileStatus sfp
                let fname = if normalise (sfp ++ "/") == normalise (hfp devd ++ "/") 
                              then "/"
                              else head . reverse $ splitPath sfp
                ret <- stat2stat st fname
                return $ Resp9P (msg {msg_typ = TRstat, msg_body = Rstat [ret]}) (dpacc devd)
      (TTclunk, Tclunk {}) -> do
        let clfid = tcl_fid $ msg_body msg
            rclunk dv = return $ Resp9P (msg {msg_typ = TRclunk, msg_body = Rclunk}) dv
        if clfid == c_NOFID         -- this special value causes all FIDs to be clunked,
          then do                   -- and the device returned to the unauthenticated state
            let fids = M.keys (fidmap devd)
            mapM_ (clunk devd) fids
            rclunk . dpvers $ newdata (devshr devd) (hfp devd)
          else do
            devd' <- clunk devd clfid
            rclunk . dpacc $ devd'
      (TTwalk, Twalk {}) -> do
        let twfid = tw_fid $ msg_body msg
            twnfid = tw_newfid $ msg_body msg
            twnames = tw_wnames $ msg_body msg
            twpath = M.lookup twfid $ fidmap devd
            twex = isJust twpath
            twopen = M.member twfid $ openmap devd
            twnused = M.member twnfid $ fidmap devd
            difffid = twfid /= twnfid
            rwalk q d = return $ Resp9P (msg {msg_typ = TRwalk, msg_body = Rwalk q}) (dpacc d)
        case (twex, twopen, twnused && difffid) of
          (False, _, _) -> emsg $ "Fid is invalid: " ++ show twfid
          (True, True, _) -> emsg $ "Fid is open: " ++ show twfid
          (True, False, True) -> emsg $ "New fid " ++ show twnfid ++ " is in use"
          (True, False, False) -> do
            (rpth, res) <- walk (hfp devd) (fromJust twpath) twnames []
            let fidmap' = M.insert twnfid rpth (fidmap devd)
            case (length twnames, length res) of
              (0, 1) -> rwalk res (devd {fidmap = fidmap'})
              (_, 1) -> emsg $ show Enonexist
              (m, n) | n == m + 1 -> rwalk (tail res) (devd {fidmap = fidmap'})
              _ -> rwalk (tail res) devd
      (TTopen, Topen ofid omode) -> do -- for directory, just store its contents
        let opath = M.lookup ofid $ fidmap devd
        case opath of
          Nothing -> emsg $ "Incorrect fid: " ++ show ofid
          Just ofp -> do
            ex <- fileExist ofp     -- file could have disappeared
            case ex of
              False -> emsg $ "File/directory does not exist: " ++ ofp
              True -> do
                let dot "." = True
                    dot ".." = True
                    dot _ = False
                st <- getFileStatus ofp
                oval <- if isDirectory st
                          then getDirectoryContents ofp >>= 
                               return . filter (not . dot) >>= 
                               return . Right
                          else openFd ofp (mod2mod $ omode .&. 3) Nothing (mod2flg omode) >>=
                               fdToHandle >>=
                               return . Left
                let openmap' = M.insert ofid (omode, oval) (openmap devd)
                    oqid = stat2qid st
                    devd' = devd {openmap = openmap'}
                return $ Resp9P msg {msg_typ = TRopen, msg_body = Ropen oqid 0} (dpacc devd')
      (TTread, Tread rfid roff rcnt) -> do -- directory contents always reads entirely
        let rpath = M.lookup rfid $ fidmap devd
            rval = M.lookup rfid $ openmap devd
            rread b = return $ Resp9P (msg {msg_typ = TRread, msg_body = Rread b}) (dpacc devd)
        case rpath of
          Nothing -> emsg $ "Incorrect fid: " ++ show rfid
          Just rfp -> do
            ex <- fileExist rfp     -- file could have disappeared
            case ex of
              False -> emsg $ show Enonexist
              True -> case rval of
                Nothing -> emsg $ "Fid " ++ show rfid ++ " was not open"
                Just (m, Left h) | m .&. 3 /= c_OWRITE -> do
                  hSeek h AbsoluteSeek (fromIntegral roff)
                  B.hGet h (fromIntegral rcnt) >>= rread
                Just (m, Right fps) | m .&. 3 == c_OREAD && roff == 0 -> do
                  let rfps = map (rfp </>) fps
                      fstz f = (getFileStatus f >>= \s -> return [(s, f)]) `catch` 
                                 (\_ -> return [])
                  sts <- mapM fstz rfps >>= return . concat
                  nsts <- zipWithM stat2stat (map fst sts) (map (snd . splitFileName . snd) sts)
                  let bs = map (runPut . put) nsts -- get Stat for each file
                      cbs = B.concat bs            -- serialize each Stat and concat
                  rread cbs                        -- send whatever results from concatenation
                _ -> emsg $ "Incorrect fid mode: " ++ show rfid 
      (TTwrite, Twrite wfid woff wdat) -> do -- directories cannot be written
        let wpath = M.lookup wfid $ fidmap devd
            wval = M.lookup wfid $ openmap devd
            rwrite b = return $ Resp9P (msg {msg_typ = TRwrite, msg_body = Rwrite b}) (dpacc devd)
        case wpath of
          Nothing -> emsg $ "Incorrect fid: " ++ show wfid
          Just wfp -> do
            ex <- fileExist wfp     -- file could have disappeared
            case ex of
              False -> emsg $ show Enonexist
              True -> case wval of
                Nothing -> emsg $ "Fid " ++ show wfid ++ " was not open"
                Just (m, Left h) -> do -- append-only files not supported, always write at woff
                  hSeek h AbsoluteSeek (fromIntegral woff)
                  B.hPut h wdat >> hFlush h >> rwrite (fromIntegral $ B.length wdat)
                _ -> emsg $ show Eisdir
      _ -> emsg $ "Incorrect message " ++ show msg


-- Clunk one fid, update the internal data as needed.

clunk :: DevPosix -> Word32 -> IO DevPosix

clunk devd clfid = do
  let clmode = M.lookup clfid $ openmap devd
      clpath = M.lookup clfid $ fidmap devd
      (rm, cl) = case clmode of
        Nothing -> (False, False)
        Just (m, mbfd) -> ((m .&. c_ORCLOSE) /= 0, isLeft mbfd)
      openmap' = M.delete clfid $ openmap devd
      fidmap' = M.delete clfid $ fidmap devd
      devd' = devd {openmap = openmap', fidmap = fidmap'}
  when cl $ hClose (fromLeft . snd . fromJust $ clmode)
  when (rm && isJust clpath && fromJust clpath /= hfp devd) $ removeLink (fromJust clpath)
  return devd'

-- Walk the given path from the base step by step.

walk :: FilePath -> FilePath -> [FilePath] -> [Qid] -> IO (FilePath, [Qid])

walk root base fps fpqs = do
  nbase <- canonicalizePath base
  ex <- fileExist nbase
  case ex of
    False -> return ("", fpqs)
    True -> do
      let nbase' = case isSubdir root nbase of
            True -> nbase
            False -> root
      stat <- getFileStatus nbase'
      let qid = stat2qid stat
          nxt = fpqs ++ [qid]
      case fps of
        [] -> return (nbase', nxt)
        fph:fpt -> walk root (nbase' </> fph) fpt nxt
      
      
-- Convert a 9P2000 open mode to Posix open mode.  

mod2mod :: Word8 -> OpenMode

mod2mod omode | omode == c_OREAD = ReadOnly
              | omode == c_OWRITE = WriteOnly
              | omode == c_ORDWR = ReadWrite
              | otherwise = error $ "Incorrect open mode: " ++ show omode

-- Convert a 9P2000 open mode to Posix open flags (in fact only O_TRUNC is affected).

mod2flg :: Word8 -> OpenFileFlags

mod2flg omode | (omode .&. c_OTRUNC) /= 0 = defaultFileFlags {trunc = True}
              | otherwise = defaultFileFlags

-- Check that the path2 is a subdirectory of path1 (or equal to path1).

isSubdir p1 p2 | equalFilePath p1 p2 = True

isSubdir p1 p2 =
  let sp1 = splitPath p1
      sp2 = splitPath p2
  in  p1 `isPrefixOf` p2

-- Build a Qid from file status.

stat2qid :: FileStatus -> Qid

stat2qid stat =
  let isdir = isDirectory stat
      inode = fileID stat
      ctime = modificationTime stat
      qid = Qid {
        qid_typ = if isdir then c_QTDIR else 0
       ,qid_vers = round(realToFrac ctime)
       ,qid_path = fromIntegral inode
      }
  in  qid

-- Build a filemode mask in terms of the 9P definition.

stat2mode :: FileStatus -> Word32

stat2mode st =
  let umode = fileMode st
      oshift = 6
      gshift = 3
      wshift = 0
      permmap = [(ownerReadMode, c_DMREAD `shiftL` oshift)
                ,(ownerWriteMode, c_DMWRITE `shiftL` oshift)
                ,(ownerExecuteMode, c_DMEXEC `shiftL` oshift)
                ,(groupReadMode, c_DMREAD `shiftL` gshift)
                ,(groupWriteMode, c_DMWRITE `shiftL` gshift)
                ,(groupExecuteMode, c_DMEXEC `shiftL` gshift)
                ,(otherReadMode, c_DMREAD `shiftL` wshift)
                ,(otherWriteMode, c_DMWRITE `shiftL` wshift)
                ,(otherExecuteMode, c_DMEXEC `shiftL` wshift)
                ,(directoryMode, c_DMDIR)]
      nmode = foldl mbit 0 permmap
      mbit acc (umb, nmb) = case umb .&. umode of
        0 -> acc
        _ -> acc .|. nmb
  in  nmode

-- Convert a Unix stat record to 9P2000 stat record.

stat2stat :: FileStatus -> FilePath -> IO Stat

stat2stat st fname = do
  funame <- (getUserEntryForID (fileOwner st) >>= return . userName) `catch`
              (\_ -> return . show $ fileOwner st)
  fgroup <- (getGroupEntryForID (fileGroup st) >>= return . groupName) `catch`
              (\_ -> return . show $ fileGroup st)
  let qid = stat2qid st
      mode = stat2mode st
      ret = Stat {
        st_typ = 0    -- these are not filled in by the driver, but
       ,st_dev = 0    -- rather by the surrounding framework
       ,st_qid = qid
       ,st_mode = mode
       ,st_atime = round $ realToFrac $ accessTime st
       ,st_mtime = round $ realToFrac $ modificationTime st
       ,st_length = fromIntegral $ fileSize st
       ,st_name = fname
       ,st_uid = funame
       ,st_gid = fgroup
       ,st_muid = funame
      }
  return ret