diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,11 @@ +This is a Cabalized and somewhat modernized/cleaned-up package containing Oleg's famous ZipperFS. For details, see . + +A demonstration of how to use it is contained in zfs.pdf. The short of the matter is: + + "Load ZFS.hs into GHCi + Start up the system: main at the GHCi prompt + From some terminal: 'telnet localhost 1503'" + +And then you can play around with it. + +This package also comes with an old implementation of delimited continuations. Ideally it would be updated to use the maintained package, CC-Delcont . But I don't know how. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks defaultUserHooks diff --git a/ZFS.cabal b/ZFS.cabal new file mode 100644 --- /dev/null +++ b/ZFS.cabal @@ -0,0 +1,29 @@ +name: ZFS +version: 0.0 +synopsis: Oleg's Zipper FS +description: A implementation of a zipper filesystem using delimited continuations. + + Zipper-based File/Operating system + with threading and exceptions all realized via delimited continuations. + There are no unsafe operations, no GHC (let alone) Unix threads, + no concurrency problems. Our threads can't even do IO and can't + mutate any global state -- and the type system sees to it. + +category: Monads +license: PublicDomain + +author: Amr Sabry, R. Kent Dybvig, Simon L. Peyton Jones, Oleg Kiselyov +maintainer: Gwern Branwen = 1.2 +Tested-With: GHC==6.8.2 +build-type: Simple + +Library + build-depends: base, haskell98, mtl, unix, network, containers, CC-delcont <= 0.2 + + hs-source-dirs: src + exposed-modules: ZFS, ZipperM + + ghc-options: -O2 -Wall -optl-Wl,-s + ghc-prof-options: -prof -auto-all diff --git a/src/ZFS.hs b/src/ZFS.hs new file mode 100644 --- /dev/null +++ b/src/ZFS.hs @@ -0,0 +1,680 @@ +{-# OPTIONS -fglasgow-exts #-} + +{- +Zipper-based File/Operating system +with threading and exceptions all realized via delimited continuations. +There are no unsafe operations, no GHC (let alone) Unix threads, +no concurrency problems. Our threads can't even do IO and can't +mutate any global state -- and the type system sees to it. + +Please see http://pobox.com/~oleg/ftp/papers/zfs-talk.pdf +for the demo and explanations. + +-- $Id: ZFS.hs,v 1.8 2005/10/14 23:00:41 oleg Exp $ +-} + +module ZFS where + +import ZipperM + +import Control.Exception (bracket) +import Control.Monad.Trans (liftIO, MonadIO()) +import Data.List as List +import Data.Map as Map +import Foreign -- needed for select hacks: +import Foreign.C -- Unix select is not available in +import Foreign.Ptr -- GHC +import Network.Socket +import System.IO +import System.IO.Error as IO +import System.Posix (closeFd) +import System.Posix.Types(Fd(..)) + +-- import CC_FrameT (runCC) -- have to import runCC manually, even though the import of + -- ZipperM should pull it in. + +-- Port to serve clients from +newClientPort :: PortNumber +newClientPort = 1503 +-- select_timeout = 100000 -- microseconds + +-- Initial content of the file system +-- Certainly, structurally richer filesystems are equally possible +-- (where content is annotated with attributes, e.g.) +-- A lambda-term can be made a filesystem too +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)] + +-- Another file system -- this time, it is cyclic! +fs2 :: Term +fs2 = Folder $ Map.fromList [("d1",fs2), ("fl1", File "File1")] + +-- Operating system requests: from a ``process'' to the ``OS'' +type FSZipper r m = DZipper r m Term Path + +-- Note: the base monad type `m' is left polymorphic. +-- A Process doesn't do any IO (it asks the ``OS''). +-- So, the significant part of the OS, the process itself, is overtly +-- outside the IO monad! +-- Note: using different prompts, the requests can be modularized. +-- Unlike OS (with its only one syscall handler), we can have as +-- many syscall handlers as we wish. +data OSReq r m = OSRDone + | OSRRead (ReadK r m) + | OSRWrite String (UnitK r m) + | OSRTrace String (UnitK r m) -- so a process can syslog + | 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 -- process' socket + } + +-- A process can only be blocked on reading. For simplicity we assume +-- that writing into the client socket never blocks + +data JobQueueT r = JQBlockedOnRead ProcessCTX (ReadK r IO) + | JQRunnable ProcessCTX (UnitK r IO) + | JQNewClient Socket -- accept new clients from + +data World r = World { mountedFS :: Term + , jobQueue :: [JobQueueT r] + , osPrompt :: Prompt r (OSReq r IO) + } + +main = main' fs1 + +main' :: Term -> IO a +main' fs = bracket (serverSocket newClientPort) sClose $ + \s -> + do + -- The following doesn't help: accept blocks anyway... + -- setFdOption (Fd (fdSocket s)) NonBlockingRead True + 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 + +-- In OS parlance, the following is the interrupt handler. +-- It `waits' for interrupts that is, if any input socket has something +-- to read from. +-- It doesn't actually return, so the answer type is just any +-- osloop :: World r -> CCT r IO any +osloop world = + maybe (wait'for'intr world) (uncurry try'to'run) (find'runnable world) + >>= osloop + + where + -- Try to find the first runnable job + 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 -- nothing found + (jq1,(now'runnable:jq2)) -> + try'to'run now'runnable world{jobQueue=jq1++jq2} + where + -- compile the list of file descriptors we are waiting at + 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 + + -- Add to the end of the job queue + enqueue el world = world{jobQueue = jobQueue world ++ [el]} + +-- ifnM action onf ont = liftIO action >>= \b -> if b then ont else onf + + -- New client is trying to connect + 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 + + -- A client socket may have something to read + 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 <- IO.try (recv s (1024 * 8)) + case r of + Left err -> if isEOFError err then return "" + else ioError err + Right msg -> return msg) + k (return dat) >>= interpret'req world ctx + +-- The system logger +syslog :: (Control.Monad.Trans.MonadIO m) => [String] -> m () +syslog s = liftIO $ putStrLn (concat s) + +-- The interpreter of OS requests -- the syscall handler, in OS parlance +-- It handles simple requests by itself. When the request involves +-- rescheduling or change in the global OS state, it returns to +-- the scheduler/interrupt-handler/osloop. + +-- The process is finished +interpret'req :: World r -> ProcessCTX -> OSReq r IO -> CCT r IO (World r) +interpret'req world ctx OSRDone = (liftIO $ sClose $ psocket ctx) + >> return world + +-- The request for read may block. So, we do the context switch and go +-- to the main loop, to check if the process socket has something to read +-- from +interpret'req world ctx (OSRRead k) = + return world{jobQueue = (jobQueue world) ++ [JQBlockedOnRead ctx k]} + +-- We assume that writing to a socket never blocks +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 + +-- We have the functionality of threads -- although our whole program +-- is simply threaded, both at the OS level and at the GHC runtime level. +-- Our process functions don't even have the IO type! +-- Note, the function to run the process has forall m. That means, a process +-- function can't do any IO and can't have any reference cells. +-- Processes can't mutate the global state -- and the type system checks that! +-- Because processes can't interfere with each other and with the OS, there +-- is no need for any thread synchronization, locking, etc. We get +-- the transactional semantics for free. +-- Of course, as different processes manipulate their own (copy-on-write) +-- terms (file systems), when the processes commit, there may be conflicts. +-- So, one has to implement some conflict resolution -- be it versioning, +-- patching, asking for permission for update, etc. But +-- these policies are implemented at the higher-level; the programmer can +-- implement any set of policies. Because processes always ask the supervisor +-- for anything, and the supervisor has the view of the global state, +-- the resolution policies are easier to implement in this execution model. +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) + +-- Processes. No IO action is possible in here +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 until we get newline + 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) + -- could have a command ``down N'' -- positional descend + -- Note: next is really cool! + -- Note, we can cd inside a file! So, cat is just `ls' inside a file + ] + +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) + +-- We use delimited continuations rather than an Error monad +-- A delimited continuation suffices! +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 $ intersperse ", " $ List.map fst cmds) + where + cmds = fsCommands + -- The following statement does nothing at run-time. It is here + -- just to tell the typechecker that the monad `m' in fsCommands and + -- that in 'z' are the same + _ = snd (head cmds) z + +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' + +-- main navigation function +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 -- already at the top + 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 the current contents of the node pointed by the zipper +-- This function subsumes both `ls' and `cat' +-- For files, it sends the content of the file +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 _ = "" + +-- make a node (an empty directory or an empty file or a moved node) +-- named 'dirn' in the current directory +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 + -- go back to the current directory + adj _ (DZipDone term) = dzip'term term + adj cn z = dz_k z $ return (Nothing,cn) + +-- echo string > path +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 z z1| brings z1 to the same place as z +-- Right now we use a pathetic algorithm -- but it works... +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)) + +-- Delete the node pointed to by path and return the +-- updated zipper (which points to the same location as z) and the +-- deleted node +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) + +-- insert a node as `path' +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 + +-- rm path +-- works both on directories and files +-- One can even try to remove one's own parent -- and this is safe! +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 + +-- mv path_from path_to +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 + +-- cp path_from path_to +-- We don't do any copying: we merely establish sharing: +-- so a node accessible via `from_path' becomes accessible via `to_path' +-- The copy-on-write semantics of ZFS does the rest. +-- So, in ZFS, we can copy arbitrary file systems trees in constant time! +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 + +-- Supervisor call +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) + +-- break the path into (dirname,basename) +split'path :: String -> (String, String) +split'path path = let (p1,p2) = breakspan (=='/') (reverse path) + in (reverse p2, reverse p1) + +------------------------------------------------------------------------ +-- Some hacks to get around the lack of select + + -- Darn! We don't have the real select over several descriptors! + -- We have to implement it ourselves +type FDSET = CUInt +type TIMEVAL = CLong -- Two longs +foreign import ccall "unistd.h select" c_select + :: CInt -> Ptr FDSET -> Ptr FDSET -> Ptr FDSET -> Ptr TIMEVAL -> IO CInt + +-- Convert a file descriptor to an FDSet (for use with select) +-- essentially encode a file descriptor in a big-endian notation +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) +-- fdmax = maximum $ List.map fromIntegral mfd + ormax [] x = x + ormax x [] = x + ormax (a:ar) (b:br) = (a .|. b) : ormax ar br + +-- poll if file descriptors have something to read +-- Return the list of read-pending descriptors +select'read'pending :: [CInt] -> IO [CInt] +select'read'pending mfd = + withArray ([0,1]::[TIMEVAL]) ( -- holdover... + \_ -> + withArray fds ( + \readfs -> + do + _ <- throwErrnoIfMinus1 "select" + (c_select (fdmax+1) readfs nullPtr nullPtr nullPtr) + -- because the wait was indefinite, rc must be positive! + 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 + +-- use it as cleanup'fd [5..6] to clean up the sockets left hanging... +cleanup'fd :: [CInt] -> IO () +cleanup'fd = mapM_ (closeFd . Fd) + + diff --git a/src/ZipperM.hs b/src/ZipperM.hs new file mode 100644 --- /dev/null +++ b/src/ZipperM.hs @@ -0,0 +1,231 @@ +{-# OPTIONS -fglasgow-exts #-} + +-- Zipper over the Map with path accumulation +-- $Id: ZipperM.hs,v 1.4 2005/09/22 03:06:38 oleg Exp $ + +module ZipperM (Term(..) + , FileName + , FileCont + , Path(..) + , DZipper(..) + , dzip'term + , module Control.Monad.CC + , promptP + ) where + +import Control.Monad.CC +import Control.Monad.Identity +import Control.Monad.Trans +import Data.Map as Map + +--------------------------------------------------------------- +-- Control operators + +-- Non-darcs +-- promptP :: (MonadDelimitedCont p s t) => (p a -> t a) -> t a + +-- Darcs repo of CC-delcont +-- promptP :: (MonadDelimitedCont t) => (Prompt t a -> t a) -> t a + +promptP f = do p <- newPrompt; pushPrompt p (f p) + +--------------------------------------------------------------- +-- Term to traverse + +type FileName = String +type FileCont = String +data Term = File String | Folder (Map.Map FileName Term) + +instance Show Term where + showsPrec _ (File file) = (file ++) + showsPrec _ (Folder dir) = + ("\n >>>" ++) . (Map.foldWithKey fl ("\n<<<" ++) dir) + where fl k term acc = ("\n" ++) . (k ++) . (": " ++) . + (showsPrec 5 term) . acc + +-- Path in the Term +-- Down is the same as DownToN 0 -- descend to the first child +data Path = Down | DownTo FileName | DownToN Int | Up | Next + deriving (Eq, Show) + +-- Updateable traverse that maximally preserves the sharing +traverse tf term = traverse' id Down term >>= maybeM term id + where traverse' next_dir init_dir term = + do + (term', direction) <- tf init_dir term + let new_term = maybe term id term' + select (next_dir direction) new_term >>= maybeM term' Just + select Up t = return Nothing + select Next t@(File _) = return Nothing + select dir@(DownTo fname) t@(Folder fld) = + select (DownToN (Map.findIndex fname fld)) t + select dir t@(Folder _) | dir == Next || dir == Down = + select (DownToN 0) t + select (DownToN n) t@(Folder fld) | n >= Map.size fld = + return Nothing + select (DownToN n) t@(Folder fld) = + do + let (fname,term) = Map.elemAt n fld + t' <- traverse' id (DownTo fname) term >>= + (return . fmap (\newv -> Folder $ + Map.adjust (const newv) fname fld)) + let nextd = let idx = succ n + in if idx == Map.size fld then next Up + else next (DownToN idx) + traverse' nextd Up (maybe t id t') >>= maybeM t' Just + + next next_dir dir = if dir == Next then next_dir else dir + maybeM onn onj v = return $ maybe onn onj v + + +fs1 :: Term = + 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)] + + +{- +-- self-application... +-- A sort of a 2-place Y-combinator: term2 f = f (term2 f) (term2 f) +-- The recursion is represented via sharing indeed +-- term2 represents an infinite tree spanning in depth and in breadth +term2 = L "f" (A (A f (A term2 f)) (A term2 f)) where f = Var "f" + +-} + +testt1 = runIdentity (traverse (\_ term -> return (Nothing,Next)) fs1) +-- *Zipper2> testt1 == fs1 +-- True + +testt2 = traverse tf fs1 + where tf dir term = do print dir; print term; return (Nothing,Next) +testt3 = traverse tf fs1 + where + tf (DownTo "d11") term = do + print "cutting" + print term + return (Nothing,Up) + tf dir term = do + print term + return (Nothing,Next) + + +testt4 = runIdentity (traverse tf fs1) + where tf (DownTo "d11") _ = return (Just $ Folder $ Map.empty ,Up) + tf (DownTo "fl2") _ = return (Just $ File $ "New file2", Up) + tf _ _ = return (Nothing,Next) + +lprint x = liftIO $ print x + +-- fs2 is harder to handle via traverse as we are liable to loop +-- easily. Zipper is far better for fs2 +-- In general, traverse is better for context-insensitive transformations +-- and zipper is for context-sensitive + +-- Note that the zipper data structure is very generic +-- It depends only on the _interface_ of the traversal function +-- (but not on its implementation) + +-- One may say, why not to put path accumulation into `traverse' itself? +-- We could have. However, we wish to illustrate here that the traverse +-- deals only with the local information. Accumulating it into a global +-- state is left for the clients. Zipper can let us add a new, `missing' +-- aspect to the enumerator. + +data DZipper r m term dir = + DZipper{ + dz_dir :: dir, + dz_path :: [dir], + dz_term :: term, + dz_k :: CCT r m (Maybe term, dir) -> CCT r m (DZipper r m term dir) + } + | DZipDone term + +data HPReq r m dir = HPReq dir (CCT r m [dir] -> CCT r m (HPReq r m dir)) + +dzip'term term = do + p <- newPrompt + path_pr <- newPrompt + pushPrompt p (acc_path [] (pushPrompt path_pr ( + traverse (tf p path_pr) term >>= + done p))) + where tf p path_pr dir term = + do + path <- shift path_pr (\k -> return (HPReq dir k)) + shift p (\k -> return (DZipper dir path term k)) + acc_path path body = + do + HPReq dir k <- body + let new_path = if dir == Up then tail path else dir:path + acc_path new_path (k (return new_path)) + -- we use abort to return the result... + done p term = abort p (return $ DZipDone term) + +testdz1 :: IO () + = runCCT ( + do + dz <- dzip'term fs1 + let loop (DZipDone term) = lprint "Finished" >> lprint term + loop dz = + do + lprint $ (show $ dz_dir dz) ++ "->" ++ (show $ dz_path dz) + lprint $ dz_term dz + dz_k dz (return (Nothing,Next)) >>= loop + loop dz + ) + + +{- + + +zip'through (ZipDone term) = lprint "Done" >> lprint term +zip'through (Zipper dir term k) = do lprint dir; lprint term + nz <- k (return (Nothing,Next)) + zip'through nz + +zip'move dir (Zipper _ term k) = do lprint dir; lprint term + k (return (Nothing,dir)) + + +tz1 :: IO () = runCCT (zip'term traverse term1 >>= zip'through) + +tz2 :: IO () + = runCCT ( + do + zipper <- zip'term traverse term1 + z1 <- zip'move Next zipper + Zipper d (A _ _) k <- zip'move Next z1 + k (return (Just (A (Var "x") (Var "x")),Up)) >>= zip'move Down + >>= zip'through + -- uncomment the following to see that the cursor z1 + -- is still valid, but it doesn't see the changes + --zip'through z1 + -- but the same cursor sees its own changes! + ) + +tz3 :: IO () + = runCCT ( + do + zipper <- zip'term traverse term2 + let max_depth = 5 + t <- traverse_replace max_depth zipper 0 + lprint "Final"; lprint t) + where + traverse_replace max_depth (Zipper dir term k) depth = + do + let new_depth = update_depth dir depth + let loop z = traverse_replace max_depth z new_depth + if new_depth <= max_depth then k (return (Nothing, Next)) >>= loop + else case term of + L "f" _ -> k (return (Just (L "f" (Var "f")),Up)) >>= + loop + _ -> k (return (Nothing, Next)) >>= loop + traverse_replace max_depth (ZipDone term) depth = return term + + update_depth Up = (+ (-1)) + update_depth _ = (+ 1) + +-} diff --git a/zfs.pdf b/zfs.pdf new file mode 100644 Binary files /dev/null and b/zfs.pdf differ