module ZFS where
import ZipperM
import Control.Exception (try, bracket)
import Control.Monad.Trans (liftIO, MonadIO())
import qualified Data.List as List
import qualified Data.Map as Map
import Foreign
import Foreign.C
import Foreign.Ptr
import Network.Socket
import System.IO
import qualified System.IO.Error as IO
import System.Posix (closeFd)
import System.Posix.Types(Fd(..))
newClientPort :: PortNumber
newClientPort = 1503
fs1 :: Term
fs1 = Folder $ Map.fromList [("d1",d1), ("d2",Folder $ Map.empty),
("fl1", File "File1"),
("fl2", File "File2")]
where d1 = Folder $ Map.fromList [("fl13",File "File 3"),
("d11", d11)]
d11 = Folder $ Map.fromList [("d111", Folder $ Map.empty)]
fs2 :: Term
fs2 = Folder $ Map.fromList [("d1",fs2), ("fl1", File "File1")]
type FSZipper r m = DZipper r m Term Path
data OSReq r m = OSRDone
| OSRRead (ReadK r m)
| OSRWrite String (UnitK r m)
| OSRTrace String (UnitK r m)
| OSRCommit Term (UnitK r m)
| OSRefresh (CCT r m (FSZipper r m) -> CCT r m (OSReq r m))
type UnitK r m = CCT r m () -> CCT r m (OSReq r m)
type ReadK r m = CCT r m String -> CCT r m (OSReq r m)
data ProcessCTX = ProcessCTX { psocket :: Socket
}
data JobQueueT r = JQBlockedOnRead ProcessCTX (ReadK r IO)
| JQRunnable ProcessCTX (UnitK r IO)
| JQNewClient Socket
data World r = World { mountedFS :: Term
, jobQueue :: [JobQueueT r]
, osPrompt :: Prompt r (OSReq r IO)
}
main' :: Term -> IO a
main' fs = bracket (serverSocket newClientPort) sClose $
\s ->
do
runCCT $ do
p <- newPrompt
syslog ["Entering the osloop",show s]
osloop $ World{
mountedFS = fs,
jobQueue = [JQNewClient s],
osPrompt = p}
where
serverSocket port = do
s <- socket AF_INET Stream 0
setSocketOption s ReuseAddr 1
localhost <- inet_addr "127.0.0.1"
bindSocket s (SockAddrInet port localhost)
listen s 5
return s
osloop world =
maybe (wait'for'intr world) (uncurry try'to'run) (find'runnable world)
>>= osloop
where
find'runnable world = case break is'runnable (jobQueue world) of
(_,[]) -> Nothing
(jq1,(runnable:jq2)) -> Just (runnable, world{jobQueue=jq1++jq2})
where is'runnable (JQRunnable _ _) = True
is'runnable _ = False
wait'for'intr world@World{jobQueue=jq} =
do readyfd <- liftIO $ select'read'pending mfd
case break (\e -> maybe False (`elem` readyfd) (toFD e)) jq of
(_,[]) -> return world
(jq1,(now'runnable:jq2)) ->
try'to'run now'runnable world{jobQueue=jq1++jq2}
where
mfd = foldr (\e a -> maybe [] (:a) (toFD e)) [] jq
toFD (JQNewClient s) = Just $ fdSocket s
toFD (JQBlockedOnRead ProcessCTX{psocket=s} _) = Just $ fdSocket s
toFD _ = Nothing
enqueue el world = world{jobQueue = jobQueue world ++ [el]}
try'to'run qe@(JQNewClient s) world =
do
syslog ["accepting from",show s]
(clientS,addr) <- liftIO $ accept s
liftIO $ setSocketOption clientS NoDelay 1
syslog ["accepted new client connection from ", show addr]
let newCtx = ProcessCTX clientS
run'process (fsProcess (dzip'term (mountedFS world)))(osPrompt world)
>>= interpret'req (enqueue qe world) newCtx
try'to'run (JQRunnable ctx k) world =
k (return ()) >>= interpret'req world ctx
try'to'run (JQBlockedOnRead ctx@ProcessCTX{psocket=s} k) world =
do
syslog ["reading from",show s]
syslog ["osloop: queue size: ", show $ length $ jobQueue world]
dat <- liftIO $ (
do r <- try (recv s (1024 * 8))
case r of
Left err -> if IO.isEOFError err then return ""
else ioError err
Right msg -> return msg)
k (return dat) >>= interpret'req world ctx
syslog :: (Control.Monad.Trans.MonadIO m) => [String] -> m ()
syslog s = liftIO $ putStrLn (concat s)
interpret'req :: World r -> ProcessCTX -> OSReq r IO -> CCT r IO (World r)
interpret'req world ctx OSRDone = (liftIO $ sClose $ psocket ctx)
>> return world
interpret'req world ctx (OSRRead k) =
return world{jobQueue = (jobQueue world) ++ [JQBlockedOnRead ctx k]}
interpret'req world ctx (OSRWrite datum k) =
do
send' (psocket ctx) datum
k (return ()) >>= interpret'req world ctx
where
send' _ "" = return ()
send' s msg = do c <- liftIO $ send s msg
send' s (drop c msg)
interpret'req world ctx (OSRTrace datum k) =
do
syslog ["Trace from",show $ psocket ctx,": ",datum]
k (return ()) >>= interpret'req world ctx
interpret'req world ctx (OSRCommit term k) =
return world{jobQueue = (jobQueue world) ++ [JQRunnable ctx k],
mountedFS = term}
interpret'req world ctx (OSRefresh k) =
k (dzip'term $ mountedFS world) >>= interpret'req world ctx
run'process :: (forall m. Monad m =>
(Prompt r (OSReq r m)) -> CCT r m (OSReq r m))
-> Prompt r (OSReq r IO) -> CCT r IO (OSReq r IO)
run'process body p = pushPrompt p (body p)
fsProcess :: Monad m =>
CCT r m (FSZipper r m) -> Prompt r (OSReq r m)
-> CCT r m (OSReq r m)
fsProcess zipper'action svcp =
do
z <- zipper'action
svc svcp $ OSRTrace "Begin process"
fsloop z svcp ""
fsloop :: forall r (m :: * -> *).
(Monad m) =>
DZipper r m Term Path
-> Prompt r (OSReq r m)
-> String
-> CCT r m (OSReq r m)
fsloop z svcp line'acc
= do
send_shell_prompt z svcp
(line,rest) <- read'line line'acc
let (cmd,arg) = breakspan is'whitespace line
svc svcp $ OSRTrace $ "received command: " ++ cmd
maybe (svc svcp (OSRWrite $ "bad command: " ++ cmd) >>
fsloop z svcp rest)
(\h -> h z svcp cmd arg rest)
(List.lookup cmd fsCommands)
where
read'line acc = case break is'nl acc of
(_,"") -> do
b <- svc svcp OSRRead
svc svcp $ OSRTrace $ "Read str: " ++ b
(l,rest) <- read'line b
return (acc ++ l, rest)
(l,rest) -> return (l,snd $ span is'nl rest)
send_shell_prompt z svcp =
svc svcp $ OSRWrite $ ("\n" ++ show_path (dz_path z) ++ "> ")
show_path :: [Path] -> String
show_path path = concatMap (\pc -> case pc of
Down -> "/"
DownTo s -> s ++ "/")
(reverse path)
fsCommands :: Monad m => [(String,FSZipper r m -> Prompt r (OSReq r m) ->
String -> String -> String ->
CCT r m (OSReq r m))]
fsCommands =
[
("quit", \_ svcp _ _ _ -> svc svcp $ const OSRDone),
("cd", fsWrapper
(\z shp _ path -> cd'zipper z shp path >>= return . FSCZ)),
("ls", fsWrapper cmd'ls),
("cat", fsWrapper cmd'ls),
("next", fsWrapper cmd'next),
("mkdir", fsWrapper (cmd'mknode (Folder Map.empty))),
("touch", fsWrapper (cmd'mknode (File ""))),
("echo", fsWrapper cmd'echo),
("rm", fsWrapper cmd'rm),
("mv", fsWrapper cmd'mv),
("cp", fsWrapper cmd'cp),
("help", fsWrapper cmd'help),
("commit", fcmd'commit),
("refresh", \_ svcp _ _ rest -> svc svcp OSRefresh >>=
\z -> fsloop z svcp rest)
]
fcmd'commit :: forall t t1 r (m :: * -> *).
(Monad m) =>
DZipper r m Term Path
-> Prompt r (OSReq r m)
-> t
-> t1
-> String
-> CCT r m (OSReq r m)
fcmd'commit z svcp _ _ rest = aux z
where
aux (DZipDone term) = (svc svcp $ OSRCommit term) >>
fsloop z svcp rest
aux DZipper{dz_k = k} = k (return (Nothing,Up)) >>= aux
data FSCmdResp r m = FSCS String | FSCZ (FSZipper r m)
fsWrapper :: forall t t1 r (m :: * -> *).
(Monad m) =>
(FSZipper r m
-> Prompt r (FSCmdResp r m)
-> t
-> t1
-> CCT r m (FSCmdResp r m))
-> FSZipper r m
-> Prompt r (OSReq r m)
-> t
-> t1
-> String
-> CCT r m (OSReq r m)
fsWrapper cmd z svcp cmd'name cmd'arg rest =
do
shp <- newPrompt
resp <- pushPrompt shp (cmd z shp cmd'name cmd'arg)
z' <- case resp of
FSCS str -> (svc svcp $ OSRWrite str) >> return z
FSCZ z -> return z
fsloop z' svcp rest
cmd'help :: forall t
t1
t2
(m :: * -> *)
r
(m1 :: * -> *)
r1
(m2 :: * -> *).
(Monad m, Monad m1) =>
FSZipper r m -> t -> t1 -> t2 -> m1 (FSCmdResp r1 m2)
cmd'help z _ _ _ = return $ FSCS $ "Commands: " ++
(concat $ List.intersperse ", " $ List.map fst cmds)
where
cmds :: [(String, FSZipper r2 m
-> Prompt r2 (OSReq r2 m)
-> String
-> String
-> String
-> CCT r2 m (OSReq r2 m))]
cmds = fsCommands
cmd'ls :: forall t
r
(m :: * -> *)
r1
(m1 :: * -> *).
(Monad m) =>
FSZipper r m
-> Prompt r (FSCmdResp r m)
-> t
-> String
-> CCT r m (FSCmdResp r1 m1)
cmd'ls z shp _ slash'path = cd'zipper z shp slash'path
>>= return . FSCS . list_node
cmd'next :: forall t t1 t2 r (m :: * -> *).
(Monad m) =>
DZipper r m Term Path
-> t
-> t1
-> t2
-> CCT r m (FSCmdResp r m)
cmd'next z _ _ _ =
do z' <- dz_k z (return (Nothing,Next))
return $ FSCZ $ case z' of DZipDone _ -> z; _ -> z'
cd'zipper :: Monad m =>
FSZipper r m -> Prompt r (FSCmdResp r m) -> String
-> CCT r m (FSZipper r m)
cd'zipper z _ "" = return z
cd'zipper z shp ('/':path) = do z' <- ascend'to'root z; cd'zipper z' shp path
where
ascend'to'root z =
dz_k z (return (Nothing,Up)) >>= ascend'to'root' z
ascend'to'root' z (DZipDone _) = return z
ascend'to'root' _ z = ascend'to'root z
cd'zipper z shp ('.':'.':path) = aux z (snd $ span (=='/') path)
where
aux DZipper{dz_path = [Down]} _ = return z
aux DZipper{dz_k = k} path = k (return (Nothing,Up)) >>=
(\z -> cd'zipper z shp path)
aux (DZipDone _) _ = return z
cd'zipper DZipper{dz_term = File _} shp _ =
abort shp (return $ FSCS "cannot descend down the file")
cd'zipper DZipper{dz_term = Folder fld, dz_k = k} shp path
= let (pc,prest) = breakspan (== '/') path
in if Map.member pc fld then do
z' <- k (return (Nothing,DownTo pc))
cd'zipper z' shp prest
else abort shp (return $ FSCS $ "No such dir component " ++ pc)
list_node :: forall t (t1 :: * -> *) t2.
DZipper t t1 Term t2 -> String
list_node DZipper{dz_term = File str} = str
list_node DZipper{dz_term = Folder fld} =
Map.foldWithKey (\name el acc ->
"\n" ++ name ++ (case el of Folder _ -> "/"
_ -> "") ++ acc)
"" fld
list_node _ = ""
cmd'mknode :: forall t
r
r1
(m :: * -> *)
(m1 :: * -> *).
(Monad m1) =>
Term
-> DZipper r m1 Term Path
-> Prompt r (FSCmdResp r1 m)
-> t
-> String
-> CCT r m1 (FSCmdResp r m1)
cmd'mknode _ _ shp _ dirn | '/' `elem` dirn =
abort shp (return $ FSCS "the name of the new node can't contain slash")
cmd'mknode _ _ shp _ "" =
abort shp (return $ FSCS "the name of the new node is empty")
cmd'mknode _ DZipper{dz_term = File _} shp _ _ =
abort shp (return $ FSCS "cannot create anything in a file")
cmd'mknode _ DZipper{dz_term = Folder fld} shp _ dirn
| Map.member dirn fld =
abort shp (return $ FSCS $ "node " ++ dirn ++ " already exists")
cmd'mknode newnode DZipper{dz_term = Folder fld, dz_k = k, dz_dir = cn}
_ _ dirn =
let fld' = Folder $ Map.insert dirn newnode fld
in k (return (Just fld',Up)) >>= adj cn >>= return . FSCZ
where
adj _ (DZipDone term) = dzip'term term
adj cn z = dz_k z $ return (Nothing,cn)
cmd'echo :: forall t r (m :: * -> *).
(Monad m) =>
DZipper r m Term Path
-> Prompt r (FSCmdResp r m)
-> t
-> String
-> CCT r m (FSCmdResp r m)
cmd'echo z shp _ args = aux $ (reads::ReadS String) args
where
aux [(content,rest)] = aux1 content (snd $ span is'whitespace rest)
aux _ = abort shp (return $ FSCS $ "bad format, str, of the echo cmd")
aux1 content ('>':rest) =
cd'zipper z shp (snd $ span is'whitespace rest) >>= aux2 content rest
aux1 _ _ = abort shp (return $ FSCS $ "bad format, path, of the echo cmd")
aux2 content _t DZipper{dz_term = File _, dz_k = k} =
k (return (Just $ File content,Up)) >>= zip'back'to'place shp z
>>= return . FSCZ
aux2 _ rest _ = abort shp
(return $ FSCS $ rest ++ " does not point to a file")
zip'back'to'place :: forall r
(m :: * -> *)
r1
(m1 :: * -> *)
term.
(Monad m) =>
Prompt r (FSCmdResp r m)
-> DZipper r1 m1 term Path
-> DZipper r m Term Path
-> CCT r m (FSZipper r m)
zip'back'to'place shp z (DZipDone term) =
dzip'term term >>= zip'back'to'place shp z
zip'back'to'place shp z z1 = cd'zipper z1 shp (show_path (dz_path z))
del'zipper :: forall r (m :: * -> *).
(Monad m) =>
DZipper r m Term Path
-> Prompt r (FSCmdResp r m)
-> String
-> CCT r m (FSZipper r m, Term)
del'zipper z shp path = cd'zipper z shp path >>=
\z -> dz_k z (return (Nothing,Up)) >>= aux (dz_dir z)
where
aux _ (DZipDone _) =
abort shp (return $ FSCS $ "cannot remove the root folder")
aux (DownTo pc) DZipper{dz_term = Folder fld, dz_k = k} =
let (Just old'node, fld') = Map.updateLookupWithKey (\_ _ -> Nothing) pc fld
in k (return (Just $ Folder $ fld',Up))
>>= zip'back'to'place shp z >>= \z -> return (z,old'node)
ins'zipper :: forall r (m :: * -> *).
(Monad m) =>
Term
-> FSZipper r m
-> Prompt r (FSCmdResp r m)
-> String
-> CCT r m (FSCmdResp r m)
ins'zipper node z0 shp path =
do
let (dirname,basename) = split'path path
z <- if dirname == "" then return z0 else cd'zipper z0 shp dirname
FSCZ z <- cmd'mknode node z shp "mv" basename
zip'back'to'place shp z0 z >>= return . FSCZ
cmd'rm :: forall t r (m :: * -> *).
(Monad m) =>
DZipper r m Term Path
-> Prompt r (FSCmdResp r m)
-> t
-> String
-> CCT r m (FSCmdResp r m)
cmd'rm z shp _ path = del'zipper z shp path >>= return . FSCZ . fst
cmd'mv :: forall t r (m :: * -> *).
(Monad m) =>
DZipper r m Term Path
-> Prompt r (FSCmdResp r m)
-> t
-> String
-> CCT r m (FSCmdResp r m)
cmd'mv z shp _ args = aux $ breakspan is'whitespace args
where
aux ("",_) = abort shp (return $ FSCS $ "mv: from-path is empty")
aux (_,"") = abort shp (return $ FSCS $ "mv: to-path is empty")
aux (pfrom,pto) = del'zipper z shp pfrom >>=
\ (z,node) -> ins'zipper node z shp pto
cmd'cp :: forall t r (m :: * -> *).
(Monad m) =>
DZipper r m Term Path
-> Prompt r (FSCmdResp r m)
-> t
-> String
-> CCT r m (FSCmdResp r m)
cmd'cp z0 shp _ args = aux $ breakspan is'whitespace args
where
aux ("",_) = abort shp (return $ FSCS $ "cp: from-path is empty")
aux (_,"") = abort shp (return $ FSCS $ "cp: to-path is empty")
aux (pfrom,pto) = cd'zipper z0 shp pfrom >>=
\z -> dz_k z (return (Nothing,Up)) >>=
aux' (dz_dir z) pto
aux' _ pto (DZipDone term) =
dzip'term term >>= zip'back'to'place shp z0 >>=
\z -> ins'zipper term z shp pto
aux' (DownTo pc) pto z@DZipper{dz_term = Folder fld} =
zip'back'to'place shp z0 z >>=
\z -> ins'zipper ((Map.!) fld pc) z shp pto
svc :: (Monad m) => Prompt r b -> ((CCT r m a -> CCT r m b) -> b) -> CCT r m a
svc p req = ZipperM.shift p (return . req)
is'nl, is'whitespace :: Char -> Bool
is'whitespace c = c == ' ' || c == '\t'
is'nl c = c == '\n' || c == '\r'
breakspan :: (a -> Bool) -> [a] -> ([a], [a])
breakspan pred l = let (p1,p2) = break pred l
in (p1,snd $ span pred p2)
split'path :: String -> (String, String)
split'path path = let (p1,p2) = breakspan (=='/') (reverse path)
in (reverse p2, reverse p1)
type FDSET = CUInt
type TIMEVAL = CLong
foreign import ccall "unistd.h select" c_select
:: CInt -> Ptr FDSET -> Ptr FDSET -> Ptr FDSET -> Ptr TIMEVAL -> IO CInt
fd2fds :: CInt -> [FDSET]
fd2fds fd = (replicate nb 0) ++ [setBit 0 off]
where
(nb,off) = quotRem (fromIntegral fd) (bitSize (undefined::FDSET))
fds2mfd :: [FDSET] -> [CInt]
fds2mfd fds = [fromIntegral (j+i*bitsize) |
(afds,i) <- zip fds [0..], j <- [0..bitsize],
testBit afds j]
where bitsize = bitSize (undefined::FDSET)
test_fd_conv, test_fd_conv' :: Bool
test_fd_conv = and $ List.map (\e -> [e] == (fds2mfd $ fd2fds e)) lst
where
lst = [0,1,5,7,8,9,16,17,63,64,65]
test_fd_conv' = mfd == fds2mfd fds
where
mfd = [0,1,5,7,8,9,16,17,63,64,65]
fds :: [FDSET] = foldr ormax [] (List.map fd2fds mfd)
ormax [] x = x
ormax x [] = x
ormax (a:ar) (b:br) = (a .|. b) : ormax ar br
select'read'pending :: [CInt] -> IO [CInt]
select'read'pending mfd =
withArray ([0,1]::[TIMEVAL]) (
\_ ->
withArray fds (
\readfs ->
do
_ <- throwErrnoIfMinus1 "select"
(c_select (fdmax+1) readfs nullPtr nullPtr nullPtr)
peekArray (length fds) readfs))
>>= (return . fds2mfd)
where
fds :: [FDSET] = foldr ormax [] (List.map fd2fds mfd)
fdmax = maximum $ List.map fromIntegral mfd
ormax [] x = x
ormax x [] = x
ormax (a:ar) (b:br) = (a .|. b) : ormax ar br
foreign import ccall "fcntl.h fcntl" fcntl :: CInt -> CInt -> CInt -> IO CInt
cleanup'fd :: [CInt] -> IO ()
cleanup'fd = mapM_ (closeFd . Fd)