<commit_before>{-# LANGUAGE PatternGuards #-}
module Distribution.Client where

import Network.HTTP
import Network.Browser
import Network.URI (URI(..), URIAuth(..), parseURI)

import Distribution.Server.LegacyImport.UploadLog as UploadLog (read, Entry(..))
import Distribution.Server.Users.Types (UserId(..), UserName(UserName))
import Distribution.Server.Util.Index as PackageIndex (read)
import Distribution.Server.Util.Merge
import Distribution.Package
import Distribution.Verbosity
import Distribution.Simple.Utils
import Distribution.Text

import Data.List
import Data.Maybe
import Control.Applicative
import Control.Exception
import Data.Time
import Data.Time.Clock.POSIX
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Codec.Compression.GZip  as GZip
import qualified Codec.Archive.Tar       as Tar
import qualified Codec.Archive.Tar.Entry as Tar

import System.IO
import System.IO.Error
import System.FilePath
import System.Directory
import qualified System.FilePath.Posix as Posix

-------------------------
-- Command line handling
-------------------------

validateHackageURI :: String -> Either String URI
validateHackageURI str = case parseURI str of
  Nothing                          -> Left ("invalid URL " ++ str)
  Just uri
    | uriScheme uri /= "http:"     -> Left ("only http URLs are supported " ++ str)
    | isNothing (uriAuthority uri) -> Left ("server name required in URL " ++ str)
    | otherwise                    -> Right uri

validatePackageIds :: [String] -> Either String [PackageId]
validatePackageIds pkgstrs = case errs of
            (err:_) -> Left $ "'" ++ err ++ "' is not a valid package name or id"
            _       -> Right pkgs
  where
    pkgstrs' = [ (pkgstr, simpleParse pkgstr) | pkgstr <- pkgstrs ]
    pkgs     = [ pkgid  | (_, Just pkgid)   <- pkgstrs' ]
    errs     = [ pkgstr | (pkgstr, Nothing) <- pkgstrs' ]

----------------------------------------------------
-- Fetching info from source and destination servers
----------------------------------------------------

data PkgIndexInfo = PkgIndexInfo
                       PackageId
                       (Maybe UTCTime)  -- Upload time
                       (Maybe UserName) -- Name of uploader
                       (Maybe UserId)   -- Id of uploader
  deriving Show

downloadIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo]
downloadIndex uri | isOldHackageURI uri = downloadOldIndex uri
                  | otherwise           = downloadNewIndex uri
  where

isOldHackageURI :: URI -> Bool
isOldHackageURI uri
  | Just auth <- uriAuthority uri = uriRegName auth == "hackage.haskell.org"
  | otherwise                     = False


downloadOldIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo]
downloadOldIndex uri cacheFile = do

    downloadFile indexURI indexFile
    downloadFile logURI logFile

    ioAction $ do

      pkgids <- withFile indexFile ReadMode $ \hnd -> do
        content <- BS.hGetContents hnd
        case PackageIndex.read (\pkgid _ -> pkgid) (GZip.decompress content) of
          Left  err  -> die $ "Error parsing index at " ++ show uri ++ ": " ++ err
          Right pkgs -> return pkgs

      log <- withFile logFile ReadMode $ \hnd -> do
        content <- hGetContents hnd
        case UploadLog.read content of
          Right log -> return log
          Left  err -> die $ "Error parsing log at " ++ show uri ++ ": " ++ err

      return (mergeLogInfo pkgids log)

  where
    indexURI  = uri <//> "packages" </> "archive" </> "00-index.tar.gz"
    indexFile = cacheFile <.> "tar.gz"

    logURI    = uri <//> "packages" </> "archive" </> "log"
    logFile   = cacheFile <.> "log"

    mergeLogInfo pkgids log =
        catMaybes
      . map selectDetails
      $ mergeBy (\pkgid entry -> compare pkgid (entryPkgId entry))
                (sort pkgids)
                ( map (maximumBy (comparing entryTime))
                . groupBy (equating  entryPkgId)
                . sortBy  (comparing entryPkgId)
                $ log )

    selectDetails (OnlyInRight _)     = Nothing
    selectDetails (OnlyInLeft  pkgid) =
      Just $ PkgIndexInfo pkgid Nothing Nothing Nothing
    selectDetails (InBoth pkgid (UploadLog.Entry time uname _)) =
      Just $ PkgIndexInfo pkgid (Just time) (Just uname) Nothing

    entryPkgId (Entry _ _ pkgid) = pkgid
    entryTime  (Entry time _ _)  = time


downloadNewIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo]
downloadNewIndex uri cacheFile = do
    downloadFile indexURI indexFile
    ioAction $ withFile indexFile ReadMode $ \hnd -> do
      content <- BS.hGetContents hnd
      case PackageIndex.read selectDetails (GZip.decompress content) of
        Left err   -> error $ "Error parsing index at " ++ show uri ++ ": " ++ err
        Right pkgs -> return pkgs

  where
    indexURI  = uri <//> "packages/00-index.tar.gz"
    indexFile = cacheFile <.> "tar.gz"

    selectDetails :: PackageId -> Tar.Entry -> PkgIndexInfo
    selectDetails pkgid entry =
        PkgIndexInfo
          pkgid
          (Just time)
          (if null username then Nothing else Just (UserName username))
          (if userid == 0   then Nothing else Just (UserId userid))
      where
        time     = epochTimeToUTC (Tar.entryTime entry)
        username = Tar.ownerName (Tar.entryOwnership entry)
        userid   = Tar.ownerId   (Tar.entryOwnership entry)

        epochTimeToUTC :: Tar.EpochTime -> UTCTime
        epochTimeToUTC = posixSecondsToUTCTime . realToFrac


