Merge pull request #283 from lehins/external-cabal-files

External cabal files

package.yaml

@@ -39,6 +39,7 @@ dependencies:
 - persistent-template
 - resourcet
 - rio
+- semialign
 - shakespeare
 - tar-conduit
 - template-haskell

src/Data/WebsiteContent.hs

@@ -11,7 +11,6 @@ module Data.WebsiteContent
 
 import ClassyPrelude.Yesod
 import CMarkGFM
-import Data.Aeson (withObject)
 import Data.GhcLinks
 import Data.Yaml
 import System.FilePath (takeFileName)

src/Handler/Blog.hs

@@ -86,4 +86,5 @@ getBlogFeedR = do
             , feedEntryTitle = postTitle post
             , feedEntryContent = postBody post
             , feedEntryEnclosure = Nothing
+            , feedEntryCategories = []
             }

src/Handler/Download.hs

@@ -12,7 +12,6 @@ import Import
 import Data.GhcLinks
 import Yesod.GitRepo (grContent)
 import Stackage.Database
-import Stackage.Database.Types (ghcVersion)
 
 getDownloadR :: Handler Html
 getDownloadR = track "Hoogle.Download.getDownloadR" $

src/Handler/Feed.hs

@@ -12,7 +12,6 @@ import RIO.Time (getCurrentTime)
 import Stackage.Database
 import Stackage.Snapshot.Diff
 import Text.Blaze (text)
-import Yesod.Core.Handler (lookupGetParam)
 
 getFeedR :: Handler TypedContent
 getFeedR = track "Handler.Feed.getBranchFeedR" $ getBranchFeed Nothing
@@ -38,6 +37,7 @@ mkFeed mBranch snaps = do
             , feedEntryTitle = snapshotTitle snap
             , feedEntryContent = content
             , feedEntryEnclosure = Nothing
+            , feedEntryCategories = []
             }
     updated <-
         case entries of

src/Handler/Haddock.hs

@@ -7,7 +7,6 @@ module Handler.Haddock
 import Import
 import qualified Data.Text as T (takeEnd)
 import Stackage.Database
-import Stackage.Database.Types (haddockBucketName)
 
 makeURL :: SnapName -> [Text] -> Text
 makeURL snapName rest = concat

src/Handler/Hoogle.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Handler.Hoogle where
 
-import Control.DeepSeq (NFData(..))
 import qualified Data.Text as T
 import Data.Text.Read (decimal)
 import qualified Hoogle

src/Handler/MirrorStatus.hs

@@ -8,7 +8,7 @@ module Handler.MirrorStatus
 import Import
 import Control.AutoUpdate
 import Network.HTTP.Simple
-import RIO.Time (parseTimeM, diffUTCTime, addUTCTime, getCurrentTime)
+import RIO.Time (diffUTCTime, addUTCTime, getCurrentTime)
 import Text.XML.Stream.Parse
 import Data.XML.Types (Event (EventContent), Content (ContentText))
 import qualified Prelude

src/Handler/Package.hs

@@ -27,8 +27,6 @@ import Graphics.Badge.Barrier
 import Import
 import Stackage.Database
 import Stackage.Database.PackageInfo (PackageInfo(..), Identifier(..), renderEmail)
-import Stackage.Database.Types (HackageCabalInfo(..), LatestInfo(..),
-                                ModuleListingInfo(..))
 import qualified Text.Blaze.Html.Renderer.Text as LT
 import Yesod.GitRepo
 
@@ -75,9 +73,7 @@ checkSpam pname inner = do
         $(widgetFile "spam-package")
       else inner
 
-packagePage :: Maybe SnapshotPackageInfo
+packagePage :: Maybe SnapshotPackageInfo -> PackageNameP -> Handler Html
-            -> PackageNameP
-            -> Handler Html
 packagePage mspi pname =
     track "Handler.Package.packagePage" $
     checkSpam pname $
@@ -88,8 +84,6 @@ packagePage mspi pname =
           Just spi -> handlePackage $ Right spi
 
 
-
-
 handlePackage :: Either HackageCabalInfo SnapshotPackageInfo -> Handler Html
 handlePackage epi = do
     (isDeprecated, inFavourOf) <- getDeprecated pname

src/Handler/PackageDeps.hs

@@ -9,9 +9,7 @@ module Handler.PackageDeps
 
 import Handler.StackageSdist (pnvToSnapshotPackageInfo)
 import Import
-import Types (PackageVersionRev(..))
 import Stackage.Database
-import Stackage.Database.Types (SnapshotPackageInfo(..))
 
 getPackageDepsR :: PackageNameP -> Handler Html
 getPackageDepsR pname = do

src/Handler/StackageHome.hs

@@ -17,7 +17,6 @@ import Data.These
 import RIO.Time (FormatTime)
 import Import
 import Stackage.Database
-import Stackage.Database.Types (PackageListingInfo(..), isLts)
 import Stackage.Snapshot.Diff
 
 getStackageHomeR :: SnapName -> Handler TypedContent

src/Handler/StackageSdist.hs

@@ -6,7 +6,6 @@ module Handler.StackageSdist
 
 import Import
 import Stackage.Database
-import Stackage.Database.Types (SnapshotPackageInfo(..))
 import Handler.Package (packagePage)
 
 handlePNVTarball :: PackageNameP -> VersionP -> Handler TypedContent

src/Import.hs

@@ -3,19 +3,16 @@ module Import
     ( module Import
     ) where
 
