mcm-0.6.4.10: InterpretState.hs
-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>
--
-- Licence:
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module InterpretState (State, addError, Error, getResult, Expander(..), collapseExpander, AllLocals(..), Interpret, Args(..), PendingCmd(..), runInterpret, lookupSection, allImports, takeFragments, takeAllLaters, pushLocation, popLocation, invokeLater, logInvokeOf, pl2section, addFragment, addToLoad, PackageLets, parseOwner, parseGroup, iAddPath, PLSection(..), getSearchPath, SearchPath(..), addSection, getLoadFiles, initState, Cache, setCache, getCache)
where
import Control.Applicative(Applicative(..))
import Control.Arrow((&&&))
import Control.Monad(ap, liftM, when)
import Data.List(intersect, intercalate)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text.Lazy as T
import FileCorrector(theRootDir,Path,addPath,PathType, Permissions)
import ParserTypes(Group(..),Section,Prepend,Append,Separator,PackagePath, dummyPP,imports,Import,ExpandedInvocationCmd,Ident(..),DefName(..))
import System.FilePath(normalise,dropTrailingPathSeparator,combine)
import System.Posix.User(UserEntry(userName, userID), GroupEntry(groupName, groupID))
import System.Posix.Types (UserID, GroupID)
newtype SearchPath = SearchPath {fromSearchPath :: [FilePath]}
deriving (Show)
newtype Unexpanded = Unexpanded T.Text
deriving (Show)
-- AllLocals have the Unexpanded expanded
newtype AllLocals = AllLocals (Map.Map Ident Expander)
deriving (Show, Eq, Ord)
data Location = Location PackagePath DefName
instance Show Location where
showsPrec _ (Location s d) = (show s++) . ('.':) . (show d++)
data Error = Error Location String
instance Show Error where
showsPrec _ (Error l m) = ("Error in "++) . shows l . (": "++) . (m++)
-- Expanding Package-level locals is just like expanding define-level locals
type PackageLets = AllLocals
-- PLSection is like Section but in addition PackageLets have been expanded from the package lets
data PLSection = PLSection Section PackageLets
deriving (Show, Eq)
pl2section :: PLSection -> Section
pl2section (PLSection s _) = s
-- Expander is like Content, but AllLocals have been expanded from the given strings
data Expander = Expanded T.Text
| EFile FilePath AllLocals -- AllLocals needed for expanding template
| EFragments PackagePath Group Prepend Append Separator
| ERawFile FilePath
| EMulti [Expander]
deriving (Show, Eq, Ord)
collapseExpander :: [Expander] -> Expander
collapseExpander = ce
where
isExpanded (Expanded _) = True
isExpanded _ = False
fromExpanded (Expanded s) = s
fromExpanded _ = error "Internal error: bad arg to fromExpanded"
ce [x] = x
ce xs@(Expanded _:Expanded _:_) =
case span isExpanded xs of
(expands, rest) -> ce (Expanded (T.concat $ map fromExpanded expands):rest)
ce (EMulti as:bs) = EMulti [ce as, ce bs]
ce (a:b:cs) = EMulti [a, b, ce cs]
ce [] = Expanded T.empty
newtype Args = Args {fromArgs :: Map.Map Ident Expander}
deriving (Show, Eq, Ord)
data PendingCmd = PendingFile | PendingPath | PendingSymlink | PendingAbsent | PendingFragment
deriving (Show, Eq)
data PendingInvocation = PI
{_piPp :: PackagePath
,piArgs :: Args
,_piCmd :: PendingCmd
}
deriving (Show, Eq)
type FragName = T.Text
type Fragments = Map.Map FragName T.Text
type FragmentGroups = Map.Map Group Fragments
type AllFragments = Map.Map PackagePath FragmentGroups
type PFMap = Map.Map (PackagePath, Group) [PendingInvocation]
data State = State
{sPath :: Path
,sSections :: Map.Map PackagePath PLSection
,sSearchPath :: SearchPath
,sRoot :: FilePath
,sErrors :: [Error]
,sPendingSimple :: [PendingInvocation]
,sPendingFragment :: PFMap
,sToLoad :: Set.Set FilePath -- FilePath should be relative - will be looked for within SearchPath
,sFragments :: AllFragments
,sNewFragments :: Set.Set (PackagePath, Group)
,sCurrentLocation :: [Location] -- Purely for error messages (to be updated at the start of every Define invocation; head = current)
,sOwners :: Map.Map T.Text UserID
,sGroups :: Map.Map T.Text GroupID
,sOwnerWarnings :: Set.Set T.Text
,sGroupWarnings :: Set.Set T.Text
,sInvocationHistory :: Set.Set (ExpandedInvocationCmd, PackagePath, Args)
}
newtype Cache = Cache (Map.Map PackagePath PLSection)
newtype Interpret a = Interpret (State -> (a, State))
instance Monad Interpret where
Interpret c1 >>= fc2 = Interpret (\s0 -> let (r,s1) = c1 s0
Interpret c2 = fc2 r
in c2 s1)
return k = Interpret (\s -> (k,s))
instance Applicative Interpret where
pure = return
(<*>) = ap
instance Functor Interpret where
fmap = liftM
runInterpret :: State -> Interpret a -> (a, State)
runInterpret s0 (Interpret i) = i s0
addError :: String -> Interpret ()
addError msg =
Interpret (\s -> ((), s {sErrors=Error ((head.sCurrentLocation) s) msg:sErrors s}))
pushLocation :: PackagePath -> DefName -> Interpret ()
pushLocation sect d = Interpret (\s -> ((), s {sCurrentLocation=Location sect d:sCurrentLocation s}))
popLocation :: Interpret ()
popLocation = Interpret (\s -> ((), s{sCurrentLocation=(tail.sCurrentLocation) s}))
showLocationStack :: [Location] -> String
showLocationStack = showLocationStack' . tail . reverse
where
showLocationStack' ls = intercalate "-" $ map show ls
lookupRoot :: Interpret FilePath
lookupRoot = Interpret (\s -> (sRoot s, s))
iAddPath :: FilePath -> PathType -> Permissions -> Interpret ()
iAddPath f pt perm = do
r <- lookupRoot
let lookupSPath = Interpret (\s -> (sPath s, s))
let lookupLocation = Interpret (\s -> (sCurrentLocation s, s))
sp <- lookupSPath
l <- lookupLocation
fp <- rootCombine r f
case fp of
Nothing -> return ()
Just fp' -> case addPath sp fp' pt perm (showLocationStack l) of
Left e -> addError e
Right p -> Interpret (\s -> ((), s {sPath=p}))
-- NB. different from standard combine because we (always) want to prepend (sRoot s)
rootCombine :: FilePath -> FilePath -> Interpret (Maybe FilePath)
rootCombine ('/':'/':_) _ =
addError "Internal error: impossible (and bad) root" >> return Nothing
rootCombine _ p@('/':'/':_) =
addError ("Invalid path: " ++ p) >> return Nothing
rootCombine r ('/':p) = return $ Just $ combine r p
rootCombine _ p = addError ("Expected path to start '/' but found: " ++ p) >> return Nothing
initState :: [UserEntry] -> [GroupEntry] -> SearchPath -> FilePath -> State
initState users groups sp r =
State theRootDir Map.empty sp r' [] [] Map.empty Set.empty Map.empty Set.empty [l0] us gs Set.empty Set.empty Set.empty
where
l0 = Location dummyPP $ (DefName . T.pack) "<init>"
r' = dropTrailingPathSeparator $ normalise r
us = Map.fromList (map ((T.pack . userName) &&& userID ) users)
gs = Map.fromList (map ((T.pack . groupName) &&& groupID) groups)
getCache :: State -> Cache
getCache s = Cache $ sSections s
setCache :: State -> Cache -> State
setCache s (Cache ss) = s {sSections = sSections s `Map.union` ss}
getResult :: State -> ([Error], [String], Path, [(PackagePath, Group)])
getResult s = (reverse (sErrors s), ownerAndGroupWarnings, sPath s, Set.toList $ sNewFragments s)
where
ownerAndGroupWarnings :: [String]
ownerAndGroupWarnings = uWs (sOwnerWarnings s) ++ gWs (sGroupWarnings s)
where
uWs w = map (\x -> "Warning: User " ++ T.unpack x ++ " not found. "
++ "Using root instead.") $ Set.toList w
gWs w = map (\x -> "Warning: Group " ++ T.unpack x ++ " not found. "
++ "Using root instead.") $ Set.toList w
lookupSection :: PackagePath -> Interpret (Maybe PLSection)
lookupSection pp = Interpret (\s -> (Map.lookup pp (sSections s), s))
getSearchPath :: State -> SearchPath
getSearchPath = sSearchPath
addSection :: (PackagePath, PLSection) -> Interpret ()
addSection (name, section) = Interpret (\s -> ((), s {sSections=Map.insert name section (sSections s)}))
allImports :: Interpret [Import]
allImports = Interpret (\s -> (allImports' (Map.elems $ sSections s), s))
where
allImports' :: [PLSection] -> [Import]
allImports' = concatMap (\(PLSection s _) -> imports s)
-- Record a file for loading (e.g. template, raw)
addToLoad :: FilePath -> Interpret ()
addToLoad f = Interpret (\s -> ((), s {sToLoad=Set.insert f (sToLoad s)}))
getLoadFiles :: State -> [FilePath]
getLoadFiles s = Set.toList $ sToLoad s
thisgroup :: Args -> Group
thisgroup (Args as) =
case Map.lookup (Ident $ T.pack "group") as of
Just (Expanded g) -> Group g
Just _ -> error "Groups cannnot reference external files"
Nothing -> error $ "Internal failure: fragment args without a group: " ++ show as
invokeLater :: PendingCmd -> PackagePath -> Args -> Interpret ()
invokeLater pc pp as = Interpret (\s -> ((), invokeLater' pc s))
where
invokeLater' PendingFragment s =
s {sPendingFragment=addFrag (PI pp as pc) (sPendingFragment s)}
invokeLater' _ s =
s {sPendingSimple=PI pp as pc : sPendingSimple s}
addFrag :: PendingInvocation -> PFMap -> PFMap
addFrag pendi@(PI pp' as' _) =
Map.insertWith (++) (pp', g) [pendi]
where
g = thisgroup as'
-- takeAllLaters solves an ordering problem: fragment dependencies
-- We need to fully process all dependent fragments first
-- And if there is a recursive loop, need to error to the user
-- We return non-Fragments last, as they can depend on fragments but aren't required by fragments
{-
- Does a PendingFragment know which group it is for?
- - yes: the "group" parameter
- How do I know when a PendingFragment is ready to yield?
- - there are no later PendingFragments that are needed
- to generate any of its parameters (e.g. "content")
- So:
- 1) Spurt out all PendingFragments that don't have
- Fragments commands in their parameters
- (NB. complicated by EMulti)
- (NB. complicated by movement of EFragments between files in args)
- Collect other PendingFragments in a map of sets, grouped by
- their (pp,group parameter) (ppgp)
- 2) Calcualate the set of fragment (pp, group) mentioned in the
- parameters (fgms)
- 3) Spurt out PendingFragments once none of their fgms are in the keyset of ppgp-s
- 4) Add to sError any loops found
-}
takeAllLaters :: Interpret [(PendingCmd, PackagePath, Args)]
takeAllLaters = Interpret (\s -> ((extract.fragmentextract) (sPendingFragment s)
++ extract (sPendingSimple s)
,s {sPendingSimple=[], sPendingFragment=Map.empty}))
where
extract = map (\(PI pp args cmd) -> (cmd, pp, args))
fragmentextract :: PFMap -> [PendingInvocation]
fragmentextract m = orderbymentions withMentioned
where
withMentioned :: Map.Map (PackagePath, Group) ([(PackagePath, Group)], [PendingInvocation])
withMentioned = Map.map addMentioned m
orderbymentions m | Map.null m = []
orderbymentions m = readypis' ++ orderbymentions othergroups
where
(readygroups, othergroups) = Map.partition (readytogo (Map.keys m)) m
readypis :: [PendingInvocation]
readypis = concatMap snd $ Map.elems readygroups
readypis' = case readypis of
[] -> error $ "Circular reference in fragments: " ++ show m
xs -> xs
readytogo keys (grs, _) = null (keys `intersect` grs)
addMentioned :: [PendingInvocation] -> ([(PackagePath, Group)], [PendingInvocation])
addMentioned pis = (concatMap mentionedfragments pis, pis)
mentionedfragments :: PendingInvocation -> [(PackagePath, Group)]
mentionedfragments (PI {piArgs=Args as}) = mentionedfragments' (Map.elems as)
mentionedfragments' [] = []
mentionedfragments' (EFragments ppF g _ _ _:as) = (ppF,g):mentionedfragments' as
mentionedfragments' (EMulti xs:as) = mentionedfragments' xs ++ mentionedfragments' as
mentionedfragments' (_:as) = mentionedfragments' as
addFragment :: PackagePath -> Group -> T.Text -> T.Text -> Interpret ()
addFragment pp g n c = do
existingFragmentContent <- lookupFragment
case existingFragmentContent of
Nothing -> return ()
Just c' -> when (c' /= c)
$ addError $ "Fragment " ++ show n ++ " already exists with different content (" ++ show c ++ " vs " ++ show c' ++ ")."
updateFragments insertFragment
updateNewFragments
where
updateFragments :: (AllFragments -> AllFragments) -> Interpret ()
updateFragments f = Interpret (\s -> ((), s {sFragments=f (sFragments s)}))
updateNewFragments :: Interpret ()
updateNewFragments = Interpret (\s -> ((), s {sNewFragments=Set.insert (pp, g) (sNewFragments s)}))
lookupFragment :: Interpret (Maybe T.Text)
lookupFragment = Interpret (\s -> (lup (sFragments s), s))
where
lup af = Map.lookup n $ lookupFragmentGroup af pp g
insertFragment :: AllFragments -> AllFragments
insertFragment af = Map.insert pp newfg af
where
fg :: FragmentGroups
fg = Map.findWithDefault Map.empty pp af
newfg :: FragmentGroups
newfg = Map.insert g newf fg
f :: Fragments
f = Map.findWithDefault Map.empty g fg
newf = Map.insert n c f
-- Return set of requested fragments
-- Fragments should be complete thanks to takeAllLaters
-- (Assumption: sPendingFragment and sPendingSimple are empty at this point)
takeFragments :: PackagePath -> Group -> Interpret [T.Text]
takeFragments pp g = Interpret takeFragments'
where
takeFragments' :: State -> ([T.Text], State)
takeFragments' (s@State {sFragments=af, sNewFragments=sNew}) =
(Map.elems (lookupFragmentGroup af pp g), s {sNewFragments=Set.delete (pp, g) sNew})
lookupFragmentGroup :: AllFragments -> PackagePath -> Group -> Fragments
lookupFragmentGroup af pp g =
let fg :: FragmentGroups
fg = Map.findWithDefault Map.empty pp af
in Map.findWithDefault Map.empty g fg
parseOwner :: T.Text -> Interpret UserID
parseOwner o = do
let lookupOwner x = Interpret (\s -> (Map.lookup x (sOwners s), s))
let addOwnerWarning x = Interpret (\s -> ((), s {sOwnerWarnings=Set.insert x (sOwnerWarnings s)}))
o' <- lookupOwner o
case o' of
Nothing -> do
addOwnerWarning o
r <- lookupOwner $ T.pack "root"
case r of
Nothing -> error "Internal assumption failure: no root user on system"
Just r' -> return r'
Just ii -> return ii
parseGroup :: T.Text -> Interpret GroupID
parseGroup o = do
let lookupGroup x = Interpret (\s -> (Map.lookup x (sGroups s), s))
let addGroupWarning x = Interpret (\s -> ((), s {sGroupWarnings=Set.insert x (sGroupWarnings s)}))
o' <- lookupGroup o
case o' of
Nothing -> do
addGroupWarning o
r <- lookupGroup $ T.pack "root"
case r of
Nothing -> error "Internal assumption failure: no group \"root\" on system"
Just r' -> return r'
Just ii -> return ii
logInvokeOf :: (ExpandedInvocationCmd, PackagePath, Args) -> Interpret Bool
logInvokeOf t = Interpret (\s -> (Set.member t (sInvocationHistory s),
s {sInvocationHistory=Set.insert t (sInvocationHistory s)}))