codex-0.5.1.0: codex/Main.hs
{-# LANGUAGE CPP #-}
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Traversable (traverse)
#endif
import Control.Arrow
import Control.Exception (try, SomeException)
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Either hiding (left, right)
import Data.Either
import Data.List
import Data.String.Utils
import Distribution.Text
import Network.Socket (withSocketsDo)
import Network.Wreq.Session (withSession)
import Paths_codex (version)
import System.Console.AsciiProgress (displayConsoleRegions)
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.Process (shell, readCreateProcessWithExitCode)
import Codex
import Codex.Project
import Codex.Internal (Builder(..), hackagePathOf, readStackPath)
import Main.Config
-- TODO Add 'cache dump' to dump all tags in stdout (usecase: pipe to grep)
-- TODO Use a mergesort algorithm for `assembly`
-- TODO Better error handling and fine grained retry
retrying :: Int -> IO (Either a b) -> IO (Either [a] b)
retrying n x = retrying' n $ fmap (left (:[])) x where
retrying' 0 x' = x'
retrying' n' x' = retrying' (n' - 1) $ x' >>= \res -> case res of
Left ls -> fmap (left (++ ls)) x'
Right r -> return $ Right r
hashFile :: Codex -> FilePath
hashFile cx = hackagePath cx </> "codex.hash"
cleanCache :: (Builder, Codex) -> IO ()
cleanCache (bldr, cx) = do
-- TODO Delete hash file!
xs <- listDirectory hp
ys <- builderOp bldr =<< traverseDirectories xs
_ <- removeTagFiles $ concat ys
return ()
where
hp = hackagePath cx
safe = (try :: IO a -> IO (Either SomeException a))
listDirectory fp = do
xs <- getDirectoryContents fp
return . fmap (fp </>) $ filter (not . startswith ".") xs
removeTagFiles = traverse (safe . removeFile) . fmap (</> "tags")
traverseDirectories = fmap rights . traverse (safe . listDirectory)
builderOp (Stack _) = traverseDirectories . concat
builderOp Cabal = return
readCacheHash :: Codex -> IO (Maybe String)
readCacheHash cx = do
fileExist <- doesFileExist $ hashFile cx
if not fileExist then return Nothing else do
content <- readFile $ hashFile cx
return $ Just content
writeCacheHash :: Codex -> String -> IO ()
writeCacheHash cx = writeFile $ hashFile cx
update :: Bool -> Codex -> Builder -> IO ()
update force cx bldr = displayConsoleRegions $ do
(project, dependencies, workspaceProjects') <- resolveCurrentProjectDependencies bldr $ hackagePath cx </> "00-index.tar"
projectHash <- computeCurrentProjectHash cx
shouldUpdate <-
if null workspaceProjects' then
either (const True) id <$> (runEitherT $ isUpdateRequired cx dependencies projectHash)
else return True
if force || shouldUpdate then do
let workspaceProjects = if not $ currentProjectIncluded cx then workspaceProjects'
else (WorkspaceProject project ".") : workspaceProjects'
fileExist <- doesFileExist tagsFile
when fileExist $ removeFile tagsFile
putStrLn $ concat ["Updating ", display project]
results <- withSession $ \s -> do
tick' <- newProgressBar' "Loading tags" (length dependencies)
traverse (retrying 3 . runEitherT . getTags tick' s) dependencies
_ <- traverse print . concat $ lefts results
res <- runEitherT $ assembly bldr cx dependencies projectHash workspaceProjects tagsFile
either print (const $ return ()) res
else
putStrLn "Nothing to update."
where
tagsFile = tagsFileName cx
hp = hackagePathOf bldr cx
getTags tick' s i = status hp i >>= \x -> case x of
Source Tagged -> tick' >> return ()
Source Untagged -> tags bldr cx i >> tick' >> getTags tick' s i
Archive -> extract hp i >> tick' >> getTags tick' s i
Remote -> liftIO $ eitherT ignore return $ fetch s hp i >> tick' >> getTags tick' s i
where
ignore msg = do
putStrLn $ concat ["codex: *warning* unable to fetch an archive for ", display i]
putStrLn msg
return ()
help :: IO ()
help = putStrLn $
unlines [ "Usage: codex [update] [cache clean] [set tagger [hasktags|ctags]] [set format [vim|emacs|sublime]]"
, " [--help]"
, " [--version]"
, ""
, " update Synchronize the tags file in the current cabal project directory"
, " update --force Discard tags file hash and force regeneration"
, " cache clean Remove all `tags` file from the local hackage cache]"
, " set tagger <tagger> Update the `~/.codex` configuration file for the given tagger (hasktags|ctags)."
, " set format <format> Update the `~/.codex` configuration file for the given format (vim|emacs|sublime)."
, ""
, "By default `hasktags` will be used, and need to be in the `PATH`, the tagger command can be fully customized in `~/.codex`."
, ""
, "Note: codex will browse the parent directory for cabal projects and use them as dependency over hackage when possible." ]
main :: IO ()
main = withSocketsDo $ do
cx <- loadConfig
args <- getArgs
run cx args where
run cx ["cache", "clean"] = toBuilderConfig cx >>= cleanCache
run cx ["update"] = withConfig cx (update False)
run cx ["update", "--force"] = withConfig cx (update True)
run cx ["set", "tagger", "ctags"] = encodeConfig $ cx { tagsCmd = taggerCmd Ctags }
run cx ["set", "tagger", "hasktags"] = encodeConfig $ cx { tagsCmd = taggerCmd Hasktags }
run cx ["set", "format", "emacs"] = encodeConfig $ cx { tagsCmd = taggerCmd HasktagsEmacs, tagsFileHeader = False, tagsFileSorted = False, tagsFileName = "TAGS" }
run cx ["set", "format", "sublime"] = encodeConfig $ cx { tagsCmd = taggerCmd HasktagsExtended, tagsFileHeader = True, tagsFileSorted = True }
run cx ["set", "format", "vim"] = encodeConfig $ cx { tagsFileHeader = True, tagsFileSorted = True }
run _ ["--version"] = putStrLn $ concat ["codex: ", display version]
run _ ["--help"] = help
run _ [] = help
run _ args = fail' $ concat ["codex: '", intercalate " " args,"' is not a codex command. See 'codex --help'."]
toBuilderConfig cx' = checkConfig cx' >>= \state -> case state of
TaggerNotFound -> fail' $ "codex: tagger not found."
Ready -> do
stackFileExists <- doesFileExist $ "." </> "stack.yaml"
if stackFileExists then do
(ec, _, _) <- readCreateProcessWithExitCode (shell "which stack") ""
case ec of
ExitSuccess -> do
let opts = stackOpts cx'
globalPath <- readStackPath opts "stack-root"
binPath <- readStackPath opts "bin-path"
path <- getEnv "PATH"
setEnv "PATH" $ concat [path, ":", binPath]
return (Stack opts, cx' { hackagePath = globalPath </> "indices" </> "Hackage" })
_ ->
return (Cabal, cx')
else return (Cabal, cx')
withConfig cx' f = do
(bldr, cx) <- toBuilderConfig cx'
cacheHash' <- readCacheHash cx
case cacheHash' of
Just cacheHash ->
when (cacheHash /= codexHash cx) $ do
putStrLn "codex: configuration has been updated, cleaning cache ..."
cleanCache (bldr, cx)
Nothing -> return ()
res <- f cx bldr
writeCacheHash cx $ codexHash cx
return res
fail' msg = do
putStrLn $ msg
exitWith (ExitFailure 1)