-import Control.Monad.Trans.Class (lift)
 import ClassyPrelude.Yesod as Import hiding (getCurrentTime)
 import Foundation as Import
 import Settings as Import
 import Settings.StaticFiles as Import
 import Types as Import
 import Yesod.Auth as Import
-import Yesod.Core.Handler (getYesod)
 import Data.WebsiteContent as Import (WebsiteContent (..))
 import Data.Text.Read (decimal)
 import RIO.Time (diffUTCTime)
 --import qualified Prometheus as P
-import Stackage.Database (SnapName)
 import Stackage.Database.Types (ModuleListingInfo(..))
 import Formatting (format)
 import Formatting.Time (diff)

src/Stackage/Database/Cron.hs

@@ -28,27 +28,25 @@ import Data.Streaming.Network (bindPortTCP)
 import Data.Yaml (decodeFileEither)
 import Database.Persist
 import Database.Persist.Postgresql
-import Distribution.PackageDescription (GenericPackageDescription)
 import qualified Hoogle
 import Network.AWS hiding (Request, Response)
-import Network.AWS.Data.Body (toBody)
 import Network.AWS.Data.Text (toText)
 import Network.AWS.S3
 import Network.HTTP.Client
 import Network.HTTP.Client.Conduit (bodyReaderSource)
-import Network.HTTP.Simple (getResponseBody, httpJSONEither, parseRequest)
+import Network.HTTP.Simple (getResponseBody, httpJSONEither)
 import Network.HTTP.Types (status200, status404)
 import Pantry (CabalFileInfo(..), DidUpdateOccur(..),
                HpackExecutable(HpackBundled), PackageIdentifierRevision(..),
-               defaultHackageSecurityConfig)
+               defaultHackageSecurityConfig, defaultCasaRepoPrefix, defaultCasaMaxPerRequest)
-import Pantry.Internal.Stackage (HackageCabalId, HackageTarballResult(..),
+import Pantry.Internal.Stackage (HackageTarballResult(..),
                                  PantryConfig(..), Storage(..),
                                  forceUpdateHackageIndex, getHackageTarball,
-                                 getTreeForKey, loadBlobById, packageTreeKey,
+                                 packageTreeKey)
-                                 treeCabal)
 import Path (parseAbsDir, toFilePath)
 import RIO
 import RIO.Directory
+import RIO.File
 import RIO.FilePath
 import RIO.List as L
 import qualified RIO.Map as Map
@@ -118,7 +116,6 @@ newHoogleLocker env man = mkSingleRun hoogleLocker
     hoogleLocker name =
         runRIO env $ do
             let fp = T.unpack $ hoogleKey name
-                fptmp = fp <.> "tmp"
             exists <- doesFileExist fp
             if exists
                 then return $ Just fp
@@ -129,24 +126,17 @@ newHoogleLocker env man = mkSingleRun hoogleLocker
                         case responseStatus res of
                             status
                                 | status == status200 -> do
-                                    createDirectoryIfMissing True $ takeDirectory fptmp
+                                    createDirectoryIfMissing True $ takeDirectory fp
-                                    -- TODO: https://github.com/commercialhaskell/rio/issues/160
+                                    withBinaryFileDurableAtomic fp WriteMode $ \h ->
-                                    -- withBinaryFileDurableAtomic fp WriteMode $ \h ->
+                                        runConduitRes $
-                                    --     runConduitRes $
-                                    --     bodyReaderSource (responseBody res) .| ungzip .|
-                                    --     sinkHandle h
-                                    runConduitRes $
                                         bodyReaderSource (responseBody res) .| ungzip .|
-                                        sinkFile fptmp
+                                        sinkHandle h
-                                    renamePath fptmp fp
                                     return $ Just fp
                                 | status == status404 -> do
                                     logDebug $ "NotFound: " <> display (hoogleUrl name)
                                     return Nothing
                                 | otherwise -> do
                                     body <- liftIO $ brConsume $ responseBody res
-                                    -- TODO: ideally only consume the body when log level set to
-                                    -- LevelDebug, will require a way to get LogLevel from LogFunc
                                     mapM_ (logDebug . displayBytesUtf8) body
                                     return Nothing
 
@@ -192,6 +182,8 @@ stackageServerCron StackageCronOptions {..} = do
                         , pcParsedCabalFilesRawImmutable = cabalImmutable
                         , pcParsedCabalFilesMutable = cabalMutable
                         , pcConnectionCount = connectionCount
+                        , pcCasaRepoPrefix = defaultCasaRepoPrefix
+                        , pcCasaMaxPerRequest = defaultCasaMaxPerRequest
                         }
                 stackage =
                     StackageCron
@@ -239,31 +231,64 @@ makeCorePackageGetters ::
 makeCorePackageGetters = do
     rootDir <- scStackageRoot <$> ask
     contentDir <- getStackageContentDir rootDir
+    coreCabalFiles <- getCoreCabalFiles rootDir
     liftIO (decodeFileEither (contentDir </> "stack" </> "global-hints.yaml")) >>= \case
         Right (hints :: Map CompilerP (Map PackageNameP VersionP)) ->
             Map.traverseWithKey
                 (\compiler ->
-                     fmap Map.elems . Map.traverseMaybeWithKey (makeCorePackageGetter compiler))
+                     fmap Map.elems .
+                     Map.traverseMaybeWithKey (makeCorePackageGetter compiler coreCabalFiles))
                 hints
         Left exc -> do
             logError $
                 "Error parsing 'global-hints.yaml' file: " <> fromString (displayException exc)
             return mempty
 
