-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2018 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(..),dummyDefName)
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 dummyDefName
        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)}))