diff --git a/codex.cabal b/codex.cabal --- a/codex.cabal +++ b/codex.cabal @@ -1,5 +1,5 @@ name: codex -version: 0.0.1.2 +version: 0.0.1.3 synopsis: Code Explorer for Cabal description: This tool download and cache the source code of packages in your local hackage, @@ -20,7 +20,7 @@ library default-language: Haskell2010 hs-source-dirs: src - ghc-options: -O2 -threaded -fwarn-incomplete-patterns + ghc-options: -fwarn-incomplete-patterns exposed-modules: Codex Codex.Internal @@ -32,24 +32,29 @@ , containers , directory , download-curl + , either , filepath , hackage-db - , mtl + , MissingH , process , tar + , text + , transformers , zlib executable codex default-language: Haskell2010 main-is: src/Main.hs - ghc-options: -O2 -threaded -fwarn-incomplete-patterns + ghc-options: -threaded -fwarn-incomplete-patterns build-depends: base , Cabal , directory + , either , filepath , hackage-db , MissingH - , mtl , monad-loops + , transformers + , yaml , codex diff --git a/src/Codex.hs b/src/Codex.hs --- a/src/Codex.hs +++ b/src/Codex.hs @@ -2,10 +2,14 @@ import Control.Exception (try, SomeException) import Control.Monad -import Control.Monad.Error -import Data.Traversable (sequenceA) +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.Hash.MD5 +import Data.Traversable (traverse) +import Data.String.Utils import Distribution.Package import Distribution.PackageDescription +import Distribution.Text import Distribution.Verbosity import Network.Curl.Download.Lazy import System.Directory @@ -16,6 +20,9 @@ import qualified Codec.Compression.GZip as GZip import qualified Data.ByteString.Lazy as BS import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.IO as TLIO import Codex.Internal @@ -31,15 +38,35 @@ data Status = Source Tagging | Archive | Remote deriving (Eq, Show) -type Action = ErrorT String IO +type Action = EitherT String IO +data Tagger = Ctags | Hasktags + deriving (Eq, Show, Read) + +taggerCmd :: Tagger -> String +taggerCmd Ctags = "ctags --tag-relative=no --recurse -f '$TAGS' '$SOURCES'" +taggerCmd Hasktags = "hasktags --ctags --output='$TAGS' '$SOURCES'" + -- TODO It would be much better to work out which `Exception`s are thrown by which operations, -- and store all of that in a ADT. For now, I'll just be lazy. tryIO :: IO a -> Action a -tryIO io = do +tryIO io = do res <- liftIO $ (try :: IO a -> IO (Either SomeException a)) io - either (throwError . show) return res + either (left . show) return res +dependenciesHash :: [PackageIdentifier] -> String +dependenciesHash xs = md5s . Str $ xs >>= display + +isUpdateRequired :: FilePath -> [PackageIdentifier] -> Action Bool +isUpdateRequired file is = do + fileExist <- tryIO $ doesFileExist file + if fileExist then do + content <- tryIO $ TLIO.readFile file + let hash = TextL.toStrict . TextL.drop 13 . head . drop 2 $ TextL.lines content + return $ hash /= (Text.pack $ dependenciesHash is) + else + return True + status :: Codex -> PackageIdentifier -> Action Status status cx i = do sourcesExist <- tryIO . doesDirectoryExist $ packageSources cx i @@ -54,7 +81,7 @@ bs <- tryIO $ do createDirectoryIfMissing True (packagePath cx i) openLazyURI url - either throwError write bs where + either left write bs where write bs = fmap (const archivePath) $ tryIO $ BS.writeFile archivePath bs archivePath = packageArchive cx i url = packageUrl i @@ -68,16 +95,18 @@ tags cx i = do tryIO . createProcess $ shell command return tags where - command = concat ["ctags --tag-relative=no --recurse -f '", tags, "' '", sources, "'"] sources = packageSources cx i tags = packageTags cx i + command = replace "$SOURCES" sources $ replace "$TAGS" tags $ tagsCmd cx assembly :: Codex -> [PackageIdentifier] -> FilePath -> Action FilePath assembly cx is o = tryIO . fmap (const o) $ mergeTags (fmap tags is) o where mergeTags files o = do - contents <- sequence $ fmap readFile files - let xs = List.sort . (List.filter (\x -> List.head x /= '!')) . concat $ fmap lines contents - writeFile o $ unlines (concat [header, xs]) + contents <- traverse TLIO.readFile files + let xs = List.sort . concat $ fmap TextL.lines contents + TLIO.writeFile o $ TextL.unlines (concat [headers, xs]) tags i = packageTags cx i - header = ["!_TAG_FILE_FORMAT 2", "!_TAG_FILE_SORTED 1"] + headers :: [TextL.Text] + headers = fmap TextL.pack ["!_TAG_FILE_FORMAT 2", "!_TAG_FILE_SORTED 1", hash] + hash = concat ["!_CODEX_HASH ", dependenciesHash is] diff --git a/src/Codex/Internal.hs b/src/Codex/Internal.hs --- a/src/Codex/Internal.hs +++ b/src/Codex/Internal.hs @@ -6,7 +6,7 @@ import Distribution.Verbosity import System.FilePath -data Codex = Codex { hackagePath :: FilePath, verbosity :: Verbosity } +data Codex = Codex { tagsCmd :: String, hackagePath :: FilePath } packagePath :: Codex -> PackageIdentifier -> FilePath packagePath cx i = joinPath [hackagePath cx, relativePath i] where diff --git a/src/Distribution/Hackage/Utils.hs b/src/Distribution/Hackage/Utils.hs --- a/src/Distribution/Hackage/Utils.hs +++ b/src/Distribution/Hackage/Utils.hs @@ -12,6 +12,9 @@ import qualified Data.List as List import qualified Data.Map as Map +identifier :: GenericPackageDescription -> PackageIdentifier +identifier = package . packageDescription + -- TODO Remove once path extracted in hackage-db getHackagePath :: IO FilePath getHackagePath = do @@ -37,5 +40,5 @@ Map.lookup latest pdsByVersion resolveDependencies :: Hackage -> GenericPackageDescription -> [GenericPackageDescription] -resolveDependencies db pd = maybeToList . resolveDependency db =<< allDependencies pd +resolveDependencies db pd = List.filter (\x -> identifier x /= identifier pd) $ maybeToList . resolveDependency db =<< allDependencies pd diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,13 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} import Control.Arrow -import Control.Monad.Error -import Data.Traversable (sequenceA) +import Control.Exception (try, SomeException) +import Control.Monad +import Control.Monad.Trans.Either hiding (left, right) +import Data.Either +import Data.Traversable (traverse) import Data.String.Utils +import Data.Yaml import Distribution.Hackage.DB (readHackage) -import Distribution.Package -- TODO Remove import Distribution.PackageDescription import Distribution.PackageDescription.Parse import Distribution.Text import Distribution.Verbosity +import GHC.Generics import System.Directory import System.Environment import System.FilePath @@ -18,10 +24,8 @@ import Codex --- TODO Make Async --- TODO Make verbosity configurable --- TODO Make `ctags` command configurable --- TODO Use `ctags --version` to check if ctags is installed +-- 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 @@ -30,36 +34,85 @@ Left ls -> fmap (left (++ ls)) x Right r -> return $ Right r --- TODO Better error handling and fine grained retry -update :: Codex -> IO () -update cx = resolve =<< getCurrentProject where - resolve Nothing = putStrLn "No cabal file found." - resolve (Just project) = do - putStrLn $ concat ["Updating ", display . identifier $ project] - dependencies <- fmap (\db -> resolveDependencies db project) readHackage - founds <- retrying 4 $ runErrorT . sequence $ fmap (getTags . identifier) dependencies - failOr (generate dependencies) founds where - identifier = package . packageDescription - -- TODO Add println of info (use verbosity) - getTags i = status cx i >>= \x -> case x of - (Source Tagged) -> return () - (Source Untagged) -> tags cx i >>= (const $ getTags i) - (Archive) -> extract cx i >>= (const $ getTags i) - (Remote) -> fetch cx i >>= (const $ getTags i) - generate xs = do - res <- runErrorT $ assembly cx (fmap identifier xs) (joinPath ["codex.tags"]) - failOr (return ()) res - failOr y x = either (putStrLn . show) (const y) x - getCurrentProject :: IO (Maybe GenericPackageDescription) getCurrentProject = do files <- getDirectoryContents $ joinPath ["."] - sequenceA . fmap (readPackageDescription silent) $ List.find (endswith ".cabal") files + traverse (readPackageDescription silent) $ List.find (endswith ".cabal") files +tagsFile :: FilePath +tagsFile = joinPath ["codex.tags"] + +cleanCache :: Codex -> IO () +cleanCache cx = do + xs <- listDirectory hp + ys <- fmap (rights) $ traverse (safe . listDirectory) xs + zs <- traverse (safe . removeFile) . fmap ( "tags") $ 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 + +update :: Codex -> Bool -> IO () +update cx force = getCurrentProject >>= resolve where + resolve Nothing = putStrLn "No cabal file found." + resolve (Just project) = do + dependencies <- fmap (\db -> resolveDependencies db project) readHackage + traverse (putStrLn . show . identifier) dependencies + shouldUpdate <- runEitherT . isUpdateRequired tagsFile $ fmap identifier dependencies + when (either (const True) id shouldUpdate || force) $ do + fileExist <- doesFileExist tagsFile + when fileExist $ removeFile tagsFile + putStrLn $ concat ["Updating ", display . identifier $ project] + results <- traverse (retrying 3 . runEitherT . getTags . identifier) dependencies + traverse (putStrLn . show) . concat $ lefts results + generate dependencies where + getTags i = status cx i >>= \x -> case x of + (Source Tagged) -> return () + (Source Untagged) -> tags cx i >>= (const $ getTags i) + (Archive) -> extract cx i >>= (const $ getTags i) + (Remote) -> fetch cx i >>= (const $ getTags i) + generate xs = do + res <- runEitherT $ assembly cx (fmap identifier xs) tagsFile + either (putStrLn . show) (const $ return ()) res + main :: IO () main = do - hp <- getHackagePath + cx <- loadConfig args <- getArgs - run (Codex hp silent) args where - run cx ["update"] = update cx - run cx _ = putStrLn "Usage: codex update" + run cx args where + run cx ["cache", clean] = cleanCache cx + run cx ["update"] = update cx False + run cx ["update", "--force"] = update cx True + run cx ["set", "tagger", "ctags"] = encodeConfig $ cx { tagsCmd = taggerCmd Ctags } + run cx ["set", "tagger", "hasktags"] = encodeConfig $ cx { tagsCmd = taggerCmd Hasktags } + run cx _ = putStrLn "Usage: codex [update|cache clean|set tagger [ctags|hasktags]]" + +loadConfig :: IO Codex +loadConfig = decodeConfig >>= maybe defaultConfig return where + defaultConfig = do + hp <- getHackagePath + let cx = Codex (taggerCmd Hasktags) hp + encodeConfig cx + return cx + +deriving instance Generic Codex +instance ToJSON Codex +instance FromJSON Codex + +encodeConfig :: Codex -> IO () +encodeConfig cx = do + path <- getConfigPath + encodeFile path cx + +decodeConfig :: IO (Maybe Codex) +decodeConfig = do + path <- getConfigPath + res <- decodeFileEither path + return $ either (const Nothing) Just res + +getConfigPath :: IO FilePath +getConfigPath = do + homedir <- getHomeDirectory + return $ joinPath [homedir, ".codex"]