+getCoreCabalFiles ::
+       FilePath
+    -> RIO StackageCron (Map PackageIdentifierP (GenericPackageDescription, CabalFileIds))
+getCoreCabalFiles rootDir = do
+    coreCabalFilesDir <- getCoreCabalFilesDir rootDir
+    cabalFileNames <- getDirectoryContents coreCabalFilesDir
+    cabalFiles <-
+        forM (filter (isExtensionOf ".cabal") cabalFileNames) $ \cabalFileName ->
+            let pidTxt = T.pack (dropExtension (takeFileName cabalFileName))
+             in case fromPathPiece pidTxt of
+                    Nothing -> do
+                        logError $ "Invalid package identifier: " <> fromString cabalFileName
+                        pure Nothing
+                    Just pid -> do
+                        cabalBlob <- readFileBinary (coreCabalFilesDir </> cabalFileName)
+                        mCabalInfo <- run $ addCabalFile pid cabalBlob
+                        pure ((,) pid <$> mCabalInfo)
+    pure $ Map.fromList $ catMaybes cabalFiles
+
 -- | Core package info rarely changes between the snapshots, therefore it would be wasteful to
 -- load, parse and update all packages from gloabl-hints for each snapshot, instead we produce
 -- a memoized version that will do it once initiall and then return information aboat a
 -- package on subsequent invocations.
 makeCorePackageGetter ::
-       CompilerP -> PackageNameP -> VersionP -> RIO StackageCron (Maybe CorePackageGetter)
+       CompilerP
-makeCorePackageGetter _compiler pname ver =
+    -> Map PackageIdentifierP (GenericPackageDescription, CabalFileIds)
+    -> PackageNameP
+    -> VersionP
+    -> RIO StackageCron (Maybe CorePackageGetter)
+makeCorePackageGetter _compiler fallbackCabalFileMap pname ver =
     run (getHackageCabalByRev0 pid) >>= \case
         Nothing -> do
             logWarn $
                 "Core package from global-hints: '" <> display pid <> "' was not found in pantry."
-            pure Nothing
+            forM (Map.lookup pid fallbackCabalFileMap) $ \(gpd, cabalFileIds) -> do
+                logInfo $
+                    "Falling back on '" <> display pid <>
+                    ".cabal' file from the commercialhaskell/core-cabal-files repo"
+                pure $ pure (Left cabalFileIds, Nothing, pid, gpd)
         Just (hackageCabalId, blobId, _) -> do
             pkgInfoRef <- newIORef Nothing -- use for caching of pkgInfo
+            let getCabalFileIdsTree gpd =
+                    \case
+                        Just tree -> pure $ Right tree
+                        Nothing -> Left <$> getCabalFileIds blobId gpd
             let getMemoPackageInfo =
                     readIORef pkgInfoRef >>= \case
                         Just pkgInfo -> return pkgInfo
@@ -273,17 +298,21 @@ makeCorePackageGetter _compiler pname ver =
                             htr <- getHackageTarball pir Nothing
                             case htrFreshPackageInfo htr of
                                 Just (gpd, treeId) -> do
-                                    mTree <- run $ getEntity treeId
+                                    eTree <-
-                                    let pkgInfo = (mTree, Just hackageCabalId, pid, gpd)
+                                        run $ do
+                                            mTree <- getEntity treeId
+                                            getCabalFileIdsTree gpd mTree
+                                    let pkgInfo = (eTree, Just hackageCabalId, pid, gpd)
                                     gpd `deepseq` writeIORef pkgInfoRef $ Just pkgInfo
                                     pure pkgInfo
                                 Nothing -> do
-                                    (cabalBlob, mTree) <-
+                                    (gpd, eCabalTree) <-
-                                        run
+                                        run $ do
-                                            ((,) <$> loadBlobById blobId <*>
+                                            cabalBlob <- loadBlobById blobId
-                                             getTreeForKey (packageTreeKey (htrPackage htr)))
+                                            let gpd = parseCabalBlob cabalBlob
-                                    let gpd = parseCabalBlob cabalBlob
+                                            mTree <- getTreeForKey (packageTreeKey (htrPackage htr))
-                                        pkgInfo = (mTree, Just hackageCabalId, pid, gpd)
+                                            (,) gpd <$> getCabalFileIdsTree gpd mTree
+                                    let pkgInfo = (eCabalTree, Just hackageCabalId, pid, gpd)
                                     gpd `deepseq` writeIORef pkgInfoRef $ Just pkgInfo
                                     pure pkgInfo
             pure $ Just getMemoPackageInfo
@@ -325,11 +354,12 @@ addPantryPackage sid compiler isHidden flags (PantryPackage pc treeKey) = do
                     , tid /= treeId -> do
                         lift $ logError $ "Pantry Tree Key mismatch for: " <> display pc
                         pure False
-                mTree@(Just (Entity _ Tree {treeCabal}))
+                Just tree@(Entity _ Tree {treeCabal})
                     | Just treeCabal' <- treeCabal -> do
                         gpd <- getCachedGPD treeCabal' mgpd
                         let mhcid = Just hcid
-                        addSnapshotPackage sid compiler Hackage mTree mhcid isHidden flags pid gpd
+                            eTree = Right tree
+                        addSnapshotPackage sid compiler Hackage eTree mhcid isHidden flags pid gpd
                         pure True
                 _ -> do
                   lift $ logError $ "Pantry is missing the source tree for " <> display pc