-------------------------
-- HTTP utilities
-------------------------

infixr 5 <//>

(<//>) :: URI -> FilePath -> URI
uri <//> path = uri { uriPath = Posix.addTrailingPathSeparator (uriPath uri)
                                Posix.</> path }


extractURICredentials :: URI -> Maybe (String, String)
extractURICredentials uri
  | Just authority <- uriAuthority uri
  , (username, ':':passwd0) <- break (==':') (uriUserInfo authority)
  , let passwd = takeWhile (/='@') passwd0
  , not (null username)
  , not (null passwd)
  = Just (username, passwd)
extractURICredentials _ = Nothing

removeURICredentials :: URI -> URI
removeURICredentials uri = uri { uriAuthority = fmap (\auth -> auth { uriUserInfo = "" }) (uriAuthority uri) }

provideAuthInfo :: URI -> Maybe (String, String) -> URI -> String -> IO (Maybe (String, String))
provideAuthInfo for_uri credentials = \uri _realm -> do
    if uriHostName uri == uriHostName for_uri then return credentials
                                              else return Nothing

uriHostName :: URI -> Maybe String
uriHostName = fmap uriRegName . uriAuthority


type HttpSession a = BrowserAction (HandleStream ByteString) a

httpSession :: Verbosity -> HttpSession a -> IO a
httpSession verbosity action =
    browse $ do
      setUserAgent "hackage-mirror"
      setErrHandler die
      setOutHandler (debug verbosity)
      setAllowBasicAuth True
      setCheckForProxy True
      action

