diff --git a/codex.cabal b/codex.cabal --- a/codex.cabal +++ b/codex.cabal @@ -1,5 +1,5 @@ name: codex -version: 0.2.1.10 +version: 0.3 synopsis: A ctags file generator for cabal project dependencies. description: This tool download and cache the source code of packages in your local hackage, @@ -29,26 +29,27 @@ Codex.Project Codex.Internal Distribution.Sandbox.Utils - other-modules: - Network.Curl.DownloadLazy build-depends: base >= 4.6.0.1 && < 5 , bytestring >= 0.10.0.2 && < 0.11 , Cabal >= 1.18 && < 1.23 + , cryptohash >= 0.11 && < 0.12 , containers >= 0.5.0.0 && < 0.6 - , curl >= 1.3.8 && < 1.4 , directory >= 1.2.0.1 && < 1.3 , either >= 4.3.0.1 && < 4.4 , filepath >= 1.3.0.1 && < 1.5 - , hackage-db >= 1.8 && < 2 + , hackage-db >= 1.22 && < 2 + , http-client >= 0.4 && < 0.5 + , lens >= 4.6 && < 5 , machines >= 0.2 && < 0.6 , machines-directory >= 0.0.0.2 && < 0.3 - , MissingH >= 1.2.1.0 && < 1.4 + -- , MissingH >= 1.2.1.0 && < 1.4 , process >= 1.1.0.2 && < 1.3 , tar >= 0.4.0.1 && < 0.5 , text >= 1.1.1.3 && < 1.3 , transformers >= 0.3.0.0 && < 0.5 , yaml >= 0.8.8.3 && < 0.9 + , wreq >= 0.3.0.1 && < 0.5 , zlib >= 0.5.4.1 && < 0.6 executable codex @@ -72,7 +73,10 @@ , MissingH , yaml , monad-loops >= 0.4.2 && < 0.5 - , codex == 0.2.1.10 + , network >= 2.6 && < 2.7 + , wreq + , yaml + , codex == 0.3 source-repository head type: git diff --git a/codex/Main.hs b/codex/Main.hs --- a/codex/Main.hs +++ b/codex/Main.hs @@ -6,6 +6,8 @@ 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.Directory import System.Environment @@ -63,13 +65,13 @@ either (const True) id <$> (runEitherT $ isUpdateRequired cx dependencies projectHash) else return True - if (shouldUpdate || force) then do + 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 <- traverse (retrying 3 . runEitherT . getTags) dependencies + results <- withSession $ \s -> traverse (retrying 3 . runEitherT . getTags s) dependencies _ <- traverse print . concat $ lefts results res <- runEitherT $ assembly cx dependencies projectHash workspaceProjects tagsFile either print (const $ return ()) res @@ -77,11 +79,11 @@ putStrLn "Nothing to update." where tagsFile = tagsFileName cx - getTags i = status cx i >>= \x -> case x of - (Source Tagged) -> return () - (Source Untagged) -> tags cx i >> getTags i - (Archive) -> extract cx i >> getTags i - (Remote) -> fetch cx i >> getTags i + getTags s i = status cx i >>= \x -> case x of + Source Tagged -> return () + Source Untagged -> tags cx i >> getTags s i + Archive -> extract cx i >> getTags s i + Remote -> fetch s cx i >> getTags s i help :: IO () help = putStrLn $ @@ -100,7 +102,7 @@ , "Note: codex will browse the parent directory for cabal projects and use them as dependency over hackage when possible." ] main :: IO () -main = do +main = withSocketsDo $ do cx <- loadConfig args <- getArgs run cx args where diff --git a/src/Codex.hs b/src/Codex.hs --- a/src/Codex.hs +++ b/src/Codex.hs @@ -1,17 +1,17 @@ module Codex (Codex(..), defaultTagsFileName, Verbosity, module Codex) where import Control.Exception (try, SomeException) +import Control.Lens ((^.)) +import Control.Lens.Review (bimap) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Either -import Data.Hash.MD5 import Data.Machine import Data.Maybe -import Data.String.Utils hiding (join) import Distribution.Package import Distribution.Text import Distribution.Verbosity -import Network.Curl.DownloadLazy +import Network.HTTP.Client (HttpException) import System.Directory import System.Directory.Machine (files, directoryWalk) import System.FilePath @@ -19,17 +19,30 @@ import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip +import qualified Crypto.Hash.MD5 as MD5 +import qualified Data.ByteString.Char8 as C8 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 qualified Network.Wreq as W +import qualified Network.Wreq.Session as WS +import qualified Text.Printf as Printf import Codex.Internal import Codex.Project -- TODO Replace the `Codex` context with a `Control.Reader.Monad `. +-- TODO Remove that function once using `Text` widely +replace :: String -> String -> String -> String +replace a b c = Text.unpack $ Text.replace (Text.pack a) (Text.pack b) (Text.pack c) + +md5hash :: String -> String +md5hash = concatMap (Printf.printf "%02x") . C8.unpack . MD5.hash . C8.pack + + data Tagging = Tagged | Untagged deriving (Eq, Show) @@ -46,10 +59,10 @@ deriving (Eq, Show, Read) taggerCmd :: Tagger -> String -taggerCmd Ctags = "ctags --tag-relative=no --recurse -f '$TAGS' '$SOURCES'" -taggerCmd Hasktags = "hasktags --ctags --output='$TAGS' '$SOURCES'" -taggerCmd HasktagsEmacs = "hasktags --etags --output='$TAGS' '$SOURCES'" -taggerCmd HasktagsExtended = "hasktags --ctags --extendedctag --output='$TAGS' '$SOURCES'" +taggerCmd Ctags = "ctags --tag-relative=no --recurse -f \"$TAGS\" \"$SOURCES\"" +taggerCmd Hasktags = "hasktags --ctags --output=\"$TAGS\" \"$SOURCES\"" +taggerCmd HasktagsEmacs = "hasktags --etags --output=\"$TAGS\" \"$SOURCES\"" +taggerCmd HasktagsExtended = "hasktags --ctags --extendedctag --output=\"$TAGS\" \"$SOURCES\"" taggerCmdRun :: Codex -> FilePath -> FilePath -> Action FilePath taggerCmdRun cx sources tags' = do @@ -65,18 +78,18 @@ either (left . show) return res codexHash :: Codex -> String -codexHash cfg = md5s . Str $ show cfg +codexHash cfg = md5hash $ show cfg dependenciesHash :: [PackageIdentifier] -> String -dependenciesHash xs = md5s . Str $ xs >>= display +dependenciesHash xs = md5hash $ xs >>= display tagsFileHash :: Codex -> [PackageIdentifier] -> String -> String -tagsFileHash cx ds projectHash = md5s . Str $ concat [codexHash cx, dependenciesHash ds, projectHash] +tagsFileHash cx ds projectHash = md5hash $ concat [codexHash cx, dependenciesHash ds, projectHash] computeCurrentProjectHash :: Codex -> IO String computeCurrentProjectHash cx = if not $ currentProjectIncluded cx then return "*" else do xs <- runT $ (autoM getModificationTime) <~ (filtered p) <~ files <~ directoryWalk <~ source ["."] - return . md5s . Str . show $ maximum xs + return . md5hash . show $ maximum xs where p fp = any (\f -> f fp) (fmap List.isSuffixOf extensions) extensions = [".hs", ".lhs", ".hsc"] @@ -102,16 +115,21 @@ (_, True) -> return Archive (_, _) -> return Remote -fetch :: Codex -> PackageIdentifier -> Action FilePath -fetch cx i = do +fetch :: WS.Session -> Codex -> PackageIdentifier -> Action FilePath +fetch s cx i = do bs <- tryIO $ do createDirectoryIfMissing True (packagePath cx i) - openLazyURI url + openLazyURI s url either left write bs where write bs = fmap (const archivePath) $ tryIO $ BS.writeFile archivePath bs archivePath = packageArchive cx i url = packageUrl i +openLazyURI :: WS.Session -> String -> IO (Either String BS.ByteString) +openLazyURI s = fmap (bimap showHttpEx (^. W.responseBody)) . try . WS.get s where + showHttpEx :: HttpException -> String + showHttpEx = show + extract :: Codex -> PackageIdentifier -> Action FilePath extract cx i = fmap (const path) . tryIO $ read' path (packageArchive cx i) where read' dir tar = Tar.unpack dir . Tar.read . GZip.decompress =<< BS.readFile tar @@ -139,7 +157,7 @@ let xs = concat $ fmap TextL.lines contents let ys = if sorted then List.sort xs else xs TLIO.writeFile o' $ TextL.unlines (concat [headers, ys]) - tags' i = packageTags cx i + tags' = packageTags cx headers = if tagsFileHeader cx then fmap TextL.pack [headerFormat, headerSorted, headerHash] else [] headerFormat = "!_TAG_FILE_FORMAT\t2" headerSorted = concat ["!_TAG_FILE_SORTED\t", if sorted then "1" else "0"] diff --git a/src/Codex/Project.hs b/src/Codex/Project.hs --- a/src/Codex/Project.hs +++ b/src/Codex/Project.hs @@ -3,7 +3,6 @@ import Control.Exception (try, SomeException) import Data.Function import Data.Maybe -import Data.String.Utils import Distribution.InstalledPackageInfo import Distribution.Hackage.DB (Hackage, readHackage) import Distribution.Package @@ -43,7 +42,7 @@ findPackageDescription :: FilePath -> IO (Maybe GenericPackageDescription) findPackageDescription root = do files <- getDirectoryContents root - traverse (readPackageDescription silent) $ fmap (\x -> root x) $ List.find (endswith ".cabal") files + traverse (readPackageDescription silent) $ fmap (\x -> root x) $ List.find (List.isSuffixOf ".cabal") files resolveCurrentProjectDependencies :: IO ProjectDependencies resolveCurrentProjectDependencies = do @@ -133,4 +132,4 @@ if isDirectory then readWorkspaceProject path else return Nothing listDirectory fp = do xs <- getDirectoryContents fp - return . fmap (fp ) $ filter (not . startswith ".") xs + return . fmap (fp ) $ filter (not . List.isPrefixOf ".") xs diff --git a/src/Network/Curl/DownloadLazy.hs b/src/Network/Curl/DownloadLazy.hs deleted file mode 100644 --- a/src/Network/Curl/DownloadLazy.hs +++ /dev/null @@ -1,115 +0,0 @@ --- TODO Remove once https://github.com/GaloisInc/curl/pull/11 is released. - --------------------------------------------------------------------- --- | --- Module : Network.Curl.DownloadLazy --- Copyright : (c) Don Stewart --- License : BSD3 --- --- Stability : provisional --- Portability: posix --- --- This module is equivalent to download-curl's Network.Curl.Download.Lazy --- A binding to curl, an efficient, high level library for --- retrieving files using Uniform Resource Locators (URLs). --- --- Content may be retrieved as a lazy "ByteString". --- --- Error handling is encapsulated in the "Either" type. --- --------------------------------------------------------------------- - -module Network.Curl.DownloadLazy ( - -- * The basic lazy interface to network content - openLazyURI - , openLazyURIWithOpts - - ) where - -import Foreign -import Network.Curl - -import Data.IORef - -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L - ------------------------------------------------------------------------- - --- | Download content specified by a url using curl, returning the --- content as a lazy "ByteString". --- --- If an error occurs, "Left" is returned, with a --- protocol-specific error string. --- --- Examples: --- --- > openLazyURI "http://haskell.org" --- -openLazyURI :: String -> IO (Either String L.ByteString) -openLazyURI = openLazyURIWithOpts [] - --- | Like openURI, but takes curl options. --- --- Examples: --- --- > openLazyURIWithOpts [CurlPost True] "http://haskell.org" --- -openLazyURIWithOpts :: [CurlOption] -> String -> IO (Either String L.ByteString) -openLazyURIWithOpts opts s = case parseURL s of - Nothing -> return $ Left $ "Malformed url: "++ s - Just url -> do - e <- getFile url opts - return $ case e of - Left err -> Left $ "Failed to connect: " ++ err - Right src -> Right src - ------------------------------------------------------------------------- --- Internal: --- - -newtype URL = URL String - -parseURL :: String -> Maybe URL -parseURL s = Just (URL s) -- no parsing - -getFile :: URL -> [CurlOption] -> IO (Either String L.ByteString) -getFile (URL url) flags = do - h <- initialize - ref <- newIORef L.Empty - - _ <- setopt h (CurlFailOnError True) - setDefaultSSLOpts h url - _ <- setopt h (CurlURL url) - _ <- setopt h (CurlWriteFunction (gather ref)) - mapM_ (setopt h) flags - rc <- perform h - chunks <- readIORef ref - - return $ if rc /= CurlOK - then Left (show rc) - else Right $! revSpine chunks - --- fp <- newForeignPtr finalizerFree buf' --- return (Right $! S.fromForeignPtr fp 0 (fromIntegral sz)) - -gather :: IORef L.ByteString -> WriteFunction -gather r = writer $ \chunk -> do - chunks <- readIORef r - let chunks' = L.Chunk chunk chunks - writeIORef r $! chunks' - --- memcpy chunks of data into our bytestring. -writer :: (S.ByteString -> IO ()) -> WriteFunction -writer f src sz nelems _ = do - let n' = sz * nelems - f =<< S.create (fromIntegral n') (\dest -> S.memcpy dest (castPtr src) (fromIntegral n')) - return n' - - --- reverse just the spine of a lazy bytestring -revSpine :: L.ByteString -> L.ByteString -revSpine l = rev l L.Empty - where - rev L.Empty a = a - rev (L.Chunk x xs) a = rev xs (L.Chunk x a)