module Main where import Desktop import Control.Exception import Control.Monad import qualified Data.ByteString.Lazy.Char8 as B import Data.List import Data.Maybe import qualified Data.Map as Map import System.Directory import System.Environment import System.FilePath.Posix import System.IO import System.Posix.User import System.Posix.Process import System.Unix.Process import Text.Printf import Text.Regex applnkdirs compat = if compat then ["/usr/share/"] else ["/usr/share/applnk", "/usr/share/applications/"] mimelnkdir = "/usr/share/mimelnk/" findDesktops :: Bool -> FilePath -> IO [FilePath] findDesktops compat dir = do (out, err, code) <- lazyCommand cmd B.empty >>= return . collectOutputUnpacked case code of [ExitSuccess] -> return . filter isDesktop . lines $ out _ -> error $ "Failure: " ++ cmd ++ " -> " ++ show err ++ " (" ++ show code ++ ")" where cmd = "find \"" ++ dir ++ "\" -type f" isDesktop path = case compat of True -> isInfixOf "desktop" path False -> isSuffixOf ".desktop" path isRealUser user = id == 0 || (id >= 1000 && id < 30000) where id = userID user main = do args <- getArgs let compat = elem "--compat" args let verbose = 1 -- length (filter (elem ["-v", "--verbose"]) args) globalApplnks <- mapM (findDesktops compat) (applnkdirs compat) >>= return . concat globalMimelnks <- findDesktops compat mimelnkdir --putStrLn ("globalApplnks=" ++ show globalApplnks) pid <- getProcessID getAllUserEntries >>= return . filter isRealUser >>= mapM_ (doUser compat verbose pid globalApplnks globalMimelnks) where doUser compat verbose pid globalApplnks globalMimelnks pw = do -- hPutStrLn stderr ("user=" ++ userName pw ++ ", home=" ++ homeDirectory pw) let tmp = "/var/tmp/mimeTypes.XML." ++ userName pw ++ "." ++ show pid userApplnks <- findDesktops compat (homeDirectory pw ++ "/.kde/share/applnk") userMimelnks <- findDesktops compat (homeDirectory pw ++ "/.kde/share/mimelnk") return (Map.empty, Map.empty, Map.empty, Map.empty) >>= \ maps -> foldM (doApplnkFile compat verbose) maps (globalApplnks ++ userApplnks) >>= \ maps -> foldM (doMimelnkFile verbose) maps (globalMimelnks ++ userMimelnks) >>= -- doProfileRCFile >>= writeMimetypesFile (homeDirectory pw) (homeDirectory pw ++ "/.kde/share/config/profilerc") tmp type Tables = (Map.Map String (), Map.Map String (Int, String), Map.Map String String, Map.Map String [String]) isIgnored x = elem x ["Desktop Action Setup", "Desktop Action InWindow", "Desktop Action Root", "Property::X-KDE-text", "Property::X-KDE-NativeExtension", "Property::X-KDE-CompatibleApplication", "Property::X-KDE-LocalProtocol"] dropPrefix s = if isPrefixOf "*." s then drop 2 s else if isPrefixOf "*" s then drop 1 s else s doApplnkFile :: Bool -> Int -> Tables -> FilePath -> IO Tables doApplnkFile compat verbose tables path = do -- when (verbose >= 2) (hPutStrLn stderr ("applnk path: " ++ path)) parseFile path >>= doDesktop where doDesktop (Desktop entries) = foldM doEntry tables entries -- foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a doEntry :: Tables -> Entry -> IO Tables doEntry tables entry@(Entry heading alist) | heading == "Desktop Entry" || heading == "KDE Desktop Entry" = do let exec = maybe Nothing (Just . stripQuotes) (lookup "Exec" alist) let mimetypes = maybe [] mimeSplit (lookup "MimeType" alist) --putStrLn ("exec=" ++ show exec) --putStrLn ("mimetypes=" ++ show mimetypes) foldM (doMimetype alist exec) tables mimetypes doEntry tables (Entry heading _) | isIgnored heading = return tables doEntry tables (Entry heading _) = error $ path ++ ": Unexpected heading: " ++ show heading doMimetype :: [(String, String)] -> Maybe String -> Tables -> String -> IO Tables doMimetype alist Nothing tables mimetype = return tables doMimetype alist (Just exec) (mimeTable, prefTable, commentTable, patternTable) mimetype = do -- hPutStrLn stderr $ " Mimetype: " ++ show mimetype ++ ", Exec: " ++ exec let mimeTable' = Map.insert mimetype () mimeTable let prefTable' = updatePref prefTable exec mimetype (maybe 2 read (lookup "InitialPreference" alist)) return (mimeTable', prefTable', commentTable, patternTable) updatePref :: Map.Map String (Int, String) -> String -> String -> Int -> (Map.Map String (Int, String)) updatePref table exec mimetype value = case Map.lookup mimetype table of Just (oldValue, oldExec) -> if oldValue < value then Map.insert mimetype (value, exec) table else table Nothing -> Map.insert mimetype (value, exec) table mimeSplit :: String -> [String] mimeSplit s = filter (/= "") (splitRegex (mkRegex ";") s) doMimelnkFile :: Int -> Tables -> FilePath -> IO Tables doMimelnkFile verbose tables path = do -- when (verbose >= 2) (hPutStrLn stderr $ "mimelnk path: " ++ path) parseFile path >>= doDesktop where doDesktop (Desktop entries) = foldM doEntry tables entries doEntry :: Tables -> Entry -> IO Tables doEntry tables@(mimeTable, prefTable, commentTable, patternTable) entry@(Entry heading alist) | heading == "Desktop Entry" || heading == "KDE Desktop Entry" = do -- hPutStrLn stderr $ "Mimelnk file: " ++ path -- hPutStrLn stderr $ " MimeType: " ++ show (lookup "MimeType" alist) -- hPutStrLn stderr $ " Comment: " ++ show (lookup "Comment" alist) -- hPutStrLn stderr $ " Patterns: " ++ show (lookup "Patterns" alist) case lookup "MimeType" alist of Nothing -> return tables Just mimetype -> do let mimeTable' = Map.insert mimetype () mimeTable let commentTable' = doComment mimetype (lookup "Comment" alist) let patternTable' = doPatterns mimetype (lookup "Patterns" alist) return (mimeTable', prefTable, commentTable', patternTable') where doComment mimetype Nothing = commentTable doComment mimetype (Just comment) = let comment' = maybe comment (\ oldComments -> oldComments ++ ", " ++ comment) (Map.lookup mimetype commentTable) in Map.insert mimetype comment' commentTable doPatterns mimetype Nothing = patternTable doPatterns mimetype (Just patterns) = foldr addPattern patternTable (map dropPrefix (patternSplit patterns)) where addPattern pattern table = Map.alter (maybe (Just [pattern]) (\ xs -> Just (pattern : xs))) mimetype table patternSplit :: String -> [String] patternSplit s = filter (/= "") (splitRegex (mkRegex ";") s) doEntry tables (Entry heading _) | isIgnored heading = return tables doEntry tables (Entry heading _) = error $ path ++ ": Unexpected heading: " ++ show heading -- Added by ASW to handle profilerc {- doProfileRCFile home tables@(mimeTable, prefTable, commentTable, patternTable) path = return tables do putStrLn $ "kdeprofilerc path: " ++ path parseFile path >>= doDesktop where let filtered_list = List.filter (fun (tag, _) -> Pcre.pmatch ~pat:"- 1$" tag) entries in let map_me = List.map ( fun (tag, alist) -> let pos = String.index tag ' ' in let mime_part = String.sub tag 0 pos in (* prerr_endline ("mime part is " ^ mime_part); *) (* Now find the desktop file *) let kdedesktopfile = try List.assoc "Application" alist with Not_found as exn -> if compat then "" else raise exn in (* prerr_endline (" desktop file part is " ^ kdedesktopfile);*) let kdefullpath = "/usr/share/applnk/" ^ kdedesktopfile in if Sys.file_exists kdefullpath then begin (* fake InitialPreference to be zero in preftable of /usr/share/applnk winner *) let (oldpref, oldexec) = Hashtbl.find preftable mime_part in Hashtbl.replace preftable mime_part (0, oldexec); do_applnk_file mimetable preftable kdefullpath end; let kdefullpath = home ^ "/.kde/share/applnk/" ^ kdedesktopfile in if Sys.file_exists kdefullpath then begin (* preftable of $HOME/.kde/share/applnk/.desktops *) let (oldpref, oldexec) = Hashtbl.find preftable mime_part in Hashtbl.replace preftable mime_part (0, oldexec); do_applnk_file mimetable preftable kdefullpath end; (* prerr_endline (" fullpath " ^ kdefullpath);*) ) filtered_list in if verbose >= 2 then prerr_endline ("kdeprofilerc path: " ^ path); with Parsing.Parse_error -> prerr_endline ("*** WARNING: parse error in " ^ path) (* End of Adam's new test function *) -} stripQuotes :: String -> String stripQuotes s = maybe s head (matchRegex (mkRegex "^[ \t]*\"(.*)\"[ \t]*$") s) writeMimetypesFile dir profileRC dest (mimeTable, prefTable, commentTable, patternTable) = do elems <- mapM (\ m -> doMimeType (Map.lookup m prefTable) m) mimetypes' >>= return . concat writeFile dest (unlines (header ++ elems ++ footer)) where mimetypes' = sort ({- filter (\ x -> elem x ["audio/mpeg"]) -} (Map.keys mimeTable)) header = ["", "", " ", " ", " "] doMimeType Nothing mimetype = return [] doMimeType (Just (pref, exec)) mimetype = do pref <- doPref mimetype (pref, exec) return $ [" ", " ", " "] ++ doComment mimetype (Map.lookup mimetype commentTable) ++ doPatterns (Map.lookup mimetype patternTable) ++ pref doComment _ Nothing = [] doComment mimetype (Just comment) = [" "] doPatterns Nothing = [] doPatterns (Just patterns) = case patterns of [pat] -> [" NC:fileExtensions=\"" ++ pat ++ "\"", " NC:editable=\"true\">"] _ -> [" NC:editable=\"true\">"] ++ map (\ pat -> " " ++ pat ++ "") patterns doPref :: String -> (Int, String) -> IO [String] doPref mimetype (pref, exec) = which (head (words exec)) >>= return . maybe [] (\ execPath -> [" ", " ", " "]) footer = [" "] ++ catMaybes (map (\ mimetype -> case Map.member mimetype prefTable of True -> Just $ " " False -> Nothing) mimetypes') ++ [" "] ++ {- [" ", " ", " "] ++ -} [""] which :: String -> IO (Maybe String) which exec = getSearchPath >>= return . map (\ dir -> dir ++ "/" ++ exec) >>= filterM doesFileExist >>= return . listToMaybe {- let write_mimetypes_file mimetable preftable commenttable patterntable pw dest = let ochan = open_out dest in let print_lines lines = List.iter (fun line -> output_string ochan (line ^ "\n")) lines in print_lines [""; ""; " "; " "; " " (*; ""*)]; let mimetypes = let tmp = ref [] in Hashtbl.iter (fun mimetype _ -> tmp := mimetype :: !tmp) mimetable; List.sort compare !tmp in List.iter (fun mimetype -> if verbose >= 2 then prerr_endline ("outputting mimetype: " ^ mimetype); try let (pref, exec) = try Hashtbl.find preftable mimetype with Not_found as exn -> if verbose >= 3 then prerr_endline " Mimetype not in preftable"; raise exn in let comment = try Hashtbl.find commenttable mimetype with Not_found as exn -> if verbose >= 3 then prerr_endline " No comment"; raise exn in print_lines [" "; " "; " " (*; ""*)]; print_lines [" [] in let patlist = patterns in let newpats = String.concat " " (keep_first patlist) in let patlist' = List2.uniq compare ( (*List.map String.uppercase*) patlist) in begin if verbose >= 4 then prerr_endline ("List.length [\"" ^ (String.concat "\"; \"" patlist') ^ "\"] = " ^ (string_of_int (List.length patlist'))); match List.length patlist' with 1 -> print_lines [" NC:fileExtensions=\"" ^ newpats ^ "\""; " NC:editable=\"true\">"] | _ -> print_lines [" NC:editable=\"true\">"]; List.iter (fun pat -> print_lines [" " ^ pat ^ ""]) patlist' end; print_lines [" "; n " "; (*"";*) " " (*; ""*)] with Not_found -> () end with Not_found -> ()) mimetypes; print_lines [" "]; List.iter (fun mimetype -> try let (pref, exec) = Hashtbl.find preftable mimetype and comment = Hashtbl.find commenttable mimetype in print_lines [" "] with Not_found -> ()) mimetypes; print_lines [" "; (*"";*) " "; " "; " "; (*"";*) ""]; close_out ochan; let cmd = "chown " ^ (string_of_int pw.pw_uid) ^ "." ^ (string_of_int pw.pw_gid) ^ " " ^ dest in if verbose > 0 then prerr_endline cmd; ignore (Sys.command cmd) -} parseFile path = readFile path >>= return . either (error . show) id . parseDesktop path