downloadFile :: URI -> FilePath -> HttpSession ()
downloadFile uri file = do<commit_msg>Use version in hackage-mirror user agent string<commit_after>{-# LANGUAGE PatternGuards #-}
module Distribution.Client where

import Network.HTTP
import Network.Browser
import Network.URI (URI(..), URIAuth(..), parseURI)

import Distribution.Server.LegacyImport.UploadLog as UploadLog (read, Entry(..))
import Distribution.Server.Users.Types (UserId(..), UserName(UserName))
import Distribution.Server.Util.Index as PackageIndex (read)
import Distribution.Server.Util.Merge
import Distribution.Package
import Distribution.Verbosity
import Distribution.Simple.Utils
import Distribution.Text

import Data.List
import Data.Maybe
import Control.Applicative
import Control.Exception
import Data.Time
import Data.Time.Clock.POSIX
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Codec.Compression.GZip  as GZip
import qualified Codec.Archive.Tar       as Tar
import qualified Codec.Archive.Tar.Entry as Tar

import System.IO
import System.IO.Error
import System.FilePath
import System.Directory
import qualified System.FilePath.Posix as Posix

import Paths_hackage_server (version)

-------------------------
-- Command line handling
-------------------------

validateHackageURI :: String -> Either String URI
validateHackageURI str = case parseURI str of
  Nothing                          -> Left ("invalid URL " ++ str)
  Just uri
    | uriScheme uri /= "http:"     -> Left ("only http URLs are supported " ++ str)
    | isNothing (uriAuthority uri) -> Left ("server name required in URL " ++ str)
    | otherwise                    -> Right uri

validatePackageIds :: [String] -> Either String [PackageId]
validatePackageIds pkgstrs = case errs of
            (err:_) -> Left $ "'" ++ err ++ "' is not a valid package name or id"
            _       -> Right pkgs
  where
    pkgstrs' = [ (pkgstr, simpleParse pkgstr) | pkgstr <- pkgstrs ]
    pkgs     = [ pkgid  | (_, Just pkgid)   <- pkgstrs' ]
    errs     = [ pkgstr | (pkgstr, Nothing) <- pkgstrs' ]

----------------------------------------------------
-- Fetching info from source and destination servers
----------------------------------------------------

data PkgIndexInfo = PkgIndexInfo
                       PackageId
                       (Maybe UTCTime)  -- Upload time
                       (Maybe UserName) -- Name of uploader
                       (Maybe UserId)   -- Id of uploader
  deriving Show

downloadIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo]
downloadIndex uri | isOldHackageURI uri = downloadOldIndex uri
                  | otherwise           = downloadNewIndex uri
  where

isOldHackageURI :: URI -> Bool
isOldHackageURI uri
  | Just auth <- uriAuthority uri = uriRegName auth == "hackage.haskell.org"
  | otherwise                     = False


downloadOldIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo]
downloadOldIndex uri cacheFile = do

    downloadFile indexURI indexFile
    downloadFile logURI logFile

    ioAction $ do

      pkgids <- withFile indexFile ReadMode $ \hnd -> do
        content <- BS.hGetContents hnd
        case PackageIndex.read (\pkgid _ -> pkgid) (GZip.decompress content) of
          Left  err  -> die $ "Error parsing index at " ++ show uri ++ ": " ++ err
          Right pkgs -> return pkgs

      log <- withFile logFile ReadMode $ \hnd -> do
        content <- hGetContents hnd
        case UploadLog.read content of
          Right log -> return log
          Left  err -> die $ "Error parsing log at " ++ show uri ++ ": " ++ err

      return (mergeLogInfo pkgids log)

  where
    indexURI  = uri <//> "packages" </> "archive" </> "00-index.tar.gz"
    indexFile = cacheFile <.> "tar.gz"

    logURI    = uri <//> "packages" </> "archive" </> "log"
    logFile   = cacheFile <.> "log"

    mergeLogInfo pkgids log =
        catMaybes
      . map selectDetails
      $ mergeBy (\pkgid entry -> compare pkgid (entryPkgId entry))
                (sort pkgids)
                ( map (maximumBy (comparing entryTime))
                . groupBy (equating  entryPkgId)
                . sortBy  (comparing entryPkgId)
                $ log )

    selectDetails (OnlyInRight _)     = Nothing
    selectDetails (OnlyInLeft  pkgid) =
      Just $ PkgIndexInfo pkgid Nothing Nothing Nothing
    selectDetails (InBoth pkgid (UploadLog.Entry time uname _)) =
      Just $ PkgIndexInfo pkgid (Just time) (Just uname) Nothing

    entryPkgId (Entry _ _ pkgid) = pkgid
    entryTime  (Entry time _ _)  = time


downloadNewIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo]
downloadNewIndex uri cacheFile = do
    downloadFile indexURI indexFile
    ioAction $ withFile indexFile ReadMode $ \hnd -> do
      content <- BS.hGetContents hnd
      case PackageIndex.read selectDetails (GZip.decompress content) of
        Left err   -> error $ "Error parsing index at " ++ show uri ++ ": " ++ err
        Right pkgs -> return pkgs

  where
    indexURI  = uri <//> "packages/00-index.tar.gz"
    indexFile = cacheFile <.> "tar.gz"

    selectDetails :: PackageId -> Tar.Entry -> PkgIndexInfo
    selectDetails pkgid entry =
        PkgIndexInfo
          pkgid
          (Just time)
          (if null username then Nothing else Just (UserName username))
          (if userid == 0   then Nothing else Just (UserId userid))
      where
        time     = epochTimeToUTC (Tar.entryTime entry)
        username = Tar.ownerName (Tar.entryOwnership entry)
        userid   = Tar.ownerId   (Tar.entryOwnership entry)

        epochTimeToUTC :: Tar.EpochTime -> UTCTime
        epochTimeToUTC = posixSecondsToUTCTime . realToFrac


-------------------------
-- HTTP utilities
-------------------------

infixr 5 <//>

(<//>) :: URI -> FilePath -> URI
uri <//> path = uri { uriPath = Posix.addTrailingPathSeparator (uriPath uri)
                                Posix.</> path }


extractURICredentials :: URI -> Maybe (String, String)
extractURICredentials uri
  | Just authority <- uriAuthority uri
  , (username, ':':passwd0) <- break (==':') (uriUserInfo authority)
  , let passwd = takeWhile (/='@') passwd0
  , not (null username)
  , not (null passwd)
  = Just (username, passwd)
extractURICredentials _ = Nothing

removeURICredentials :: URI -> URI
removeURICredentials uri = uri { uriAuthority = fmap (\auth -> auth { uriUserInfo = "" }) (uriAuthority uri) }

provideAuthInfo :: URI -> Maybe (String, String) -> URI -> String -> IO (Maybe (String, String))
provideAuthInfo for_uri credentials = \uri _realm -> do
    if uriHostName uri == uriHostName for_uri then return credentials
                                              else return Nothing

uriHostName :: URI -> Maybe String
uriHostName = fmap uriRegName . uriAuthority


type HttpSession a = BrowserAction (HandleStream ByteString) a

httpSession :: Verbosity -> HttpSession a -> IO a
httpSession verbosity action =
    browse $ do
      setUserAgent ("hackage-mirror/" ++ display version)
      setErrHandler die
      setOutHandler (debug verbosity)
      setAllowBasicAuth True
      setCheckForProxy True
      action

downloadFile :: URI -> FilePath -> HttpSession ()
downloadFile uri file = do
{'fraction_non_alphanumeric': 0.12163018230449778, 'fraction_numerical': 0.001407756739635391, 'mean_word_length': 2.3320825515947465, 'pattern_counts': {'":': 6, '<': 53, '<?xml version=': 0, '>': 119, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 30, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '316525', 'n_tokens_mistral': 4113, 'n_tokens_neox': 3903, 'n_words': 1236}