packages feed

dotfs 0.1.1.2 → 0.1.1.3

raw patch · 20 files changed

+1075/−1 lines, 20 filesdep ~parsec

Dependency ranges changed: parsec

Files

+ System/DotFS/Core/BodyParser.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Core.BodyParser where++import Prelude hiding (lex,lookup)++import System.DotFS.Core.Datatypes+import System.DotFS.Core.Lexers+import System.DotFS.Core.ExpressionParsers+import System.DotFS.Core.HelperParsers+import System.DotFS.Core.HeaderParser++import Data.Map++import Control.Applicative ((<$>), (<*), (*>), (<$), (<*>))+import Text.Parsec+import Text.Parsec.Token as P+++bodyP :: VarParser (Header,Body)+bodyP = do { b <- id <$ headerP *> blocksP <* eof <?> "body with annotations"+           ; h <- getState+           ; return (h,b)+           }++blocksP :: VarParser Body+blocksP = many blockP++blockP :: VarParser BodyElem+blockP =  try conditionalBlockP+      <|> try exprBlockP+      <|> verbBlockP <?> "body element (if, reference or verbatim)"+++conditionalBlockP :: VarParser BodyElem+conditionalBlockP = do{ state <- getState+                      ; _ <- symbol lex (extractTagStart state)+                      ; _ <- symbol lex "if"+                      ; cond <- exprP+                      ; _ <- string (extractTagStop state)+                      ; content <- blocksP+                      ; _ <- symbol lex (extractTagStart state)+                      ; _ <- symbol lex "endif" <|> symbol lex "/if" <|> symbol lex "fi"+                      ; _ <- string (extractTagStop state)+                      ; return $ Cond cond content+                      }++exprBlockP :: VarParser BodyElem+exprBlockP = do{ state <- getState+               ; _ <- symbol lex (extractTagStart state)+               ; _ <- symbol lex "var"+               ; var <- exprP+               ; _ <- string (extractTagStop state)+               ; return $ Ref var+               }+++verbBlockP :: VarParser BodyElem+verbBlockP = do{ state <- getState+               ; let opentag = const () <$> try (string (extractTagStart state))+                     endofVerb = lookAhead (eof <|> opentag)+                 in Verb <$> many1Till anyChar endofVerb+               }+++-- helpers to retrieve start and stop tags as string from the state map:+extractTagStart,extractTagStop :: Map String DFSExpr -> String+extractTagStart m = case lookup "tagstart" m of+                       Just (Prim (VString s)) -> s+                       _                -> "<<"++extractTagStop m = case lookup "tagstop" m of+                       Just (Prim (VString s)) -> s+                       _                -> ">>"
+ System/DotFS/Core/Constants.hs view
@@ -0,0 +1,43 @@+{-+ - Everything here is evil by definition.+ -}+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Core.Constants where++import System.DotFS.Core.Datatypes++import System.Fuse+import System.Posix.Files++-- there is a system call for this.+-- but never mind, since we have a read-only file+-- system, we don't need that.+dotfsGetFileSystemStats :: Conf -> String -> IO (Either Errno FileSystemStats)+dotfsGetFileSystemStats dp str = -- use stats from home dp+  return $ Right FileSystemStats+    { fsStatBlockSize  = 512+    , fsStatBlockCount = 1000+    , fsStatBlocksFree = 0+    , fsStatBlocksAvailable = 0+    , fsStatFileCount  = 5      -- IS THIS CORRECT?+    , fsStatFilesFree  = 10     -- WHAT IS THIS?+    , fsStatMaxNameLength = 255 -- SEEMS SMALL?+    }++-- this is dummy data, and turns out to never be+-- shown, even when doing `ls -la`+dirStat = FileStat {+    statEntryType = Directory+  , statFileMode  = ownerReadMode+  , statLinkCount = 5+  , statFileOwner = 666+  , statFileGroup = 666+  , statSpecialDeviceID = 0+  , statFileSize  = 4096+  , statBlocks    = 1+  , statAccessTime= 0+  , statModificationTime = 0+  , statStatusChangeTime = 0+  }++
+ System/DotFS/Core/Datatypes.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GADTs, ExistentialQuantification, FlexibleInstances #-}+module System.DotFS.Core.Datatypes where++import Data.Maybe+import Text.ParserCombinators.Parsec.Prim+import Data.Map (lookup, fromList, Map)+import Data.Char (toLower)++import Prelude hiding (lookup)++data Conf = C FilePath deriving Show++-- our threaded parser type+type VarParser a = GenParser Char DFSState a++-- and the results+type VarName = String++type DFSState = Map VarName DFSExpr++type Mountpoint = FilePath++-- | primitives+data Value = VInt Integer+           | VBool Bool+           | VString String+           deriving Eq++instance Show Value where+  show (VInt    i) = show i+  show (VBool   b) = map toLower $ show b+  show (VString s) = s+++-- | a config file is either just a normal file, to be passed+-- through unchanged, or else it's an annotated file with a header+-- and a body.+-- a proper AST for our config files, in other words.+data Config = Vanilla+            | Annotated Header Body+            deriving Show++type Header = DFSState++type Body = [BodyElem]++-- | the body is either a conditional block (shown depending on some+-- boolean value) or a literal expression (usually a variable inserted somewhere)+-- or, of course, verbatim content. These components can be chained.+data BodyElem = Cond DFSExpr Body+              | Ref  DFSExpr+              | Verb String+              deriving Show++-- | an expression+data DFSExpr   = Var  VarName+               | Prim Value+               | Sys  String+               | If DFSExpr DFSExpr DFSExpr+               | UniOp Op DFSExpr+               | BiOp  Op DFSExpr DFSExpr+               deriving Eq++instance Show DFSExpr where+  show (Var  n) = n+  show (Prim v) = show v+  show (Sys  s) = s+  show (If c e1 e2) = "if("++show c++"){"++show e1++"}else{" ++ show e2 ++ "}"+  show (UniOp o e) = "(" ++ show o ++ show e ++ ")"+  show (BiOp  o e1 e2) = "("++show e1++ show o ++ show e2++")"++instance Show Op where+  show op = (\o -> " "++o++" ") $+            fromMaybe "?" (lookup op (fromList+            [ (Add, "+")+            , (Sub, "-")+            , (Div, "/")+            , (Mul, "*")+            , (Eq,  "==")+            , (LTOp, "<")+            , (GTOp, ">")+            , (LEQ, "<=")+            , (GEQ, ">=")+            , (NEQ, "!=")+            , (And, "&&")+            , (Or, "||")+            , (Not, "!")+            ]))++data Op     = Add | Sub | Mul | Div+            | Eq  | LTOp| GTOp| LEQ | GEQ | NEQ+            | And | Or  | Not+            deriving (Eq,Ord)
+ System/DotFS/Core/ExpressionEvaluator.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Core.ExpressionEvaluator where++import Prelude hiding (lookup)+import System.IO+import Control.Applicative+import System.Process+import System.IO.Unsafe++import System.DotFS.Core.Datatypes+import Data.Map++eval :: DFSState -> DFSExpr -> Value+eval s (Prim p) = p+eval s (Var v)  = case lookup v s of+                    Nothing -> VBool False -- default...+                    Just e  -> eval s e+eval s (Sys c)  = VString $ execSystem c+eval s (If c t e) = case eval s c of+                        VBool True -> eval s t+                        _          -> eval s e+eval s o@(UniOp _ e) = evalUni s o+eval s o@(BiOp  _ e1 e2) = evalBi s o+++execSystem :: String -> String+execSystem c = unsafePerformIO $ do (inn,out,err,pid) <- runInteractiveCommand c+                                    mapM_ (`hSetBinaryMode` False) [inn, out]+                                    hSetBuffering out NoBuffering+                                    parsedIntro <- parseUntilPrompt out+                                    return (concat parsedIntro)++parseUntilPrompt :: Handle -> IO [String]+parseUntilPrompt out = do+  h <- hIsEOF out+  if h+      then+        return []+      else do+        latest <- hGetLine out+        (:) <$> return latest <*> parseUntilPrompt out++evalUni :: DFSState -> DFSExpr -> Value+evalUni s (UniOp Not b) = case eval s b of+                            VBool b -> VBool $ not b+                            _       -> VBool False   -- default value?? some way of error reporting here please+evalUni _ _ = VBool False -- no other uni-operators for now.++evalBi :: DFSState -> DFSExpr -> Value+evalBi s (BiOp Add e1 e2)   = doAdd s e1 e2+evalBi s (BiOp Sub e1 e2)   = doInt s (-) e1 e2+evalBi s (BiOp Mul e1 e2)   = doInt s (*) e1 e2+evalBi s (BiOp Div e1 e2)   = doInt s div e1 e2+evalBi s (BiOp Eq  e1 e2)   = let e1' = eval s e1+                                  e2' = eval s e2+                              in VBool $ e1' == e2'+evalBi s (BiOp LTOp e1 e2)  = doIntBool s (<) e1 e2+evalBi s (BiOp GTOp e1 e2)  = doIntBool s (>) e1 e2+evalBi s (BiOp LEQ  e1 e2)  = doIntBool s (<=) e1 e2+evalBi s (BiOp GEQ  e1 e2)  = doIntBool s (>=) e1 e2+evalBi s (BiOp NEQ  e1 e2)  = let e1' = eval s e1+                                  e2' = eval s e2+                              in VBool $ e1' /= e2'+evalBi s (BiOp And  e1 e2)  = doBool s (&&) e1 e2+evalBi s (BiOp Or   e1 e2)  = doBool s (||) e1 e2+evalBi s _                  = VBool False++doAdd :: DFSState -> DFSExpr -> DFSExpr -> Value+doAdd s a b   = let e1 = eval s a+                    e2 = eval s b+                in  f e1 e2+                where f (VString s1) (VString s2) = VString $ s1 ++ s2+                      f (VInt    i1) (VInt    i2) = VInt $ i1 +  i2+                      f _            _            = VInt 0++doInt :: DFSState+      -> (Integer -> Integer -> Integer)+      -> DFSExpr+      -> DFSExpr+      -> Value+doInt s f a b = let e1' = eval s a+                    e2' = eval s b+                in  e1' `handle` e2'+                where handle (VInt a) (VInt b) = VInt $ f a b+                      handle _ _ = VInt 0++doIntBool :: DFSState+                            -> (Integer -> Integer -> Bool)+                            -> DFSExpr+                            -> DFSExpr+                            -> Value+doIntBool s f a b = let e1' = eval s a+                        e2' = eval s b+                    in  e1' `handle` e2'+                    where handle (VInt a) (VInt b) = VBool $ f a b+                          handle _ _ = VBool False++doBool :: DFSState+                         -> (Bool -> Bool -> Bool)+                         -> DFSExpr+                         -> DFSExpr+                         -> Value+doBool s f a b = let e1' = eval s a+                     e2' = eval s b+                 in  e1' `handle` e2'+                 where handle (VBool a) (VBool b) = VBool $ f a b+                       handle _ _ = VBool False
+ System/DotFS/Core/ExpressionParsers.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NoImplicitPrelude, GADTs, ExistentialQuantification #-}+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Core.ExpressionParsers where++import Prelude hiding (lex,lookup)+import Control.Applicative ((<$>))+import System.DotFS.Core.Datatypes+import System.DotFS.Core.Lexers+import Data.Functor.Identity+import Text.Parsec+import Text.Parsec.Token as P+import Text.Parsec.Expr++exprP :: VarParser DFSExpr+exprP = buildExpressionParser table factor <?> "expression"++table :: [[ Operator String st Identity DFSExpr ]]+table = [+    [pre "!" (UniOp Not)],+    [ op "&&" (BiOp And) AssocNone ],+    [ op "||" (BiOp Or) AssocNone ],+    [ op "*" (BiOp Mul) AssocLeft, op "/" (BiOp Div) AssocLeft ],+    [ op "+" (BiOp Add) AssocLeft, op "-" (BiOp Sub) AssocLeft ],+    [ op "==" (BiOp Eq) AssocNone+        , op ">" (BiOp GTOp) AssocNone+        , op "<" (BiOp LTOp) AssocNone+        , op "<=" (BiOp LEQ) AssocNone+        , op ">=" (BiOp GEQ) AssocNone+        , op "!=" (BiOp NEQ) AssocNone+    ]+    ]+  where+    op s f       = Infix   (do { reservedOp lex s; return f } <?> "operator")+    pre s f      = Prefix  (do { reservedOp lex s; return f })++factor :: ParsecT String DFSState Identity DFSExpr+factor =  parens lex exprP+      <|> ((Prim . VInt) <$> integer lex)+      <|> ((Prim . VBool) <$> boolTerm)+      <|> ((Prim . VString) <$> stringLiteral lex)+      <|> Var <$> identifier lex+      <|> ifTerm+      <?> "simple expression or variable"++boolTerm :: forall u. ParsecT String u Identity Bool+boolTerm =  do { _ <- symbol lex "true"+               ; return True+               }+        <|> do { _ <- symbol lex "false"+               ; return False+               }++ifTerm :: ParsecT String DFSState Identity DFSExpr+ifTerm = do { reservedOp lex "if"+            ; condition <- parens lex exprP+            ; _ <- symbol lex "{"+            ; thenbody <- exprP+            ; _ <- symbol lex "}"+            ; reservedOp lex "else"+            ; _ <- symbol lex "{"+            ; elsebody <- exprP+            ; _ <- symbol lex "}"+            ; return (If condition thenbody elsebody)+            }
+ System/DotFS/Core/FSActions.hs view
@@ -0,0 +1,203 @@+module System.DotFS.Core.FSActions where++import System.DotFS.Core.Datatypes+import System.DotFS.Core.FuseTypes+import System.DotFS.Util.Debug+import System.DotFS.Util.Options+import System.DotFS.Core.Constants+import System.DotFS.Core.Parsers++import qualified Data.ByteString.Char8 as B+import System.Posix.Types+import System.Posix.Files+import System.FilePath.Posix+import System.Posix.IO+import System.Directory+import System.Fuse+import Control.Monad++import Data.Bits++import Data.List (intersperse, intercalate)++import Prelude hiding (readFile, length)+import Data.ByteString.Char8 hiding (notElem, map, filter, drop, take, intersperse, concat, intercalate)++dirContents :: FilePath -> IO [FilePath]+dirContents fp = do+                contents <- getDirectoryContents fp+                debug (intercalate "," contents)+                return $ filter (`notElem` [".",".."]) contents++fileExists, dirExists :: FilePath -> FilePath -> IO Bool+fileExists path name = doesFileExist $ path </> name+dirExists  path name = doesDirectoryExist $ path </> name+++getGenStats :: FilePath -> FilePath -> IO DotFS+getGenStats path name = do p' <- canonicalizePath $ path </> name+                           let p = path </> name+                           st <- getSymbolicLinkStatus p+                           if isDirectory st then+                             getStats Directory p+                             else+                               if isSymbolicLink st then+                                   getStats SymbolicLink p+                               else --  isRegularFile st then+                                   getStats RegularFile p++getStats :: EntryType -> FilePath -> IO DotFS+getStats entrytype uri = do+  status <- getSymbolicLinkStatus uri+  children <- case entrytype of+    Directory -> do contents <- dirContents uri+                    -- list of files+                    files    <- filterM (fileExists uri) contents+                    fileList <- mapM (getGenStats uri) files+                    -- list of directories+                    dirs     <- filterM (dirExists uri) contents+                    dirList  <- mapM (getGenStats uri) dirs+                    return $ dirList ++ fileList+    RegularFile -> return []+    _           -> return [] -- symlinks etc etc+  sz <- case entrytype of+    Directory -> return $ fileSize status+    RegularFile -> do+      fd <- readFile uri+      let parsed = process uri fd+      return $ fromIntegral (length parsed)+    SymbolicLink -> return 42 -- arbitrary size for symlinks+    _ -> return 0+  return DotFS {+      dotfsEntryName   = takeFileName uri+    , dotfsActualPath  = uri+    , dotfsVirtualPath = "" -- uri -- "test"+    , dotfsFileStat    = FileStat+        { statEntryType = entrytype+        , statFileMode  = fileMode status+        , statLinkCount = linkCount status+        , statFileOwner = fileOwner status+        , statFileGroup = fileGroup status+        , statSpecialDeviceID = specialDeviceID status+        , statFileSize  = sz+        , statBlocks    = fromIntegral $ sz `div` 1024+        , statAccessTime= accessTime status+        , statModificationTime = modificationTime status+        , statStatusChangeTime = statusChangeTime status+        }+     , dotfsContents = children+  }+++statIfExists :: FilePath -> FilePath -> IO (Maybe DotFS)+statIfExists dir file = do+                          existsAsDir <- dir `dirExists` file+                          if existsAsDir then+                                      do debug $ file ++ " is a dir in "++dir+                                         stats <- dir `getGenStats` file+                                         return $ Just stats -- this already contains the children+                             else+                                      do existsAsFile <- dir `fileExists` file+                                         if existsAsFile then do+                                                       debug $ file ++ " is a file in " ++ dir+                                                       stats <- dir `getGenStats` file+                                                       return $ Just stats+                                            else return Nothing++dotFSOps :: Options -> Mountpoint -> Conf -> FuseOperations String+dotFSOps os mp dir =+  defaultFuseOps {+                   fuseGetFileStat        = dotfsGetFileStat dir+                 , fuseGetFileSystemStats = dotfsGetFileSystemStats dir+                 , fuseOpenDirectory      = dotfsOpenDirectory dir+                 , fuseReadDirectory      = dotfsReadDirectory dir+                 , fuseRead               = dotfsRead dir+                 , fuseOpen               = dotfsOpen dir+                 , fuseReadSymbolicLink   = dotfsReadSymbolicLink dir mp+                 }++{- | here's quite a bit of logic: we want symlinks to be presented as+ - such, but we would also like links pointing outside the repo to work.+ -}+dotfsReadSymbolicLink :: Conf -> Mountpoint -> FilePath -> IO (Either Errno FilePath)+dotfsReadSymbolicLink (C confdir) mp path = do+                                              let absPathToLink = normalise $ confdir ++ "/" ++ path+                                              linkDestination <- readSymbolicLink absPathToLink+                                              let mountedDestination = mp </> linkDestination+                                              let finalDestination = normalise mountedDestination+                                              let answer = makeRelative mp finalDestination+                                              return $ Right answer++{- possible FUSE operations:+ --+ -- | Check file access permissions; this will be called for the+ --   access() system call.  If the @default_permissions@ mount option+ --   is given, this method is not called.  This method is also not+ --   called under Linux kernel versions 2.4.x+ fuseAccess :: FilePath -> Int -> IO Errno, -- FIXME present a nicer type to Haskell+ -}++{-+ - this is a rather important function for the system.+ - it finds a file by name. the idea is, if a file or directory+ - exists in the conf tree, return that.+ -}+dotfsLookUp :: Conf -> FilePath -> IO (Maybe DotFS)+dotfsLookUp (C confdir) path = do+    confVersion <- statIfExists confdir path+    case confVersion of+        Just stats ->  do let oldFileStat = dotfsFileStat stats+                              -- Prevent other users accessing the files,+                              -- and prevent writing permission.+                              newFileStat = oldFileStat {statFileMode = 0o500 .&. statFileMode oldFileStat}+                              stats'      = stats {dotfsFileStat = newFileStat}+                          return $ Just stats'+        Nothing -> return Nothing++++dotfsGetFileStat :: Conf -> FilePath -> IO (Either Errno FileStat)+dotfsGetFileStat dp (_:dir) = do+  lkup <- dotfsLookUp dp dir+  case lkup of+    Just file -> return $ Right $ dotfsFileStat file+    Nothing   -> return $ Left eNOENT++dotfsOpen :: Conf -> FilePath -> OpenMode -> OpenFileFlags -> IO (Either Errno String)+dotfsOpen dirs (_:path) ReadOnly flags = do+  file <- dotfsLookUp dirs path+  case file of+    Just f -> do+      -- at this point load and parse the file.+      fd <- readFile (dotfsActualPath f)++      let parsed = process path fd+      return (Right $ unpack parsed)+    Nothing -> return (Left eNOENT)+dotfsOpen dirs (_:path) mode flags = return (Left eACCES)++-- TODO: check permissions with `getPermissions`+dotfsOpenDirectory :: Conf -> FilePath -> IO Errno+dotfsOpenDirectory (C confdir) (_:path) = do+  extantDirs <- confdir `dirExists` path+  return $ if extantDirs then eOK else eNOENT++dotfsReadDirectory :: Conf -> FilePath -> IO (Either Errno [(FilePath, FileStat)])+dotfsReadDirectory dirs@(C confdir) (_:dir) = do+  entry <- dotfsLookUp dirs dir+  case entry of+    Nothing -> return $ Left eNOENT+    Just e -> do+        let contents = dotfsContents e+        let dirContents = map (\x -> (dotfsEntryName x :: String , dotfsFileStat x)) contents+        dotstats <- confdir `getGenStats` dir+        return $ Right $ [ (".", dotfsFileStat dotstats), ("..", dirStat)] ++ dirContents++dotfsRead  :: Conf -> FilePath -> String -> ByteCount -> FileOffset -> IO (Either Errno B.ByteString)+dotfsRead dirsToUnion (_:path) fd byteCount offset = do+  --this is unused, so it's probably for error checking. should die gracefully+  --if something goes wrong, not throw unmatched pattern...+  --(Just file) <- dotfsLookUp dirsToUnion path+  let a = drop (fromIntegral offset) fd+      b = take (fromIntegral byteCount) a+  return $ Right $ pack b
+ System/DotFS/Core/FuseTypes.hs view
@@ -0,0 +1,16 @@+module System.DotFS.Core.FuseTypes where++import System.Fuse++data DotFS = DotFS {+    dotfsEntryName     :: FilePath+  , dotfsActualPath    :: FilePath+  , dotfsVirtualPath   :: FilePath+  , dotfsFileStat      :: FileStat+  , dotfsContents      :: [DotFS]+  }+ deriving Show++instance Eq DotFS where+  (==) x y = dotfsEntryName x == dotfsEntryName y+
+ System/DotFS/Core/HeaderParser.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE NoImplicitPrelude, GADTs, ExistentialQuantification #-}+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Core.HeaderParser where++import Prelude hiding (lex)++import System.DotFS.Core.Datatypes+import System.DotFS.Core.Lexers+import System.DotFS.Core.ExpressionParsers+import System.DotFS.Core.ExpressionEvaluator+import System.DotFS.Core.HelperParsers (eatEverything)++import Control.Applicative ((<*))+import Text.Parsec hiding (parseTest)+import Text.Parsec.Token as P+import Data.Map++headerRecogniseP = do { _ <- symbol lex "<<dotfs"+                      ; return ()+                      }++-- parse the header, no whitespace around it is eaten+headerP :: VarParser DFSState+headerP = do { _ <- symbol lex "<<dotfs"+             ; whiteSpace lex+             ; _ <- many assignmentP+             ; _ <- string ">>\n"+             ; getState -- returns the state+             }++-- parse an assignment+assignmentP :: VarParser ()+assignmentP = (try tagstyleP+           <|> try commentstyleP+           <|> try shellCommandP+           <|> assignState+            ) <* ( semi lex <* whiteSpace lex) <?> "assignment"+++-- we must prevent comment tags from being ignored by the lexer,+-- so use the alternative lexer with great care+tagstyleP,commentstyleP :: VarParser ()+tagstyleP = do{ _ <- symbol lex "tagstyle"+              ; _ <- symbol styleLex "="+              ; s1 <- operator styleLex+              ; _ <- symbol styleLex "tag"+              ; s2 <- operator lex+              ; updateState (insert "tagstart" (Prim(VString s1)))+              ; updateState (insert "tagstop"  (Prim(VString s2)))+              }++commentstyleP = do{ _ <- symbol lex "commentstyle"+                  ; _ <- symbol styleLex "="+                  ; s1 <- operator styleLex+                  ; updateState (insert "commentstart" (Prim(VString s1)))+                  ; _ <- symbol styleLex "comment"+                  ; optional (do s2 <- operator lex+                                 updateState (insert "commentstop"  (Prim(VString s2))))+                  }++-- | this parses a shell command. These are denoted by using := instead+-- of = for assignment. This is because backticks are a pain to parse, and+-- we prefer the built-in stringLiteral parser.+shellCommandP :: VarParser ()+shellCommandP = do { name <- identifier lex+                   ; whiteSpace lex+                   ; _ <- symbol lex ":="+                   ; whiteSpace lex+                   ; command <- exprP+                   ; s <- getState+                   ; let finalCommand = eval s command+                   ; let e = eval s (Sys (show finalCommand))+                   ; updateState (insert name (Prim e))+}++-- | assignState parses an assignment. That is, an identifier, an equals (=)+-- symbol, and then an expression.+assignState :: VarParser ()+assignState = do{ name <- identifier lex+                ; whiteSpace lex+                ; _ <- symbol lex "="+                ; whiteSpace lex+                ; val <- exprP+                ; s   <- getState+                ; let e = eval s val+                ; updateState (insert name (Prim e))+                }
+ System/DotFS/Core/HelperParsers.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Core.HelperParsers where++import System.DotFS.Core.Datatypes++import Control.Monad (join)+import Text.Parsec+import Text.Parsec.String+++eatEverything :: VarParser String+eatEverything = many anyChar++++-- new combinator: (source: http://www.haskell.org/pipermail/beginners/2010-January/003123.html)+many1Till :: Show end => VarParser a -> VarParser end -> VarParser [a]+many1Till p end = do notFollowedBy' end+                     p1 <- p+                     ps <- manyTill p end+                     return (p1:ps) where+                       notFollowedBy' :: Show a => GenParser tok st a -> GenParser tok st ()+                       notFollowedBy' p = try $ join $ do a <- try p+                                                          return (unexpected (show a))+                                                       <|> return (return ())+++++-- combinator that outputs the state tupled with the parse result+includeState :: GenParser s st a -> GenParser s st (a,st)+includeState p = do{ res <- p+                   ; state <- getState+                   ; return (res,state)+                   }++-- parseTest adepted to accept an initial state+parseTest p st inp = case runParser (includeState p) st "" inp of+                          (Left err) -> do{ putStr "parse error at "+                                          ; print err+                                          }+                          (Right (x,state))  -> case x of+                                                 Vanilla       -> putStrLn "Vanilla"+                                                 Annotated h b -> putStrLn "Annotated"
+ System/DotFS/Core/Lexers.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Haskell98 #-}+{-# LANGUAGE RankNTypes #-}+module System.DotFS.Core.Lexers where++import Prelude hiding (lex)++import Text.Parsec+import Text.Parsec.Language+import Text.Parsec.Token as P+import Data.Functor.Identity+++-- stuff about the language and the default lexer+tagletter :: forall u. ParsecT [Char] u Data.Functor.Identity.Identity Char+tagletter = oneOf "~!@#$%^&*_+|`-=\\:<>?[]',./"++lang :: LanguageDef st+lang = javaStyle+     { reservedNames = ["commentstyle","tagstyle","if","else","true","false"]+     , caseSensitive = True+     , opStart  = tagletter+     , opLetter = tagletter+     }++lex :: forall u. GenTokenParser String u Identity+lex = P.makeTokenParser lang++-- alternative lexer for style definitions+styleLang :: LanguageDef st+styleLang = emptyDef+          { opStart  = tagletter+          , opLetter = tagletter }++styleLex :: forall u. GenTokenParser String u Identity+styleLex = P.makeTokenParser styleLang
+ System/DotFS/Core/Parsers.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Core.Parsers where++import Prelude hiding (lex, lookup, readFile, putStrLn)++import System.DotFS.Core.Datatypes+import System.DotFS.Core.HeaderParser (headerP, headerRecogniseP)+import System.DotFS.Core.HelperParsers+import System.DotFS.Core.Lexers+import System.DotFS.Core.ExpressionEvaluator+import System.DotFS.Core.BodyParser++import Control.Applicative ((<$>))+import Text.Parsec hiding (parseTest)+import Text.Parsec.Token++import Data.Map++import Data.ByteString.Char8 (unpack, pack, ByteString, putStrLn)+import Data.ByteString (readFile)++-- | Test-process a given file, and show the result.+-- Especially useful for testing in combination with GHCi.+testfile :: FilePath -> IO ()+testfile name = do { fc <- readFile name+                   ; let output = process name fc+                   ; putStrLn output+                   ; return ()+                   }+++-- run the header parser and evaluator, and then the body parser on the result+process :: FilePath -> ByteString -> ByteString+process file contents =+                       let inp = unpack contents in+                         case runParser headerRecogniseP empty file inp of+                             Left err  -> contents+                             Right _   -> case runParser bodyP empty file inp of+                                Left err     -> pack $ "\n" ++ "error = \n" ++ show err ++ "\n"+                                Right (h,bs) -> pack $ present h bs++present :: Header -> Body -> String+present _ []     = ""+present h (Cond c b:bs) = case eval h c of+                                VBool True -> outputComment h c "if:" ++ present h b ++ outputComment h c "endif:"+                                _          -> outputComment h c "if-hiding; false == "+                            ++ present h bs+present h (Ref r:bs)    = outputComment h r "ref:" ++ show (eval h r) ++ present h bs+present h (Verb v:bs)   = v ++ present h bs++outputComment :: Header -> DFSExpr -> String -> String+outputComment h e note   = case lookup "commentstart" h of+                           Nothing -> ""+                           Just (Prim (VString start)) ->+                             case lookup "commentstop" h of+                             Nothing -> concat               ("\n":[start,note,show e]++["\n"])+                             Just (Prim (VString stop)) -> unwords ([start,note,show e]++[stop])+                             _ -> ""+                           _ -> ""
+ System/DotFS/Test/Tests.hs view
@@ -0,0 +1,34 @@+module System.DotFS.Test.Tests where++import System.DotFS.Core.ExpressionParsers+import Text.Parsec hiding (parseTest)+import Control.Monad+import System.DotFS.Core.Datatypes+import Test.QuickCheck.Gen+import Data.Char+import Data.Map++-- import the instances of Arbitrary ... from Test.Unit+-- this uses a trick to prevent circular dependencies+import {-# SOURCE #-} System.DotFS.Test.Unit()++prop_parseExpr :: DFSExpr -> Bool+prop_parseExpr xs = xs == testExprP (show xs)++--prop_parseHeader :: Header -> Bool+--prop_parseHeader xs = xs == testHeaderP (show xs)++testExprP :: String -> DFSExpr+testExprP inp = case runParser exprP empty "expr" inp of+              Left err -> Prim . VString $ "error = \n" ++ show (errorPos err) ++ "\n"+              Right s  -> s++-- | unfortunately we need to override the "instance Arbitrary [a]" for strings+arbitraryStr :: Gen String+arbitraryStr = sized $ \n ->+    do k <- choose (0,n)+       sequence [ arbitraryChar | _ <- [1..k] ]++-- | we don't want newlines in our strings...+arbitraryChar :: Gen Char+arbitraryChar = chr `fmap` oneof [choose (65,90), choose (97,122)]
+ System/DotFS/Test/Unit.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_GHC -fno-warn-unused-imports -fforce-recomp -fth #-}+module System.DotFS.Test.Unit where++import System.DotFS.Test.Utility -- our TH functions+import System.DotFS.Test.Tests   -- our test cases+import Control.Monad+import Test.QuickCheck+import System.DotFS.Core.Datatypes+import Test.QuickCheck.Test+import System.Exit++runTests :: IO ()+runTests = $(mkChecks tests)++-- Arbitrary instances:++-- there's actually a reason these instances are here, even if+-- they seem like orphans. The TH above requires them, but ghc doesn't+-- realise this at compile time.+instance Arbitrary DFSExpr where+    arbitrary  =  sized expr+        where+          expr n | n <= 0     =  atom+                 | otherwise  =  oneof [ atom+                                       , liftM2 UniOp unioperator subform+                                       , liftM3 BiOp bioperator subform subform'+                                       ]+                 where+                   atom = oneof [ liftM Var (elements ["P", "Q", "R", "S"])+                                , liftM Prim arbitrary+                                ]+                   subform  = expr (n `div` 2)+                   subform' = expr (n `div` 4)+                   unioperator = elements [Not]+                   bioperator  = elements [Add, Sub, Mul, Div, And, Or, Eq, LTOp, GTOp, GEQ, LEQ, NEQ]++instance Arbitrary Value where+    arbitrary = oneof [ liftM VBool   arbitrary+                      , liftM VInt    arbitrary+                      , liftM VString arbitraryStr+                      ]
+ System/DotFS/Test/Unit.hs-boot view
@@ -0,0 +1,1 @@+module System.DotFS.Test.Unit where
+ System/DotFS/Test/Utility.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell #-}++module System.DotFS.Test.Utility where++import Language.Haskell.Syntax+import Language.Haskell.TH+import Data.List+import Test.QuickCheck+import Test.QuickCheck.Test+import Control.Monad (unless)+import Language.Haskell.Parser+import System.IO.Unsafe+import System.IO+import System.Exit++{- | looks in Tests.hs for functions like prop_foo and returns+  the list.  Requires that Tests.hs be valid Haskell98. -}+tests :: [String]+tests = unsafePerformIO $+  do h <- openFile "System/DotFS/Test/Tests.hs" ReadMode+     s <- hGetContents h+     case parseModule s of+       (ParseOk (HsModule _ _ _ _ ds)) -> return (map declName (filter isProp ds))+       (ParseFailed loc s')            -> error (s' ++ " " ++ show loc)++{- | checks if function binding name starts with @prop_@ indicating+ that it is a quickcheck property -}+isProp :: HsDecl -> Bool+isProp d@(HsFunBind _) = "prop_" `isPrefixOf` declName d+isProp _ = False++{- | takes an HsDecl and returns the name of the declaration -}+declName :: HsDecl -> String+declName (HsFunBind (HsMatch _ (HsIdent name) _ _ _:_)) = name+declName _                                              = undefined++mkCheck :: String -> Q Exp+mkCheck name = [| putStr (name ++ ": ")+               >> do res <- quickCheckResult $(varE (mkName name))+                     unless (isSuccess res) exitFailure+               |]++mkChecks :: [String] -> Q Exp+mkChecks []        = undefined -- if we don't have any tests, then the test suite is undefined right?+mkChecks [name]    = mkCheck name+mkChecks (name:ns) = [| $(mkCheck name) >> $(mkChecks ns) |]
+ System/DotFS/Util/Debug.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Util.Debug where++-- TODO: nicer logging, to a variable filename (State / Reader monad?)+debug :: String -> IO ()+debug str = appendFile "/tmp/foo" (str ++ "\n")
+ System/DotFS/Util/Options.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Util.Options where++import System.DotFS.Util.Version+import System.Exit+import System.Environment+import System.Console.GetOpt+import System.IO++data Options = Options {+    optLog :: String,+    script :: Bool+    }+++defaultOptions :: Options+defaultOptions = Options { optLog = undefined, script = False }+++options :: [OptDescr (Options -> IO Options)]+options =+  [ Option "V?" ["version"] (NoArg printVersion) "show version number"+  , Option "l"  ["log"] (ReqArg (\ arg opt -> return opt {optLog = arg})+                          "FILE") "write log to FILE"+  , Option "h"  ["help"] (NoArg printHelp) "show this help message"+  , Option "g"  ["gen","gen-symlinks"] (NoArg printSyms) "generate a script to set symlinks"+  ]++printSyms :: Options -> IO Options+printSyms os = do+    hPutStrLn stderr "Printing script to stdout."+    return $ os {script = True}++printHelp :: Options -> IO Options+printHelp _ = do+  prg <- getProgName+  hPutStrLn stderr "Usage:"+  hPutStrLn stderr $ "\t"++prg++" [options] confdir mountpoint"+  hPutStrLn stderr (usageInfo prg options)+  exitSuccess+++printVersion :: Options -> IO Options+printVersion _ = do+  hPutStrLn stderr $ "DotFS v" ++ version ++ "\n\nCopyright 2012 Sjoerd Timmer, Paul van der Walt"+  exitSuccess++
+ System/DotFS/Util/Sanity.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Util.Sanity where++import System.DotFS.Core.Datatypes+import System.DotFS.Util.Options++import System.IO+import System.Directory+import Control.Monad+import System.Exit++validateDirs :: [String] -> IO (String, Conf)+validateDirs dirs =+                   do+                      existingDirs <- filterM doesDirectoryExist dirs+                      canonicalDirs <- mapM canonicalizePath existingDirs+                      if length canonicalDirs == 2 then do+                          let (confdir : mountpoint : []) = canonicalDirs+                          return (mountpoint, C confdir)+                         else do+                           hPutStrLn stderr "Invalid director(y|ies)"+                           _ <- printHelp defaultOptions+                           exitWith $ ExitFailure 1++
+ System/DotFS/Util/Version.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE Haskell98 #-}+module System.DotFS.Util.Version where++version :: String+version = "0.1"
dotfs.cabal view
@@ -1,5 +1,5 @@ name:                dotfs-version:             0.1.1.2+version:             0.1.1.3 synopsis:            Filesystem to manage and parse dotfiles description:         A system which, when pointed to a folder full of specially                      annotated config files, will present these files tailored to@@ -37,6 +37,46 @@   ghc-options:      -Wall -rtsopts   default-language: Haskell98   main-is:          System/DotFS/Test/Main.hs++Library+  other-modules:      System.DotFS.Core.BodyParser,+                      System.DotFS.Core.ExpressionParsers,+                      System.DotFS.Core.Constants,+                      System.DotFS.Core.Datatypes,+                      System.DotFS.Core.ExpressionEvaluator,+                      System.DotFS.Core.FSActions,+                      System.DotFS.Core.FuseTypes,+                      System.DotFS.Core.HeaderParser,+                      System.DotFS.Core.HelperParsers,+                      System.DotFS.Core.Lexers,+                      System.DotFS.Core.Parsers,+                      System.DotFS.Test.Tests,+                      System.DotFS.Test.Unit,+                      System.DotFS.Test.Utility,+                      System.DotFS.Util.Debug,+                      System.DotFS.Util.Options,+                      System.DotFS.Util.Sanity,+                      System.DotFS.Util.Version++  default-language:   Haskell98+  build-depends:      bytestring >=0.9,+                      base >= 4 && < 5,+                      HFuse > 0.2.4,+                      directory>=1,+                      unix >= 2.3,+                      filepath >=1.1,+                      parsec,+                      containers,+                      transformers,+                      process,+                      HUnit >= 1.2 && < 2,+                      QuickCheck >= 2.4,+                      test-framework >= 0.4.1,+                      test-framework-quickcheck2,+                      test-framework-hunit,+                      parsec >= 3,+                      haskell-src,+                      template-haskell  Executable            dotfs   default-language:   Haskell98