@@ -363,9 +393,7 @@ checkForDocs snapshotId snapName = do
         runConduit $
         AWS.paginate (req bucketName) .| concatMapC (^. lovrsContents) .|
         mapC (\obj -> toText (obj ^. oKey)) .|
-        concatMapC (T.stripSuffix ".html") .|
+        concatMapC (T.stripSuffix ".html" >=> T.stripPrefix prefix >=> pathToPackageModule) .|
-        concatMapC (T.stripPrefix prefix) .|
-        concatMapC pathToPackageModule .|
         sinkList
     -- it is faster to download all modules in this snapshot, than process them with a conduit all
     -- the way to the database.
@@ -429,19 +457,15 @@ sourceSnapshots = do
                             "Error parsing snapshot file: " <> fromString fp <> "\n" <>
                             fromString (displayException exc)
                         return Nothing
-        lastGitFileUpdate gitDir fp >>= \case
+        mUpdatedOn <- lastGitFileUpdate gitDir fp
-            Left err -> do
+        forM mUpdatedOn $ \updatedOn -> do
-                logError $ "Error parsing git commit date: " <> fromString err
+            env <- lift ask
-                return Nothing
+            return $
-            Right updatedOn -> do
+                SnapshotFileInfo
-                env <- lift ask
+                    { sfiSnapName = snapName
-                return $
+                    , sfiUpdatedOn = updatedOn
-                    Just
+                    , sfiSnapshotFileGetter = runRIO env (parseSnapshot updatedOn)
-                        SnapshotFileInfo
+                    }
-                            { sfiSnapName = snapName
-                            , sfiUpdatedOn = updatedOn
-                            , sfiSnapshotFileGetter = runRIO env (parseSnapshot updatedOn)
-                            }
     getLtsParser gitDir fp =
         case mapM (BS8.readInt . BS8.pack) $ take 2 $ reverse (splitPath fp) of
             Just [(minor, ".yaml"), (major, "/")] ->
