content: {- Copyright (c) 2011 Galois, Inc. -}
  {-|
  
  add-source command
  
  Puts local source packages into a repository readable by cabal-install
  
  -}
  {-# LANGUAGE CPP #-}
  module Distribution.Dev.AddSource
      ( actions
      )
  where
  
  #ifndef MIN_VERSION_Cabal
  #define MIN_VERSION_Cabal(a,b,c) 1
  #endif
  
  import Control.Applicative                   ( (<$>), (<*>) )
  import Control.Arrow                         ( right )
  import qualified Control.Exception as Ex     ( catch, bracket )
  import Control.Monad                         ( guard, (<=<), forM_ )
  import Control.Monad.Error                   ( runErrorT, throwError )
  import Control.Monad.Trans                   ( liftIO )
  import Data.List                             ( isPrefixOf )
  import Distribution.PackageDescription       ( PackageDescription(buildType), BuildType(Custom)
                                               , packageDescription, package )
  import Distribution.Package                  ( PackageIdentifier(..) )
  #if MIN_VERSION_Cabal(1,6,0)
  import Distribution.PackageDescription.Parse ( ParseResult(ParseOk), readPackageDescription
                                               , parsePackageDescription )
  import Distribution.Package                  ( PackageName(..) )
  #elif MIN_VERSION_Cabal(1,4,0)
  import Distribution.PackageDescription       ( ParseResult(ParseOk), readPackageDescription
                                               , parsePackageDescription )
  #else
  #error Unsupported Cabal version
  #endif
  import Distribution.Text                     ( simpleParse, display )
  import Network.HTTP                          ( mkRequest, RequestMethod(GET)
                                               , rspBody, simpleHTTP
                                               )
  import Network.URI                           ( parseURI, uriScheme, URI
                                               , uriPath )
  import System.Cmd                            ( rawSystem )
  import System.Console.GetOpt                 ( OptDescr(..) )
  import System.Directory                      ( getDirectoryContents
                                               , renameFile, copyFile
                                               , getCurrentDirectory
                                               , setCurrentDirectory
                                               , createDirectoryIfMissing
                                               , getTemporaryDirectory
                                               , removeFile
                                               )
  import System.Exit                           ( ExitCode(..) )
  import System.FilePath                       ( takeExtension, takeBaseName
                                               , splitDirectories, (<.>), (</>)
                                               , splitExtension
                                               )
  import System.IO                             ( withBinaryFile, IOMode(..), hClose
                                               , openTempFile, hFlush, hSetBinaryMode
                                               )
  import System.IO.Error                       ( isDoesNotExistError )
  
  import qualified Codec.Archive.Tar           as T
  import qualified Codec.Archive.Tar.Entry     as T
  import qualified Codec.Compression.GZip      as Z
  import qualified Data.ByteString.Lazy        as L
  import qualified Data.ByteString.Lazy.Char8  as L8 ( unpack )
  import qualified Distribution.Verbosity      as V
  
  import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) )
  import Distribution.Dev.Flags   ( Config, getVerbosity )
  import Distribution.Dev.Sandbox ( resolveSandbox, localRepoPath
                                  , Sandbox, indexTar, indexTarBase, indexCache
                                  )
  
  import Distribution.Simple.Utils ( debug, notice )
  
  actions :: CommandActions
  actions = CommandActions
              { cmdDesc = "Add packages to a local cabal install repository"
              , cmdRun = \cfg _ -> addSources cfg
              , cmdOpts = [] :: [OptDescr ()]
              , cmdPassFlags = False
              }
  
  addSources :: Config -> [String] -> IO CommandResult
  addSources _    [] = return $ CommandError "No package locations supplied"
  addSources flgs fns = do
    sandbox <- resolveSandbox flgs
    let v = getVerbosity flgs
    debug v $ "Making a cabal repo in " ++ localRepoPath sandbox ++
              " out of " ++ show fns
    results <- mapM (processLocalSource v) fns
    let errs = [e | Left e <- results]
        srcs = [s | Right s <- results]
    if not $ null errs
        then return $ CommandError $ unlines $
                 "Errors finding cabal files:":map (showString "  ") errs
        else do
          let (sources, newEntries) = unzip srcs
          res <- readExistingIndex sandbox
          case res of
            Left err -> return $
                   CommandError $ "Error reading existing index: " ++ err
            Right existingIndex ->
                do let newIndex = mergeIndices existingIndex newEntries
                   -- Now we have the new index ready and have
                   -- sanity-checked all of the package locations
                   -- to be sure that they contain a cabal package
                   -- (or at least a .cabal file)
                   --
                   -- Now to install the tarballs for the
                   -- directories:
                   forM_ sources $ \(src, pkgId, pkgDesc) ->
                        installTarball flgs sandbox src pkgId pkgDesc
                   -- and now that the tarballs are in place,
                   -- write out the updated index
                   writeIndex sandbox newIndex
                   return CommandOk
  
  -- |Atomically write an index tarball in the supplied directory
  -- and invalidates the cache
  writeIndex :: Sandbox a -- ^The local repository path
             -> [T.Entry] -- ^The index entries
             -> IO ()
  writeIndex sandbox ents =
      do newIndexName <- withTmpIndex $ \(fn, h) -> do
                           hSetBinaryMode h True
                           L.hPut h (T.write ents)
                           hFlush h
                           return fn
         renameFile newIndexName $ indexTar sandbox
         removeFile (indexCache sandbox) `Ex.catch` \e ->
           if isDoesNotExistError e
           then return ()
           else ioError e
      where
        pth = localRepoPath sandbox
        withTmpIndex = Ex.bracket (openTempFile pth indexTarBase) (hClose . snd)
  
  -- |Merge two lists of tar entries, filtering out the entries from the
  -- original list that will be duplicated by the second list of
  -- entries
  mergeIndices :: [T.Entry] -> [T.Entry] -> [T.Entry]
  mergeIndices old new = filter notInNew old ++ new
      where
        newPaths = map T.entryTarPath new
        notInNew e = not $ T.entryTarPath e `elem` newPaths
  
  -- |Create a tar entry for the package identifier and cabal file contents
  toIndexEntry :: PackageIdentifier -> L.ByteString -> Either String T.Entry
  toIndexEntry pkgId c = right toEnt $ T.toTarPath False (indexName pkgId)
      where
        toEnt p = T.fileEntry p c
  
  -- |Read an existing index tarball from the local repository, if one
  -- exists. If the file does not exist, behave as if the index has no
  -- entries.
  readExistingIndex :: Sandbox a -> IO (Either String [T.Entry])
  readExistingIndex sandbox =
      readIndexFile `Ex.catch` \e ->
          if isDoesNotExistError e
          then return $ Right []
          else ioError e
      where
        readIndexFile = withBinaryFile (indexTar sandbox) ReadMode $
                        (forceEntries . T.read <=< L.hGetContents)
        forceEntries es =
          let step _ l@(Left _) = l
              step x (Right xs) = Right (x:xs)
              es' = T.foldEntries step (Right []) (Left . show) es
          in either (const 0) length es' `seq` return es'
  
  
  -- |What kind of package source is this?
  data LocalSource = DirPkg FilePath | TarPkg FilePath deriving Show
  
  -- |Determine if this filename looks like a tarball (otherwise, it
  -- assumes that it's a directory and treats it as such)
  classifyLocalSource :: String -> Either URI LocalSource
  classifyLocalSource fn =
      case parseURI fn of
        Just u | isHttpUri u && isTarGzUri u -> Left u
        _      | isTarball fn                -> Right $ TarPkg fn
               | otherwise                   -> Right $ DirPkg fn
      where
        isHttpUri = (`elem` ["http:", "https:"]) . uriScheme
        isTarGzUri = (reverse ".tar.gz" `isPrefixOf`) . reverse . uriPath
  
  -- |Put the tarball for this package in the local repository
  installTarball :: Config
                 -> Sandbox a -- ^Location of the local repository
                 -> LocalSource -- ^What kind of package source
                 -> PackageIdentifier
                 -> PackageDescription -- ^Package description
                 -> IO (Either String ())
  installTarball flgs sandbox src pkgId pkgDesc =
      do createDirectoryIfMissing True $ localRepoPath sandbox </> repoDir pkgId
         case src of
           TarPkg fn -> do copyFile fn dest
                           return $ Right ()
           DirPkg fn -> do
                    res <- makeSDist fn
                    case res of
                      Left err -> return $ Left err
                      Right tarFn -> do
                               renameFile tarFn dest
                               return $ Right ()
      where
        dest = localRepoPath sandbox </> tarballName pkgId
        makeSDist fn = do
          debug (getVerbosity flgs) $ "Running cabal sdist in " ++ fn
          Ex.bracket getCurrentDirectory setCurrentDirectory $ \_ -> do
                      setCurrentDirectory fn
                      -- If the build-type is custom, run 'configure'
                      -- and invoke the generated setup program.
                      -- Otherwise, just run plain sdist.  We do this to
                      -- work around
                      -- http://hackage.haskell.org/trac/hackage/ticket/410
                      cabalRes <- case buildType pkgDesc of
                                    Just Custom -> do
                                      -- We run configure without args
                                      -- first to compile the Setup
                                      -- program.  We do this to work
                                      -- around a different bug in Cabal
                                      -- (http://hackage.haskell.org/trac/hackage/ticket/731)
                                      _ <- rawSystem "cabal" ["configure"]
                                      rawSystem "dist/setup/setup" ["sdist"]
                                    _ -> rawSystem "cabal" ["sdist"]
  
                      case cabalRes of
                        ExitSuccess ->
                            do here <- getCurrentDirectory
                               return $ Right $ here </> "dist" </>
                                      display pkgId <.> "tar" <.> "gz"
                        ExitFailure code ->
                            return $ Left $
                                    "cabal sdist failed with " ++ show code
  
  downloadTarball :: URI -> IO (Either String FilePath)
  downloadTarball u = do
    tmpLoc <- getTemporaryDirectory
    Ex.bracket (openTempFile tmpLoc "package-.tar.gz") (hClose . snd) $ \(fn, h) ->
        do httpRes <- simpleHTTP $ mkRequest GET u
           case httpRes of
             Left err -> return $ Left $ show err
             Right resp ->
                 do L.hPut h $ rspBody resp
                    return $ Right fn
  
  -- |Extract the index information from the supplied path, either as a
  -- tarball or as a local package directory
  processLocalSource :: V.Verbosity -> FilePath
                     -> IO (Either String ((LocalSource, PackageIdentifier, PackageDescription), T.Entry))
  processLocalSource v fn =
      runErrorT $ do
        let cls = classifyLocalSource fn
        src <- case cls of
                 Left u -> do
                    liftIO $ notice v $ "Downloading " ++ show u
                    TarPkg `fmap` eitherErrorIO (downloadTarball u)
                 Right s -> return s
        (pkgId, c, pkgDesc) <- eitherErrorIO $
                      case src of
                        TarPkg x -> processTarball x
                        DirPkg x -> processDirectory v x
        ent <- eitherError $ toIndexEntry pkgId c
        return ((src, pkgId, pkgDesc), ent)
      where
        eitherError = either throwError return
        eitherErrorIO = eitherError <=< liftIO
  
  -- |Extract the index information from a tarball
  processTarball :: FilePath
                 -> IO (Either String (PackageIdentifier, L.ByteString, PackageDescription))
  processTarball fn =
      withBinaryFile fn ReadMode $ \h ->
          do ents <- T.read . Z.decompress <$> L.hGetContents h
             case extractCabalFile ents of
               Nothing -> return $ Left "No cabal file found"
  
               -- Force reading the cabal file before we exit withFile
               Just res@(_, bs, _) -> do
                 forceBS bs
                 return (Right res)
  
  #if MIN_VERSION_Cabal(1,6,0)
  mkPackageName :: String -> PackageName
  mkPackageName = PackageName
  
  displayPackageName :: PackageName -> String
  displayPackageName = display
  #elif MIN_VERSION_Cabal(1,4,0)
  mkPackageName :: String -> String
  mkPackageName = id
  
  displayPackageName :: String -> String
  displayPackageName = id
  #else
  #error Unsupported cabal version
  #endif
  
  -- |Extract the index information from a directory containing a cabal
  -- file
  processDirectory :: V.Verbosity -> FilePath
                   -> IO (Either String (PackageIdentifier, L.ByteString, PackageDescription))
  processDirectory v d = go `Ex.catch` \e ->
                       if expected e
                       then return $ Left $ show e
                       else ioError e
      where
        expected e = any ($ e) [ isDoesNotExistError
                               ]
  
        go = do
          debug v =<< getCurrentDirectory
          fns <- getDirectoryContents d
          case filter isCabalFile fns of
            [c] -> processCabalFile c
            []  -> return $ Left "No cabal file found"
            _   -> return $ Left "More than one cabal file present"
  
        processCabalFile c = do
          let fn = d </> c
          pkgDesc <- packageDescription <$>
                     readPackageDescription V.normal fn
          let pkgId = package pkgDesc
          if mkPackageName (takeBaseName c) == pkgName pkgId
            then do
              notice v $ "Building source dist at " ++ d ++ " for " ++ display pkgId
              cabalFile <- withBinaryFile fn ReadMode $
                           forcedBS <=< L.hGetContents
              return $ Right (pkgId, cabalFile, pkgDesc)
            else
              return $ Left $ unlines $
                         [ "Package name does not match cabal file name:"
                         , " filename = " ++ fn
                         , " package name 1 = " ++ show (mkPackageName (takeBaseName c))
                         , " package name 2 = " ++ show (pkgName pkgId)
                         ]
  
  -- |Force a lazy ByteString to be read
  forceBS :: L.ByteString -> IO ()
  forceBS bs = L.length bs `seq` return ()
  
  -- |Force a lazy ByteString to be read, and pass it on to the next action
  forcedBS :: L.ByteString -> IO L.ByteString
  forcedBS bs = forceBS bs >> return bs
  
  -- |Extract a cabal file from a package tarball
  extractCabalFile :: T.Entries T.FormatError -> Maybe (PackageIdentifier, L.ByteString, PackageDescription)
  extractCabalFile = T.foldEntries step Nothing (const Nothing)
      where
        step ent Nothing = (,,) <$> entPackageId ent <*> entBytes ent <*> (parseDesc $ entBytes ent)
        step _   ans     = ans
  
        parseDesc bs = do
          str <- L8.unpack <$> bs
          let result = parsePackageDescription str
          case result of
            ParseOk _ pkg -> return $ packageDescription pkg
            _ -> Nothing
  
        entPackageId ent =
            case splitDirectories $ T.entryPath ent of
              [d, f] ->
                  do i <- simpleParse d
                     let cabalName = mkPackageName $ takeBaseName f
                     guard $ isCabalFile f && cabalName == pkgName i
                     return i
              _      -> Nothing
  
        entBytes ent = case T.entryContent ent of
                         T.NormalFile x _ -> return x
                         _ -> Nothing
  
  -- | Does this filename look like a cabal file?
  isCabalFile :: FilePath -> Bool
  isCabalFile = (== ".cabal") . takeExtension
  
  -- |Does this filename look like a gzipped tarball?
  isTarball :: FilePath -> Bool
  isTarball fn = (ext2, ext1) == (".tar", ".gz")
      where
        (fn1, ext1) = splitExtension fn
        (_, ext2) = splitExtension fn1
  
  -- |The path to the .cabal file in the 00-index.tar file
  indexName :: PackageIdentifier -> FilePath
  indexName pkgId = repoDir pkgId </>
                    (displayPackageName (pkgName pkgId) <.> "cabal")
  
  -- |The path to the tarball in the local repository
  tarballName :: PackageIdentifier -> FilePath
  tarballName pkgId = repoDir pkgId </> (display pkgId <.> "tar" <.> "gz")
  
  repoDir :: PackageIdentifier -> FilePath
  repoDir pkgId = displayPackageName (pkgName pkgId) </>
                  display (pkgVersion pkgId)
  