{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}

module Network.NineP.Internal.Msg
	( Config(..)
	, rversion
	, rattach
	, rwalk
	, rstat
	, rwstat
	, rclunk
	, rauth
	, ropen
	, rcreate
	, rread
	, rwrite
	, rremove
	, rflush
	) where

import Control.Concurrent.MState hiding (put)
import Control.Exception
import Control.Monad.EmbedIO
import Control.Monad.Reader
import Data.Binary.Put
import Data.Bits
import qualified Data.ByteString.Lazy as B
import Data.NineP
import Data.Map (Map)
import Data.Maybe
import Data.Word
import Prelude hiding (lookup, read)

import Network.NineP.Error
import Network.NineP.Internal.File
import Network.NineP.Internal.State

checkPerms :: (Monad m, EmbedIO m) => Word16 -> NineFile m -> Word8 -> Nine m ()
checkPerms tag f want = do
	s <- getStat tag f
	checkPerms' (st_mode s) want

checkPerms' :: (Monad m, EmbedIO m) => Word32 -> Word8 -> Nine m ()
checkPerms' have want = do
	-- TODO stop presuming we are owners
	let checkRead = unless (testBit have 2) $ throw EPermissionDenied
	let checkWrite = unless (testBit have 1) $ throw EPermissionDenied
	let checkExec = unless (testBit have 0) $ throw EPermissionDenied
	when (testBit want 4) $ do
		checkWrite
		throw $ ENotImplemented "OTRUNC"
	when (testBit want 6) $ do
		throw $ ENotImplemented "ORCLOSE"
	case want of
		0 -> checkRead
		1 -> checkWrite
		2 -> checkRead >> checkWrite
		3 -> checkExec

getQidTyp :: Stat -> Word8
getQidTyp s = fromIntegral $ shift (st_mode s) 24

makeQid :: (Monad m, EmbedIO m) => Word16 -> NineFile m -> Nine m Qid
makeQid t x = do
	s <- getStat t x
	return $ Qid (getQidTyp s) 0 42

rversion :: Msg -> Nine m [Msg]
rversion (Msg _ t (Tversion s v)) = do
	let ver = readVersion v
	modifyM_ (\st -> st { msize = s, protoVersion = ver })
	return $ return $ Msg TRversion t $ Rversion s $ show ver

rattach (Msg _ t (Tattach fid _ _ _)) = do
	root <- asks root
	insert fid root
	q <- makeQid t root
	return $ return $ Msg TRattach t $ Rattach q 

desc :: (Monad m, EmbedIO m) => NineFile m -> String -> m (NineFile m)
desc f ".." = do
	mp <- parent f
	return $ case mp of
		Just p -> p
		Nothing -> f
desc f s = descend f s

walk :: (Monad m, EmbedIO m) => [Qid] -> Word16 -> [String] -> NineFile m -> Nine m (NineFile m, [Qid])
walk qs t [] f = return (f, qs)
walk qs t (x:xs) (RegularFile {}) = throw ENotADir
walk qs t (x:xs) d@(Directory {}) = do
	f <- call t $ desc d x
	q <- makeQid t f
	walk (q:qs) t xs f

walk' :: (Monad m, EmbedIO m) => Word16 -> [String] -> NineFile m -> Nine m (NineFile m, [Qid])
walk' = walk []

rwalk (Msg _ t (Twalk fid newfid path)) = do
	f <- lookup fid
	(nf, qs) <- walk' t path f
	insert newfid nf
	return $ return $ Msg TRwalk t $ Rwalk $ qs

getStat :: (Monad m, EmbedIO m) => Word16 -> NineFile m -> Nine m Stat
getStat t f = do
	let fixDirBit = (case f of
				(RegularFile {}) -> flip clearBit 31
				(Directory {}) -> flip setBit 31
			)
	s <- call t $ stat f
	return s { st_mode = fixDirBit $ st_mode s,
		st_qid = (st_qid s) { qid_typ = getQidTyp s } }
	
rstat (Msg _ t (Tstat fid)) = do
	f <- lookup fid
	case f of
		RegularFile {} -> do
			s <- getStat t f
			return $ return $ Msg TRstat t $ Rstat $ [s]
		Directory {} -> do
			mys <- getStat t f
			return $ return $ Msg TRstat t $ Rstat $ return $ mys

rclunk (Msg _ t (Tclunk fid)) = do
	delete fid
	return $ return $ Msg TRclunk t $ Rclunk

rauth (Msg {}) = do
	throw ENoAuthRequired

open :: (Monad m, EmbedIO m) => Word16 -> NineFile m -> Nine m Qid
open t f = do
	makeQid t f

ropen (Msg _ t (Topen fid mode)) = do
	f <- lookup fid
	checkPerms t f mode
	qid <- open t f
	iou <- iounit
	return $ return $ Msg TRopen t $ Ropen qid iou

rcreate (Msg _ t (Tcreate fid name perm mode)) = do
	f <- lookup fid
	-- TODO check permissions to create
	case f of
		RegularFile {} -> throw ENotADir
		Directory {} -> do
			nf <- call t $ (create f) name perm
			insert fid nf
			qid <- open t f
			iou <- iounit
			return $ return $ Msg TRcreate t $ Rcreate qid iou

rread :: (Monad m, EmbedIO m) => Msg -> Nine m [Msg]
rread (Msg _ t (Tread fid offset count)) = do
	f <- lookup fid
	u <- iounit
	checkPerms t f 0
	let	splitMsg d s = let r = splitMsg' d s in if null r then [B.empty] else r
		splitMsg' d s = if B.null d then [] else
			let (a, b) = B.splitAt s d in a : splitMsg' b s
	case f of
		RegularFile {} -> do
			d <- call t $ (read f) offset count
			mapM (return . Msg TRread t . Rread) $ splitMsg d $ fromIntegral u
		Directory {} -> do
			contents <- call t $ getFiles f
			s <- mapM (getStat t) $ contents
			let d = runPut $ mapM_ put s
			mapM (return . Msg TRread t . Rread) $ splitMsg (B.drop (fromIntegral offset) d) $ fromIntegral u
		
--rwrite :: Msg -> Nine m [Msg]
rwrite (Msg _ t (Twrite fid offset d)) = do
	f <- lookup fid
	checkPerms t f 1
	case f of
		Directory {} -> throw EDir
		RegularFile {} -> do
			c <- call t $ (write f) offset d
			return $ return $ Msg TRwrite t $ Rwrite c

rwstat (Msg _ t (Twstat fid stat)) = do
	-- TODO check perms
	f <- lookup fid
	-- TODO implement
	return $ return $ Msg TRwstat t $ Rwstat

rremove (Msg _ t (Tremove fid)) = do
	-- TODO check perms
	f <- lookup fid
	throw $ ENotImplemented "remove"

-- TODO meaningful flush behaviour instead of pretending it works
rflush (Msg _ t _) = return $ return $ Msg TRflush t $ Rflush