Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

simplified

  • Loading branch information...
commit ca6916ac9b299acbd1d4468e34ab83bec62468fe 1 parent 81d0c0b
@bernstein authored
View
87 Ircfs/Filesystem.hs
@@ -21,6 +21,7 @@ module Ircfs.Filesystem
, stat
, rootDirFiles
, subDirFiles
+ , readDir
, appendRaw
, appendEvent
@@ -30,6 +31,7 @@ module Ircfs.Filesystem
import Prelude hiding ((.), id, read)
import qualified Prelude as P
+import Control.Arrow
import Control.Applicative
import Control.Category
import Control.Monad.State (modify)
@@ -37,6 +39,7 @@ import qualified Data.Lens.Common as L
import Data.Monoid
import Data.Char (isNumber)
import qualified Data.ByteString.Char8 as B
+import qualified Data.IntMap as IM
import qualified System.Fuse as F
import qualified System.Fuse.Request as F
@@ -128,10 +131,9 @@ fileStat Qctl {} = F.defaultFileStat { F.statFileMode = filemode Qrootctl }
fileStat q = F.defaultFileStat { F.statFileMode = filemode q }
stat :: IrcfsState -> FilePath -> Maybe F.FileStat
-stat (IrcfsState NotConnected _ _) _ = Nothing
-stat s@(IrcfsState con _ _) p = maybePlus1 <$> m <*> x
+stat st p = maybePlus1 <$> m <*> x
where m = fromFilePath p
- x = stat' s =<< m
+ x = stat' st =<< m
-- add 1 for newline charakter, XXX find a better way
maybePlus1 Qnick s = L.modL statFileSizeL (+1) s
maybePlus1 Qname {} s = L.modL statFileSizeL (+1) s
@@ -139,20 +141,20 @@ stat s@(IrcfsState con _ _) p = maybePlus1 <$> m <*> x
stat' :: IrcfsState -> Qreq -> Maybe F.FileStat
stat' f Qroot = Just $ F.defaultDirStat
- { F.statFileMode = filemode Qroot
- , F.statFileOwner = fromIntegral $ userID f
- , F.statFileGroup = fromIntegral $ groupID f
- }
+ { F.statFileMode = filemode Qroot
+ , F.statFileOwner = fromIntegral $ userID f
+ , F.statFileGroup = fromIntegral $ groupID f
+ }
stat' f Qdir {} = Just $ F.defaultDirStat
- { F.statFileMode = filemode Qroot
- , F.statFileOwner = fromIntegral $ userID f
- , F.statFileGroup = fromIntegral $ groupID f
- }
+ { F.statFileMode = filemode Qroot
+ , F.statFileOwner = fromIntegral $ userID f
+ , F.statFileGroup = fromIntegral $ groupID f
+ }
stat' f Qctl {} = Just $ F.defaultFileStat
- { F.statFileMode = filemode Qrootctl
- , F.statFileOwner = fromIntegral $ userID f
- , F.statFileGroup = fromIntegral $ groupID f
- }
+ { F.statFileMode = filemode Qrootctl
+ , F.statFileOwner = fromIntegral $ userID f
+ , F.statFileGroup = fromIntegral $ groupID f
+ }
stat' f q =
let mn = fromIntegral . B.length <$> read' f q
s = F.defaultFileStat { F.statFileMode = filemode q
@@ -165,25 +167,40 @@ statFileSizeL :: L.Lens F.FileStat S.FileOffset
statFileSizeL = L.lens F.statFileSize (\x s -> s { F.statFileSize = x })
readF :: IrcfsState -> FilePath -> S.ByteCount -> S.FileOffset -> Maybe B.ByteString
-readF s@(IrcfsState con _ _) p bc off = cut <$> (read' s =<< fromFilePath p)
+readF s p bc off = cut <$> (read' s =<< fromFilePath p)
where cut = B.take (fromIntegral bc) . B.drop (fromIntegral off)
read' :: IrcfsState -> Qreq -> Maybe B.ByteString
-read' (IrcfsState con _ _) Qroot = Nothing
-read' (IrcfsState con _ _) Qrootctl = Just mempty
-read' (IrcfsState con _ _) Qevent = Just $ eventFile con
-read' (IrcfsState con _ _) Qraw = Just $ rawFile con
-read' (IrcfsState con _ _) Qnick = Just $ B.append (nick con) "\n"
-read' (IrcfsState con _ _) Qpong = Just $ pongFile con
-read' (IrcfsState con _ _) Qdir {} = Nothing
-read' (IrcfsState con _ _) Qctl {} = Just mempty
-read' (IrcfsState con _ _) (Qname 0) = Just . (`B.append` "\n") . addr $ con
-read' (IrcfsState con _ _) (Qname k) =
- ((`B.append` "\n") . targetName) <$> L.getL (targetLens k) con
-read' (IrcfsState con _ _) (Qusers 0) = Just mempty
-read' (IrcfsState con _ _) (Qusers k) = users <$> L.getL (targetLens k) con
-read' (IrcfsState con _ _) (Qdata 0) = Just mempty
-read' (IrcfsState con _ _) (Qdata k) = text <$> L.getL (targetLens k) con
+read' _ Qroot = Nothing
+read' _ Qrootctl = Just mempty
+read' con Qevent = Just $ eventFile con
+read' con Qraw = Just $ rawFile con
+read' con Qnick = Just $ mappend (nick con) "\n"
+read' con Qpong = Just $ pongFile con
+read' _ Qdir {} = Nothing
+read' con Qctl {} = Just mempty
+read' con (Qname 0) = Just . (`mappend` "\n") . addr $ con
+read' con (Qname k) =
+ ((`mappend` "\n") . targetName) <$> L.getL (targetLens k) con
+read' _ (Qusers 0) = Just mempty
+read' con (Qusers k) = users <$> L.getL (targetLens k) con
+read' _ (Qdata 0) = Just mempty
+read' con (Qdata k) = text <$> L.getL (targetLens k) con
+
+readDir' :: IrcfsState -> Qreq -> [(FilePath, F.FileStat)]
+readDir' st Qroot =
+ let ks = IM.keys (targets st)
+ rootDir = map (showFilepath &&& fileStat) rootDirFiles
+ subDirs = map (\x -> (show x,F.defaultDirStat)) ks
+ in [(".", F.defaultDirStat), ("..", F.defaultDirStat),
+ ("0",F.defaultDirStat) ] ++ rootDir ++ subDirs
+readDir' st Qdir {} =
+ let subDir = map (showFilepath &&& fileStat) subDirFiles
+ in [(".", F.defaultDirStat), ("..",F.defaultDirStat)] ++ subDir
+readDir' _ _ = []
+
+readDir :: IrcfsState -> FilePath -> [(FilePath, F.FileStat)]
+readDir st p = maybe [] (readDir' st) (fromFilePath p)
{-
- uses readHelper
@@ -196,15 +213,15 @@ statHelper (Qname k) con = targetName con
-- readHelper (Qname k) con =
appendRaw :: B.ByteString -> Ircfs ()
-appendRaw s = modify $ L.modL (rawLens.connectionLens) (`B.append` s)
+appendRaw s = modify $ L.modL rawLens (`mappend` s)
appendEvent :: B.ByteString -> Ircfs ()
-appendEvent s = modify $ L.modL (eventLens.connectionLens) (`B.append` s)
+appendEvent s = modify $ L.modL eventLens (`mappend` s)
writeNick :: B.ByteString -> Ircfs ()
-writeNick = modify . L.modL (nickLens.connectionLens) . const
+writeNick = modify . L.modL nickLens . const
appendPong :: B.ByteString -> Ircfs ()
-appendPong s = modify $ L.modL (pongLens.connectionLens) (`B.append` s)
+appendPong s = modify $ L.modL pongLens (`mappend` s)
View
124 Ircfs/Process.hs
@@ -18,7 +18,6 @@ module Ircfs.Process
import Prelude hiding ((.), id)
import Control.Category
-import Control.Arrow
import Control.Applicative
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO, MonadIO)
@@ -27,7 +26,6 @@ import qualified Control.Concurrent.Chan as C
import qualified Control.Concurrent as C
import qualified Data.Lens.Common as L
import qualified Data.ByteString.Char8 as B
-import qualified Data.IntMap as IM
import Data.Monoid
import Data.Maybe (maybeToList)
import Data.Attoparsec as A
@@ -41,6 +39,7 @@ import Ircfs.Ctl as I
import Ircfs.Types
import Ircfs.Filesystem
+-- process :: Enumeratee F.Request I.Message IO a
--process :: IrcfsState -> F.Request -> IO (Maybe B.ByteString, IrcfsState)
--process :: IrcOut -> IrcfsState -> F.Request -> IO IrcfsState
process :: IrcOut -> F.Request -> Ircfs ()
@@ -49,27 +48,12 @@ process o (F.Req t) = processTmsg o t >> return ()
-- | Process incoming filesystem requests.
processTmsg :: IrcOut -> F.Tmsg -> Ircfs F.Rmsg
--- process Tread
processTmsg _ (F.Tread p bc off) = do
st <- get
maybe (return F.Rerror) (return . F.Rread) (readF st p bc off)
-processTmsg _ (F.Tread {}) = return F.Rerror
-
--- process Treaddir
-processTmsg _ (F.Treaddir "/") = do
- ks <- (IM.keys . targets . connection) <$> get
- let ds = [(".", F.defaultDirStat) ,
- ("..", F.defaultDirStat),
- ("0",F.defaultDirStat) ] ++ rootDir ++ subDirs
- rootDir = map (showFilepath &&& fileStat) rootDirFiles
- subDirs = map (\x -> (show x,F.defaultDirStat)) ks
- return . F.Rreaddir $ ds
-processTmsg _ (F.Treaddir _) = do
- -- let m = fromFilePath p
- let ds = [(".", F.defaultDirStat), ("..",F.defaultDirStat)] ++ subDir
- subDir = map (showFilepath &&& fileStat) subDirFiles
- return (F.Rreaddir ds)
-
+processTmsg _ F.Topen {} = return F.Ropen
+processTmsg _ (F.Tstat p) = maybe F.Rerror F.Rstat . (`stat` p) <$> get
+processTmsg _ (F.Treaddir p) = F.Rreaddir . (`readDir` p) <$> get
-- process Twrite, usually appends to files
processTmsg ircoutc (F.Twrite "/ctl" s _) = do
-- Todo if a msg is longer than 512 then split it into chunks
@@ -88,93 +72,89 @@ processTmsg _ (F.Twrite "/pong" s _) = do
appendPong s
return . F.Rwrite . fromIntegral . B.length $ s
processTmsg ircoutc (F.Twrite "/raw" s _) = do
- appendRaw (">>>" `B.append` s)
+ appendRaw (">>>" `mappend` s)
io . C.writeChan (unIrcOut ircoutc) $ s
return . F.Rwrite . fromIntegral . B.length $ s
processTmsg ircoutc (F.Twrite "/ircin" s _) = do
- appendRaw ("<<<" `B.append` s `B.append` "\n")
+ appendRaw ("<<<" `mappend` s `mappend` "\n")
let m = A.maybeResult $ A.feed (A.parse I.message s) "\n"
- maybe (return ()) (processIrc ircoutc) m
+ ms' <- maybe (return []) processIrc m
+ mapM_ (\c -> processTmsg ircoutc (F.Twrite "/raw" (I.toByteString c) 0)) ms'
return . F.Rwrite . fromIntegral . B.length $ s
processTmsg _ (F.Twrite {}) = return F.Rerror
--- process Topen
-processTmsg _ F.Topen {} = return F.Ropen
-
--- process Tstat
-processTmsg _ (F.Tstat p) = maybe F.Rerror F.Rstat . (`stat` p) <$> get
-
--- | Process incommint irc messages.
-processIrc :: IrcOut -> I.Message -> Ircfs ()
+-- | Process incomming irc messages.
+processIrc :: I.Message -> Ircfs [I.Message]
-- example: PING :irc.funet.fi ; Ping message sent by server
-processIrc ircoutc (I.Message _ I.PING (I.Params _ (Just p))) = do
- stamp <- timeStamp
- let cmd = "pong " `B.append` p `B.append` "\n"
- off = fromIntegral . B.length $ cmd
- s = stamp `B.append` " " `B.append` cmd
- _ <- processTmsg ircoutc (F.Twrite "/ctl" cmd off)
- appendPong s
-processIrc _ (I.Message (Just (I.PrefixNick n _ _)) I.NICK (I.Params [] (Just new))) = do
- yourNick <- (nick.connection) <$> get
+processIrc (I.Message _ I.PING (I.Params _ (Just p))) = do
+ stamp <- timeStamp
+ let s = mconcat [stamp," pong ",p,"\n"]
+ msg = I.Message Nothing I.PONG (I.Params [p] Nothing)
+ appendPong s
+ return [msg]
+processIrc (I.Message (Just (I.PrefixNick n _ _)) I.NICK (I.Params [] (Just new))) = do
+ yourNick <- nick <$> get
if n == yourNick
then do
- appendEvent $ "your nick changed to " `B.append` new `B.append` "\n"
+ appendEvent . mconcat $ ["You're now known as ",new,"\n"]
writeNick new
else
- appendEvent $ n `B.append` " changed nick to "
- `B.append` new
- `B.append` "\n"
-processIrc _ (I.Message (Just (I.PrefixNick n _ _)) I.NICK (I.Params (new:_) _)) = do
- yourNick <- (nick.connection) <$> get
+ appendEvent . mconcat $ [n," changed nick to ",new,"\n"]
+ return []
+processIrc (I.Message (Just (I.PrefixNick n _ _)) I.NICK (I.Params (new:_) _)) = do
+ yourNick <- nick <$> get
if n == yourNick
then do
- appendEvent $ "your nick changed to " `B.append` new `B.append` "\n"
+ appendEvent (mconcat ["You're now known as ",new,"\n"])
writeNick new
else
- appendEvent $ n `B.append` " changed nick to "
- `B.append` new
- `B.append` "\n"
-processIrc _ (I.Message (Just (I.PrefixNick n _ _)) I.JOIN (I.Params (c:_) _)) = do
- yourNick <- (nick.connection) <$> get
+ appendEvent . mconcat $ [n," changed nick to ",new,"\n"]
+ return []
+processIrc (I.Message (Just (I.PrefixNick n _ _)) I.JOIN (I.Params (c:_) _)) = do
+ yourNick <- nick <$> get
when (n == yourNick) $ do
k <- nextDirName
- modify $ L.setL (targetLens k.connectionLens)
+ modify $ L.setL (targetLens k)
(Just (Target k TChannel c mempty mempty))
- modify $ L.setL (targetMapLens' c.connectionLens) (Just k)
+ modify $ L.setL (targetMapLens' c) (Just k)
let s = B.pack $ "new " ++ show k ++ " "
- appendEvent $ s `B.append` c `B.append` "\n"
-processIrc _ (I.Message (Just (I.PrefixNick n _ _)) I.PART (I.Params (c:_) _)) = do
- yourNick <- (nick.connection) <$> get
+ appendEvent $ s `mappend` c `mappend` "\n"
+ return []
+processIrc (I.Message (Just (I.PrefixNick n _ _)) I.PART (I.Params (c:_) _)) = do
+ yourNick <- nick <$> get
when (n == yourNick) $ do
- m <- L.getL (targetMapLens' c.connectionLens) <$> get
+ m <- L.getL (targetMapLens' c) <$> get
maybe (return ()) (\k -> do
- modify (L.setL (targetLens k.connectionLens) Nothing)
- modify (L.setL (targetMapLens' c.connectionLens) Nothing)
+ modify (L.setL (targetLens k) Nothing)
+ modify (L.setL (targetMapLens' c) Nothing)
freeDirName k
let s = B.pack $ "del " ++ show k ++ " "
- appendEvent (s `B.append` c `B.append` "\n")
+ appendEvent (mconcat [s,c,"\n"])
) m
-processIrc _ (I.Message (Just (I.PrefixNick n _ _)) I.PRIVMSG (I.Params (c:cs) t)) = do
+ return []
+processIrc (I.Message (Just (I.PrefixNick n _ _)) I.PRIVMSG (I.Params (c:cs) t)) = do
stamp <- timeStamp
- tm <- L.getL (targetMapLens' c.connectionLens) <$> get
+ tm <- L.getL (targetMapLens' c) <$> get
let ts = maybeToList t
+
maybe (return ()) (\k -> do
- modify $ L.modL (targetLens k.connectionLens)
- (fmap (L.modL textLens (\s -> s `B.append` stamp `B.append` " < " `B.append` n `B.append` "> " `B.append` B.unwords (cs++ts) `B.append` "\n")))
+ modify $ L.modL (targetLens k)
+ (fmap (L.modL textLens (\s -> mconcat [s,stamp," < ",n,"> ",B.unwords (cs++ts),"\n"])))
) tm
- return ()
-processIrc _ m@(I.Message _ I.ERROR _) =
- appendEvent ("error " `B.append` I.toByteString m `B.append` "\n")
-processIrc _ _ = return ()
+ return []
+processIrc m@(I.Message _ I.ERROR _) = do
+ appendEvent (mconcat ["error ",I.toByteString m,"\n"])
+ return []
+processIrc _ = return []
nextDirName :: Ircfs Int
nextDirName = do
- k <- (head . nextDirNames . connection) <$> get
- modify $ L.modL (nextDirNamesLens . connectionLens) tail
+ k <- (head . nextDirNames) <$> get
+ modify $ L.modL nextDirNamesLens tail
return k
freeDirName :: Int -> Ircfs ()
-freeDirName = modify . L.modL (nextDirNamesLens . connectionLens) . (:)
+freeDirName = modify . L.modL nextDirNamesLens . (:)
timeStamp :: MonadIO m => m B.ByteString
timeStamp = do
View
65 Ircfs/Types.hs
@@ -20,13 +20,12 @@ module Ircfs.Types
, Ircfs(..)
, io
, Qreq(..)
- , Connection(..)
, File
, Target(..)
, Targets
, To(..)
- , connectionLens
+ --, connectionLens
, addrLens
, nickLens
, targetLens
@@ -59,14 +58,27 @@ import qualified Data.Map as M
-- | IrcfsState, the irc file system state.
data IrcfsState = IrcfsState
- { connection :: Connection
+ { --connection :: Connection
+ addr :: File
+ , nick :: File
+ --, lnick :: String
+ , targets :: Targets -- M.Map Int Target
+ -- readable Files in the root dir
+ -- , ctlFile :: B.ByteString -- reading provides command history ?
+ -- , commandHistoryFile
+ , eventFile :: File -- everything
+ , pongFile :: File -- every time a pong is send
+ , rawFile :: File
+ , nextDirNames :: [Int]
+ , targetMap :: M.Map B.ByteString Int -- map directory number to target id
+
-- , fsreq :: C.Chan FsRequest -- > move to IrcfsState
, userID :: Int
, groupID :: Int
}
-connectionLens :: L.Lens IrcfsState Connection
-connectionLens = L.lens connection (\x s -> s { connection = x })
+--connectionLens :: L.Lens IrcfsState Connection
+--connectionLens = L.lens connection (\x s -> s { connection = x })
io :: MonadIO m => IO a -> m a
io = liftIO
@@ -99,54 +111,31 @@ data Qreq = Qroot -- "/"
| Qdata { dirNr :: Int } -- "/n/data"
deriving (Show, Read, Eq, Ord)
--- |
--- A Connection
---
-data Connection =
- NotConnected
- | Connection
- { addr :: File
- , nick :: File
- --, lnick :: String
- , targets :: Targets -- M.Map Int Target
- , sock :: N.Socket
- -- readable Files in the root dir
- -- , ctlFile :: B.ByteString -- reading provides command history ?
- -- , commandHistoryFile
- , eventFile :: File -- everything
- , pongFile :: File -- every time a pong is send
- , rawFile :: File
- , nextDirNames :: [Int]
- , targetMap :: M.Map B.ByteString Int -- map directory number to target id
- }
-
type File = B.ByteString
--ctlLens :: L.Lens Connection File
--ctlLens = L.lens ctlFile (\x s -> s { ctlFile = x })
-addrLens :: L.Lens Connection File
+addrLens :: L.Lens IrcfsState File
addrLens = L.lens addr (\x s -> s { addr = x })
-nickLens :: L.Lens Connection File
+nickLens :: L.Lens IrcfsState File
nickLens = L.lens nick (\x s -> s { nick = x })
-targetsLens :: L.Lens Connection Targets
+targetsLens :: L.Lens IrcfsState Targets
targetsLens = L.lens targets (\x s -> s { targets = x })
-targetLens :: Int -> L.Lens Connection (Maybe Target)
+targetLens :: Int -> L.Lens IrcfsState (Maybe Target)
targetLens k = L.intMapLens k . targetsLens
-sockLens :: L.Lens Connection N.Socket
-sockLens = L.lens sock (\x s -> s { sock = x })
-eventLens :: L.Lens Connection File
+eventLens :: L.Lens IrcfsState File
eventLens = L.lens eventFile (\x s -> s { eventFile = x })
-pongLens :: L.Lens Connection File
+pongLens :: L.Lens IrcfsState File
pongLens = L.lens pongFile (\x s -> s { pongFile = x })
-rawLens :: L.Lens Connection File
+rawLens :: L.Lens IrcfsState File
rawLens = L.lens rawFile (\x s -> s { rawFile = x })
-nextDirNamesLens :: L.Lens Connection [Int]
+nextDirNamesLens :: L.Lens IrcfsState [Int]
nextDirNamesLens = L.lens nextDirNames (\x s -> s { nextDirNames = x})
-targetMapLens :: L.Lens Connection (M.Map B.ByteString Int)
+targetMapLens :: L.Lens IrcfsState (M.Map B.ByteString Int)
targetMapLens = L.lens targetMap (\x s -> s { targetMap = x})
-targetMapLens' :: B.ByteString -> L.Lens Connection (Maybe Int)
+targetMapLens' :: B.ByteString -> L.Lens IrcfsState (Maybe Int)
targetMapLens' s = L.mapLens s . targetMapLens
type Targets = IntMap Target -- change to (IntMap Target)
View
48 Main.hs
@@ -1,4 +1,15 @@
{-# LANGUAGE OverloadedStrings #-}
+-- -----------------------------------------------------------------------------
+-- |
+-- Module : Main
+-- Copyright : (c) Andreas-Christoph Bernstein 2011
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : andreas.bernstein@googlemail.com
+-- Stability : unstable
+-- Portability : not portable
+--
+--------------------------------------------------------------------------------
module Main where
import Prelude hiding ((.), id)
@@ -29,15 +40,12 @@ import Ircfs.Process
import qualified Ircfs.CmdLine as O
import qualified System.Fuse.Request as F
---newtype IrcOut = IrcOut { unIrcOut :: C.Chan I.Message }
--- process :: Enumeratee F.Request I.Message IO a
-
chanToIter2 :: C.Chan a -> E.Iteratee a IO ()
chanToIter2 c = go
where
go = EL.head >>= maybe go (\x -> liftIO (C.writeChan c x) >> go)
--- | Listens on the sockets, writes received messages to ircinc
+-- | Listens on the sockets, writes received messages to fsReq
ircReader :: C.Chan F.Request -> N.Socket -> IO ()
ircReader fsReq socket =
E.run_ $ E.enumSocket 1024 socket E.$$ irclines E.=$ iterFuseWriteFs_ fsReq
@@ -45,7 +53,7 @@ ircReader fsReq socket =
ircWriter :: N.Socket -> IrcOut -> IO ()
ircWriter s out = mapM_ (N.sendAll s) =<< C.getChanContents (unIrcOut out)
--- | Initialize the filesystem.
+-- | Initialize file system.
fsInit :: C.Chan F.Request -> O.Config -> IO ()
fsInit fsReq cfg = do
s <- getSocket (O.addr cfg) (read (O.port cfg))
@@ -53,23 +61,6 @@ fsInit fsReq cfg = do
gid <- fromIntegral <$> S.getEffectiveGroupID
-- userEntry <- S.getUserEntryForID (fromIntegral uid)
name <- S.getEffectiveUserName
- let st = IrcfsState
- { connection =
- Connection
- { addr = B.pack . O.addr $ cfg
- , nick = B.pack . O.nick $ cfg
- , targets = mempty
- , sock = s
- , eventFile = ""
- , pongFile = ""
- , rawFile = ""
- , nextDirNames = [1..100]
- , targetMap = mempty
- }
- , userID = uid
- , groupID = gid
- }
-
_ <- C.forkIO $ ircReader fsReq s
let nickMsg = B.pack $ "NICK " ++ O.nick cfg ++ "\r\n"
@@ -80,6 +71,19 @@ fsInit fsReq cfg = do
_ <- C.forkIO $ ircWriter s ircoutc
rs <- C.getChanContents fsReq
+ let st = IrcfsState
+ { addr = B.pack . O.addr $ cfg
+ , nick = B.pack . O.nick $ cfg
+ , targets = mempty
+ , eventFile = ""
+ , pongFile = ""
+ , rawFile = ""
+ , nextDirNames = [1..100]
+ , targetMap = mempty
+ , userID = uid
+ , groupID = gid
+ }
+
_ <- C.forkIO $ runIrcfs st (mapM_ (process ircoutc) rs) >> return ()
return ()
View
36 Network/IRC/Message.hs
@@ -343,19 +343,19 @@ toByteString :: Message -> B.ByteString
--toByteString (Message Nothing (CmdNumericReply _) ps) = "toByteString: CmdNumericReply not implemented yet"
toByteString (Message Nothing (CmdString _) ps) = "toByteString: CmdString not Implemented yet"
toByteString (Message Nothing cmd ps) =
- commandToByteString cmd `B.append` paramsToByteString ps `B.append` "\r\n"
-toByteString (Message (Just p) cmd ps) =
- ":"
- `B.append` prefixToByteString p
- `B.append` " "
- `B.append` commandToByteString cmd
- `B.append` paramsToByteString ps
- `B.append` "\r\n"
+ commandToByteString cmd `mappend` paramsToByteString ps `mappend` "\r\n"
+toByteString (Message (Just p) cmd ps) = mconcat [
+ ":"
+ , prefixToByteString p
+ , " "
+ , commandToByteString cmd
+ , paramsToByteString ps
+ , "\r\n"]
commandToByteString :: Command -> B.ByteString
commandToByteString (CmdNumericReply x)
- | x < 10 = "00" `B.append` B.pack (show x)
- | x < 100 = "0" `B.append` B.pack (show x)
+ | x < 10 = "00" `mappend` B.pack (show x)
+ | x < 100 = "0" `mappend` B.pack (show x)
| otherwise = B.pack (show x)
commandToByteString c = B.pack . show $ c
@@ -363,16 +363,12 @@ commandToByteString c = B.pack . show $ c
prefixToByteString :: Prefix -> B.ByteString
prefixToByteString (PrefixServer s) = s
prefixToByteString (PrefixNick n Nothing Nothing) = n
-prefixToByteString (PrefixNick n (Just u) Nothing) =
- n `B.append` "!" `B.append` u
-prefixToByteString (PrefixNick n Nothing (Just h)) =
- n `B.append` "@" `B.append` h
-prefixToByteString (PrefixNick n (Just u) (Just h)) =
- n `B.append` "!" `B.append` u `B.append` "@" `B.append` h
+prefixToByteString (PrefixNick n (Just u) Nothing) = n `mappend` "!" `mappend` u
+prefixToByteString (PrefixNick n Nothing (Just h)) = n `mappend` "@" `mappend` h
+prefixToByteString (PrefixNick n (Just u) (Just h)) = mconcat [n,"!",u,"@",h]
paramsToByteString :: Params -> B.ByteString
paramsToByteString (Params [] Nothing) = mempty
-paramsToByteString (Params m@(x:_) Nothing) = " " `B.append` B.unwords m
-paramsToByteString (Params [] (Just t)) = " :" `B.append` t
-paramsToByteString (Params m@(x:_) (Just t)) = " " `B.append` B.unwords m
- `B.append` " :" `B.append` t
+paramsToByteString (Params m@(x:_) Nothing) = " " `mappend` B.unwords m
+paramsToByteString (Params [] (Just t)) = " :" `mappend` t
+paramsToByteString (Params m@(x:_) (Just t)) = mconcat [" ",B.unwords m," :",t]
View
4 System/Fuse/Request.hs
@@ -59,6 +59,10 @@ deriving instance Show OpenFileFlags
fromRmsg :: Rmsg -> Either Errno B.ByteString
fromRmsg (Rread s) = Right s
+fromRmsg (Rwrite _) = error "fromRmsg: implement me"
+fromRmsg Ropen = error "fromRmsg: implement me"
+fromRmsg (Rstat _) = error "fromRmsg: implement me"
+fromRmsg (Rreaddir _) = error "fromRmsg: implement me"
fromRmsg Rerror = Left eNOENT
fuseRequest_ :: C.Chan Request -> Tmsg -> IO ()
View
1  tests/TestDecode.hs
@@ -21,6 +21,7 @@ import Test.QuickCheck hiding (property)
-- message = [ ":" prefix SPACE ] command [ params ] crlf
genMessage :: Gen B.ByteString
-- promote
+ -- sequenceA
genMessage = BS.concat <$> sequence [pre , genCommandStr, ps, pure "\r\n"]
where pre = oneof [ pure mempty
, B.append ":" <$> (B.append <$> genPrefix <*> pure " ")]
Please sign in to comment.
Something went wrong with that request. Please try again.