@@ -496,7 +520,7 @@ decideOnSnapshotUpdate SnapshotFileInfo {sfiSnapName, sfiUpdatedOn, sfiSnapshotF
         _ -> return Nothing
 
 type CorePackageGetter
-     = RIO StackageCron ( Maybe (Entity Tree)
+     = RIO StackageCron ( Either CabalFileIds (Entity Tree)
                         , Maybe HackageCabalId
                         , PackageIdentifierP
                         , GenericPackageDescription)
@@ -598,8 +622,8 @@ updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {..
                     ]
         Just compilerCorePackages ->
             forM_ compilerCorePackages $ \getCorePackageInfo -> do
-                (mTree, mhcid, pid, gpd) <- getCorePackageInfo
+                (eTree, mhcid, pid, gpd) <- getCorePackageInfo
-                run $ addSnapshotPackage snapshotId sfCompiler Core mTree mhcid False mempty pid gpd
+                run $ addSnapshotPackage snapshotId sfCompiler Core eTree mhcid False mempty pid gpd
     return $ do
         checkForDocsSucceeded <-
             tryAny (checkForDocs snapshotId snapName) >>= \case
@@ -707,12 +731,8 @@ createHoogleDB snapshotId snapName =
             withResponseUnliftIO req {decompress = const True} man $ \res -> do
                 throwErrorStatusCodes req res
                 createDirectoryIfMissing True $ takeDirectory tarFP
-                --withBinaryFileDurableAtomic tarFP WriteMode $ \tarHandle ->
+                withBinaryFileDurableAtomic tarFP WriteMode $ \tarHandle ->
-                --FIXME: https://github.com/commercialhaskell/rio/issues/160
-                let tmpTarFP = tarFP <.> "tmp"
-                withBinaryFile tmpTarFP WriteMode $ \tarHandle ->
                     runConduitRes $ bodyReaderSource (responseBody res) .| sinkHandle tarHandle
-                renameFile tmpTarFP tarFP
         void $ tryIO $ removeDirectoryRecursive bindir
         void $ tryIO $ removeFile outname
         createDirectoryIfMissing True bindir

src/Stackage/Database/Github.hs

@@ -4,6 +4,7 @@ module Stackage.Database.Github
     ( cloneOrUpdate
     , lastGitFileUpdate
     , getStackageContentDir
+    , getCoreCabalFilesDir
     , GithubRepo(..)
     ) where
 
@@ -14,6 +15,7 @@ import RIO.FilePath
 import RIO.Process
 import RIO.Time
 
+
 data GithubRepo = GithubRepo
     { grAccount :: !String
     , grName    :: !String
@@ -32,17 +34,22 @@ lastGitFileUpdate ::
        (MonadReader env m, HasLogFunc env, HasProcessContext env, MonadUnliftIO m)
     => FilePath -- ^ Root dir of the repository
     -> FilePath -- ^ Relative path of the file
-    -> m (Either String UTCTime)
+    -> m (Maybe UTCTime)
 lastGitFileUpdate gitDir filePath = do
     lastCommitTimestamps <- gitLog gitDir filePath ["-1", "--format=%cD"]
     parseGitDate rfc822DateFormat lastCommitTimestamps
   where
     parseGitDate fmt dates =
         case listToMaybe $ LBS8.lines dates of
-            Nothing -> return $ Left "Git log is empty for the file"
+            Nothing -> do
-            Just lbsDate ->
+                logError "Git log is empty for the file"
-                mapLeft (displayException :: SomeException -> String) <$>
+                return Nothing
-                try (parseTimeM False defaultTimeLocale fmt (LBS8.unpack lbsDate))
+            Just lbsDate -> do
+                let parseDateTime = parseTimeM False defaultTimeLocale fmt (LBS8.unpack lbsDate)
+                catchAny (Just <$> liftIO parseDateTime) $ \exc -> do
+                    logError $
+                        "Error parsing git commit date: " <> fromString (displayException exc)
+                    pure Nothing
 
 -- | Clone a repository locally. In case when repository is already present sync it up with
 -- remote. Returns the full path where repository was cloned into.
@@ -72,3 +79,11 @@ getStackageContentDir ::
     -> m FilePath
 getStackageContentDir rootDir =
     cloneOrUpdate rootDir (GithubRepo "commercialhaskell" "stackage-content")
+
+-- | Use backup location with cabal files, hackage doesn't have all of them.
+getCoreCabalFilesDir ::
+       (MonadReader env m, HasLogFunc env, HasProcessContext env, MonadIO m)
+    => FilePath
+    -> m FilePath
+getCoreCabalFilesDir rootDir =
+    cloneOrUpdate rootDir (GithubRepo "commercialhaskell" "core-cabal-files")

src/Stackage/Database/Haddock.hs

@@ -38,9 +38,7 @@ hToHtml =
         H.dt (go x) ++ H.dd (go y)
     go (DocCodeBlock x) = H.pre $ H.code $ go x
     go (DocHyperlink (Hyperlink url mlabel)) =
-        H.a H.! A.href (H.toValue url) $ toHtml label
+        H.a H.! A.href (H.toValue url) $ maybe (toHtml url) (toHtml . go) mlabel
-      where
-        label = fromMaybe url mlabel
     go (DocPic (Picture url mtitle)) =
         H.img H.! A.src (H.toValue url) H.! A.title (H.toValue $ fromMaybe mempty mtitle)
     go (DocAName s) = H.div H.! A.id (H.toValue s) $ mempty

src/Stackage/Database/PackageInfo.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ViewPatterns #-}
 module Stackage.Database.PackageInfo
     ( PackageInfo(..)
     , Identifier(..)
@@ -14,12 +14,11 @@ module Stackage.Database.PackageInfo
     ) where
 
 import CMarkGFM
-import Data.Coerce
 import Data.Char (isSpace)
+import Data.Coerce
 import Data.Map.Merge.Strict as Map
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8With)
+import qualified Data.Text.Encoding as T
-import Data.Text.Encoding.Error (lenientDecode)
 import Distribution.Compiler (CompilerFlavor(GHC))
 import Distribution.Package (Dependency(..))
 import Distribution.PackageDescription (CondTree(..), Condition(..),
@@ -28,28 +27,29 @@ import Distribution.PackageDescription (CondTree(..), Condition(..),
                                         GenericPackageDescription, author,
                                         condExecutables, condLibrary,
                                         description, genPackageFlags, homepage,
-                                        license, maintainer,
+                                        license, maintainer, packageDescription,
-                                        packageDescription, synopsis)
+                                        synopsis)
 import Distribution.PackageDescription.Parsec (parseGenericPackageDescription,
                                                runParseResult)
 import Distribution.Pretty (prettyShow)
 import Distribution.System (Arch(X86_64), OS(Linux))
 import Distribution.Types.CondTree (CondBranch(..))
 import Distribution.Types.Library (exposedModules)
+import Distribution.Types.PackageDescription (PackageDescription(package))
 import Distribution.Types.VersionRange (VersionRange, intersectVersionRanges,
                                         normaliseVersionRange, withinRange)
 import Distribution.Version (simplifyVersionRange)
-import qualified Data.Text.Encoding as T
 import RIO
 import qualified RIO.Map as Map
 import qualified RIO.Map.Unchecked as Map (mapKeysMonotonic)
 import Stackage.Database.Haddock (renderHaddock)
 import Stackage.Database.Types (Changelog(..), Readme(..))
 import Text.Blaze.Html (Html, preEscapedToHtml, toHtml)
-import Types (CompilerP(..), FlagNameP(..), ModuleNameP(..), PackageNameP(..),
-              SafeFilePath, VersionP(..), VersionRangeP(..), unSafeFilePath)
-import Yesod.Form.Fields (Textarea(..))
 import Text.Email.Validate
+import Types (CompilerP(..), FlagNameP(..), ModuleNameP(..), PackageIdentifierP,
+              PackageNameP(..), SafeFilePath, VersionP(..), VersionRangeP(..),
+              unSafeFilePath, dtDisplay)
+import Yesod.Form.Fields (Textarea(..))
 
 
 data PackageInfo = PackageInfo
@@ -81,7 +81,7 @@ toPackageInfo gpd mreadme mchangelog =
         , piHomepage =
               case T.strip $ T.pack $ homepage pd of
                   "" -> Nothing
-                  x -> Just x
+                  x  -> Just x
         , piLicenseName = T.pack $ prettyShow $ license pd
         }
   where
@@ -127,17 +127,23 @@ parseCabalBlob cabalBlob =
 
 parseCabalBlobMaybe ::
        (MonadIO m, MonadReader env m, HasLogFunc env)
-    => PackageNameP
+    => PackageIdentifierP
     -> ByteString
     -> m (Maybe GenericPackageDescription)
-parseCabalBlobMaybe packageName cabalBlob =
+parseCabalBlobMaybe pidp cabalBlob =
     case snd $ runParseResult $ parseGenericPackageDescription cabalBlob of
         Left err ->
             Nothing <$
             logError
-                ("Problem parsing cabal blob for '" <> display packageName <> "': " <>
+                ("Problem parsing cabal blob for '" <> display pidp <> "': " <> displayShow err)
-                 displayShow err)
+        Right gpd -> do
-        Right pgd -> pure $ Just pgd
+            let pid = package (packageDescription gpd)
+            unless (textDisplay (dtDisplay pid :: Utf8Builder) == textDisplay pidp) $
+                logError $
+                "Supplied package identifier: '" <> display pidp <>
+                "' does not match the one in cabal file: '" <>
+                dtDisplay pid
+            pure $ Just gpd
 
 getCheckCond ::
        CompilerP -> Map FlagName Bool -> GenericPackageDescription -> Condition ConfVar -> Bool
@@ -172,7 +178,7 @@ getDeps checkCond = goTree
   where
     goTree (CondNode _data deps comps) =
         combineDeps $
-        map (\(Dependency name range) -> Map.singleton (PackageNameP name) range) deps ++
+        map (\(Dependency name range _) -> Map.singleton (PackageNameP name) range) deps ++
         map goComp comps
     goComp (CondBranch cond yes no)
         | checkCond cond = goTree yes

src/Stackage/Database/Query.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 module Stackage.Database.Query
     (
       -- * Snapshot
@@ -53,13 +53,15 @@ module Stackage.Database.Query
     , getTreeForKey
     , treeCabal
     -- ** Stackage server
+    , CabalFileIds
+    , addCabalFile
+    , getCabalFileIds
     , addSnapshotPackage
     , getHackageCabalByRev0
     , getHackageCabalByKey
     , snapshotMarkUpdated
     , insertSnapshotName
     , markModuleHasDocs
-    , insertSnapshotPackageModules
     , insertDeps
     -- ** For Hoogle db creation
     , lastLtsNightly
@@ -72,11 +74,14 @@ import qualified Data.List as L
 import Database.Esqueleto
 import Database.Esqueleto.Internal.Language (FromPreprocess)
 import Database.Esqueleto.Internal.Sql
+import Distribution.Types.PackageId (PackageIdentifier(PackageIdentifier))
+import Distribution.PackageDescription (packageDescription)
+import Distribution.Types.PackageDescription (PackageDescription(package))
 import qualified Database.Persist as P
-import Pantry.Internal.Stackage (EntityField(..), PackageName, Unique(..),
+import Pantry.Internal.Stackage (EntityField(..), PackageName,
                                  Version, getBlobKey, getPackageNameById,
                                  getPackageNameId, getTreeForKey, getVersionId,
-                                 loadBlobById, mkSafeFilePath, treeCabal)
+                                 loadBlobById, storeBlob, mkSafeFilePath)
 import RIO hiding (on, (^.))
 import qualified RIO.Map as Map
 import qualified RIO.Set as Set
@@ -365,7 +370,7 @@ getPackageVersionForSnapshot snapshotId pname =
              pure (v ^. VersionVersion))
 
 getLatest ::
-       FromPreprocess SqlQuery SqlExpr SqlBackend t
+       FromPreprocess t
     => PackageNameP
     -> (t -> SqlExpr (Value SnapshotId))
     -> (t -> SqlQuery ())
@@ -777,6 +782,75 @@ insertDeps pid snapshotPackageId dependencies =
                     display dep
                 return $ Just dep
 
+data CabalFileIds = CabalFileIds
+    { cfiPackageNameId :: !PackageNameId
+    , cfiVersionId :: !VersionId
+    , cfiCabalBlobId :: !(Maybe BlobId)
+    , cfiModuleNameIds :: ![ModuleNameId]
+    }
+
+getCabalFileIds ::
+       HasLogFunc env
+    => BlobId
+    -> GenericPackageDescription
+    -> ReaderT SqlBackend (RIO env) CabalFileIds
+getCabalFileIds cabalBlobId gpd = do
+    let PackageIdentifier name ver = package (packageDescription gpd)
+    packageNameId <- getPackageNameId name
+    versionId <- getVersionId ver
+    moduleNameIds <- mapM insertModuleSafe (extractModuleNames gpd)
+    pure
+        CabalFileIds
+            { cfiPackageNameId = packageNameId
+            , cfiVersionId = versionId
+            , cfiCabalBlobId = Just cabalBlobId
+            , cfiModuleNameIds = moduleNameIds
+            }
+
+addCabalFile ::
+       HasLogFunc env
+    => PackageIdentifierP
+    -> ByteString
+    -> ReaderT SqlBackend (RIO env) (Maybe (GenericPackageDescription, CabalFileIds))
+addCabalFile pid cabalBlob = do
+    mgpd <- lift $ parseCabalBlobMaybe pid cabalBlob
+    forM mgpd $ \gpd -> do
+        (cabalBlobId, _) <- storeBlob cabalBlob
+        cabalIds <- getCabalFileIds cabalBlobId gpd
+        pure (gpd, cabalIds)
+
+getPackageIds ::
+       GenericPackageDescription
+    -> Either CabalFileIds (Entity Tree)
+    -> ReaderT SqlBackend (RIO env) (CabalFileIds, Maybe (TreeId, BlobId))
+getPackageIds gpd =
+    \case
+        Left cabalFileIds -> pure (cabalFileIds, Nothing)
+        Right (Entity treeId tree)
+            -- -- TODO: Remove Maybe from cfiCabalBlobId and
+            -- --       Generate cabal file from package.yaml:
+            -- case treeCabal tree of
+            --   Just cabalBlobId -> pure cabalBlobId
+            --   Nothing -> do
+            --     let rawMetaData = RawPackageMetadata {
+            --           rpmName = Just pname
+            --           , rpmVersion = Just pver
+            --           , rpmTreeKey = treeKey tree
+            --           }
+            --         rpli = ... get
+            --     generateHPack (RPLIArchive / RPLIRepo ..) treeId treeVersion tree
+            --     ...
+         -> do
+            moduleNameIds <- mapM insertModuleSafe (extractModuleNames gpd)
+            let cabalFileIds =
+                    CabalFileIds
+                        { cfiPackageNameId = treeName tree
+                        , cfiVersionId = treeVersion tree
+                        , cfiCabalBlobId = treeCabal tree
+                        , cfiModuleNameIds = moduleNameIds
+                        }
+            pure (cabalFileIds, Just (treeId, treeKey tree))
+
 -- TODO: Optimize, whenever package is already in one snapshot only create the modules and new
 -- SnapshotPackage
 addSnapshotPackage ::
@@ -784,30 +858,27 @@ addSnapshotPackage ::
     => SnapshotId
     -> CompilerP
     -> Origin
-    -> Maybe (Entity Tree)
+    -> Either CabalFileIds (Entity Tree)
     -> Maybe HackageCabalId
     -> Bool
     -> Map FlagNameP Bool
     -> PackageIdentifierP
     -> GenericPackageDescription
     -> ReaderT SqlBackend (RIO env) ()
-addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden flags pid gpd = do
+addSnapshotPackage snapshotId compiler origin eCabalTree mHackageCabalId isHidden flags pid gpd = do
-    let PackageIdentifierP pname pver = pid
+    (CabalFileIds{..}, mTree) <- getPackageIds gpd eCabalTree
-        mTreeId = entityKey <$> mTree
+    let mTreeId = fst <$> mTree
-    packageNameId <-
-        maybe (getPackageNameId (unPackageNameP pname)) (pure . treeName . entityVal) mTree
-    versionId <- maybe (getVersionId (unVersionP pver)) (pure . treeVersion . entityVal) mTree
     mrevision <- maybe (pure Nothing) getHackageRevision mHackageCabalId
     mreadme <- fromMaybe (pure Nothing) $ getContentTreeEntryId <$> mTreeId <*> mreadmeQuery
     mchangelog <- fromMaybe (pure Nothing) $ getContentTreeEntryId <$> mTreeId <*> mchangelogQuery
     let snapshotPackage =
             SnapshotPackage
                 { snapshotPackageSnapshot = snapshotId
-                , snapshotPackagePackageName = packageNameId
+                , snapshotPackagePackageName = cfiPackageNameId
-                , snapshotPackageVersion = versionId
+                , snapshotPackageVersion = cfiVersionId
                 , snapshotPackageRevision = mrevision
-                , snapshotPackageCabal = treeCabal =<< entityVal <$> mTree
+                , snapshotPackageCabal = cfiCabalBlobId
-                , snapshotPackageTreeBlob = treeKey . entityVal <$> mTree
+                , snapshotPackageTreeBlob = snd <$> mTree
                 , snapshotPackageOrigin = origin
                 , snapshotPackageOriginUrl = "" -- TODO: add
                 , snapshotPackageSynopsis = getSynopsis gpd
@@ -832,7 +903,8 @@ addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden fla
     forM_ msnapshotPackageId $ \snapshotPackageId -> do
         _ <- insertDeps pid snapshotPackageId (extractDependencies compiler flags gpd)
         -- TODO: collect all missing dependencies and make a report
-        insertSnapshotPackageModules snapshotPackageId (extractModuleNames gpd)
+        forM_ cfiModuleNameIds $ \modNameId -> do
+            void $ P.insertBy (SnapshotPackageModule snapshotPackageId modNameId False)
 
 getContentTreeEntryId ::
        TreeId
@@ -979,16 +1051,6 @@ getSnapshotPackageCabalBlob snapshotId pname =
              (pn ^. PackageNameName ==. val pname))
         return (blob ^. BlobContents)
 
-
--- | Add all modules available for the package in a particular snapshot. Initially they are marked
--- as without available documentation.
-insertSnapshotPackageModules ::
-       SnapshotPackageId -> [ModuleNameP] -> ReaderT SqlBackend (RIO env) ()
-insertSnapshotPackageModules snapshotPackageId =
-    mapM_ $ \modName -> do
-        moduleId <- insertModuleSafe modName
-        void $ P.insertBy (SnapshotPackageModule snapshotPackageId moduleId False)
-
 -- | Idempotent and thread safe way of adding a new module.
 insertModuleSafe :: ModuleNameP -> ReaderT SqlBackend (RIO env) ModuleNameId
 insertModuleSafe modName = do

src/Stackage/Database/Schema.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
@@ -8,8 +9,10 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Stackage.Database.Schema
     ( -- * Database
       run
@@ -47,7 +50,7 @@ import Database.Persist.Postgresql
 import Database.Persist.TH
 import Pantry (HasPantryConfig(..), Revision)
 import Pantry.Internal.Stackage as PS (BlobId, HackageCabalId, ModuleNameId,
-                                       PackageNameId, Tree(..), TreeEntry(..),
+                                       PackageNameId, Tree(..),
                                        TreeEntryId, TreeId, Unique(..),
                                        VersionId, unBlobKey)
 import Pantry.Internal.Stackage (PantryConfig(..), Storage(..))

src/Stackage/Database/Types.hs

@@ -51,9 +51,7 @@ import qualified Data.Text as T
 import Data.Text.Read (decimal)
 import Network.AWS (Env, HasEnv(..))
 import Pantry (BlobKey(..), CabalFileInfo(..), FileSize(..),
-               HasPantryConfig(..), PackageIdentifierRevision(..), TreeKey(..))
+               HasPantryConfig(..), PantryConfig, PackageIdentifierRevision(..), TreeKey(..))
-import Pantry.Internal.Stackage as Pantry (PackageNameP(..), PantryConfig,
-                                           VersionP(..))
 import Pantry.SHA256 (fromHexText)
 import RIO
 import RIO.Process (HasProcessContext(..), ProcessContext)

src/Stackage/Snapshot/Diff.hs

@@ -22,7 +22,7 @@ import Data.These
 import RIO
 import Stackage.Database (GetStackageDatabase, SnapshotId,
                           getPackagesForSnapshot)
-import Stackage.Database.Types (PackageListingInfo(..), SnapName)
+import Stackage.Database.Types (PackageListingInfo(..))
 import Types
 import Web.PathPieces
 

src/Types.hs

@@ -49,7 +49,6 @@ module Types
     ) where
 
 import ClassyPrelude.Yesod (ToBuilder(..))
