├── .gitignore ├── Setup.hs ├── README.md ├── ZFS.cabal └── src ├── ZipperM.hs └── ZFS.hs /.gitignore: -------------------------------------------------------------------------------- 1 | zfs.pdf 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | 3 | import Distribution.Simple 4 | 5 | main = defaultMainWithHooks defaultUserHooks 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ZipperFS 2 | 3 | > Zipper-based File/Operating system with threading and exceptions all realized 4 | > via delimited continuations. There are no unsafe operations, no GHC (let 5 | > alone) Unix threads, no concurrency problems. Our threads can't even do IO and 6 | > can't mutate any global state - and the type system sees to it. 7 | 8 | ## setup 9 | 10 | ``` 11 | git clone https://github.com/jkarni/ZipperFS 12 | cd ZipperFS 13 | cabal install 14 | ``` 15 | 16 | ## usage 17 | 18 | ``` 19 | $ ghci 20 | GHCi, version 8.0.2: http://www.haskell.org/ghc/ :? for help 21 | Prelude> :load src/ZFS.hs src/ZipperM.hs 22 | [1 of 2] Compiling ZipperM ( src/ZipperM.hs, interpreted ) 23 | [2 of 2] Compiling ZFS ( src/ZFS.hs, interpreted ) 24 | ... 25 | *ZFS> main' fs1 26 | Entering the osloop 27 | ``` 28 | 29 | then, in another terminal 30 | 31 | ``` 32 | telnet localhost 1503 33 | Trying 127.0.0.1... 34 | Connected to localhost. 35 | Escape character is '^]'. 36 | 37 | /> help 38 | Commands: quit, cd, ls, cat, next, mkdir, touch, echo, rm, mv, cp, help, commit, refresh 39 | ``` 40 | 41 | ## license 42 | 43 | This code is in the public domain. 44 | 45 | ## references 46 | 47 | - [original source website](https://web.archive.org/web/20200215013516/http://okmij.org/ftp/continuations/zipper.html) 48 | - [the slides from ZipperFS's presentation](https://web.archive.org/web/20190809002903/http://okmij.org/ftp/continuations/ZFS/zfs-talk.pdf) 49 | - [ZipperFS's paper](https://web.archive.org/web/20190809002914/http://okmij.org/ftp/continuations/ZFS/context-OS.pdf) 50 | - [zipper definition](https://web.archive.org/web/20181013022915/https://xlinux.nist.gov/dads/HTML/zipper.html) 51 | - [Using zippers to handle huge trees](https://web.archive.org/web/20181013022915/http://caml.inria.fr/pub/ml-archives/caml-list/2003/04/d9701aacd4580cf3feb60ae8cd7a1836.en.html) 52 | -------------------------------------------------------------------------------- /ZFS.cabal: -------------------------------------------------------------------------------- 1 | name: ZFS 2 | version: 0.0.2 3 | 4 | license: PublicDomain 5 | author: Amr Sabry, R. Kent Dybvig, Simon L. Peyton Jones, Oleg Kiselyov 6 | maintainer: Julian K. Arni 7 | homepage: https://github.com/jkarni/ZipperFS 8 | bug-reports: https://github.com/jkarni/ZipperFS/issues 9 | 10 | stability: Experimental 11 | category: Monads 12 | synopsis: Oleg's Zipper FS 13 | description: A implementation of a zipper filesystem using delimited continuations. 14 | . 15 | Zipper-based File/Operating system 16 | with threading and exceptions all realized via delimited continuations. 17 | There are no unsafe operations, no GHC (let alone) Unix threads, 18 | no concurrency problems. Our threads can't even do IO and can't 19 | mutate any global state - and the type system sees to it. 20 | . 21 | To run, type @main' fs1@ on ghci after loading ZFS.hs. 22 | Then from some other terminal, type 'telnet localhost 1503'. 23 | 24 | data-files: zfs.pdf, README 25 | Cabal-Version: >= 1.8 26 | Tested-With: GHC==8.0.2 27 | build-type: Simple 28 | 29 | source-repository head 30 | type: git 31 | location: git://github.com/jkarni/ZipperFS.git 32 | 33 | Library 34 | build-depends: base > 3 && < 5 35 | , mtl 36 | , unix 37 | , network 38 | , containers 39 | , CC-delcont 40 | hs-source-dirs: src 41 | exposed-modules: ZFS, ZipperM 42 | 43 | ghc-options: -Wall -threaded 44 | ghc-prof-options: -prof -auto-all 45 | -------------------------------------------------------------------------------- /src/ZipperM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module ZipperM (Term(..) 3 | , FileName 4 | , FileCont 5 | , Path(..) 6 | , DZipper(..) 7 | , dzip'term 8 | , module Control.Monad.CC 9 | , promptP 10 | ) where 11 | 12 | import Prelude hiding (traverse) 13 | import Control.Monad.CC 14 | import Control.Monad.Identity 15 | import Control.Monad.Trans 16 | import Data.Map as Map 17 | 18 | --------------------------------------------------------------- 19 | -- Control operators 20 | 21 | -- Non-darcs 22 | -- promptP :: (MonadDelimitedCont p s t) => (p a -> t a) -> t a 23 | 24 | -- Darcs repo of CC-delcont 25 | -- promptP :: (MonadDelimitedCont t) => (Prompt t a -> t a) -> t a 26 | 27 | promptP f = do p <- newPrompt; pushPrompt p (f p) 28 | 29 | --------------------------------------------------------------- 30 | -- Term to traverse 31 | 32 | type FileName = String 33 | type FileCont = String 34 | data Term = File String | Folder (Map.Map FileName Term) 35 | 36 | instance Show Term where 37 | showsPrec _ (File file) = (file ++) 38 | showsPrec _ (Folder dir) = 39 | ("\n >>>" ++) . (Map.foldWithKey fl ("\n<<<" ++) dir) 40 | where fl k term acc = ("\n" ++) . (k ++) . (": " ++) . 41 | (showsPrec 5 term) . acc 42 | 43 | -- Path in the Term 44 | -- Down is the same as DownToN 0 -- descend to the first child 45 | data Path = Down | DownTo FileName | DownToN Int | Up | Next 46 | deriving (Eq, Show) 47 | 48 | -- Updateable traverse that maximally preserves the sharing 49 | traverse tf term = traverse' id Down term >>= maybeM term id 50 | where traverse' next_dir init_dir term = 51 | do 52 | (term', direction) <- tf init_dir term 53 | let new_term = maybe term id term' 54 | select (next_dir direction) new_term >>= maybeM term' Just 55 | select Up t = return Nothing 56 | select Next t@(File _) = return Nothing 57 | select dir@(DownTo fname) t@(Folder fld) = 58 | select (DownToN (Map.findIndex fname fld)) t 59 | select dir t@(Folder _) | dir == Next || dir == Down = 60 | select (DownToN 0) t 61 | select (DownToN n) t@(Folder fld) | n >= Map.size fld = 62 | return Nothing 63 | select (DownToN n) t@(Folder fld) = 64 | do 65 | let (fname,term) = Map.elemAt n fld 66 | t' <- traverse' id (DownTo fname) term >>= 67 | (return . fmap (\newv -> Folder $ 68 | Map.adjust (const newv) fname fld)) 69 | let nextd = let idx = succ n 70 | in if idx == Map.size fld then next Up 71 | else next (DownToN idx) 72 | traverse' nextd Up (maybe t id t') >>= maybeM t' Just 73 | 74 | next next_dir dir = if dir == Next then next_dir else dir 75 | maybeM onn onj v = return $ maybe onn onj v 76 | 77 | 78 | fs1 :: Term = 79 | Folder $ Map.fromList [("d1",d1), ("d2",Folder $ Map.empty), 80 | ("fl1", File "File1"), 81 | ("fl2", File "File2")] 82 | where d1 = Folder $ Map.fromList [("fl13",File "File 3"), 83 | ("d11", d11)] 84 | d11 = Folder $ Map.fromList [("d111", Folder $ Map.empty)] 85 | 86 | 87 | {- 88 | -- self-application... 89 | -- A sort of a 2-place Y-combinator: term2 f = f (term2 f) (term2 f) 90 | -- The recursion is represented via sharing indeed 91 | -- term2 represents an infinite tree spanning in depth and in breadth 92 | term2 = L "f" (A (A f (A term2 f)) (A term2 f)) where f = Var "f" 93 | 94 | -} 95 | 96 | testt1 = runIdentity (traverse (\_ term -> return (Nothing,Next)) fs1) 97 | -- *Zipper2> testt1 == fs1 98 | -- True 99 | 100 | testt2 = traverse tf fs1 101 | where tf dir term = do print dir; print term; return (Nothing,Next) 102 | testt3 = traverse tf fs1 103 | where 104 | tf (DownTo "d11") term = do 105 | print "cutting" 106 | print term 107 | return (Nothing,Up) 108 | tf dir term = do 109 | print term 110 | return (Nothing,Next) 111 | 112 | 113 | testt4 = runIdentity (traverse tf fs1) 114 | where tf (DownTo "d11") _ = return (Just $ Folder $ Map.empty ,Up) 115 | tf (DownTo "fl2") _ = return (Just $ File $ "New file2", Up) 116 | tf _ _ = return (Nothing,Next) 117 | 118 | lprint x = liftIO $ print x 119 | 120 | -- fs2 is harder to handle via traverse as we are liable to loop 121 | -- easily. Zipper is far better for fs2 122 | -- In general, traverse is better for context-insensitive transformations 123 | -- and zipper is for context-sensitive 124 | 125 | -- Note that the zipper data structure is very generic 126 | -- It depends only on the _interface_ of the traversal function 127 | -- (but not on its implementation) 128 | 129 | -- One may say, why not to put path accumulation into `traverse' itself? 130 | -- We could have. However, we wish to illustrate here that the traverse 131 | -- deals only with the local information. Accumulating it into a global 132 | -- state is left for the clients. Zipper can let us add a new, `missing' 133 | -- aspect to the enumerator. 134 | 135 | data DZipper r m term dir = 136 | DZipper{ 137 | dz_dir :: dir, 138 | dz_path :: [dir], 139 | dz_term :: term, 140 | dz_k :: CCT r m (Maybe term, dir) -> CCT r m (DZipper r m term dir) 141 | } 142 | | DZipDone term 143 | 144 | data HPReq r m dir = HPReq dir (CCT r m [dir] -> CCT r m (HPReq r m dir)) 145 | 146 | dzip'term term = do 147 | p <- newPrompt 148 | path_pr <- newPrompt 149 | pushPrompt p (acc_path [] (pushPrompt path_pr ( 150 | traverse (tf p path_pr) term >>= 151 | done p))) 152 | where tf p path_pr dir term = 153 | do 154 | path <- shift path_pr (\k -> return (HPReq dir k)) 155 | shift p (\k -> return (DZipper dir path term k)) 156 | acc_path path body = 157 | do 158 | HPReq dir k <- body 159 | let new_path = if dir == Up then tail path else dir:path 160 | acc_path new_path (k (return new_path)) 161 | -- we use abort to return the result... 162 | done p term = abort p (return $ DZipDone term) 163 | 164 | testdz1 :: IO () 165 | = runCCT ( 166 | do 167 | dz <- dzip'term fs1 168 | let loop (DZipDone term) = lprint "Finished" >> lprint term 169 | loop dz = 170 | do 171 | lprint $ (show $ dz_dir dz) ++ "->" ++ (show $ dz_path dz) 172 | lprint $ dz_term dz 173 | dz_k dz (return (Nothing,Next)) >>= loop 174 | loop dz 175 | ) 176 | 177 | 178 | {- 179 | 180 | 181 | zip'through (ZipDone term) = lprint "Done" >> lprint term 182 | zip'through (Zipper dir term k) = do lprint dir; lprint term 183 | nz <- k (return (Nothing,Next)) 184 | zip'through nz 185 | 186 | zip'move dir (Zipper _ term k) = do lprint dir; lprint term 187 | k (return (Nothing,dir)) 188 | 189 | 190 | tz1 :: IO () = runCCT (zip'term traverse term1 >>= zip'through) 191 | 192 | tz2 :: IO () 193 | = runCCT ( 194 | do 195 | zipper <- zip'term traverse term1 196 | z1 <- zip'move Next zipper 197 | Zipper d (A _ _) k <- zip'move Next z1 198 | k (return (Just (A (Var "x") (Var "x")),Up)) >>= zip'move Down 199 | >>= zip'through 200 | -- uncomment the following to see that the cursor z1 201 | -- is still valid, but it doesn't see the changes 202 | --zip'through z1 203 | -- but the same cursor sees its own changes! 204 | ) 205 | 206 | tz3 :: IO () 207 | = runCCT ( 208 | do 209 | zipper <- zip'term traverse term2 210 | let max_depth = 5 211 | t <- traverse_replace max_depth zipper 0 212 | lprint "Final"; lprint t) 213 | where 214 | traverse_replace max_depth (Zipper dir term k) depth = 215 | do 216 | let new_depth = update_depth dir depth 217 | let loop z = traverse_replace max_depth z new_depth 218 | if new_depth <= max_depth then k (return (Nothing, Next)) >>= loop 219 | else case term of 220 | L "f" _ -> k (return (Just (L "f" (Var "f")),Up)) >>= 221 | loop 222 | _ -> k (return (Nothing, Next)) >>= loop 223 | traverse_replace max_depth (ZipDone term) depth = return term 224 | 225 | update_depth Up = (+ (-1)) 226 | update_depth _ = (+ 1) 227 | 228 | -} 229 | -------------------------------------------------------------------------------- /src/ZFS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | {- 7 | Zipper-based File/Operating system 8 | with threading and exceptions all realized via delimited continuations. 9 | There are no unsafe operations, no GHC (let alone) Unix threads, 10 | no concurrency problems. Our threads can't even do IO and can't 11 | mutate any global state -- and the type system sees to it. 12 | 13 | Please see http://pobox.com/~oleg/ftp/papers/zfs-talk.pdf 14 | for the demo and explanations. 15 | 16 | -- $Id: ZFS.hs,v 1.8 2005/10/14 23:00:41 oleg Exp $ 17 | 18 | NOTE: the above demo and explanation can be viewed at the following url: 19 | - https://web.archive.org/web/20190809002903/http://okmij.org/ftp/continuations/ZFS/zfs-talk.pdf 20 | -} 21 | 22 | 23 | 24 | module ZFS where 25 | 26 | import ZipperM 27 | 28 | import Control.Exception (try, bracket) 29 | import Control.Monad.Trans (liftIO, MonadIO()) 30 | import qualified Data.List as List 31 | import qualified Data.Map as Map 32 | import Foreign -- needed for select hacks: 33 | import Foreign.C -- Unix select is not available in 34 | import Foreign.Ptr -- GHC 35 | import Network.Socket 36 | import System.IO 37 | import qualified System.IO.Error as IO 38 | import System.Posix (closeFd) 39 | import System.Posix.Types(Fd(..)) 40 | 41 | -- import CC_FrameT (runCC) -- have to import runCC manually, even though the import of 42 | -- ZipperM should pull it in. 43 | 44 | -- Port to serve clients from 45 | newClientPort :: PortNumber 46 | newClientPort = 1503 47 | -- select_timeout = 100000 -- microseconds 48 | 49 | -- Initial content of the file system 50 | -- Certainly, structurally richer filesystems are equally possible 51 | -- (where content is annotated with attributes, e.g.) 52 | -- A lambda-term can be made a filesystem too 53 | fs1 :: Term 54 | fs1 = Folder $ Map.fromList [("d1",d1), ("d2",Folder $ Map.empty), 55 | ("fl1", File "File1"), 56 | ("fl2", File "File2")] 57 | where d1 = Folder $ Map.fromList [("fl13",File "File 3"), 58 | ("d11", d11)] 59 | d11 = Folder $ Map.fromList [("d111", Folder $ Map.empty)] 60 | 61 | -- Another file system -- this time, it is cyclic! 62 | fs2 :: Term 63 | fs2 = Folder $ Map.fromList [("d1",fs2), ("fl1", File "File1")] 64 | 65 | -- Operating system requests: from a ``process'' to the ``OS'' 66 | type FSZipper r m = DZipper r m Term Path 67 | 68 | -- Note: the base monad type `m' is left polymorphic. 69 | -- A Process doesn't do any IO (it asks the ``OS''). 70 | -- So, the significant part of the OS, the process itself, is overtly 71 | -- outside the IO monad! 72 | -- Note: using different prompts, the requests can be modularized. 73 | -- Unlike OS (with its only one syscall handler), we can have as 74 | -- many syscall handlers as we wish. 75 | data OSReq r m = OSRDone 76 | | OSRRead (ReadK r m) 77 | | OSRWrite String (UnitK r m) 78 | | OSRTrace String (UnitK r m) -- so a process can syslog 79 | | OSRCommit Term (UnitK r m) 80 | | OSRefresh (CCT r m (FSZipper r m) -> CCT r m (OSReq r m)) 81 | 82 | type UnitK r m = CCT r m () -> CCT r m (OSReq r m) 83 | type ReadK r m = CCT r m String -> CCT r m (OSReq r m) 84 | 85 | data ProcessCTX = ProcessCTX { psocket :: Socket -- process' socket 86 | } 87 | 88 | -- A process can only be blocked on reading. For simplicity we assume 89 | -- that writing into the client socket never blocks 90 | 91 | data JobQueueT r = JQBlockedOnRead ProcessCTX (ReadK r IO) 92 | | JQRunnable ProcessCTX (UnitK r IO) 93 | | JQNewClient Socket -- accept new clients from 94 | 95 | data World r = World { mountedFS :: Term 96 | , jobQueue :: [JobQueueT r] 97 | , osPrompt :: Prompt r (OSReq r IO) 98 | } 99 | 100 | main' :: Term -> IO a 101 | main' fs = bracket (serverSocket newClientPort) sClose $ 102 | \s -> 103 | do 104 | -- The following doesn't help: accept blocks anyway... 105 | -- setFdOption (Fd (fdSocket s)) NonBlockingRead True 106 | runCCT $ do 107 | p <- newPrompt 108 | syslog ["Entering the osloop",show s] 109 | osloop $ World{ 110 | mountedFS = fs, 111 | jobQueue = [JQNewClient s], 112 | osPrompt = p} 113 | where 114 | serverSocket port = do 115 | s <- socket AF_INET Stream 0 116 | setSocketOption s ReuseAddr 1 117 | localhost <- inet_addr "127.0.0.1" 118 | bindSocket s (SockAddrInet port localhost) 119 | listen s 5 120 | return s 121 | 122 | -- In OS parlance, the following is the interrupt handler. 123 | -- It `waits' for interrupts that is, if any input socket has something 124 | -- to read from. 125 | -- It doesn't actually return, so the answer type is just any 126 | -- osloop :: World r -> CCT r IO any 127 | osloop world = 128 | maybe (wait'for'intr world) (uncurry try'to'run) (find'runnable world) 129 | >>= osloop 130 | 131 | where 132 | -- Try to find the first runnable job 133 | find'runnable world = case break is'runnable (jobQueue world) of 134 | (_,[]) -> Nothing 135 | (jq1,(runnable:jq2)) -> Just (runnable, world{jobQueue=jq1++jq2}) 136 | where is'runnable (JQRunnable _ _) = True 137 | is'runnable _ = False 138 | 139 | wait'for'intr world@World{jobQueue=jq} = 140 | do readyfd <- liftIO $ select'read'pending mfd 141 | case break (\e -> maybe False (`elem` readyfd) (toFD e)) jq of 142 | (_,[]) -> return world -- nothing found 143 | (jq1,(now'runnable:jq2)) -> 144 | try'to'run now'runnable world{jobQueue=jq1++jq2} 145 | where 146 | -- compile the list of file descriptors we are waiting at 147 | mfd = foldr (\e a -> maybe [] (:a) (toFD e)) [] jq 148 | toFD (JQNewClient s) = Just $ fdSocket s 149 | toFD (JQBlockedOnRead ProcessCTX{psocket=s} _) = Just $ fdSocket s 150 | toFD _ = Nothing 151 | 152 | -- Add to the end of the job queue 153 | enqueue el world = world{jobQueue = jobQueue world ++ [el]} 154 | 155 | -- ifnM action onf ont = liftIO action >>= \b -> if b then ont else onf 156 | 157 | -- New client is trying to connect 158 | try'to'run qe@(JQNewClient s) world = 159 | do 160 | syslog ["accepting from",show s] 161 | (clientS,addr) <- liftIO $ accept s 162 | liftIO $ setSocketOption clientS NoDelay 1 163 | syslog ["accepted new client connection from ", show addr] 164 | let newCtx = ProcessCTX clientS 165 | run'process (fsProcess (dzip'term (mountedFS world)))(osPrompt world) 166 | >>= interpret'req (enqueue qe world) newCtx 167 | 168 | try'to'run (JQRunnable ctx k) world = 169 | k (return ()) >>= interpret'req world ctx 170 | 171 | -- A client socket may have something to read 172 | try'to'run (JQBlockedOnRead ctx@ProcessCTX{psocket=s} k) world = 173 | do 174 | syslog ["reading from",show s] 175 | syslog ["osloop: queue size: ", show $ length $ jobQueue world] 176 | dat <- liftIO $ ( 177 | do r <- try (recv s (1024 * 8)) 178 | case r of 179 | Left err -> if IO.isEOFError err then return "" 180 | else ioError err 181 | Right msg -> return msg) 182 | k (return dat) >>= interpret'req world ctx 183 | 184 | -- The system logger 185 | syslog :: (Control.Monad.Trans.MonadIO m) => [String] -> m () 186 | syslog s = liftIO $ putStrLn (concat s) 187 | 188 | -- The interpreter of OS requests -- the syscall handler, in OS parlance 189 | -- It handles simple requests by itself. When the request involves 190 | -- rescheduling or change in the global OS state, it returns to 191 | -- the scheduler/interrupt-handler/osloop. 192 | 193 | -- The process is finished 194 | interpret'req :: World r -> ProcessCTX -> OSReq r IO -> CCT r IO (World r) 195 | interpret'req world ctx OSRDone = (liftIO $ sClose $ psocket ctx) 196 | >> return world 197 | 198 | -- The request for read may block. So, we do the context switch and go 199 | -- to the main loop, to check if the process socket has something to read 200 | -- from 201 | interpret'req world ctx (OSRRead k) = 202 | return world{jobQueue = (jobQueue world) ++ [JQBlockedOnRead ctx k]} 203 | 204 | -- We assume that writing to a socket never blocks 205 | interpret'req world ctx (OSRWrite datum k) = 206 | do 207 | send' (psocket ctx) datum 208 | k (return ()) >>= interpret'req world ctx 209 | where 210 | send' _ "" = return () 211 | send' s msg = do c <- liftIO $ send s msg 212 | send' s (drop c msg) 213 | 214 | interpret'req world ctx (OSRTrace datum k) = 215 | do 216 | syslog ["Trace from",show $ psocket ctx,": ",datum] 217 | k (return ()) >>= interpret'req world ctx 218 | 219 | interpret'req world ctx (OSRCommit term k) = 220 | return world{jobQueue = (jobQueue world) ++ [JQRunnable ctx k], 221 | mountedFS = term} 222 | 223 | interpret'req world ctx (OSRefresh k) = 224 | k (dzip'term $ mountedFS world) >>= interpret'req world ctx 225 | 226 | -- We have the functionality of threads -- although our whole program 227 | -- is simply threaded, both at the OS level and at the GHC runtime level. 228 | -- Our process functions don't even have the IO type! 229 | -- Note, the function to run the process has forall m. That means, a process 230 | -- function can't do any IO and can't have any reference cells. 231 | -- Processes can't mutate the global state -- and the type system checks that! 232 | -- Because processes can't interfere with each other and with the OS, there 233 | -- is no need for any thread synchronization, locking, etc. We get 234 | -- the transactional semantics for free. 235 | -- Of course, as different processes manipulate their own (copy-on-write) 236 | -- terms (file systems), when the processes commit, there may be conflicts. 237 | -- So, one has to implement some conflict resolution -- be it versioning, 238 | -- patching, asking for permission for update, etc. But 239 | -- these policies are implemented at the higher-level; the programmer can 240 | -- implement any set of policies. Because processes always ask the supervisor 241 | -- for anything, and the supervisor has the view of the global state, 242 | -- the resolution policies are easier to implement in this execution model. 243 | run'process :: (forall m. Monad m => 244 | (Prompt r (OSReq r m)) -> CCT r m (OSReq r m)) 245 | -> Prompt r (OSReq r IO) -> CCT r IO (OSReq r IO) 246 | run'process body p = pushPrompt p (body p) 247 | 248 | -- Processes. No IO action is possible in here 249 | fsProcess :: Monad m => 250 | CCT r m (FSZipper r m) -> Prompt r (OSReq r m) 251 | -> CCT r m (OSReq r m) 252 | fsProcess zipper'action svcp = 253 | do 254 | z <- zipper'action 255 | svc svcp $ OSRTrace "Begin process" 256 | fsloop z svcp "" 257 | 258 | fsloop :: forall r (m :: * -> *). 259 | (Monad m) => 260 | DZipper r m Term Path 261 | -> Prompt r (OSReq r m) 262 | -> String 263 | -> CCT r m (OSReq r m) 264 | fsloop z svcp line'acc 265 | = do 266 | send_shell_prompt z svcp 267 | (line,rest) <- read'line line'acc 268 | let (cmd,arg) = breakspan is'whitespace line 269 | svc svcp $ OSRTrace $ "received command: " ++ cmd 270 | maybe (svc svcp (OSRWrite $ "bad command: " ++ cmd) >> 271 | fsloop z svcp rest) 272 | (\h -> h z svcp cmd arg rest) 273 | (List.lookup cmd fsCommands) 274 | where 275 | -- Read until we get newline 276 | read'line acc = case break is'nl acc of 277 | (_,"") -> do 278 | b <- svc svcp OSRRead 279 | svc svcp $ OSRTrace $ "Read str: " ++ b 280 | (l,rest) <- read'line b 281 | return (acc ++ l, rest) 282 | (l,rest) -> return (l,snd $ span is'nl rest) 283 | 284 | send_shell_prompt z svcp = 285 | svc svcp $ OSRWrite $ ("\n" ++ show_path (dz_path z) ++ "> ") 286 | 287 | show_path :: [Path] -> String 288 | show_path path = concatMap (\pc -> case pc of 289 | Down -> "/" 290 | DownTo s -> s ++ "/") 291 | (reverse path) 292 | 293 | fsCommands :: Monad m => [(String,FSZipper r m -> Prompt r (OSReq r m) -> 294 | String -> String -> String -> 295 | CCT r m (OSReq r m))] 296 | 297 | fsCommands = 298 | [ 299 | ("quit", \_ svcp _ _ _ -> svc svcp $ const OSRDone), 300 | ("cd", fsWrapper 301 | (\z shp _ path -> cd'zipper z shp path >>= return . FSCZ)), 302 | ("ls", fsWrapper cmd'ls), 303 | ("cat", fsWrapper cmd'ls), 304 | ("next", fsWrapper cmd'next), 305 | 306 | ("mkdir", fsWrapper (cmd'mknode (Folder Map.empty))), 307 | ("touch", fsWrapper (cmd'mknode (File ""))), 308 | 309 | ("echo", fsWrapper cmd'echo), 310 | ("rm", fsWrapper cmd'rm), 311 | ("mv", fsWrapper cmd'mv), 312 | ("cp", fsWrapper cmd'cp), 313 | 314 | ("help", fsWrapper cmd'help), 315 | 316 | ("commit", fcmd'commit), 317 | ("refresh", \_ svcp _ _ rest -> svc svcp OSRefresh >>= 318 | \z -> fsloop z svcp rest) 319 | -- could have a command ``down N'' -- positional descend 320 | -- Note: next is really cool! 321 | -- Note, we can cd inside a file! So, cat is just `ls' inside a file 322 | ] 323 | 324 | fcmd'commit :: forall t t1 r (m :: * -> *). 325 | (Monad m) => 326 | DZipper r m Term Path 327 | -> Prompt r (OSReq r m) 328 | -> t 329 | -> t1 330 | -> String 331 | -> CCT r m (OSReq r m) 332 | fcmd'commit z svcp _ _ rest = aux z 333 | where 334 | aux (DZipDone term) = (svc svcp $ OSRCommit term) >> 335 | fsloop z svcp rest 336 | aux DZipper{dz_k = k} = k (return (Nothing,Up)) >>= aux 337 | 338 | 339 | data FSCmdResp r m = FSCS String | FSCZ (FSZipper r m) 340 | 341 | -- We use delimited continuations rather than an Error monad 342 | -- A delimited continuation suffices! 343 | fsWrapper :: forall t t1 r (m :: * -> *). 344 | (Monad m) => 345 | (FSZipper r m 346 | -> Prompt r (FSCmdResp r m) 347 | -> t 348 | -> t1 349 | -> CCT r m (FSCmdResp r m)) 350 | -> FSZipper r m 351 | -> Prompt r (OSReq r m) 352 | -> t 353 | -> t1 354 | -> String 355 | -> CCT r m (OSReq r m) 356 | fsWrapper cmd z svcp cmd'name cmd'arg rest = 357 | do 358 | shp <- newPrompt 359 | resp <- pushPrompt shp (cmd z shp cmd'name cmd'arg) 360 | z' <- case resp of 361 | FSCS str -> (svc svcp $ OSRWrite str) >> return z 362 | FSCZ z -> return z 363 | fsloop z' svcp rest 364 | 365 | cmd'help :: forall t 366 | t1 367 | t2 368 | (m :: * -> *) 369 | r 370 | (m1 :: * -> *) 371 | r1 372 | (m2 :: * -> *). 373 | (Monad m, Monad m1) => 374 | FSZipper r m -> t -> t1 -> t2 -> m1 (FSCmdResp r1 m2) 375 | cmd'help z _ _ _ = return $ FSCS $ "Commands: " ++ 376 | (concat $ List.intersperse ", " $ List.map fst cmds) 377 | where 378 | 379 | cmds :: [(String, FSZipper r2 m 380 | -> Prompt r2 (OSReq r2 m) 381 | -> String 382 | -> String 383 | -> String 384 | -> CCT r2 m (OSReq r2 m))] 385 | cmds = fsCommands 386 | 387 | cmd'ls :: forall t 388 | r 389 | (m :: * -> *) 390 | r1 391 | (m1 :: * -> *). 392 | (Monad m) => 393 | FSZipper r m 394 | -> Prompt r (FSCmdResp r m) 395 | -> t 396 | -> String 397 | -> CCT r m (FSCmdResp r1 m1) 398 | cmd'ls z shp _ slash'path = cd'zipper z shp slash'path 399 | >>= return . FSCS . list_node 400 | 401 | cmd'next :: forall t t1 t2 r (m :: * -> *). 402 | (Monad m) => 403 | DZipper r m Term Path 404 | -> t 405 | -> t1 406 | -> t2 407 | -> CCT r m (FSCmdResp r m) 408 | cmd'next z _ _ _ = 409 | do z' <- dz_k z (return (Nothing,Next)) 410 | return $ FSCZ $ case z' of DZipDone _ -> z; _ -> z' 411 | 412 | -- main navigation function 413 | cd'zipper :: Monad m => 414 | FSZipper r m -> Prompt r (FSCmdResp r m) -> String 415 | -> CCT r m (FSZipper r m) 416 | cd'zipper z _ "" = return z 417 | cd'zipper z shp ('/':path) = do z' <- ascend'to'root z; cd'zipper z' shp path 418 | where 419 | ascend'to'root z = 420 | dz_k z (return (Nothing,Up)) >>= ascend'to'root' z 421 | ascend'to'root' z (DZipDone _) = return z 422 | ascend'to'root' _ z = ascend'to'root z 423 | 424 | cd'zipper z shp ('.':'.':path) = aux z (snd $ span (=='/') path) 425 | where 426 | aux DZipper{dz_path = [Down]} _ = return z -- already at the top 427 | aux DZipper{dz_k = k} path = k (return (Nothing,Up)) >>= 428 | (\z -> cd'zipper z shp path) 429 | aux (DZipDone _) _ = return z 430 | 431 | cd'zipper DZipper{dz_term = File _} shp _ = 432 | abort shp (return $ FSCS "cannot descend down the file") 433 | cd'zipper DZipper{dz_term = Folder fld, dz_k = k} shp path 434 | = let (pc,prest) = breakspan (== '/') path 435 | in if Map.member pc fld then do 436 | z' <- k (return (Nothing,DownTo pc)) 437 | cd'zipper z' shp prest 438 | else abort shp (return $ FSCS $ "No such dir component " ++ pc) 439 | 440 | -- List the current contents of the node pointed by the zipper 441 | -- This function subsumes both `ls' and `cat' 442 | -- For files, it sends the content of the file 443 | list_node :: forall t (t1 :: * -> *) t2. 444 | DZipper t t1 Term t2 -> String 445 | list_node DZipper{dz_term = File str} = str 446 | list_node DZipper{dz_term = Folder fld} = 447 | Map.foldWithKey (\name el acc -> 448 | "\n" ++ name ++ (case el of Folder _ -> "/" 449 | _ -> "") ++ acc) 450 | "" fld 451 | list_node _ = "" 452 | 453 | -- make a node (an empty directory or an empty file or a moved node) 454 | -- named 'dirn' in the current directory 455 | cmd'mknode :: forall t 456 | r 457 | r1 458 | (m :: * -> *) 459 | (m1 :: * -> *). 460 | (Monad m1) => 461 | Term 462 | -> DZipper r m1 Term Path 463 | -> Prompt r (FSCmdResp r1 m) 464 | -> t 465 | -> String 466 | -> CCT r m1 (FSCmdResp r m1) 467 | cmd'mknode _ _ shp _ dirn | '/' `elem` dirn = 468 | abort shp (return $ FSCS "the name of the new node can't contain slash") 469 | cmd'mknode _ _ shp _ "" = 470 | abort shp (return $ FSCS "the name of the new node is empty") 471 | cmd'mknode _ DZipper{dz_term = File _} shp _ _ = 472 | abort shp (return $ FSCS "cannot create anything in a file") 473 | cmd'mknode _ DZipper{dz_term = Folder fld} shp _ dirn 474 | | Map.member dirn fld = 475 | abort shp (return $ FSCS $ "node " ++ dirn ++ " already exists") 476 | cmd'mknode newnode DZipper{dz_term = Folder fld, dz_k = k, dz_dir = cn} 477 | _ _ dirn = 478 | let fld' = Folder $ Map.insert dirn newnode fld 479 | in k (return (Just fld',Up)) >>= adj cn >>= return . FSCZ 480 | where 481 | -- go back to the current directory 482 | adj _ (DZipDone term) = dzip'term term 483 | adj cn z = dz_k z $ return (Nothing,cn) 484 | 485 | -- echo string > path 486 | cmd'echo :: forall t r (m :: * -> *). 487 | (Monad m) => 488 | DZipper r m Term Path 489 | -> Prompt r (FSCmdResp r m) 490 | -> t 491 | -> String 492 | -> CCT r m (FSCmdResp r m) 493 | cmd'echo z shp _ args = aux $ (reads::ReadS String) args 494 | where 495 | aux [(content,rest)] = aux1 content (snd $ span is'whitespace rest) 496 | aux _ = abort shp (return $ FSCS $ "bad format, str, of the echo cmd") 497 | aux1 content ('>':rest) = 498 | cd'zipper z shp (snd $ span is'whitespace rest) >>= aux2 content rest 499 | aux1 _ _ = abort shp (return $ FSCS $ "bad format, path, of the echo cmd") 500 | aux2 content _t DZipper{dz_term = File _, dz_k = k} = 501 | k (return (Just $ File content,Up)) >>= zip'back'to'place shp z 502 | >>= return . FSCZ 503 | aux2 _ rest _ = abort shp 504 | (return $ FSCS $ rest ++ " does not point to a file") 505 | 506 | -- |zip'back'to'place z z1| brings z1 to the same place as z 507 | -- Right now we use a pathetic algorithm -- but it works... 508 | zip'back'to'place :: forall r 509 | (m :: * -> *) 510 | r1 511 | (m1 :: * -> *) 512 | term. 513 | (Monad m) => 514 | Prompt r (FSCmdResp r m) 515 | -> DZipper r1 m1 term Path 516 | -> DZipper r m Term Path 517 | -> CCT r m (FSZipper r m) 518 | zip'back'to'place shp z (DZipDone term) = 519 | dzip'term term >>= zip'back'to'place shp z 520 | zip'back'to'place shp z z1 = cd'zipper z1 shp (show_path (dz_path z)) 521 | 522 | -- Delete the node pointed to by path and return the 523 | -- updated zipper (which points to the same location as z) and the 524 | -- deleted node 525 | del'zipper :: forall r (m :: * -> *). 526 | (Monad m) => 527 | DZipper r m Term Path 528 | -> Prompt r (FSCmdResp r m) 529 | -> String 530 | -> CCT r m (FSZipper r m, Term) 531 | del'zipper z shp path = cd'zipper z shp path >>= 532 | \z -> dz_k z (return (Nothing,Up)) >>= aux (dz_dir z) 533 | where 534 | aux _ (DZipDone _) = 535 | abort shp (return $ FSCS $ "cannot remove the root folder") 536 | aux (DownTo pc) DZipper{dz_term = Folder fld, dz_k = k} = 537 | let (Just old'node, fld') = Map.updateLookupWithKey (\_ _ -> Nothing) pc fld 538 | in k (return (Just $ Folder $ fld',Up)) 539 | >>= zip'back'to'place shp z >>= \z -> return (z,old'node) 540 | 541 | -- insert a node as `path' 542 | ins'zipper :: forall r (m :: * -> *). 543 | (Monad m) => 544 | Term 545 | -> FSZipper r m 546 | -> Prompt r (FSCmdResp r m) 547 | -> String 548 | -> CCT r m (FSCmdResp r m) 549 | ins'zipper node z0 shp path = 550 | do 551 | let (dirname,basename) = split'path path 552 | z <- if dirname == "" then return z0 else cd'zipper z0 shp dirname 553 | FSCZ z <- cmd'mknode node z shp "mv" basename 554 | zip'back'to'place shp z0 z >>= return . FSCZ 555 | 556 | -- rm path 557 | -- works both on directories and files 558 | -- One can even try to remove one's own parent -- and this is safe! 559 | cmd'rm :: forall t r (m :: * -> *). 560 | (Monad m) => 561 | DZipper r m Term Path 562 | -> Prompt r (FSCmdResp r m) 563 | -> t 564 | -> String 565 | -> CCT r m (FSCmdResp r m) 566 | cmd'rm z shp _ path = del'zipper z shp path >>= return . FSCZ . fst 567 | 568 | -- mv path_from path_to 569 | cmd'mv :: forall t r (m :: * -> *). 570 | (Monad m) => 571 | DZipper r m Term Path 572 | -> Prompt r (FSCmdResp r m) 573 | -> t 574 | -> String 575 | -> CCT r m (FSCmdResp r m) 576 | cmd'mv z shp _ args = aux $ breakspan is'whitespace args 577 | where 578 | aux ("",_) = abort shp (return $ FSCS $ "mv: from-path is empty") 579 | aux (_,"") = abort shp (return $ FSCS $ "mv: to-path is empty") 580 | aux (pfrom,pto) = del'zipper z shp pfrom >>= 581 | \ (z,node) -> ins'zipper node z shp pto 582 | 583 | -- cp path_from path_to 584 | -- We don't do any copying: we merely establish sharing: 585 | -- so a node accessible via `from_path' becomes accessible via `to_path' 586 | -- The copy-on-write semantics of ZFS does the rest. 587 | -- So, in ZFS, we can copy arbitrary file systems trees in constant time! 588 | cmd'cp :: forall t r (m :: * -> *). 589 | (Monad m) => 590 | DZipper r m Term Path 591 | -> Prompt r (FSCmdResp r m) 592 | -> t 593 | -> String 594 | -> CCT r m (FSCmdResp r m) 595 | cmd'cp z0 shp _ args = aux $ breakspan is'whitespace args 596 | where 597 | aux ("",_) = abort shp (return $ FSCS $ "cp: from-path is empty") 598 | aux (_,"") = abort shp (return $ FSCS $ "cp: to-path is empty") 599 | aux (pfrom,pto) = cd'zipper z0 shp pfrom >>= 600 | \z -> dz_k z (return (Nothing,Up)) >>= 601 | aux' (dz_dir z) pto 602 | aux' _ pto (DZipDone term) = 603 | dzip'term term >>= zip'back'to'place shp z0 >>= 604 | \z -> ins'zipper term z shp pto 605 | aux' (DownTo pc) pto z@DZipper{dz_term = Folder fld} = 606 | zip'back'to'place shp z0 z >>= 607 | \z -> ins'zipper ((Map.!) fld pc) z shp pto 608 | 609 | -- Supervisor call 610 | svc :: (Monad m) => Prompt r b -> ((CCT r m a -> CCT r m b) -> b) -> CCT r m a 611 | svc p req = ZipperM.shift p (return . req) 612 | 613 | is'nl, is'whitespace :: Char -> Bool 614 | is'whitespace c = c == ' ' || c == '\t' 615 | is'nl c = c == '\n' || c == '\r' 616 | 617 | breakspan :: (a -> Bool) -> [a] -> ([a], [a]) 618 | breakspan pred l = let (p1,p2) = break pred l 619 | in (p1,snd $ span pred p2) 620 | 621 | -- break the path into (dirname,basename) 622 | split'path :: String -> (String, String) 623 | split'path path = let (p1,p2) = breakspan (=='/') (reverse path) 624 | in (reverse p2, reverse p1) 625 | 626 | ------------------------------------------------------------------------ 627 | -- Some hacks to get around the lack of select 628 | 629 | -- Darn! We don't have the real select over several descriptors! 630 | -- We have to implement it ourselves 631 | type FDSET = CUInt 632 | type TIMEVAL = CLong -- Two longs 633 | foreign import ccall "unistd.h select" c_select 634 | :: CInt -> Ptr FDSET -> Ptr FDSET -> Ptr FDSET -> Ptr TIMEVAL -> IO CInt 635 | 636 | -- Convert a file descriptor to an FDSet (for use with select) 637 | -- essentially encode a file descriptor in a big-endian notation 638 | fd2fds :: CInt -> [FDSET] 639 | fd2fds fd = (replicate nb 0) ++ [setBit 0 off] 640 | where 641 | (nb,off) = quotRem (fromIntegral fd) (bitSize (undefined::FDSET)) 642 | 643 | fds2mfd :: [FDSET] -> [CInt] 644 | fds2mfd fds = [fromIntegral (j+i*bitsize) | 645 | (afds,i) <- zip fds [0..], j <- [0..bitsize], 646 | testBit afds j] 647 | where bitsize = bitSize (undefined::FDSET) 648 | 649 | test_fd_conv, test_fd_conv' :: Bool 650 | test_fd_conv = and $ List.map (\e -> [e] == (fds2mfd $ fd2fds e)) lst 651 | where 652 | lst = [0,1,5,7,8,9,16,17,63,64,65] 653 | test_fd_conv' = mfd == fds2mfd fds 654 | where 655 | mfd = [0,1,5,7,8,9,16,17,63,64,65] 656 | fds :: [FDSET] = foldr ormax [] (List.map fd2fds mfd) 657 | -- fdmax = maximum $ List.map fromIntegral mfd 658 | ormax [] x = x 659 | ormax x [] = x 660 | ormax (a:ar) (b:br) = (a .|. b) : ormax ar br 661 | 662 | -- poll if file descriptors have something to read 663 | -- Return the list of read-pending descriptors 664 | select'read'pending :: [CInt] -> IO [CInt] 665 | select'read'pending mfd = 666 | withArray ([0,1]::[TIMEVAL]) ( -- holdover... 667 | \_ -> 668 | withArray fds ( 669 | \readfs -> 670 | do 671 | _ <- throwErrnoIfMinus1 "select" 672 | (c_select (fdmax+1) readfs nullPtr nullPtr nullPtr) 673 | -- because the wait was indefinite, rc must be positive! 674 | peekArray (length fds) readfs)) 675 | >>= (return . fds2mfd) 676 | where 677 | fds :: [FDSET] = foldr ormax [] (List.map fd2fds mfd) 678 | fdmax = maximum $ List.map fromIntegral mfd 679 | ormax [] x = x 680 | ormax x [] = x 681 | ormax (a:ar) (b:br) = (a .|. b) : ormax ar br 682 | 683 | foreign import ccall "fcntl.h fcntl" fcntl :: CInt -> CInt -> CInt -> IO CInt 684 | 685 | -- use it as cleanup'fd [5..6] to clean up the sockets left hanging... 686 | cleanup'fd :: [CInt] -> IO () 687 | cleanup'fd = mapM_ (closeFd . Fd) 688 | 689 | 690 | --------------------------------------------------------------------------------