-import Control.Monad.Catch (MonadThrow, throwM)
 import Data.Aeson
 import Data.Bifunctor (bimap)
 import Data.Char (ord)
@@ -62,16 +61,16 @@ import Database.Persist
 import Database.Persist.Sql (PersistFieldSql(sqlType))
 import qualified Distribution.ModuleName as DT (components, fromComponents,
                                                 validModuleComponent)
-import Distribution.PackageDescription (FlagName, GenericPackageDescription)
+import Distribution.PackageDescription (GenericPackageDescription)
-import qualified Distribution.Text as DT (Text, display, simpleParse)
+import Distribution.Parsec as DT (Parsec)
+import Distribution.Pretty as DT (Pretty)
+import qualified Distribution.Text as DT (display, simpleParse)
 import Distribution.Types.VersionRange (VersionRange)
 import Distribution.Version (mkVersion, versionNumbers)
-import Pantry (Revision(..))
+import Pantry (FlagName, Revision(..), packageNameString, parsePackageName,
+               parseVersionThrowing, parseVersion, versionString)
 import Pantry.Internal.Stackage (ModuleNameP(..), PackageNameP(..),
-                                 SafeFilePath, VersionP(..), packageNameString,
+                                 SafeFilePath, VersionP(..), unSafeFilePath)
-                                 parsePackageName, parseVersion,
-                                 parseVersionThrowing, unSafeFilePath,
-                                 versionString)
 import RIO
 import qualified RIO.Map as Map
 import RIO.Time (Day)
@@ -84,14 +83,14 @@ instance Exception ParseFailedException where
     displayException (ParseFailedException tyRep origString) =
         "Was unable to parse " ++ showsTypeRep tyRep ": " ++ origString
 
-dtParse :: forall a m. (Typeable a, DT.Text a, MonadThrow m) => Text -> m a
+dtParse :: forall a m. (Typeable a, DT.Parsec a, MonadThrow m) => Text -> m a
 dtParse txt =
     let str = T.unpack txt
      in case DT.simpleParse str of
             Nothing -> throwM $ ParseFailedException (typeRep (Proxy :: Proxy a)) str
             Just dt -> pure dt
 
-dtDisplay :: (DT.Text a, IsString b) => a -> b
+dtDisplay :: (DT.Pretty a, IsString b) => a -> b
 dtDisplay = fromString . DT.display
 
 

stack.yaml

@@ -1,10 +1,17 @@
-resolver: lts-13.16
+resolver: nightly-2020-02-08
 packages:
   - '.'
 extra-deps:
-- git: https://github.com/commercialhaskell/stack
+- barrier-0.1.1@sha256:2021f84c3aba67bb635d72825d3bc0371942444dc014bc307b875071e29eea98,3931
-  commit: dfbf85ad7e8af5b01cf7b51367290870ffc2c90e
+- hackage-security-0.6.0.0@sha256:69987d46e7b55fe5f0fc537021c3873c5f6f44a6665d349ee6995fd593df8147,11976
+- hoogle-5.0.17.14@sha256:a35eab4f833cd131f1abc79360e3bdbc5aecd7526b9a530ac606580e18691e2b,3173
+- hpack-0.33.0@sha256:ca82f630abe0fba199aa05dcc9942ee8bf137e1425049a7a9ac8458c82d9dcc9,4406
+- yesod-gitrepo-0.3.0@sha256:7aad996935065726ce615c395d735cc01dcef3993b1788f670f6bfc866085e02,1191
+- lukko-0.1.1.1@sha256:5c674bdd8a06b926ba55d872abe254155ed49a58df202b4d842b643e5ed6bcc9,4289
+- github: commercialhaskell/pantry
+  commit: ed48bebc30e539280ad7e13680480be2b87b97ea
+- github: fpco/casa
+  commit: fc0ed26858bfc4f2966ed2dfb2871bae9266dda6
   subdirs:
-  - subs/http-download
+     - casa-client
-  - subs/pantry
+     - casa-types
-  - subs/rio-prettyprint