Integration with Pantry and usage of new stackage-snapshots:

* Moved all extensions into modules that are using them, rather than globally,
  since they mess up ghci session and introduce conflicts among
  packages. Removed those from `.ghci` file as well
* Redesigned the schema to use Pantry and moved it into it's own module
* Switched all of the db and cron related stuff to RIO. Yesod part is
  still on classy-prelude
* Got pantry to update stackage-server database from hackage
* Got import of stackage-snapshots implemented
* Moved some logic from all-cabal-tool
* Switched everything to `PackageNameP`, `VersionP`, etc. from a la Text.
* Fixed haddock, so it now does proper redirects and pipes the docs
  correctly. Also implemented piping of json files from S3 bucket,
  so index-doc.json is also served by stackage-server thus making
  Ctrl+S feature work properly on haddock. Fix for commercialhaskell/stackage#4301
* Import of modules is done through cabal file parsing, which slows
  down the initial import process drastically, but incremental update
  is not a problem.
* Just as with modules, dependencies are also imported from cabal file.
* In general improved type safety by introducing a few data types:
  eg. `ModuleNameP`, `HackageCabalInfo`, and many more.
* Implemented pulling of deprecation map from hackages and storing it in db
* Implementation of forward/backward dependencies within a snapshot only.
* Drastically improved performance of cron import job, by checking which
  snapshots are not up to date
* Implemented pulling haddock list from S3 bucket. Modules that have
  documentation are marked from the availability of actual haddock. This
  process happens concurrently with snapshots loading.
* Rearranged modules a bit:
  * github related functions went into it's own module
  * cron related functions where moved from Database to Cron module
  * Split up some functions to reduce individual complexity
* Parallelized package loading in cron job
* Implemented parsed cabal file caching.
* All queries where reqritten with esqueleto
* Syntactic improvements:
  * Added stylish-haskell config
  * Formatted all imports and extensions with stylish-haskell.
  * Fixed inconsistent indentation across all modules
* Many improvements to the package page as well as few others.
* Reimplemented hoogledb creation.
* Dropped dependency on tar in favor of tar-conduit
* Added cli for stackage-server-cron
* Add cabal sha and size to the package page
* Fixed links in hoogle searches. Improved type safety for a hoogle handler
* satckage-server-cron is customizable with cli arguments

Final adjustments for the new stackage server release:

* Upgrade to lts-13.16.
* Stackage server related code has been merged to pantry. Made the code
  compatible with the newer version pantry
* Added cli '--snapshots-repo'
* Add readme to package page
* Adjust snapshots expected format:
  * Added `publish-time`
  * Removed name `field`
  * `compiler` field is now in the `resolver` field with fallback to
    the root

.dir-locals.el

@@ -1,6 +1,6 @@
 ((haskell-mode . ((haskell-indent-spaces . 4)
-                  (hindent-style . "johan-tibell")
-                  (haskell-process-type . cabal-repl)
+                  ;;(hindent-style . "johan-tibell")
+                  ;;(haskell-process-type . cabal-repl)
                   (haskell-process-use-ghci . t)))
  (hamlet-mode . ((hamlet/basic-offset . 4)
                  (haskell-process-use-ghci . t)))

.ghci

@@ -1,6 +1,6 @@
 :set -fobject-code
 :set -i.:config:dist/build/autogen
-:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XDeriveDataTypeable -XRankNTypes -XNoImplicitPrelude -XFunctionalDependencies -XFlexibleInstances -XTemplateHaskell -XQuasiQuotes -XOverloadedStrings -XNoImplicitPrelude -XCPP -XMultiParamTypeClasses -XTypeFamilies -XGADTs -XGeneralizedNewtypeDeriving -XFlexibleContexts -XEmptyDataDecls -XNoMonomorphismRestriction -XDeriveDataTypeable -XViewPatterns -XTypeSynonymInstances -XFlexibleInstances -XRankNTypes -XFunctionalDependencies -XPatternGuards -XStandaloneDeriving -XUndecidableInstances -XBangPatterns -XScopedTypeVariables
+:set -XOverloadedStrings
 :set -DDEVELOPMENT=1
 :set -DINGHCI=1
 :set -package foreign-store

.gitignore

@@ -21,3 +21,5 @@ TAGS
 *~
 *#
 /stackage-server.cabal
+/hoogle/
+/hoogle-gen/

.hindent.yaml

@@ -0,0 +1,3 @@
+indent-size: 4
+line-length: 100
+force-trailing-newline: true

.stylish-haskell.yaml

@@ -0,0 +1,229 @@
+# stylish-haskell configuration file
+# ==================================
+
+# The stylish-haskell tool is mainly configured by specifying steps. These steps
+# are a list, so they have an order, and one specific step may appear more than
+# once (if needed). Each file is processed by these steps in the given order.
+steps:
+  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
+  # by default.
+  # - unicode_syntax:
+  #     # In order to make this work, we also need to insert the UnicodeSyntax
+  #     # language pragma. If this flag is set to true, we insert it when it's
+  #     # not already present. You may want to disable it if you configure
+  #     # language extensions using some other method than pragmas. Default:
+  #     # true.
+  #     add_language_pragma: true
+
+  # Align the right hand side of some elements.  This is quite conservative
+  # and only applies to statements where each element occupies a single
+  # line.
+  - simple_align:
+      cases: true
+      top_level_patterns: true
+      records: true
+
+  # Import cleanup
+  - imports:
+      # There are different ways we can align names and lists.
+      #
+      # - global: Align the import names and import list throughout the entire
+      #   file.
+      #
+      # - file: Like global, but don't add padding when there are no qualified
+      #   imports in the file.
+      #
+      # - group: Only align the imports per group (a group is formed by adjacent
+      #   import lines).
+      #
+      # - none: Do not perform any alignment.
+      #
+      # Default: global.
+      align: none
+
+      # The following options affect only import list alignment.
+      #
+      # List align has following options:
+      #
+      # - after_alias: Import list is aligned with end of import including
+      #   'as' and 'hiding' keywords.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #   >                                          init, last, length)
+      #
+      # - with_alias: Import list is aligned with start of alias or hiding.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #   >                                 init, last, length)
+      #
+      # - new_line: Import list starts always on new line.
+      #
+      #   > import qualified Data.List      as List
+      #   >     (concat, foldl, foldr, head, init, last, length)
+      #
+      # Default: after_alias
+      list_align: after_alias
+
+      # Right-pad the module names to align imports in a group:
+      #
+      # - true: a little more readable
+      #
+      #   > import qualified Data.List       as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #
+      # - false: diff-safe
+      #
+      #   > import qualified Data.List as List (concat, foldl, foldr, init,
+      #   >                                     last, length)
+      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #
+      # Default: true
+      pad_module_names: true
+
+      # Long list align style takes effect when import is too long. This is
+      # determined by 'columns' setting.
+      #
+      # - inline: This option will put as much specs on same line as possible.
+      #
+      # - new_line: Import list will start on new line.
+      #
+      # - new_line_multiline: Import list will start on new line when it's
+      #   short enough to fit to single line. Otherwise it'll be multiline.
+      #
+      # - multiline: One line per import list entry.
+      #   Type with constructor list acts like single import.
+      #
+      #   > import qualified Data.Map as M
+      #   >     ( empty
+      #   >     , singleton
+      #   >     , ...
+      #   >     , delete
+      #   >     )
+      #
+      # Default: inline
+      long_list_align: inline
+
+      # Align empty list (importing instances)
+      #
+      # Empty list align has following options
+      #
+      # - inherit: inherit list_align setting
+      #
+      # - right_after: () is right after the module name:
+      #
+      #   > import Vector.Instances ()
+      #
+      # Default: inherit
+      empty_list_align: right_after
+
+      # List padding determines indentation of import list on lines after import.
+      # This option affects 'long_list_align'.
+      #
+      # - <integer>: constant value
+      #
+      # - module_name: align under start of module name.
+      #   Useful for 'file' and 'group' align settings.
+      list_padding: 4
+
+      # Separate lists option affects formatting of import list for type
+      # or class. The only difference is single space between type and list
+      # of constructors, selectors and class functions.
+      #
+      # - true: There is single space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
+      #
+      # - false: There is no space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
+      #
+      # Default: true
+      separate_lists: false
+
+      # Space surround option affects formatting of import lists on a single
+      # line. The only difference is single space after the initial
+      # parenthesis and a single space before the terminal parenthesis.
+      #
+      # - true: There is single space associated with the enclosing
+      #   parenthesis.
+      #
+      #   > import Data.Foo ( foo )
+      #
+      # - false: There is no space associated with the enclosing parenthesis
+      #
+      #   > import Data.Foo (foo)
+      #
+      # Default: false
+      space_surround: false
+
+  # Language pragmas
+  - language_pragmas:
+      # We can generate different styles of language pragma lists.
+      #
+      # - vertical: Vertical-spaced language pragmas, one per line.
+      #
+      # - compact: A more compact style.
+      #
+      # - compact_line: Similar to compact, but wrap each line with
+      #   `{-#LANGUAGE #-}'.
+      #
+      # Default: vertical.
+      style: vertical
+
+      # Align affects alignment of closing pragma brackets.
+      #
+      # - true: Brackets are aligned in same column.
+      #
+      # - false: Brackets are not aligned together. There is only one space
+      #   between actual import and closing bracket.
+      #
+      # Default: true
+      align: false
+
+      # stylish-haskell can detect redundancy of some language pragmas. If this
+      # is set to true, it will remove those redundant pragmas. Default: true.
+      remove_redundant: false
+
+  # Replace tabs by spaces. This is disabled by default.
+  # - tabs:
+  #     # Number of spaces to use for each tab. Default: 8, as specified by the
+  #     # Haskell report.
+  #     spaces: 8
+
+  # Remove trailing whitespace
+  - trailing_whitespace: {}
+
+  # Squash multiple spaces between the left and right hand sides of some
+  # elements into single spaces. Basically, this undoes the effect of
+  # simple_align but is a bit less conservative.
+  # - squash: {}
+
+# A common setting is the number of columns (parts of) code will be wrapped
+# to. Different steps take this into account. Default: 80.
+columns: 80
+
+# By default, line endings are converted according to the OS. You can override
+# preferred format here.
+#
+# - native: Native newline format. CRLF on Windows, LF on other OSes.
+#
+# - lf: Convert to LF ("\n").
+#
+# - crlf: Convert to CRLF ("\r\n").
+#
+# Default: native.
+newline: native
+
+# Sometimes, language extensions are specified in a cabal file or from the
+# command line instead of using language pragmas in the file. stylish-haskell
+# needs to be aware of these, so it can parse the file correctly.
+#
+# No language extensions are enabled by default.
+# language_extensions:
+  # - TemplateHaskell
+  # - QuasiQuotes

app/DevelMain.hs

@@ -9,33 +9,41 @@
 
 module DevelMain where
 
-import Application (getApplicationDev)
+import Application (App, withFoundationDev, makeApplication)
 
 import Control.Concurrent
-import Data.IORef
 import Foreign.Store
 import Network.Wai.Handler.Warp
 import Yesod
+import Data.IORef
+
+
+data Command = Run (IO ())
+             | Stop
+
+newtype Devel = Devel (Store (IORef (App -> IO Application)))
 
 -- | Start the web server.
-main :: IO (Store (IORef Application))
-main =
-  do c <- newChan
-     (settings,app) <- getApplicationDev
-     ref <- newIORef app
-     tid <- forkIO
-              (runSettings
-                 settings
-                 (\req cont ->
-                    do handler <- readIORef ref
-                       handler req cont))
-     _ <- newStore tid
-     ref' <- newStore ref
-     _ <- newStore c
-     return ref'
+main :: IO Devel
+main = do
+    c <- newChan
+    ref <- newIORef makeApplication
+    tid <-
+        forkIO $
+        withFoundationDev $ \settings foundation ->
+            runSettings
+                settings
+                (\req cont -> do
+                     mkApp <- readIORef ref
+                     application <- mkApp foundation
+                     application req cont)
+    _ <- newStore tid
+    ref' <- newStore ref
+    _ <- newStore c
+    return $ Devel ref'
 
 -- | Update the server, start it if not running.
-update :: IO (Store (IORef Application))
+update :: IO Devel
 update =
   do m <- lookupStore 1
      case m of
@@ -44,6 +52,5 @@ update =
          do ref <- readStore store
             c <- readStore (Store 2)
             writeChan c ()
-            (_,app) <- getApplicationDev
-            writeIORef ref app
-            return store
+            writeIORef ref makeApplication
+            return $ Devel store

app/stackage-server-cron.hs

@@ -1,9 +1,85 @@
-import Prelude
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+import Options.Applicative
+import RIO
+import RIO.List as L
+import RIO.Text as T
 import Stackage.Database.Cron
-import System.IO
+import Stackage.Database.Github
+
+readText :: ReadM T.Text
+readText = T.pack <$> str
+
+readLogLevel :: ReadM LogLevel
+readLogLevel =
+    maybeReader $ \case
+        "debug" -> Just LevelDebug
+        "info" -> Just LevelInfo
+        "warn" -> Just LevelWarn
+        "error" -> Just LevelError
+        _ -> Nothing
+
+readGithubRepo :: ReadM GithubRepo
+readGithubRepo =
+    maybeReader $ \str' ->
+        case L.span (/= '/') str' of
+            (grAccount, '/':grName)
+                | not (L.null grName) -> Just GithubRepo {..}
+            _ -> Nothing
+
+optsParser :: Parser StackageCronOptions
+optsParser =
+    StackageCronOptions <$>
+    switch
+        (long "force-update" <> short 'f' <>
+         help
+             "Initiate a force update, where all snapshots will be updated regardless if \
+             \their yaml files from stackage-snapshots repo have been updated or not.") <*>
+    option
+        readText
+        (long "download-bucket" <> value haddockBucketName <> metavar "DOWNLOAD_BUCKET" <>
+         help
+             ("S3 Bucket name where things like haddock and current hoogle files should \
+              \be downloaded from. Default is: " <>
+              T.unpack haddockBucketName)) <*>
+    option
+        readText
+        (long "upload-bucket" <> value haddockBucketName <> metavar "UPLOAD_BUCKET" <>
+         help
+             ("S3 Bucket where hoogle db and snapshots.json file will be uploaded to. Default is: " <>
+              T.unpack haddockBucketName)) <*>
+    switch
+        (long "do-not-upload" <>
+         help "Stop from hoogle db and snapshots.json from being generated and uploaded") <*>
+    option
+        readLogLevel
+        (long "log-level" <> metavar "LOG_LEVEL" <> short 'l' <> value LevelInfo <>
+         help "Verbosity level (debug|info|warn|error). Default level is 'info'.") <*>
+    option
+        readGithubRepo
+        (long "snapshots-repo" <> metavar "SNAPSHOTS_REPO" <>
+         value (GithubRepo repoAccount repoName) <>
+         help
+             ("Github repository with snapshot files. Default level is '" ++
+              repoAccount ++ "/" ++ repoName ++ "'."))
+  where
+    repoAccount = "commercialhaskell"
+    repoName = "stackage-snapshots"
 
 main :: IO ()
 main = do
     hSetBuffering stdout LineBuffering
     hSetBuffering stderr LineBuffering
-    stackageServerCron
+    opts <-
+        execParser $
+        info
+            (optsParser <*
+             abortOption ShowHelpText (long "help" <> short 'h' <> help "Display this message."))
+            (header "stackage-cron - Keep stackage.org up to date" <>
+             progDesc
+                 "Uses github.com/commercialhaskell/stackage-snapshots repository as a source \
+                 \for keeping stackage.org up to date. Amongst other things are: update of hoogle db\
+                 \and it's upload to S3 bucket, use stackage-content for global-hints" <>
+             fullDesc)
+    stackageServerCron opts

config/routes

@@ -31,12 +31,12 @@
 /system SystemR GET
 /haddock/#SnapName/*Texts HaddockR GET
 !/haddock/*Texts HaddockBackupR GET
-/package/#PackageName PackageR GET
-/package/#PackageName/snapshots PackageSnapshotsR GET
-/package/#PackageName/badge/#SnapshotBranch PackageBadgeR GET
+/package/#PackageNameP PackageR GET
+/package/#PackageNameP/snapshots PackageSnapshotsR GET
+/package/#PackageNameP/badge/#SnapshotBranch PackageBadgeR GET
 /package PackageListR GET
-/package/#PackageName/deps PackageDepsR GET
-/package/#PackageName/revdeps PackageRevDepsR GET
+/package/#PackageNameP/deps PackageDepsR GET
+/package/#PackageNameP/revdeps PackageRevDepsR GET
 
 /authors AuthorsR GET
 /install InstallR GET

config/settings.yml

@@ -19,7 +19,7 @@ approot:        "_env:APPROOT:"
 # reload-templates: false
 # mutable-static: false
 # skip-combining: false
-# force-ssl: true
+force-ssl: false
 # dev-download: false
 
 postgres-string: "_env:PGSTRING:host=localhost port=5432 user=stackage dbname=stackage password=stackage"

package.yaml

@@ -21,13 +21,11 @@ dependencies:
 - classy-prelude-yesod
 - conduit
 - conduit-extra
-- cryptonite
 - directory
 - email-validate
 - esqueleto
 - exceptions
 - fast-logger
-- foreign-store
 - ghc-prim
 - html-conduit
 - http-conduit
@@ -35,14 +33,17 @@ dependencies:
 - mtl
 #- prometheus-client
 #- prometheus-metrics-ghc
+- pantry
+- path
 - persistent
 - persistent-template
 - resourcet
+- rio
 - shakespeare
-- tar
+- tar-conduit
 - template-haskell
-- temporary
 - text
+- transformers
 - these
 - unliftio
 - wai
@@ -63,7 +64,6 @@ dependencies:
 - hashable
 - Cabal
 - mono-traversable
-- time
 - process
 - cmark-gfm
 - formatting
@@ -89,39 +89,9 @@ dependencies:
 - file-embed
 - resource-pool
 - containers
-- pretty
 
 default-extensions:
-- TemplateHaskell
-- QuasiQuotes
 - OverloadedStrings
-- NoImplicitPrelude
-- CPP
-- MultiParamTypeClasses
-- TypeFamilies
-- GADTs
-- GeneralizedNewtypeDeriving
-- FlexibleContexts
-- EmptyDataDecls
-- NoMonomorphismRestriction
-- DeriveDataTypeable
-- ViewPatterns
-- TypeSynonymInstances
-- FlexibleInstances
-- RankNTypes
-- FunctionalDependencies
-- PatternGuards
-- StandaloneDeriving
-- UndecidableInstances
-- RecordWildCards
-- ScopedTypeVariables
-- BangPatterns
-- TupleSections
-- DeriveGeneric
-- DeriveFunctor
-- DeriveFoldable
-- DeriveTraversable
-- LambdaCase
 
 library:
   source-dirs: src
@@ -141,24 +111,33 @@ executables:
   stackage-server:
     main: main.hs
     source-dirs: app
-    ghc-options: -threaded -O2 -rtsopts "-with-rtsopts=-N -T"
+    ghc-options: -Wall -threaded -O2 -rtsopts "-with-rtsopts=-N -T"
     dependencies:
     - stackage-server
     when:
     - condition: flag(library-only)
       buildable: false
     - condition: flag(dev)
-      cpp-options: -DDEVELOPMENT
+      then:
+        other-modules: DevelMain
+        dependencies:
+          - foreign-store
+      else:
+        other-modules: []
 
   stackage-server-cron:
     main: stackage-server-cron.hs
     source-dirs: app
+    other-modules: []
     ghc-options:
+    - -Wall
     - -threaded
     - -O2
     - -rtsopts
     - -with-rtsopts=-N
     dependencies:
+    - optparse-applicative
+    - rio
     - stackage-server
     when:
     - condition: flag(library-only)

src/Application.hs

@@ -1,70 +1,79 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE CPP#-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE BlockArguments #-}
+
 module Application
-    ( getApplicationDev
+    ( App
+    , withApplicationDev
+    , withFoundationDev
+    , makeApplication
     , appMain
     , develMain
-    , makeFoundation
+    , withFoundation
     , makeLogWare
     -- * for DevelMain
-    , getApplicationRepl
-    , shutdownApp
+    , withApplicationRepl
     -- * for GHCI
     , handler
     ) where
 
-import Control.Monad.Logger                 (liftLoc)
-import Language.Haskell.TH.Syntax           (qLocation)
-import           Control.Concurrent (forkIO)
-import           Data.WebsiteContent
-import           Import hiding (catch)
-import           Network.Wai (Middleware, rawPathInfo)
-import Network.Wai.Handler.Warp             (Settings, defaultSettings,
-                                             defaultShouldDisplayException,
-                                             runSettings, setHost,
-                                             setOnException, setPort, getPort)
-import           Network.Wai.Middleware.ForceSSL (forceSSL)
-import           Network.Wai.Middleware.RequestLogger
-    ( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
-    , Destination (Logger)
-    )
-import           System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, toLogStr)
-import           Yesod.Core.Types (loggerSet)
-import           Yesod.Default.Config2
-import           Yesod.Default.Handlers
-import           Yesod.GitRepo
-import           System.Process (rawSystem)
-import           Stackage.Database (openStackageDatabase, PostgresConf (..))
-import           Stackage.Database.Cron (newHoogleLocker, singleRun)
-import           Control.AutoUpdate
-import           Control.Concurrent (threadDelay)
-import           Yesod.GitRev (tGitRev)
+import Control.AutoUpdate
+import Control.Concurrent (threadDelay)
+import Control.Monad.Logger (liftLoc)
+import Data.WebsiteContent
+import Database.Persist.Postgresql (PostgresConf(..))
+import Import hiding (catch)
+import Language.Haskell.TH.Syntax (qLocation)
+import Network.Wai (Middleware, rawPathInfo)
+import Network.Wai.Handler.Warp (Settings, defaultSettings,
+                                 defaultShouldDisplayException, getPort,
+                                 runSettings, setHost, setOnException, setPort)
+import Network.Wai.Middleware.ForceSSL (forceSSL)
+import Network.Wai.Middleware.RequestLogger (Destination(Logger),
+                                             IPAddrSource(..), OutputFormat(..),
+                                             destination, mkRequestLogger,
+                                             outputFormat)
+import RIO (LogFunc, LogOptions, logOptionsHandle, withLogFunc, runRIO, logError)
+import RIO.Prelude.Simple (runSimpleApp)
+import Stackage.Database (withStackageDatabase)
+import Stackage.Database.Cron (newHoogleLocker, singleRun)
+import Stackage.Database.Github (getStackageContentDir)
+import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
+import Yesod.Core.Types (loggerSet)
+import Yesod.Default.Config2
+import Yesod.Default.Handlers
+import Yesod.GitRepo
+import Yesod.GitRev (tGitRev)
 
 -- Import all relevant handler modules here.
--- Don't forget to add new modules to your cabal file!
-import           Handler.Home
-import           Handler.Snapshots
-import           Handler.StackageHome
-import           Handler.StackageIndex
-import           Handler.StackageSdist
-import           Handler.System
-import           Handler.Haddock
-import           Handler.Package
-import           Handler.PackageDeps
-import           Handler.PackageList
-import           Handler.Hoogle
-import           Handler.Sitemap
-import           Handler.BuildPlan
-import           Handler.Download
-import           Handler.OldLinks
-import           Handler.Feed
-import           Handler.DownloadStack
-import           Handler.MirrorStatus
-import           Handler.Blog
+import Handler.Blog
+import Handler.BuildPlan
+import Handler.Download
+import Handler.DownloadStack
+import Handler.Feed
+import Handler.Haddock
+import Handler.Home
+import Handler.Hoogle
+import Handler.MirrorStatus
+import Handler.OldLinks
+import Handler.Package
+import Handler.PackageDeps
+import Handler.PackageList
+import Handler.Sitemap
+import Handler.Snapshots
+import Handler.StackageHome
+import Handler.StackageIndex
+import Handler.StackageSdist
+import Handler.System
 
---import           Network.Wai.Middleware.Prometheus (prometheus)
---import           Prometheus (register)
---import           Prometheus.Metric.GHC (ghcMetrics)
+--import Network.Wai.Middleware.Prometheus (prometheus)
+--import Prometheus (register)
+--import Prometheus.Metric.GHC (ghcMetrics)
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -104,52 +113,52 @@ forceSSL' settings app
 
 -- | Loads up any necessary settings, creates your foundation datatype, and
 -- performs some initialization.
-makeFoundation :: AppSettings -> IO App
-makeFoundation appSettings = do
-    -- Some basic initializations: HTTP connection manager, logger, and static
-    -- subsite.
+--
+-- Some basic initializations: HTTP connection manager, logger, and static
+-- subsite.
+withFoundation :: LogFunc -> AppSettings -> (App -> IO a) -> IO a
+withFoundation appLogFunc appSettings inner = do
     appHttpManager <- newManager
     appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
     appStatic <-
-        (if appMutableStatic appSettings then staticDevel else static)
-        (appStaticDir appSettings)
+        (if appMutableStatic appSettings
+             then staticDevel
+             else static)
+            (appStaticDir appSettings)
+    appWebsiteContent <-
+        if appDevDownload appSettings
+            then do
+                fp <- runSimpleApp $ getStackageContentDir "."
+                gitRepoDev fp loadWebsiteContent
+            else gitRepo "https://github.com/fpco/stackage-content.git" "master" loadWebsiteContent
+    let pgConf =
+            PostgresConf {pgPoolSize = 2, pgConnStr = encodeUtf8 $ appPostgresString appSettings}
+        -- Temporary workaround to force content updates regularly, until
+        -- distribution of webhooks is handled via consul
+        runContentUpdates =
+            Concurrently $
+            forever $
+            void $ do
+                threadDelay $ 1000 * 1000 * 60 * 5
+                handleAny (runRIO appLogFunc . RIO.logError . fromString . displayException) $
+                    grRefresh appWebsiteContent
+    withStackageDatabase (appShouldLogAll appSettings) pgConf $ \appStackageDatabase -> do
+        appLatestStackMatcher <-
+            mkAutoUpdate
+                defaultUpdateSettings
+                    { updateFreq = 1000 * 1000 * 60 * 30 -- update every thirty minutes
+                    , updateAction = getLatestMatcher appHttpManager
+                    }
+        appHoogleLock <- newMVar ()
+        appMirrorStatus <- mkUpdateMirrorStatus
+        hoogleLocker <- newHoogleLocker appLogFunc appHttpManager
+        let appGetHoogleDB = singleRun hoogleLocker
+        let appGitRev = $$tGitRev
+        runConcurrently $ runContentUpdates *> Concurrently (inner App {..})
 
-    appWebsiteContent <- if appDevDownload appSettings
-        then do
-            void $ rawSystem "git"
-                [ "clone"
-                , "https://github.com/fpco/stackage-content.git"
-                ]
-            gitRepoDev "stackage-content" loadWebsiteContent
-        else gitRepo
-            "https://github.com/fpco/stackage-content.git"
-            "master"
-            loadWebsiteContent
+getLogOpts :: AppSettings -> IO LogOptions
+getLogOpts settings = logOptionsHandle stdout (appShouldLogAll settings)
 
-    appStackageDatabase <- openStackageDatabase PostgresConf
-      { pgPoolSize = 2
-      , pgConnStr = encodeUtf8 $ appPostgresString appSettings
-      }
-
-    -- Temporary workaround to force content updates regularly, until
-    -- distribution of webhooks is handled via consul
-    void $ forkIO $ forever $ void $ do
-        threadDelay $ 1000 * 1000 * 60 * 5
-        handleAny print $ grRefresh appWebsiteContent
-
-    appLatestStackMatcher <- mkAutoUpdate defaultUpdateSettings
-        { updateFreq = 1000 * 1000 * 60 * 30 -- update every thirty minutes
-        , updateAction = getLatestMatcher appHttpManager
-        }
-
-    appHoogleLock <- newMVar ()
-
-    appMirrorStatus <- mkUpdateMirrorStatus
-    hoogleLocker <- newHoogleLocker True appHttpManager
-    let appGetHoogleDB = singleRun hoogleLocker
-    let appGitRev = $$tGitRev
-
-    return App {..}
 
 makeLogWare :: App -> IO Middleware
 makeLogWare foundation =
@@ -180,21 +189,26 @@ warpSettings foundation =
             (toLogStr $ "Exception from Warp: " ++ show e))
       defaultSettings
 
--- | For yesod devel, return the Warp settings and WAI Application.
-getApplicationDev :: IO (Settings, Application)
-getApplicationDev = do
-    settings <- getAppSettings
-    foundation <- makeFoundation settings
-    wsettings <- getDevSettings $ warpSettings foundation
-    app <- makeApplication foundation
-    return (wsettings, app)
+-- | For yesod devel, apply an action to Warp settings, RIO's LogFunc and Foundation.
+withFoundationDev :: (Settings -> App -> IO a) -> IO a
+withFoundationDev inner = do
+    appSettings <- getAppSettings
+    logOpts <- getLogOpts appSettings
+    withLogFunc logOpts $ \logFunc ->
+        withFoundation logFunc appSettings $ \foundation -> do
+            settings <- getDevSettings $ warpSettings foundation
+            inner settings foundation
 
-getAppSettings :: IO AppSettings
-getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
+
+withApplicationDev :: (Settings -> Application -> IO a) -> IO a
+withApplicationDev inner =
+    withFoundationDev $ \ settings foundation -> do
+        application <- makeApplication foundation
+        inner settings application
 
 -- | main function for use by yesod devel
 develMain :: IO ()
-develMain = develMainHelper getApplicationDev
+develMain = withApplicationDev $ \settings app -> develMainHelper (pure (settings, app))
 
 -- | The @main@ function for an executable running this site.
 appMain :: IO ()
@@ -206,30 +220,30 @@ appMain = do
 
         -- allow environment variables to override
         useEnv
+    logOpts <- getLogOpts settings
+    withLogFunc logOpts $ \ logFunc -> do
+        -- Generate the foundation from the settings
+        withFoundation logFunc settings $ \ foundation -> do
 
-    -- Generate the foundation from the settings
-    foundation <- makeFoundation settings
+            -- Generate a WAI Application from the foundation
+            app <- makeApplication foundation
 
-    -- Generate a WAI Application from the foundation
-    app <- makeApplication foundation
-
-    -- Run the application with Warp
-    runSettings (warpSettings foundation) app
+            -- Run the application with Warp
+            runSettings (warpSettings foundation) app
 
 
 --------------------------------------------------------------
 -- Functions for DevelMain.hs (a way to run the app from GHCi)
 --------------------------------------------------------------
-getApplicationRepl :: IO (Int, App, Application)
-getApplicationRepl = do
+withApplicationRepl :: (Int -> App -> Application -> IO ()) -> IO ()
+withApplicationRepl inner = do
     settings <- getAppSettings
-    foundation <- makeFoundation settings
-    wsettings <- getDevSettings $ warpSettings foundation
-    app1 <- makeApplication foundation
-    return (getPort wsettings, foundation, app1)
-
-shutdownApp :: App -> IO ()
-shutdownApp _ = return ()
+    logOpts <- getLogOpts settings
+    withLogFunc logOpts $ \ logFunc ->
+        withFoundation logFunc settings $ \foundation -> do
+            wsettings <- getDevSettings $ warpSettings foundation
+            app1 <- makeApplication foundation
+            inner (getPort wsettings) foundation app1
 
 
 ---------------------------------------------
@@ -238,4 +252,8 @@ shutdownApp _ = return ()
 
 -- | Run a handler
 handler :: Handler a -> IO a
-handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
+handler h = do
+    logOpts <- logOptionsHandle stdout True
+    withLogFunc logOpts $ \ logFunc -> do
+        settings <- getAppSettings
+        withFoundation logFunc settings (`unsafeHandler` h)

src/Control/SingleRun.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 -- | Ensure that a function is only being run on a given input in one
 -- thread at a time. All threads trying to make the call at once
 -- return the same result.
@@ -7,10 +9,7 @@ module Control.SingleRun
     , singleRun
     ) where
 
-import Control.Concurrent.MVar
-import Control.Exception
-import Control.Monad (join)
-import Prelude
+import RIO
 
 -- | Captures all of the locking machinery and the function which is
 -- run to generate results. Use 'mkSingleRun' to create this value.
@@ -20,13 +19,13 @@ data SingleRun k v = SingleRun
     -- computations. More ideal would be to use a Map, but we're
     -- avoiding dependencies outside of base in case this moves into
     -- auto-update.
-    , srFunc :: k -> IO v
+    , srFunc :: forall m . MonadIO m => k -> m v
     }
 
 -- | Create a 'SingleRun' value out of a function.
-mkSingleRun :: Eq k
-            => (k -> IO v)
-            -> IO (SingleRun k v)
+mkSingleRun :: MonadIO m => Eq k
+            => (forall n . MonadIO n => k -> n v)
+            -> m (SingleRun k v)
 mkSingleRun f = do
     var <- newMVar []
     return SingleRun
@@ -52,7 +51,7 @@ toRes se =
 -- exception, we will rethrow that same synchronous exception. If,
 -- however, that other thread dies from an asynchronous exception, we
 -- will retry.
-singleRun :: Eq k => SingleRun k v -> k -> IO v
+singleRun :: (MonadUnliftIO m, Eq k) => SingleRun k v -> k -> m v
 singleRun sr@(SingleRun var f) k =
     -- Mask all exceptions so that we don't get killed between exiting
     -- the modifyMVar and entering the join, which could leave an

src/Data/GhcLinks.hs

@@ -1,13 +1,19 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Data.GhcLinks
   ( GhcLinks(..)
   , readGhcLinks
   ) where
 
-import ClassyPrelude.Yesod
-import Control.Monad.State.Strict (modify, execStateT)
+import Control.Monad.State.Strict (execStateT, modify)
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Yaml as Yaml
+import RIO
+import RIO.FilePath
+import RIO.Text (unpack)
 import System.Directory
+import Web.PathPieces
 
 import Types
 
@@ -21,23 +27,18 @@ supportedArches = [minBound .. maxBound]
 
 readGhcLinks :: FilePath -> IO GhcLinks
 readGhcLinks dir = do
-  let ghcMajorVersionsPath = dir </> "supported-ghc-major-versions.yaml"
-  Yaml.decodeFileEither ghcMajorVersionsPath >>= \case
-    Left _ -> return $ GhcLinks HashMap.empty
-    Right (ghcMajorVersions :: [GhcMajorVersion]) -> do
-      let opts =
-            [ (arch, ver)
-            | arch <- supportedArches
-            , ver <- ghcMajorVersions
-            ]
-      hashMap <- flip execStateT HashMap.empty
-               $ forM_ opts $ \(arch, ver) -> do
-        let verText = ghcMajorVersionToText ver
-            fileName = "ghc-" <> verText <> "-links.yaml"
-            path = dir
-              </> unpack (toPathPiece arch)
-              </> unpack fileName
-        whenM (liftIO $ doesFileExist path) $ do
-          text <- liftIO $ readFileUtf8 path
-          modify (HashMap.insert (arch, ver) text)
-      return $ GhcLinks hashMap
+    let ghcMajorVersionsPath = dir </> "supported-ghc-major-versions.yaml"
+    Yaml.decodeFileEither ghcMajorVersionsPath >>= \case
+        Left _ -> return $ GhcLinks HashMap.empty
+        Right (ghcMajorVersions :: [GhcMajorVersion]) -> do
+            let opts = [(arch, ver) | arch <- supportedArches, ver <- ghcMajorVersions]
+            hashMap <-
+                flip execStateT HashMap.empty $
+                forM_ opts $ \(arch, ver) -> do
+                    let verText = textDisplay ver
+                        fileName = "ghc-" <> verText <> "-links.yaml"
+                        path = dir </> unpack (toPathPiece arch) </> unpack fileName
+                    whenM (liftIO $ doesFileExist path) $ do
+                        text <- liftIO $ readFileUtf8 path
+                        modify (HashMap.insert (arch, ver) text)
+            return $ GhcLinks hashMap

src/Data/WebsiteContent.hs

@@ -1,3 +1,7 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
 module Data.WebsiteContent
     ( WebsiteContent (..)
     , StackRelease (..)
@@ -7,31 +11,31 @@ module Data.WebsiteContent
 
 import ClassyPrelude.Yesod
 import CMarkGFM
-import Data.GhcLinks
 import Data.Aeson (withObject)
+import Data.GhcLinks
 import Data.Yaml
 import System.FilePath (takeFileName)
-import Types
 import Text.Blaze.Html (preEscapedToHtml)
+import Types
 
 data WebsiteContent = WebsiteContent
-    { wcHomepage :: !Html
-    , wcAuthors  :: !Html
+    { wcHomepage      :: !Html
+    , wcAuthors       :: !Html
     , wcOlderReleases :: !Html
-    , wcGhcLinks :: !GhcLinks
+    , wcGhcLinks      :: !GhcLinks
     , wcStackReleases :: ![StackRelease]
-    , wcPosts :: !(Vector Post)
-    , wcSpamPackages :: !(Set PackageName)
+    , wcPosts         :: !(Vector Post)
+    , wcSpamPackages  :: !(Set PackageNameP)
     -- ^ Packages considered spam which should not be displayed.
     }
 
 data Post = Post
-  { postTitle :: !Text
-  , postSlug :: !Text
-  , postAuthor :: !Text
-  , postTime :: !UTCTime
+  { postTitle       :: !Text
+  , postSlug        :: !Text
+  , postAuthor      :: !Text
+  , postTime        :: !UTCTime
   , postDescription :: !Text
-  , postBody :: !Html
+  , postBody        :: !Html
   }
 
 loadWebsiteContent :: FilePath -> IO WebsiteContent
@@ -47,7 +51,7 @@ loadWebsiteContent dir = do
       putStrLn $ "Error loading posts: " ++ tshow e
       return mempty
     wcSpamPackages <- decodeFileEither (dir </> "spam-packages.yaml")
-                  >>= either throwIO (return . setFromList . map PackageName)
+                  >>= either throwIO (return . setFromList)
     return WebsiteContent {..}
   where
     readHtml fp = fmap preEscapedToMarkup $ readFileUtf8 $ dir </> fp
@@ -93,7 +97,7 @@ instance (slug ~ Text, body ~ Html) => FromJSON (slug -> body -> Post) where
     return $ \postSlug postBody -> Post {..}
 
 data StackRelease = StackRelease
-    { srName :: !Text
+    { srName    :: !Text
     , srPattern :: !Text
     }
 instance FromJSON StackRelease where

src/Distribution/Package/ModuleForest.hs

@@ -1,5 +1,6 @@
 -- Adopted from https://github.com/haskell/hackage-server/blob/master/Distribution/Server/Packages/ModuleForest.hs
-
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ViewPatterns #-}
 module Distribution.Package.ModuleForest
     ( moduleName
     , moduleForest
@@ -8,9 +9,10 @@ module Distribution.Package.ModuleForest
     , NameComponent
     ) where
 
-import           Distribution.ModuleName (ModuleName)
+import Distribution.ModuleName (ModuleName)
 import qualified Distribution.ModuleName as ModuleName
-import           Import
+import RIO
+import RIO.Text (pack, unpack)
 
 type NameComponent = Text
 

src/Foundation.hs

@@ -1,38 +1,46 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 module Foundation where
 
-import           ClassyPrelude.Yesod
-import           Data.WebsiteContent
-import           Settings
-import           Settings.StaticFiles
-import           Text.Blaze
-import           Text.Hamlet (hamletFile)
-import           Types
-import           Yesod.Core.Types (Logger)
-import           Yesod.AtomFeed
-import           Yesod.GitRepo
+import ClassyPrelude.Yesod
+import Data.WebsiteContent
+import Settings
+import Settings.StaticFiles
 import Stackage.Database
+import Text.Blaze
+import Text.Hamlet (hamletFile)
+import Types
+import Yesod.AtomFeed
+import Yesod.Core.Types (Logger)
 import qualified Yesod.Core.Unsafe as Unsafe
-import           Yesod.GitRev (GitRev)
+import Yesod.GitRepo
+import Yesod.GitRev (GitRev)
+import qualified RIO
 
 -- | The site argument for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data App = App
-    { appSettings :: AppSettings
-    , appStatic :: Static -- ^ Settings for static file serving.
-    , appHttpManager :: Manager
-    , appLogger :: Logger
-    , appWebsiteContent :: GitRepo WebsiteContent
-    , appStackageDatabase :: StackageDatabase
-    , appLatestStackMatcher :: IO (Text -> Maybe Text)
+    { appSettings           :: !AppSettings
+    , appStatic             :: !Static -- ^ Settings for static file serving.
+    , appHttpManager        :: !Manager
+    , appLogger             :: !Logger
+    , appLogFunc            :: !RIO.LogFunc
+    , appWebsiteContent     :: !(GitRepo WebsiteContent)
+    , appStackageDatabase   :: !StackageDatabase
+    , appLatestStackMatcher :: !(IO (Text -> Maybe Text))
     -- ^ Give a pattern, get a URL
-    , appHoogleLock :: MVar ()
+    , appHoogleLock         :: !(MVar ())
     -- ^ Avoid concurrent Hoogle queries, see
     -- https://github.com/fpco/stackage-server/issues/172
-    , appMirrorStatus :: IO (Status, WidgetFor App ())
-    , appGetHoogleDB :: SnapName -> IO (Maybe FilePath)
-    , appGitRev :: GitRev
+    , appMirrorStatus       :: !(IO (Status, WidgetFor App ()))
+    , appGetHoogleDB        :: !(SnapName -> IO (Maybe FilePath))
+    , appGitRev             :: !GitRev
     }
 
 instance HasHttpManager App where
@@ -87,7 +95,7 @@ defaultLayoutWithContainer insideContainer widget = do
 instance Yesod App where
     approot = ApprootRequest $ \app req ->
         case appRoot $ appSettings app of
-            Nothing -> getApprootText guessApproot app req
+            Nothing   -> getApprootText guessApproot app req
             Just root -> root
 
     -- Store session data on the client in encrypted cookies,
@@ -145,8 +153,8 @@ instance ToMarkup (Route App) where
     toMarkup c =
         case c of
           AllSnapshotsR{} -> "Snapshots"
-          BlogHomeR -> "Blog"
-          _ -> ""
+          BlogHomeR       -> "Blog"
+          _               -> ""
 
 -- This instance is required to use forms. You can modify renderMessage to
 -- achieve customized and internationalized form validation messages.
@@ -160,7 +168,10 @@ instance RenderMessage App FormMessage where
 --
 -- https://github.com/yesodweb/yesod/wiki/Sending-email
 
-instance GetStackageDatabase Handler where
+instance GetStackageDatabase App Handler where
     getStackageDatabase = appStackageDatabase <$> getYesod
-instance GetStackageDatabase (WidgetFor App) where
+    getLogFunc = appLogFunc <$> getYesod
+
+instance GetStackageDatabase App (WidgetFor App) where
     getStackageDatabase = appStackageDatabase <$> getYesod
+    getLogFunc = appLogFunc <$> getYesod

src/Handler/Blog.hs

@@ -1,84 +1,89 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Handler.Blog
   ( getBlogHomeR
   , getBlogPostR
   , getBlogFeedR
   ) where
 
-import Import
 import Data.WebsiteContent
-import Yesod.GitRepo (grContent)
+import Import
 import Yesod.AtomFeed (atomLink)
+import Yesod.GitRepo (grContent)
+import RIO.Time (getCurrentTime)
 
 getPosts :: Handler (Vector Post)
 getPosts = do
-  now <- liftIO getCurrentTime
-  posts <- getYesod >>= fmap wcPosts . liftIO . grContent . appWebsiteContent
-  mpreview <- lookupGetParam "preview"
-  case mpreview of
-    Just "true" -> return posts
-    _ -> return $ filter (\p -> postTime p <= now) posts
+    now <- getCurrentTime
+    posts <- getYesod >>= fmap wcPosts . liftIO . grContent . appWebsiteContent
+    mpreview <- lookupGetParam "preview"
+    case mpreview of
+        Just "true" -> return posts
+        _ -> return $ filter (\p -> postTime p <= now) posts
 
 getAddPreview :: Handler (Route App -> (Route App, [(Text, Text)]))
 getAddPreview = do
   mpreview <- lookupGetParam "preview"
   case mpreview of
     Just "true" -> return $ \route -> (route, [("preview", "true")])
-    _ -> return $ \route -> (route, [])
+    _           -> return $ \route -> (route, [])
 
 postYear :: Post -> Year
 postYear p =
-  let (y, _, _) = toGregorian $ utctDay $ postTime p
-   in fromInteger y
+    let (y, _, _) = toGregorian $ utctDay $ postTime p
+     in fromInteger y
 
 postMonth :: Post -> Month
 postMonth p =
-  let (_, m, _) = toGregorian $ utctDay $ postTime p
-   in Month m
+    let (_, m, _) = toGregorian $ utctDay $ postTime p
+     in Month m
 
 getBlogHomeR :: Handler ()
 getBlogHomeR = do
-  posts <- getPosts
-  case headMay posts of
-    Nothing -> notFound
-    Just post -> do
-      addPreview <- getAddPreview
-      redirect $ addPreview $ BlogPostR (postYear post) (postMonth post) (postSlug post)
+    posts <- getPosts
+    case headMay posts of
+        Nothing -> notFound
+        Just post -> do
+            addPreview <- getAddPreview
+            redirect $ addPreview $ BlogPostR (postYear post) (postMonth post) (postSlug post)
 
 getBlogPostR :: Year -> Month -> Text -> Handler Html
 getBlogPostR year month slug = do
-  posts <- getPosts
-  post <- maybe notFound return $ find matches posts
-  now <- liftIO getCurrentTime
-  addPreview <- getAddPreview
-  defaultLayout $ do
-    setTitle $ toHtml $ postTitle post
-    atomLink BlogFeedR "Stackage Curator blog"
-    $(widgetFile "blog-post")
-    toWidgetHead [shamlet|<meta name=og:description value=#{postDescription post}>|]
+    posts <- getPosts
+    post <- maybe notFound return $ find matches posts
+    now <- getCurrentTime
+    addPreview <- getAddPreview
+    defaultLayout $ do
+        setTitle $ toHtml $ postTitle post
+        atomLink BlogFeedR "Stackage Curator blog"
+        $(widgetFile "blog-post")
+        toWidgetHead [shamlet|<meta name=og:description value=#{postDescription post}>|]
   where
     matches p = postYear p == year && postMonth p == month && postSlug p == slug
 
 getBlogFeedR :: Handler TypedContent
 getBlogFeedR = do
-  posts <- fmap (take 10) getPosts
-  latest <- maybe notFound return $ headMay posts
-  newsFeed Feed
-    { feedTitle = "Stackage Curator blog"
-    , feedLinkSelf = BlogFeedR
-    , feedLinkHome = HomeR
-    , feedAuthor = "The Stackage Curator team"
-    , feedDescription = "Messages from the Stackage Curators about the Stackage project"
-    , feedLanguage = "en"
-    , feedUpdated = postTime latest
-    , feedLogo = Nothing
-    , feedEntries = map toEntry $ toList posts
-    }
+    posts <- fmap (take 10) getPosts
+    latest <- maybe notFound return $ headMay posts
+    newsFeed
+        Feed
+            { feedTitle = "Stackage Curator blog"
+            , feedLinkSelf = BlogFeedR
+            , feedLinkHome = HomeR
+            , feedAuthor = "The Stackage Curator team"
+            , feedDescription = "Messages from the Stackage Curators about the Stackage project"
+            , feedLanguage = "en"
+            , feedUpdated = postTime latest
+            , feedLogo = Nothing
+            , feedEntries = map toEntry $ toList posts
+            }
   where
-    toEntry post = FeedEntry
-      { feedEntryLink = BlogPostR (postYear post) (postMonth post) (postSlug post)
-      , feedEntryUpdated = postTime post
-      , feedEntryTitle = postTitle post
-      , feedEntryContent = postBody post
-      , feedEntryEnclosure = Nothing
-      }
+    toEntry post =
+        FeedEntry
+            { feedEntryLink = BlogPostR (postYear post) (postMonth post) (postSlug post)
+            , feedEntryUpdated = postTime post
+            , feedEntryTitle = postTitle post
+            , feedEntryContent = postBody post
+            , feedEntryEnclosure = Nothing
+            }

src/Handler/BuildPlan.hs

@@ -1,9 +1,8 @@
-{-# LANGUAGE ConstraintKinds #-}
 module Handler.BuildPlan where
 
-import Import hiding (get, PackageName (..), Version (..), DList)
+import Import
 --import Stackage.Types
-import Stackage.Database
+--import Stackage.Database
 
 getBuildPlanR :: SnapName -> Handler TypedContent
 getBuildPlanR _slug = track "Handler.BuildPlan.getBuildPlanR" $ do

src/Handler/Download.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 module Handler.Download
   ( getDownloadR
   , getDownloadSnapshotsJsonR
@@ -6,11 +7,12 @@ module Handler.Download
   , getDownloadGhcLinksR
   ) where
 
+import RIO (textDisplay)
 import Import
 import Data.GhcLinks
 import Yesod.GitRepo (grContent)
 import Stackage.Database
-import qualified Data.Text as T
+import Stackage.Database.Types (ghcVersion)
 
 getDownloadR :: Handler Html
 getDownloadR = track "Hoogle.Download.getDownloadR" $
@@ -21,16 +23,11 @@ getDownloadSnapshotsJsonR = track "Hoogle.Download.getDownloadSnapshotsJsonR"
     getDownloadLtsSnapshotsJsonR
 
 getDownloadLtsSnapshotsJsonR :: Handler Value
-getDownloadLtsSnapshotsJsonR = track "Hoogle.Download.getDownloadLtsSnapshotsJsonR"
-    snapshotsJSON
+getDownloadLtsSnapshotsJsonR = track "Hoogle.Download.getDownloadLtsSnapshotsJsonR" snapshotsJSON
 
 -- Print the ghc major version for the given snapshot.
 ghcMajorVersionText :: Snapshot -> Text
-ghcMajorVersionText =
-    getMajorVersion . snapshotGhc
-  where
-    getMajorVersion :: Text -> Text
-    getMajorVersion = intercalate "." . take 2 . T.splitOn "."
+ghcMajorVersionText = textDisplay . keepMajorVersion . ghcVersion . snapshotCompiler
 
 getGhcMajorVersionR :: SnapName -> Handler Text
 getGhcMajorVersionR name = track "Hoogle.Download.getGhcMajorVersionR" $ do
@@ -38,15 +35,14 @@ getGhcMajorVersionR name = track "Hoogle.Download.getGhcMajorVersionR" $ do
     return $ ghcMajorVersionText $ entityVal snapshot
 
 getDownloadGhcLinksR :: SupportedArch -> Text -> Handler TypedContent
-getDownloadGhcLinksR arch fileName = track "Hoogle.Download.getDownloadGhcLinksR" $ do
-  ver <- maybe notFound return
-       $ stripPrefix "ghc-"
-         >=> stripSuffix "-links.yaml"
-         >=> ghcMajorVersionFromText
-       $ fileName
-  ghcLinks <- getYesod >>= fmap wcGhcLinks . liftIO . grContent . appWebsiteContent
-  case lookup (arch, ver) (ghcLinksMap ghcLinks) of
-    Just text -> return $ TypedContent yamlMimeType $ toContent text
-    Nothing -> notFound
+getDownloadGhcLinksR arch fName =
+    track "Hoogle.Download.getDownloadGhcLinksR" $ do
+        ver <-
+            maybe notFound return $
+            stripPrefix "ghc-" >=> stripSuffix "-links.yaml" >=> ghcMajorVersionFromText $ fName
+        ghcLinks <- getYesod >>= fmap wcGhcLinks . liftIO . grContent . appWebsiteContent
+        case lookup (arch, ver) (ghcLinksMap ghcLinks) of
+            Just text -> return $ TypedContent yamlMimeType $ toContent text
+            Nothing -> notFound
   where
     yamlMimeType = "text/yaml"

src/Handler/DownloadStack.hs

@@ -1,14 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Handler.DownloadStack
     ( getDownloadStackListR
     , getDownloadStackR
     , getLatestMatcher
     ) where
 
-import Import
-import Yesod.GitRepo
-import Data.WebsiteContent
 import Data.Aeson.Parser (json)
 import Data.Conduit.Attoparsec (sinkParser)
+import Data.WebsiteContent
+import Import
+import Yesod.GitRepo
 
 getDownloadStackListR :: Handler Html
 getDownloadStackListR = track "Handler.DownloadStack.getDownloadStackListR" $ do
@@ -18,9 +20,9 @@ getDownloadStackListR = track "Handler.DownloadStack.getDownloadStackListR" $ do
         $(widgetFile "download-stack-list")
 
 getDownloadStackR :: Text -> Handler ()
-getDownloadStackR pattern = track "Handler.DownloadStack.getDownloadStackR" $ do
+getDownloadStackR pattern' = track "Handler.DownloadStack.getDownloadStackR" $ do
     matcher <- getYesod >>= liftIO . appLatestStackMatcher
-    maybe notFound redirect $ matcher pattern
+    maybe notFound redirect $ matcher pattern'
 
 -- | Creates a function which will find the latest release for a given pattern.
 getLatestMatcher :: Manager -> IO (Text -> Maybe Text)
@@ -30,11 +32,11 @@ getLatestMatcher man = do
             }
     val <- flip runReaderT man $ withResponse req
         $ \res -> runConduit $ responseBody res .| sinkParser json
-    return $ \pattern -> do
-        let pattern' = pattern ++ "."
+    return $ \pattern' -> do
+        let pattern'' = pattern' ++ "."
         Object top <- return val
         Array assets <- lookup "assets" top
-        headMay $ preferZip $ catMaybes $ map (findMatch pattern') assets
+        headMay $ preferZip $ catMaybes $ map (findMatch pattern'') assets
   where
     findMatch pattern' (Object o) = do
         String name <- lookup "name" o
@@ -44,5 +46,5 @@ getLatestMatcher man = do
         Just url
     findMatch _ _ = Nothing
 
-    preferZip = map snd . sortBy (comparing fst) . map
+    preferZip = map snd . sortOn fst . map
         (\x -> (if ".zip" `isSuffixOf` x then 0 else 1 :: Int, x))

src/Handler/Feed.hs

@@ -1,13 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE QuasiQuotes #-}
 module Handler.Feed
     ( getFeedR
     , getBranchFeedR
     ) where
 
+import Data.These
 import Import
 import Stackage.Database
-import Data.These
 import Stackage.Snapshot.Diff
 import Text.Blaze (text)
+import RIO.Time (getCurrentTime)
 
 getFeedR :: Handler TypedContent
 getFeedR = track "Handler.Feed.getBranchFeedR" $ getBranchFeed Nothing
@@ -26,13 +29,13 @@ mkFeed mBranch snaps = do
         return FeedEntry
             { feedEntryLink = SnapshotR (snapshotName snap) StackageHomeR
             , feedEntryUpdated = UTCTime (snapshotCreated snap) 0
-            , feedEntryTitle = prettyName (snapshotName snap) (snapshotGhc snap)
+            , feedEntryTitle = snapshotTitle snap
             , feedEntryContent = content
             , feedEntryEnclosure = Nothing
             }
     updated <-
         case entries of
-            [] -> liftIO getCurrentTime
+            []  -> getCurrentTime
             x:_ -> return $ feedEntryUpdated x
     newsFeed Feed
         { feedTitle = title
@@ -46,8 +49,8 @@ mkFeed mBranch snaps = do
         , feedLogo = Nothing
         }
   where
-    branchTitle NightlyBranch = "Nightly"
-    branchTitle LtsBranch     = "LTS"
+    branchTitle NightlyBranch      = "Nightly"
+    branchTitle LtsBranch          = "LTS"
     branchTitle (LtsMajorBranch x) = "LTS-" <> tshow x
     title = "Recent Stackage " <> maybe "" branchTitle mBranch <> " snapshots"
 
@@ -61,7 +64,7 @@ getContent sid2 snap = do
             let name2 = snapshotName snap
             withUrlRenderer
                 [hamlet|
-                  <p>Difference between #{prettyNameShort name1} and #{prettyNameShort $ snapshotName snap}
+                  <p>Difference between #{snapshotPrettyNameShort name1} and #{snapshotPrettyNameShort $ snapshotName snap}
                   <table border=1 cellpadding=5>
                     <thead>
                       <tr>
@@ -69,9 +72,9 @@ getContent sid2 snap = do
                         <th align=right>Old
                         <th align=left>New
                     <tbody>
-                      $forall (pkgname@(PackageName name), VersionChange change, versionDiff) <- toVersionedDiffList snapDiff
+                      $forall (pkgname, VersionChange change, versionDiff) <- toVersionedDiffList snapDiff
                         <tr>
-                          <th align=right>#{name}
+                          <th align=right>#{pkgname}
                           $case change
                             $of This old
                               <td align=right>

src/Handler/Haddock.hs

@@ -1,51 +1,77 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 module Handler.Haddock
     ( getHaddockR
     , getHaddockBackupR
     ) where
 
 import Import
+import qualified Data.Text as T (takeEnd)
 import Stackage.Database
+import Stackage.Database.Types (haddockBucketName)
 
 makeURL :: SnapName -> [Text] -> Text
-makeURL slug rest = concat
-    $ "https://s3.amazonaws.com/haddock.stackage.org/"
-    : toPathPiece slug
+makeURL snapName rest = concat
+    $ "https://s3.amazonaws.com/"
+    : haddockBucketName
+    : "/"
+    : toPathPiece snapName
     : map (cons '/') rest
 
 shouldRedirect :: Bool
 shouldRedirect = False
 
+data DocType = DocHtml | DocJson
+
 getHaddockR :: SnapName -> [Text] -> Handler TypedContent
-getHaddockR slug rest
-  | shouldRedirect = do
-      result <- redirectWithVersion slug rest
-      case result of
-        Just route -> redirect route
-        Nothing -> redirect $ makeURL slug rest
-  | final:_ <- reverse rest, ".html" `isSuffixOf` final = do
-      render <- getUrlRender
-      result <- redirectWithVersion slug rest
-      case result of
-        Just route -> redirect route
-        Nothing -> do
-            let extra = concat
-                  [ "<link rel='stylesheet' href='https://fonts.googleapis.com/css?family=Open+Sans'>"
-                  , "<link rel='stylesheet' href='"
-                  , render $ StaticR haddock_style_css
-                  , "'>"
-                  ]
-            req <- parseRequest $ unpack $ makeURL slug rest
-            man <- getHttpManager <$> getYesod
-            (_, res) <- runReaderT (acquireResponse req >>= allocateAcquire) man
-            mstyle <- lookupGetParam "style"
-            case mstyle of
-              Just "plain" -> respondSource "text/html; charset=utf-8"
-                            $ responseBody res .| mapC (Chunk . toBuilder)
-              _ -> respondSource "text/html; charset=utf-8" $ responseBody res .| (do
-                    takeUntilChunk "</head>"
-                    peekC >>= maybe (return ()) (const $ yield $ encodeUtf8 extra)
-                    mapC id) .| mapC (Chunk . toBuilder)
-  | otherwise = redirect $ makeURL slug rest
+getHaddockR snapName rest
+    | shouldRedirect = do
+        result <- redirectWithVersion snapName rest
+        case result of
+            Just route -> redirect route
+            Nothing -> redirect $ makeURL snapName rest
+    | Just docType <- mdocType = do
+        result <- redirectWithVersion snapName rest
+        case result of
+            Just route -> redirect route
+            Nothing -> do
+                (contentType, plain) <-
+                    case docType of
+                        DocHtml -> do
+                            mstyle <- lookupGetParam "style"
+                            return ("text/html; charset=utf-8", mstyle == Just "plain")
+                        DocJson ->
+                            return ("application/jsontml; charset=utf-8", True)
+                req <- parseRequest $ unpack $ makeURL snapName rest
+                man <- getHttpManager <$> getYesod
+                (_, res) <- runReaderT (acquireResponse req >>= allocateAcquire) man
+                if plain
+                    then respondSource contentType $ responseBody res .| mapC (Chunk . toBuilder)
+                    else do
+                        extra <- getExtra
+                        respondSource contentType $
+                            responseBody res .|
+                            (do takeUntilChunk "</head>"
+                                peekC >>= maybe (return ()) (const $ yield $ encodeUtf8 extra)
+                                mapC id) .|
+                            mapC (Chunk . toBuilder)
+    | otherwise = redirect $ makeURL snapName rest
+  where
+    mdocType =
+        case T.takeEnd 5 <$> headMay (reverse rest) of
+            Just ".html" -> Just DocHtml
+            Just ".json" -> Just DocJson
+            _ -> Nothing
+    getExtra = do
+        render <- getUrlRender
+        return $
+            concat
+                [ "<link rel='stylesheet' href='https://fonts.googleapis.com/css?family=Open+Sans'>"
+                , "<link rel='stylesheet' href='"
+                , render $ StaticR haddock_style_css
+                , "'>"
+                ]
+
+
 
 takeUntilChunk :: Monad m => ByteString -> ConduitM ByteString ByteString m ()
 takeUntilChunk fullNeedle =
@@ -70,7 +96,13 @@ takeUntilChunk fullNeedle =
                 Just needle' -> loop (front . (bs:)) needle'
                 Nothing -> yieldMany (front [bs]) >> start
 
-data CheckNeedle = CNNotFound | CNFound !ByteString !ByteString | CNPartial !ByteString !ByteString !ByteString
+data CheckNeedle
+    = CNNotFound
+    | CNFound !ByteString
+              !ByteString
+    | CNPartial !ByteString
+                !ByteString
+                !ByteString
 
 checkNeedle :: ByteString -> ByteString -> CheckNeedle
 checkNeedle needle bs0 =
@@ -88,18 +120,20 @@ checkNeedle needle bs0 =
       | Just needle' <- stripPrefix bs needle = CNPartial before bs needle'
       | otherwise = CNNotFound
 
-redirectWithVersion
-  :: (GetStackageDatabase m,MonadHandler m,RedirectUrl (HandlerSite m) (Route App))
-  => SnapName -> [Text] -> m (Maybe (Route App))
-redirectWithVersion slug rest =
+redirectWithVersion ::
+       (GetStackageDatabase env m, MonadHandler m) => SnapName -> [Text] -> m (Maybe (Route App))
+redirectWithVersion snapName rest =
     case rest of
-        [pkg,file] -> do
-            Entity sid _ <- lookupSnapshot slug >>= maybe notFound return
-            mversion <- getPackageVersionBySnapshot sid pkg
-            case mversion of
+        [pkg, file] | Just pname <- fromPathPiece pkg -> do
+            mspi <- getSnapshotPackageInfo snapName pname
+            case mspi of -- TODO: Should `Nothing` cause a 404 here, since haddock will fail?
                 Nothing -> return Nothing -- error "That package is not part of this snapshot."
-                Just version -> do
-                    return (Just (HaddockR slug [pkg <> "-" <> version, file]))
+                Just spi -> do
+                    return
+                        (Just
+                             (HaddockR
+                                  snapName
+                                  [toPathPiece $ PackageIdentifierP pname (spiVersion spi), file]))
         _ -> return Nothing
 
 getHaddockBackupR :: [Text] -> Handler ()
@@ -107,6 +141,6 @@ getHaddockBackupR (snap':rest)
   | Just branch <- fromPathPiece snap' = track "Handler.Haddock.getHaddockBackupR" $ do
       snapName <- newestSnapshot branch >>= maybe notFound pure
       redirect $ HaddockR snapName rest
-getHaddockBackupR rest = track "Handler.Haddock.getHaddockBackupR" $  redirect $ concat
+getHaddockBackupR rest = track "Handler.Haddock.getHaddockBackupR" $ redirect $ concat
     $ "https://s3.amazonaws.com/haddock.stackage.org"
     : map (cons '/') rest

src/Handler/Home.hs

@@ -1,5 +1,8 @@
-{-# LANGUAGE TupleSections, OverloadedStrings #-}
-
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 module Handler.Home
     ( getHomeR
     , getAuthorsR
@@ -7,7 +10,7 @@ module Handler.Home
     , getOlderReleasesR
     ) where
 
-import Data.Time.Clock
+import RIO.Time
 import Import
 import Stackage.Database
 import Yesod.GitRepo (grContent)
@@ -21,7 +24,7 @@ import Yesod.GitRepo (grContent)
 -- inclined, or create a single monolithic file.
 getHomeR :: Handler Html
 getHomeR = track "Handler.Snapshots.getAllSnapshotsR" $ do
-    now' <- liftIO getCurrentTime
+    now' <- getCurrentTime
     currentPageMay <- lookupGetParam "page"
     let currentPage :: Int
         currentPage = fromMaybe 1 (currentPageMay >>= readMay)

src/Handler/Hoogle.hs

@@ -1,24 +1,30 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Handler.Hoogle where
 
-import           Control.DeepSeq (NFData(..))
-import           Data.Data (Data)
-import           Data.Text.Read (decimal)
-import qualified Hoogle
-import           Import
-import           Text.Blaze.Html (preEscapedToHtml)
-import Stackage.Database
+import Control.DeepSeq (NFData(..))
 import qualified Data.Text as T
+import Data.Text.Read (decimal)
+import qualified Hoogle
+import Import
+import Stackage.Database
+import Text.Blaze.Html (preEscapedToHtml)
 import qualified Text.HTML.DOM
-import Text.XML.Cursor (fromDocument, ($//), content)
+import Text.XML.Cursor (content, fromDocument, ($//))
 
 getHoogleDB :: SnapName -> Handler (Maybe FilePath)
-getHoogleDB name = track "Handler.Hoogle.getHoogleDB" $ do
+getHoogleDB name = track "Handler.Hoogle.getHoogleDB" do
     app <- getYesod
     liftIO $ appGetHoogleDB app name
 
 getHoogleR :: SnapName -> Handler Html
-getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do
+getHoogleR name = track "Handler.Hoogle.getHoogleR" do
     Entity _ snapshot <- lookupSnapshot name >>= maybe notFound return
     mquery <- lookupGetParam "q"
     mPackageName <- lookupGetParam "package"
@@ -28,11 +34,11 @@ getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do
     let count' =
             case decimal <$> mresults' of
                 Just (Right (i, "")) -> min perPage i
-                _ -> perPage
+                _                    -> perPage
         page =
             case decimal <$> mpage of
                 Just (Right (i, "")) -> i
-                _ -> 1
+                _                    -> 1
         offset = (page - 1) * perPage
     mdatabasePath <- getHoogleDB name
     dbPath <- maybe (hoogleDatabaseNotAvailableFor name) return mdatabasePath
@@ -67,27 +73,30 @@ getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do
               [("page", tshow p)])
         snapshotLink = SnapshotR name StackageHomeR
         hoogleForm = $(widgetFile "hoogle-form")
-    defaultLayout $ do
+    defaultLayout do
         setTitle "Hoogle Search"
         $(widgetFile "hoogle")
 
 getHoogleDatabaseR :: SnapName -> Handler Html
-getHoogleDatabaseR name = track "Handler.Hoogle.getHoogleDatabaseR" $ do
-    mdatabasePath <- getHoogleDB name
-    case mdatabasePath of
-        Nothing -> hoogleDatabaseNotAvailableFor name
-        Just path -> sendFile "application/octet-stream" path
+getHoogleDatabaseR name =
+    track "Handler.Hoogle.getHoogleDatabaseR" do
+        mdatabasePath <- getHoogleDB name
+        case mdatabasePath of
+            Nothing   -> hoogleDatabaseNotAvailableFor name
+            Just path -> sendFile "application/octet-stream" path
 
 hoogleDatabaseNotAvailableFor :: SnapName -> Handler a
-hoogleDatabaseNotAvailableFor name = track "Handler.Hoogle.hoogleDatabaseNotAvailableFor" $ do
-    (>>= sendResponse) $ defaultLayout $ do
-        setTitle "Hoogle database not available"
-        [whamlet|
+hoogleDatabaseNotAvailableFor name =
+    track "Handler.Hoogle.hoogleDatabaseNotAvailableFor" do
+        sendResponse =<<
+            defaultLayout
+                (do setTitle "Hoogle database not available"
+                    [whamlet|
             <div .container>
                 <p>The given Hoogle database is not available.
                 <p>
                     <a href=@{SnapshotR name StackageHomeR}>Return to snapshot homepage
-        |]
+        |])
 
 getPageCount :: Int -> Int
 getPageCount totalCount = 1 + div totalCount perPage
@@ -96,36 +105,36 @@ perPage :: Int
 perPage = 10
 
 data HoogleQueryInput = HoogleQueryInput
-    { hqiQueryInput  :: Text
-    , hqiLimitTo     :: Int
-    , hqiOffsetBy    :: Int
-    , hqiExact       :: Bool
+    { hqiQueryInput :: !Text
+    , hqiLimitTo    :: !Int
+    , hqiOffsetBy   :: !Int
+    , hqiExact      :: !Bool
     }
-    deriving (Eq, Read, Show, Data, Typeable, Ord, Generic)
+    deriving (Eq, Show, Ord, Generic)
 
 data HoogleQueryOutput = HoogleQueryOutput [HoogleResult] (Maybe Int) -- ^ Int == total count
-    deriving (Read, Typeable, Data, Show, Eq, Generic)
+    deriving (Show, Eq, Generic)
 instance NFData HoogleQueryOutput
 
 data HoogleResult = HoogleResult
-    { hrURL     :: String
-    , hrSources :: [(PackageLink, [ModuleLink])]
-    , hrTitle   :: String -- ^ HTML
-    , hrBody    :: String -- ^ plain text
+    { hrURL     :: !Text
+    , hrSources :: ![(PackageLink, [ModuleLink])]
+    , hrTitle   :: !Text -- ^ HTML
+    , hrBody    :: !String -- ^ plain text
     }
-    deriving (Eq, Read, Show, Data, Typeable, Ord, Generic)
+    deriving (Eq, Show, Ord, Generic)
 
 data PackageLink = PackageLink
-    { plName :: String
-    , plURL  :: String
+    { plName :: !PackageNameP
+    , plURL  :: !Text
     }
-    deriving (Eq, Read, Show, Data, Typeable, Ord, Generic)
+    deriving (Eq, Show, Ord, Generic)
 
 data ModuleLink = ModuleLink
-    { mlName :: String
-    , mlURL :: String
+    { mlName :: !ModuleNameP
+    , mlURL  :: !Text
     }
-    deriving (Eq, Read, Show, Data, Typeable, Ord, Generic)
+    deriving (Eq, Show, Ord, Generic)
 
 instance NFData HoogleResult
 instance NFData PackageLink
@@ -136,69 +145,67 @@ runHoogleQuery :: (Route App -> Text)
                -> Hoogle.Database
                -> HoogleQueryInput
                -> HoogleQueryOutput
-runHoogleQuery renderUrl snapshot hoogledb HoogleQueryInput {..} =
-    HoogleQueryOutput targets mcount
+runHoogleQuery renderUrl snapshot hoogledb HoogleQueryInput {..} = HoogleQueryOutput targets mcount
   where
     allTargets = Hoogle.searchDatabase hoogledb query
-    targets = take (min 100 hqiLimitTo)
-            $ drop hqiOffsetBy
-            $ map fixResult allTargets
-    query = unpack $ hqiQueryInput ++ if hqiExact then " is:exact" else ""
-
+    targets = take (min 100 hqiLimitTo) $ drop hqiOffsetBy $ map fixResult allTargets
+    query =
+        unpack $
+        hqiQueryInput ++
+        if hqiExact
+            then " is:exact"
+            else ""
     mcount = limitedLength 0 allTargets
-
     limitedLength x [] = Just x
     limitedLength x (_:rest)
         | x >= 20 = Nothing
         | otherwise = limitedLength (x + 1) rest
+    fixResult target@Hoogle.Target {..} =
+        HoogleResult
+            { hrURL =
+                  case sources of
+                      [(_, [ModuleLink _ m])] -> m <> haddockAnchorFromUrl targetURL
+                      _ -> fromMaybe (T.pack targetURL) $ asum [mModuleLink, mPackageLink]
+            , hrSources = sources
+            , hrTitle
+               -- NOTE: from hoogle documentation:
+               -- HTML span of the item, using 0 for the name and 1 onwards for arguments
+               = T.replace "<0>" "" $ T.replace "</0>" "" $ pack targetItem
+            , hrBody = targetDocs
+            }
+      where
+        sources =
+            toList do
+                (packageLink, mkModuleUrl) <- targetLinks renderUrl snapshot target
+                modName <- parseModuleNameP . fst =<< targetModule
+                Just (packageLink, [ModuleLink modName $ mkModuleUrl modName])
+        item =
+            let doc = Text.HTML.DOM.parseLBS $ encodeUtf8 $ pack targetItem
+                cursor = fromDocument doc
+             in T.concat $ cursor $// content
+        mModuleLink = do
+            "module" <- Just targetType
+            (_packageLink, mkModuleUrl) <- targetLinks renderUrl snapshot target
+            modName <- parseModuleNameP . T.unpack =<< T.stripPrefix "module " item
+            pure $ mkModuleUrl modName
+        mPackageLink = do
+            guard $ isNothing targetPackage
+            "package" <- Just targetType
+            pnameTxt <- T.stripPrefix "package " item
+            pname <- fromPathPiece pnameTxt
+            return $ renderUrl $ SnapshotR snapshot $ StackageSdistR $ PNVName pname
+        haddockAnchorFromUrl = T.pack . ('#' :) . reverse . takeWhile (/= '#') . reverse
 
-    fixResult Hoogle.Target {..} = HoogleResult
-        { hrURL     = case sources of
-                        [(_,[ModuleLink _ m])] -> m ++ haddockAnchorFromUrl targetURL
-                        _ -> fromMaybe targetURL $ asum
-                                [ moduleLink
-                                , packageLink
-                                ]
-        , hrSources = sources
-        , hrTitle   = -- FIXME find out why these replaces are necessary
-                      unpack $ T.replace "<0>" "" $ T.replace "</0>" "" $ pack
-                      targetItem
-        , hrBody    = targetDocs
-        }
-      where sources = toList $ do
-              (pname, _) <- targetPackage
-              (mname, _) <- targetModule
-              let p = PackageLink pname (makePackageLink pname)
-                  m = ModuleLink
-                        mname
-                        (T.unpack
-                             (renderUrl
-                                  (haddockUrl
-                                       snapshot
-                                       (T.pack pname)
-                                       (T.pack mname))))
-              Just (p, [m])
+targetLinks ::
+       (Route App -> Text)
+    -> SnapName
+    -> Hoogle.Target
+    -> Maybe (PackageLink, ModuleNameP -> Text)
+targetLinks renderUrl snapName Hoogle.Target {..} = do
+    (pname, _) <- targetPackage
+    packageName <- parsePackageNameP pname
+    let mkModuleUrl modName = renderUrl (hoogleHaddockUrl snapName packageName modName)
+    return (makePackageLink packageName, mkModuleUrl)
 
-            moduleLink = do
-              (pname, _) <- targetPackage
-              "module" <- Just targetType
-              let doc = Text.HTML.DOM.parseLBS $ encodeUtf8 $ pack targetItem
-                  cursor = fromDocument doc
-                  item = T.concat $ cursor $// content
-              mname <- T.stripPrefix "module " item
-              return $ T.unpack $ renderUrl $ haddockUrl snapshot (T.pack pname) mname
-
-            packageLink = do
-              Nothing <- Just targetPackage
-              "package" <- Just targetType
-              let doc = Text.HTML.DOM.parseLBS $ encodeUtf8 $ pack targetItem
-                  cursor = fromDocument doc
-                  item = T.concat $ cursor $// content
-              pname <- T.stripPrefix "package " item
-              return $ T.unpack $ renderUrl $ SnapshotR snapshot $ StackageSdistR $ PNVName $ PackageName pname
-
-            haddockAnchorFromUrl =
-                ('#':) . reverse . takeWhile (/='#') . reverse
-
-makePackageLink :: String -> String
-makePackageLink pkg = "/package/" ++ pkg
+makePackageLink :: PackageNameP -> PackageLink
+makePackageLink packageName = PackageLink packageName ("/package/" <> toPathPiece packageName)

src/Handler/MirrorStatus.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE QuasiQuotes #-}
+
 module Handler.MirrorStatus
     ( getMirrorStatusR
     , mkUpdateMirrorStatus
@@ -6,7 +8,7 @@ module Handler.MirrorStatus
 import Import
 import Control.AutoUpdate
 import Network.HTTP.Simple
-import Data.Time (parseTimeM, diffUTCTime, addUTCTime)
+import RIO.Time (parseTimeM, diffUTCTime, addUTCTime, getCurrentTime)
 import Text.XML.Stream.Parse
 import Data.XML.Types (Event (EventContent), Content (ContentText))
 import qualified Prelude

src/Handler/OldLinks.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 module Handler.OldLinks
     ( getOldSnapshotBranchR
     , getOldSnapshotR

src/Handler/Package.hs

@@ -1,4 +1,10 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
 
 -- | Lists the package page similar to Hackage.
 
@@ -7,33 +13,34 @@ module Handler.Package
     , getPackageSnapshotsR
     , packagePage
     , getPackageBadgeR
-    , renderNoPackages
+    , renderNumPackages
     ) where
 
-import           Data.Char
+import Control.Lens
+
+import Data.Coerce
 import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
 import qualified Data.Text.Lazy as LT
-import           Distribution.Package.ModuleForest
-import           Graphics.Badge.Barrier
-import           Control.Lens
-import           Import
+import Distribution.Package.ModuleForest
+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           Text.Email.Validate
-import           Stackage.Database
-import           Yesod.GitRepo
+import Yesod.GitRepo
 
 -- | Page metadata package.
-getPackageR :: PackageName -> Handler Html
+getPackageR :: PackageNameP -> Handler Html
 getPackageR = track "Handler.Package.getPackageR" . packagePage Nothing
 
-getPackageBadgeR :: PackageName -> SnapshotBranch -> Handler TypedContent
+getPackageBadgeR :: PackageNameP -> SnapshotBranch -> Handler TypedContent
 getPackageBadgeR pname branch = track "Handler.Package.getPackageBadgeR" $ do
     cacheSeconds (3 * 60 * 60)
     snapName     <- maybe notFound pure =<< newestSnapshot branch
     Entity sid _ <- maybe notFound pure =<< lookupSnapshot snapName
-    mVersion <- do mSnapPackage <- lookupSnapshotPackage sid (unPackageName pname)
-                   pure (Version . snapshotPackageVersion . entityVal <$> mSnapPackage)
+    mVersion <- getPackageVersionForSnapshot sid pname
 
     mLabel <- lookupGetParam "label"
     mStyle <- lookupGetParam "style"
@@ -47,214 +54,108 @@ renderStackageBadge :: (Badge b, HasRightColor b)
                     => b          -- ^ Style
                     -> Maybe Text -- ^ Label
                     -> SnapName
-                    -> Maybe Version
+                    -> Maybe VersionP
                     -> LByteString
 renderStackageBadge style mLabel snapName = \case
-    Nothing          -> renderBadge (style & right .~ lightgray) badgeLabel "not available"
-    Just (Version x) -> renderBadge style badgeLabel x
+    Nothing -> renderBadge (style & right .~ lightgray) badgeLabel "not available"
+    Just v -> renderBadge style badgeLabel $ toPathPiece v
   where
     badgeLabel = fromMaybe ("stackage " <> badgeSnapName snapName) mLabel
 
     badgeSnapName (SNNightly _) = "nightly"
     badgeSnapName (SNLts x _)   = "lts-" <> tshow x
 
-checkSpam :: PackageName -> Handler Html -> Handler Html
-checkSpam name inner = do
+checkSpam :: PackageNameP -> Handler Html -> Handler Html
+checkSpam pname inner = do
     wc <- getYesod >>= liftIO . grContent . appWebsiteContent
-    if name `member` wcSpamPackages wc
+    if pname `member` wcSpamPackages wc
       then defaultLayout $ do
-        setTitle $ "Spam package detected: " <> toHtml name
+        setTitle $ "Spam package detected: " <> toHtml pname
         $(widgetFile "spam-package")
       else inner
 
-packagePage :: Maybe (SnapName, Version)
-            -> PackageName
+packagePage :: Maybe SnapshotPackageInfo
+            -> PackageNameP
             -> Handler Html
-packagePage mversion pname = track "Handler.Package.packagePage" $ checkSpam pname $ do
-    let pname' = toPathPiece pname
-    (deprecated, inFavourOf) <- getDeprecated pname'
-    latests <- getLatests pname'
-    deps' <- getDeps pname' $ Just maxDisplayedDeps
-    revdeps' <- getRevDeps pname' $ Just maxDisplayedDeps
-    (depsCount, revdepsCount) <- getDepsCount pname'
-    Entity _ package <- getPackage pname' >>= maybe notFound return
+packagePage mspi pname =
+    track "Handler.Package.packagePage" $
+    checkSpam pname $
+        maybe (getSnapshotPackageLatestVersion pname) (return . Just) mspi >>= \case
+          Nothing -> do
+            hci <- run (getHackageLatestVersion pname) >>= maybe notFound pure
+            handlePackage $ Left hci
+          Just spi -> handlePackage $ Right spi
 
-    mdocs <-
-        case mversion of
-            Just (sname, version) -> do
-                ms <- getPackageModules sname pname'
-                return $ Just (sname, toPathPiece version, ms)
-            Nothing ->
-                case latests of
-                    li:_ -> do
-                        ms <- getPackageModules (liSnapName li) pname'
-                        return $ Just (liSnapName li, liVersion li, ms)
-                    [] -> return Nothing
 
-    let ixInFavourOf = zip [0::Int ..] inFavourOf
-        mdisplayedVersion = toPathPiece . snd <$> mversion
-        latestVersion = packageLatest package
 
-    let homepage = case T.strip (packageHomepage package) of
-                     x | null x -> Nothing
-                       | otherwise -> Just x
-        synopsis = packageSynopsis package
-        deps = enumerate deps'
-        revdeps = enumerate revdeps'
-        authors = enumerate (parseIdentitiesLiberally (packageAuthor package))
-        maintainers = let ms = enumerate (parseIdentitiesLiberally (packageMaintainer package))
-                      in if ms == authors
-                            then []
-                            else ms
+
+handlePackage :: Either HackageCabalInfo SnapshotPackageInfo -> Handler Html
+handlePackage epi = do
+    (isDeprecated, inFavourOf) <- getDeprecated pname
+    (msppi, mhciLatest) <-
+        case epi of
+            Right spi -> do
+                sppi <- getSnapshotPackagePageInfo spi maxDisplayedDeps
+                return (Just sppi, sppiLatestHackageCabalInfo sppi)
+            Left hci -> pure (Nothing, Just hci)
+    PackageInfo {..} <- getPackageInfo epi
+    let authors = enumerate piAuthors
+        maintainers =
+            let ms = enumerate piMaintainers
+             in if ms == authors
+                    then []
+                    else ms
+        mdisplayedVersion = msppi >>= sppiVersion
     defaultLayout $ do
         setTitle $ toHtml pname
-        $(combineScripts 'StaticR
-                          [ js_highlight_js
-                          ])
-        $(combineStylesheets 'StaticR
-            [ css_font_awesome_min_css
-            , css_highlight_github_css
-            ])
-        let pn = pname
-            toPkgVer x y = concat [x, "-", y]
-            hoogleForm name =
-              let exact = False
-                  mPackageName = Just pname
-                  queryText = "" :: Text
-               in $(widgetFile "hoogle-form")
+        $(combineScripts 'StaticR [js_highlight_js])
+        $(combineStylesheets 'StaticR [css_font_awesome_min_css, css_highlight_github_css])
+        let hoogleForm name =
+                let exact = False
+                    mPackageName = Just pname
+                    queryText = "" :: Text
+                 in $(widgetFile "hoogle-form")
         $(widgetFile "package")
-  where enumerate = zip [0::Int ..]
-        renderModules sname version = renderForest [] . moduleForest . map moduleName
-          where
-            renderForest _ [] = mempty
-            renderForest pathRev trees =
-              [hamlet|<ul .docs-list>
+  where
+    makeDepsLink spi f =
+        SnapshotR (spiSnapName spi) $ f $ PNVNameVersion (spiPackageName spi) (spiVersion spi)
+    pname = either hciPackageName spiPackageName epi
+    enumerate = zip [0 :: Int ..]
+    renderModules sppi = renderForest [] $ moduleForest $ coerce (sppiModuleNames sppi)
+      where
+        SnapshotPackageInfo{spiPackageName, spiVersion, spiSnapName} = sppiSnapshotPackageInfo sppi
+        packageIdentifier = PackageIdentifierP spiPackageName spiVersion
+        renderForest _ [] = mempty
+        renderForest pathRev trees =
+            [hamlet|<ul .docs-list>
                         $forall tree <- trees
                           ^{renderTree tree}
               |]
-              where
-                renderTree (Node{..}) = [hamlet|
+          where
+            renderTree Node {..} =
+                [hamlet|
                   <li>
                     $if isModule
-                      <a href=@{haddockUrl sname version path'}>#{path'}
+                      <a href=@{haddockUrl spiSnapName mli}>#{modName}
                     $else
-                      #{path'}
+                      #{modName}
                     ^{renderForest pathRev' subModules}
                 |]
-                  where
-                    pathRev' = component:pathRev
-                    path'    = T.intercalate "." $ reverse pathRev'
+              where
+                mli = ModuleListingInfo modName packageIdentifier
+                pathRev' = component : pathRev
+                modName = moduleNameFromComponents (reverse pathRev')
+    maxDisplayedDeps :: Int
+    maxDisplayedDeps = 40
 
-        maxDisplayedDeps :: Int
-        maxDisplayedDeps = 40
+getPackageSnapshotsR :: PackageNameP -> Handler Html
+getPackageSnapshotsR pn =
+    track "Handler.Package.getPackageSnapshotsR" $ do
+        snapshots <- getSnapshotsForPackage pn Nothing
+        defaultLayout
+            (do setTitle ("Packages for " >> toHtml pn)
+                $(combineStylesheets 'StaticR [css_font_awesome_min_css])
+                $(widgetFile "package-snapshots"))
 
-        (packageDepsLink, packageRevDepsLink) =
-          case mversion of
-            Nothing -> (PackageDepsR pname, PackageRevDepsR pname)
-            Just (snap, version) ->
-              let wrap f = SnapshotR snap $ f $ PNVNameVersion pname version
-               in (wrap SnapshotPackageDepsR, wrap SnapshotPackageRevDepsR)
-
--- | An identifier specified in a package. Because this field has
--- quite liberal requirements, we often encounter various forms. A
--- name, a name and email, just an email, or maybe nothing at all.
-data Identifier
-  = EmailOnly !EmailAddress -- ^ An email only e.g. jones@example.com
-  | Contact !Text
-            !EmailAddress -- ^ A contact syntax, e.g. Dave Jones <jones@example.com>
-  | PlainText !Text -- ^ Couldn't parse anything sensible, leaving as-is.
-  deriving (Show,Eq)
-
--- | An author/maintainer field may contain a comma-separated list of
--- identifiers. It may be the case that a person's name is written as
--- "Einstein, Albert", but we only parse commas when there's an
--- accompanying email, so that would be:
---
---  Einstein, Albert <emc2@gmail.com>, Isaac Newton <falling@apple.com>
---
--- Whereas
---
--- Einstein, Albert, Isaac Newton
---
--- Will just be left alone. It's an imprecise parsing because the
--- input is wide open, but it's better than nothing:
---
--- λ> parseIdentitiesLiberally "Chris Done, Dave Jones <chrisdone@gmail.com>, Einstein, Albert, Isaac Newton, Michael Snoyman <michael@snoyman.com>"
--- [PlainText "Chris Done"
--- ,Contact "Dave Jones" "chrisdone@gmail.com"
--- ,PlainText "Einstein, Albert, Isaac Newton"
--- ,Contact "Michael Snoyman" "michael@snoyman.com"]
---
--- I think that is quite a predictable and reasonable result.
---
-parseIdentitiesLiberally :: Text -> [Identifier]
-parseIdentitiesLiberally =
-  filter (not . emptyPlainText) .
-  map strip .
-  concatPlains .
-  map parseChunk .
-  T.split (== ',')
-  where emptyPlainText (PlainText e) = T.null e
-        emptyPlainText _ = False
-        strip (PlainText t) = PlainText (T.strip t)
-        strip x = x
-        concatPlains = go
-          where go (PlainText x:PlainText y:xs) =
-                  go (PlainText (x <> "," <> y) :
-                      xs)
-                go (x:xs) = x : go xs
-                go [] = []
-
--- | Try to parse a chunk into an identifier.
---
--- 1. First tries to parse an \"email@domain.com\".
--- 2. Then tries to parse a \"Foo <email@domain.com>\".
--- 3. Finally gives up and returns a plain text.
---
--- λ> parseChunk "foo@example.com"
--- EmailOnly "foo@example.com"
--- λ> parseChunk "Dave Jones <dave@jones.com>"
--- Contact "Dave Jones" "dave@jones.com"
--- λ> parseChunk "<x>"
--- PlainText "<x>"
--- λ> parseChunk "Hello!"
--- PlainText "Hello!"
---
-parseChunk :: Text -> Identifier
-parseChunk chunk =
-  case emailAddress (T.encodeUtf8 (T.strip chunk)) of
-    Just email -> EmailOnly email
-    Nothing ->
-      case T.stripPrefix
-             ">"
-             (T.dropWhile isSpace
-                          (T.reverse chunk)) of
-        Just rest ->
-          case T.span (/= '<') rest of
-            (T.reverse -> emailStr,this) ->
-              case T.stripPrefix "< " this of
-                Just (T.reverse -> name) ->
-                  case emailAddress (T.encodeUtf8 (T.strip emailStr)) of
-                    Just email ->
-                      Contact (T.strip name) email
-                    _ -> plain
-                _ -> plain
-        _ -> plain
-  where plain = PlainText chunk
-
--- | Render email to text.
-renderEmail :: EmailAddress -> Text
-renderEmail = T.decodeUtf8 . toByteString
-
-getPackageSnapshotsR :: PackageName -> Handler Html
-getPackageSnapshotsR pn = track "Handler.Package.getPackageSnapshotsR" $
-  do snapshots <- getSnapshotsForPackage $ toPathPiece pn
-     defaultLayout
-       (do setTitle ("Packages for " >> toHtml pn)
-           $(combineStylesheets 'StaticR
-                                [css_font_awesome_min_css])
-           $(widgetFile "package-snapshots"))
-
-renderNoPackages :: Int -> Text
-renderNoPackages n =
-  T.pack $ show n ++ " package" ++ (if n == 1 then "" else "s")
+renderNumPackages :: Int -> Text
+renderNumPackages n = T.pack $ show n ++ " package" ++ if n == 1 then "" else "s"

src/Handler/PackageDeps.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE QuasiQuotes #-}
 module Handler.PackageDeps
   ( getPackageDepsR
   , getPackageRevDepsR
@@ -5,55 +7,76 @@ module Handler.PackageDeps
   , getSnapshotPackageRevDepsR
   ) where
 
+import Handler.StackageSdist (pnvToSnapshotPackageInfo)
 import Import
+import Types (PackageVersionRev(..))
 import Stackage.Database
+import Stackage.Database.Types (SnapshotPackageInfo(..))
 
-getPackageDepsR :: PackageName -> Handler Html
-getPackageDepsR = packageDeps Nothing
+getPackageDepsR :: PackageNameP -> Handler Html
+getPackageDepsR pname = do
+    mspi <- getSnapshotPackageLatestVersion pname
+    case mspi of
+        Nothing -> redirect $ PackageR pname
+        Just spi -> helper Deps spi
 
 getSnapshotPackageDepsR :: SnapName -> PackageNameVersion -> Handler Html
-getSnapshotPackageDepsR snap (PNVNameVersion pname version) =
-  packageDeps (Just (snap, version)) pname
-getSnapshotPackageDepsR _ _ = notFound
+getSnapshotPackageDepsR snapName pnv =
+    pnvToSnapshotPackageInfo snapName pnv (\_ _ -> notFound) $ \isSameVersion spi ->
+        if isSameVersion
+            then helper Deps spi
+            else redirect $
+                 SnapshotR snapName $
+                 SnapshotPackageDepsR $ PNVNameVersion (spiPackageName spi) (spiVersion spi)
 
-packageDeps :: Maybe (SnapName, Version) -> PackageName -> Handler Html
-packageDeps = helper Deps
-
-getPackageRevDepsR :: PackageName -> Handler Html
-getPackageRevDepsR = packageRevDeps Nothing
+getPackageRevDepsR :: PackageNameP -> Handler Html
+getPackageRevDepsR pname = do
+    mspi <- getSnapshotPackageLatestVersion pname
+    case mspi of
+        Nothing -> redirect $ PackageR pname
+        Just spi -> helper RevDeps spi
 
 getSnapshotPackageRevDepsR :: SnapName -> PackageNameVersion -> Handler Html
-getSnapshotPackageRevDepsR snap (PNVNameVersion pname version) =
-  packageRevDeps (Just (snap, version)) pname
-getSnapshotPackageRevDepsR _ _ = notFound
+getSnapshotPackageRevDepsR snapName pnv =
+    pnvToSnapshotPackageInfo snapName pnv (\_ _ -> notFound) $ \isSameVersion spi ->
+        if isSameVersion
+            then helper RevDeps spi
+            else redirect $
+                 SnapshotR snapName $
+                 SnapshotPackageRevDepsR $ PNVNameVersion (spiPackageName spi) (spiVersion spi)
 
-packageRevDeps :: Maybe (SnapName, Version) -> PackageName -> Handler Html
-packageRevDeps = helper Revdeps
 
-data DepType = Deps | Revdeps
+getPackagePageLink :: SnapName -> PackageVersionRev -> Route App
+getPackagePageLink snapName (PackageVersionRev pname (VersionRev version _)) =
+  SnapshotR snapName $ StackageSdistR $ PNVNameVersion pname version
 
-helper :: DepType -> Maybe (SnapName, Version) -> PackageName -> Handler Html
-helper depType mversion pname = track "Handler.PackageDeps.helper" $ do
-  deps <-
-    (case depType of
-       Deps -> getDeps
-       Revdeps -> getRevDeps) (toPathPiece pname) Nothing
-  let packagePage =
-        case mversion of
-          Nothing -> PackageR pname
-          Just (snap, version) -> SnapshotR snap $ StackageSdistR $ PNVNameVersion pname version
-  defaultLayout $ do
-    let title = toHtml $
-          (case depType of
-            Deps -> "Dependencies"
-            Revdeps -> "Reverse dependencies ") ++ " for " ++ toPathPiece pname
-    setTitle title
-    [whamlet|
-      <h1>#{title}
-      <p>
-        <a href=#{packagePage}>Return to package page
-      <ul>
-        $forall (name, range) <- deps
-          <li>
-            <a href=@{PackageR $ PackageName name} title=#{range}>#{name}
-    |]
+data DepType = Deps | RevDeps
+
+helper :: DepType -> SnapshotPackageInfo -> Handler Html
+helper depType spi =
+    track "Handler.PackageDeps.helper" $ do
+        let (depsGetter, header) =
+                case depType of
+                    Deps -> (getForwardDeps, "Dependencies for ")
+                    RevDeps -> (getReverseDeps, "Reverse dependencies on ")
+        deps <- run $ depsGetter spi Nothing
+        render <- getUrlRender
+        let title =
+                toHtml $
+                header ++ toPathPiece (PackageIdentifierP (spiPackageName spi) (spiVersion spi))
+            packagePageUrl =
+                render $
+                SnapshotR (spiSnapName spi) $
+                StackageSdistR $ PNVNameVersion (spiPackageName spi) (spiVersion spi)
+        defaultLayout $ do
+            setTitle title
+            [whamlet|
+              <h1>#{title}
+              <h3>There is a total of #{length deps} dependencies in <em>#{spiSnapName spi}</em>
+              <p>
+                <a href=#{packagePageUrl}>&lt;&lt; Return to package page
+              <ul>
+                $forall (depNameVerRev, verRange) <- deps
+                  <li>
+                    <a href=@{getPackagePageLink (spiSnapName spi) depNameVerRev} title="'#{spiPackageName spi}' version bounds: #{verRange}">#{depNameVerRev}
+            |]

src/Handler/PackageList.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell   #-}
 module Handler.PackageList where
 
 import Import
@@ -6,9 +9,13 @@ import Stackage.Database
 
 -- FIXME maybe just redirect to the LTS or nightly package list
 getPackageListR :: Handler Html
-getPackageListR = track "Handler.PackageList.getPackageListR" $ do
+getPackageListR =
+    track "Handler.PackageList.getPackageListR" $
     defaultLayout $ do
         setTitle "Package list"
         packages <- getAllPackages
         $(widgetFile "package-list")
-  where strip x = fromMaybe x (stripSuffix "." x)
+  where
+    strip x = fromMaybe x (stripSuffix "." x)
+    makePackageLink snapName pli =
+        SnapshotR snapName $ StackageSdistR $ PNVNameVersion (pliName pli) (pliVersion pli)

src/Handler/Sitemap.hs

@@ -74,7 +74,7 @@ packageMetadataSitemaps = awaitForever go
         url' PackageR
         url' PackageSnapshotsR
       where
-        url' floc = url $ floc $ PackageName $ packageName m
+        url' floc = url $ floc $ PackageNameP $ packageName m
 
 
 url :: Route App -> Sitemap

src/Handler/Snapshots.hs

@@ -1,9 +1,13 @@
-{-# LANGUAGE TupleSections, OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Handler.Snapshots where
 
-import           Data.Time.Clock
-import           Import
+import RIO.Time
+import Import
 import Stackage.Database
 
 snapshotsPerPage :: Integral a => a
@@ -18,7 +22,7 @@ snapshotsPerPage = 50
 -- inclined, or create a single monolithic file.
 getAllSnapshotsR :: Handler TypedContent
 getAllSnapshotsR = track "Handler.Snapshots.getAllSnapshotsR" $ do
-    now' <- liftIO getCurrentTime
+    now' <- getCurrentTime
     currentPageMay <- lookupGetParam "page"
     let currentPage :: Int
         currentPage = fromMaybe 1 (currentPageMay >>= readMay)
@@ -36,9 +40,9 @@ getAllSnapshotsR = track "Handler.Snapshots.getAllSnapshotsR" $ do
         setTitle "Stackage Server"
         let snapshotsNav = $(widgetFile "snapshots-nav")
         $(widgetFile "all-snapshots")
-        
+
       provideRep $ return $ object ["snapshots" .= groups, "totalCount" .= totalCount]
-                
+
   where uncrapify now' snapshot =
             ( snapshotName snapshot
             , snapshotTitle snapshot

src/Handler/StackageHome.hs

@@ -1,3 +1,9 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 module Handler.StackageHome
     ( getStackageHomeR
     , getStackageDiffR
@@ -6,33 +12,34 @@ module Handler.StackageHome
     , getSnapshotPackagesR
     ) where
 
-import Import
+import Data.Ord
 import Data.These
-import Data.Time (FormatTime)
+import RIO.Time (FormatTime)
+import Import
 import Stackage.Database
-import Stackage.Database.Types (isLts)
+import Stackage.Database.Types (PackageListingInfo(..), isLts)
 import Stackage.Snapshot.Diff
 
 getStackageHomeR :: SnapName -> Handler TypedContent
-getStackageHomeR name = track "Handler.StackageHome.getStackageHomeR" $ do
-    Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return
-    previousSnapName <- fromMaybe name . map snd <$> snapshotBefore (snapshotName snapshot)
-    let hoogleForm =
-            let queryText = "" :: Text
-                exact = False
-                mPackageName = Nothing :: Maybe Text
-            in $(widgetFile "hoogle-form")
-    packageCount <- getPackageCount sid
-    packages <- getPackages sid
-    selectRep $ do
-      provideRep $ do
-        defaultLayout $ do
-            setTitle $ toHtml $ snapshotTitle snapshot
-            $(widgetFile "stackage-home")
-      provideRep $ pure $ toJSON $ SnapshotInfo snapshot packages
-
-
-  where strip x = fromMaybe x (stripSuffix "." x)
+getStackageHomeR name =
+    track "Handler.StackageHome.getStackageHomeR" $ do
+        Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return
+        previousSnapName <- fromMaybe name . map snd <$> snapshotBefore (snapshotName snapshot)
+        let hoogleForm =
+                let queryText = "" :: Text
+                    exact = False
+                    mPackageName = Nothing :: Maybe Text
+                 in $(widgetFile "hoogle-form")
+        packages <- getPackagesForSnapshot sid
+        let packageCount = length packages
+        selectRep $ do
+            provideRep $
+                defaultLayout $ do
+                    setTitle $ toHtml $ snapshotTitle snapshot
+                    $(widgetFile "stackage-home")
+            provideRep $ pure $ toJSON $ SnapshotInfo snapshot packages
+  where
+    strip x = fromMaybe x (stripSuffix "." x)
 
 data SnapshotInfo
   = SnapshotInfo { snapshot :: Snapshot
@@ -48,7 +55,7 @@ getStackageDiffR name1 name2 = track "Handler.StackageHome.getStackageDiffR" $ d
     Entity sid1 _ <- lookupSnapshot name1 >>= maybe notFound return
     Entity sid2 _ <- lookupSnapshot name2 >>= maybe notFound return
     (map (snapshotName . entityVal) -> snapNames) <- getSnapshots Nothing 0 0
-    let (ltsSnaps, nightlySnaps) = partition isLts $ reverse $ sort snapNames
+    let (ltsSnaps, nightlySnaps) = partition isLts $ sortOn Down snapNames
     snapDiff <- getSnapshotDiff sid1 sid2
     selectRep $ do
         provideRep $ defaultLayout $ do
@@ -69,7 +76,7 @@ getStackageCabalConfigR name = track "Handler.StackageHome.getStackageCabalConfi
     mglobal <- lookupGetParam "global"
     let isGlobal = mglobal == Just "true"
 
-    plis <- getPackages sid
+    plis <- getPackagesForSnapshot sid
 
     respondSource typePlain $ yieldMany plis .|
         if isGlobal
@@ -119,7 +126,7 @@ getStackageCabalConfigR name = track "Handler.StackageHome.getStackageCabalConfi
     asHttp s = error $ "Unexpected url prefix: " <> unpack s
 
     constraint p
-        | pliIsCore p = toBuilder $ asText " installed"
+        | pliOrigin p == Core = toBuilder $ asText " installed"
         | otherwise = toBuilder (asText " ==") ++
                       toBuilder (pliVersion p)
 
@@ -153,7 +160,7 @@ getDocsR name = track "Handler.StackageHome.getDocsR" $ do
     Entity sid _ <- lookupSnapshot name >>= maybe notFound return
     mlis <- getSnapshotModules sid
     render <- getUrlRender
-    let mliUrl mli = render $ haddockUrl name (mliPackageVersion mli) (mliName mli)
+    let mliUrl mli = render $ haddockUrl name mli
     defaultLayout $ do
         setTitle $ toHtml $ "Module list for " ++ toPathPiece name
         $(widgetFile "doc-list")

src/Handler/StackageIndex.hs

@@ -1,13 +1,15 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 module Handler.StackageIndex where
 
 import Import
-import Stackage.Database
+import Stackage.Database.Types (haddockBucketName)
 
 getStackageIndexR :: SnapName -> Handler TypedContent
-getStackageIndexR slug = do
-    -- Insecure, courtesy of cabal-install
+getStackageIndexR slug =
     redirect $ concat
-        [ "http://haddock.stackage.org/package-index/"
+        [ "https://s3.amazonaws.com/"
+        , haddockBucketName
+        , "/package-index/"
         , toPathPiece slug
         , ".tar.gz"
         ]

src/Handler/StackageSdist.hs

@@ -1,32 +1,53 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 module Handler.StackageSdist
     ( getStackageSdistR
+    , pnvToSnapshotPackageInfo
     ) where
 
 import Import
 import Stackage.Database
+import Stackage.Database.Types (SnapshotPackageInfo(..))
 import Handler.Package (packagePage)
 
-getStackageSdistR :: SnapName -> PackageNameVersion -> Handler TypedContent
-getStackageSdistR _ (PNVTarball name version) = track "Handler.StackageSdist.getStackageSdistR" $ do
-    redirect $ concat
-        -- unfortunately using insecure HTTP for cabal's sake
+handlePNVTarball :: PackageNameP -> VersionP -> Handler TypedContent
+handlePNVTarball name version =
+    redirect $
+    concat -- TODO: Should this be switched to HTTPS by now?
+                -- unfortunately using insecure HTTP for cabal's sake
         [ "http://hackage.fpcomplete.com/package/"
         , toPathPiece name
         , "-"
         , toPathPiece version
         , ".tar.gz"
         ]
-getStackageSdistR sname (PNVName pname) = track "Handler.StackageSdist.getStackageSdistR" $ do
-    version <- versionHelper sname pname
-    redirect $ SnapshotR sname $ StackageSdistR $ PNVNameVersion pname version
-getStackageSdistR sname (PNVNameVersion pname version) = track "Handler.StackageSdist.getStackageSdistR" $ do
-    version' <- versionHelper sname pname
-    if version == version'
-        then packagePage (Just (sname, version)) pname >>= sendResponse
-        else redirect $ SnapshotR sname $ StackageSdistR $ PNVNameVersion pname version'
 
-versionHelper :: SnapName -> PackageName -> Handler Version
-versionHelper sname pname = do
-    Entity sid _ <- lookupSnapshot sname >>= maybe notFound return
-    Entity _ sp <- lookupSnapshotPackage sid (toPathPiece pname) >>= maybe notFound return
-    maybe notFound return $ fromPathPiece $ snapshotPackageVersion sp
+
+getStackageSdistR
+  :: SnapName -> PackageNameVersion -> HandlerFor App TypedContent
+getStackageSdistR sname pnv =
+    track "Handler.StackageSdist.getStackageSdistR" $
+    pnvToSnapshotPackageInfo sname pnv handlePNVTarball $ \isSameVersion spi ->
+        if isSameVersion
+            then packagePage (Just spi) (spiPackageName spi) >>= sendResponse
+            else redirect $
+                 SnapshotR sname $
+                 StackageSdistR $ PNVNameVersion (spiPackageName spi) (spiVersion spi)
+
+
+pnvToSnapshotPackageInfo ::
+       SnapName
+    -> PackageNameVersion
+    -> (PackageNameP -> VersionP -> HandlerFor App b)
+    -> (Bool -> SnapshotPackageInfo -> HandlerFor App b)
+    -> HandlerFor App b
+pnvToSnapshotPackageInfo sname pnv tarballHandler spiHandler =
+    case pnv of
+        PNVName pname -> spiHelper sname pname >>= spiHandler False
+        PNVNameVersion pname version ->
+            spiHelper sname pname >>= \spi -> spiHandler (version == spiVersion spi) spi
+        PNVTarball name version -> tarballHandler name version
+
+
+spiHelper :: SnapName -> PackageNameP -> Handler SnapshotPackageInfo
+spiHelper sname pname = getSnapshotPackageInfo sname pname >>= maybe notFound return
+

src/Import.hs

@@ -1,18 +1,22 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 module Import
     ( module Import
     ) where
 
-import ClassyPrelude.Yesod as Import
+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 Data.Time.Clock (diffUTCTime)
+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)
 
@@ -23,22 +27,19 @@ parseLtsPair t1 = do
     (y, "") <- either (const Nothing) Just $ decimal t3
     Just (x, y)
 
-packageUrl :: SnapName -> PackageName -> Version -> Route App
+packageUrl :: SnapName -> PackageNameP -> VersionP -> Route App
 packageUrl sname pkgname pkgver = SnapshotR sname sdistR
   where
     sdistR = StackageSdistR (PNVNameVersion pkgname pkgver)
 
-haddockUrl :: SnapName
-           -> Text -- ^ package-version
-           -> Text -- ^ module name
-           -> Route App
-haddockUrl sname pkgver name = HaddockR sname
-    [ pkgver
-    , omap toDash name ++ ".html"
-    ]
-  where
-    toDash '.' = '-'
-    toDash c = c
+haddockUrl :: SnapName -> ModuleListingInfo -> Route App
+haddockUrl sname mli =
+    HaddockR
+        sname
+        [toPathPiece (mliPackageIdentifier mli), toPathPiece (mliModuleName mli) <> ".html"]
+
+hoogleHaddockUrl :: SnapName -> PackageNameP -> ModuleNameP -> Route App
+hoogleHaddockUrl sname pname mname = HaddockR sname [toPathPiece pname, toPathPiece mname <> ".html"]
 
 track
     :: MonadIO m

src/Settings.hs

@@ -1,3 +1,7 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
 -- | Settings are centralized, as much as possible, into this file. This
 -- includes database connection settings, static file locations, etc.
 -- In addition, you can configure a number of different aspects of Yesod
@@ -6,16 +10,16 @@
 module Settings where
 
 import ClassyPrelude.Yesod
-import Data.Aeson                  (Result (..), fromJSON, withObject, (.!=),
-                                    (.:?))
-import Data.FileEmbed              (embedFile)
-import Data.Yaml                   (decodeEither')
-import Language.Haskell.TH.Syntax  (Exp, Name, Q)
-import Network.Wai.Handler.Warp    (HostPreference)
-import Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
-import Yesod.Default.Util          (WidgetFileSettings, widgetFileNoReload,
-                                    widgetFileReload, wfsHamletSettings)
+import Data.Aeson (Result(..), fromJSON, withObject, (.!=), (.:?))
+import Data.FileEmbed (embedFile)
+import Data.Yaml (decodeEither')
+import Data.Yaml.Config
+import Language.Haskell.TH.Syntax (Exp, Name, Q)
+import Network.Wai.Handler.Warp (HostPreference)
 import Text.Hamlet
+import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
+import Yesod.Default.Util (WidgetFileSettings, wfsHamletSettings,
+                           widgetFileNoReload, widgetFileReload)
 
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
@@ -118,7 +122,7 @@ configSettingsYmlValue = either impureThrow id $ decodeEither' configSettingsYml
 compileTimeAppSettings :: AppSettings
 compileTimeAppSettings =
     case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
-        Error e -> error e
+        Error e          -> error e
         Success settings -> settings
 
 -- The following two functions can be used to combine multiple CSS or JS files
@@ -136,3 +140,7 @@ combineScripts :: Name -> [Route Static] -> Q Exp
 combineScripts = combineScripts'
     (appSkipCombining compileTimeAppSettings)
     combineSettings
+
+
+getAppSettings :: IO AppSettings
+getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv

src/Settings/StaticFiles.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 module Settings.StaticFiles where
 
 import Settings     (appStaticDir, compileTimeAppSettings)

src/Stackage/Database.hs

@@ -1,850 +1,6 @@
 module Stackage.Database
-    ( StackageDatabase
-    , PostgresConf (..)
-    , GetStackageDatabase (..)
-    , SnapName (..)
-    , SnapshotId ()
-    , Snapshot (..)
-    , closeStackageDatabase
-    , newestSnapshot
-    , newestLTS
-    , newestLTSMajor
-    , newestNightly
-    , ltsMajorVersions
-    , snapshotBefore
-    , lookupSnapshot
-    , snapshotTitle
-    , PackageListingInfo (..)
-    , getAllPackages
-    , getPackages
-    , getPackageVersionBySnapshot
-    , createStackageDatabase
-    , openStackageDatabase
-    , ModuleListingInfo (..)
-    , getSnapshotModules
-    , getPackageModules
-    , SnapshotPackage (..)
-    , lookupSnapshotPackage
-    , getDeprecated
-    , LatestInfo (..)
-    , getLatests
-    , getDeps
-    , getRevDeps
-    , getDepsCount
-    , Package (..)
-    , getPackage
-    , prettyName
-    , prettyNameShort
-    , getSnapshotsForPackage
-    , getSnapshots
-    , countSnapshots
-    , currentSchema
-    , last5Lts5Nightly
-    , lastXLts5Nightly
-    , snapshotsJSON
-    , getPackageCount
-    , getLatestLtsByGhc
+    ( module X
     ) where
-
-import Web.PathPieces (toPathPiece)
-import qualified Codec.Archive.Tar as Tar
-import Database.Esqueleto.Internal.Language (From)
-import CMarkGFM
-import System.Directory (removeFile)
-import Stackage.Database.Haddock
-import System.FilePath (takeBaseName, takeExtension)
-import ClassyPrelude.Conduit hiding (pi)
-import Text.Blaze.Html (Html, toHtml, preEscapedToHtml)
-import Yesod.Form.Fields (Textarea (..))
-import Stackage.Database.Types
-import System.Directory (getAppUserDataDirectory, doesDirectoryExist, createDirectoryIfMissing)
-import System.FilePath (takeFileName, takeDirectory)
-import Data.Conduit.Process
-import Stackage.Types
-import Stackage.Metadata
-import Stackage.PackageIndex.Conduit
-import Web.PathPieces (fromPathPiece)
-import Data.Yaml (decodeFileEither, decodeEither)
-import Database.Persist
-import Database.Persist.Postgresql
-import Database.Persist.TH
-import Control.Monad.Logger
-import System.IO.Temp
-import qualified Database.Esqueleto as E
-import Data.Yaml (decode)
-import qualified Data.Aeson as A
-import Types (SnapshotBranch(..))
-import Data.Pool (destroyAllResources)
-import Data.List (nub)
-
-currentSchema :: Int
-currentSchema = 1
-
-share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-Schema
-    val Int
-    deriving Show
-Imported
-    name SnapName
-    type Text
-    UniqueImported name type
-
-Snapshot
-    name SnapName
-    ghc Text
-    created Day
-    UniqueSnapshot name
-Lts
-    snap SnapshotId
-    major Int
-    minor Int
-    UniqueLts major minor
-Nightly
-    snap SnapshotId
-    day Day
-    UniqueNightly day
-Package
-    name Text
-    latest Text
-    synopsis Text
-    homepage Text
-    author Text
-    maintainer Text
-    licenseName Text
-    description Html
-    changelog Html
-    UniquePackage name
-SnapshotPackage
-    snapshot SnapshotId
-    package PackageId
-    isCore Bool
-    version Text
-    UniqueSnapshotPackage snapshot package
-Module
-    package SnapshotPackageId
-    name Text
-    UniqueModule package name
-Dep
-    user PackageId
-    uses Text -- avoid circular dependency issue when loading database
-    range Text
-    UniqueDep user uses
-Deprecated
-    package PackageId
-    inFavorOf [PackageId]
-    UniqueDeprecated package
-|]
-
-instance A.ToJSON Snapshot where
-  toJSON Snapshot{..} =
-    A.object [ "name"    A..= snapshotName
-             , "ghc"     A..= snapshotGhc
-             , "created" A..= formatTime defaultTimeLocale "%F" snapshotCreated
-             ]
-
-_hideUnusedWarnings
-    :: ( SnapshotPackageId
-       , SchemaId
-       , ImportedId
-       , LtsId
-       , NightlyId
-       , ModuleId
-       , DepId
-       , DeprecatedId
-       ) -> ()
-_hideUnusedWarnings _ = ()
-
-newtype StackageDatabase = StackageDatabase ConnectionPool
-
-closeStackageDatabase :: StackageDatabase -> IO ()
-closeStackageDatabase (StackageDatabase pool) = destroyAllResources pool
-
-class MonadIO m => GetStackageDatabase m where
-    getStackageDatabase :: m StackageDatabase
-instance MonadIO m => GetStackageDatabase (ReaderT StackageDatabase m) where
-    getStackageDatabase = ask
-
-sourcePackages :: MonadResource m => FilePath -> ConduitT i Tar.Entry m ()
-sourcePackages root = do
-    dir <- liftIO $ cloneOrUpdate root "commercialhaskell" "all-cabal-metadata"
-    bracketP
-        (do
-            (fp, h) <- openBinaryTempFile "/tmp" "all-cabal-metadata.tar"
-            hClose h
-            return fp)
-        removeFile
-        $ \fp -> do
-            liftIO $ runIn dir "git" ["archive", "--output", fp, "--format", "tar", "master"]
-            sourceTarFile False fp
-
-sourceBuildPlans :: MonadResource m => FilePath -> ConduitT i (SnapName, FilePath, Either (IO BuildPlan) (IO DocMap)) m ()
-sourceBuildPlans root = do
-    forM_ ["lts-haskell", "stackage-nightly"] $ \repoName -> do
-        dir <- liftIO $ cloneOrUpdate root "fpco" repoName
-        sourceDirectory dir .| concatMapMC (go Left . fromString)
-        let docdir = dir </> "docs"
-        whenM (liftIO $ doesDirectoryExist docdir) $
-            sourceDirectory docdir .| concatMapMC (go Right . fromString)
-  where
-    go wrapper fp | Just name <- nameFromFP fp = liftIO $ do
-        let bp = decodeFileEither fp >>= either throwIO return
-        return $ Just (name, fp, wrapper bp)
-    go _ _ = return Nothing
-
-    nameFromFP fp = do
-        base <- stripSuffix ".yaml" $ pack $ takeFileName fp
-        fromPathPiece base
-
-cloneOrUpdate :: FilePath -> String -> String -> IO FilePath
-cloneOrUpdate root org name = do
-    exists <- doesDirectoryExist dest
-    if exists
-        then do
-            let git = runIn dest "git"
-            git ["fetch"]
-            git ["reset", "--hard", "origin/master"]
-        else runIn root "git" ["clone", url, name]
-    return dest
-  where
-    url = "https://github.com/" ++ org ++ "/" ++ name ++ ".git"
-    dest = root </> fromString name
-
-runIn :: FilePath -> String -> [String] -> IO ()
-runIn dir cmd args =
-    withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
-  where
-    cp = (proc cmd args) { cwd = Just dir }
-
-openStackageDatabase :: MonadIO m => PostgresConf -> m StackageDatabase
-openStackageDatabase pg = liftIO $ do
-    fmap StackageDatabase $ runNoLoggingT $ createPostgresqlPool
-      (pgConnStr pg)
-      (pgPoolSize pg)
-
-getSchema :: PostgresConf -> IO (Maybe Int)
-getSchema fp = do
-    StackageDatabase pool <- openStackageDatabase fp
-    eres <- tryAny $ runSqlPool (selectList [] [Desc SchemaVal, LimitTo 1]) pool
-    case eres of
-        Right [Entity _ (Schema v)] -> return $ Just v
-        _ -> return Nothing
-
-createStackageDatabase :: MonadIO m => PostgresConf -> m ()
-createStackageDatabase fp = liftIO $ do
-    putStrLn "Entering createStackageDatabase"
-    actualSchema <- getSchema fp
-    let schemaMatch = actualSchema == Just currentSchema
-    unless schemaMatch $ do
-        putStrLn $ "Current schema does not match actual schema: " ++ tshow (actualSchema, currentSchema)
-
-    StackageDatabase pool <- openStackageDatabase fp
-    flip runSqlPool pool $ do
-        runMigration migrateAll
-        unless schemaMatch $ do
-          deleteWhere ([] :: [Filter Schema])
-          insert_ $ Schema currentSchema
-
-    root <- liftIO $ (</> "database") <$> getAppUserDataDirectory "stackage"
-    createDirectoryIfMissing True root
-    runResourceT $ do
-        putStrLn "Updating all-cabal-metadata repo"
-        flip runSqlPool pool $ runConduit $ sourcePackages root .| getZipSink
-            ( ZipSink (mapM_C addPackage)
-           *> ZipSink (do
-                deprs <- foldlC getDeprecated' []
-                lift $ do
-                    deleteWhere ([] :: [Filter Deprecated])
-                    mapM_ addDeprecated deprs)
-           *> ZipSink (
-                let loop i =
-                        await >>= maybe (return ()) (const $ go $ i + 1)
-                    go i = do
-                        when (i `mod` 500 == 0)
-                            $ putStrLn $ concat
-                                [ "Processed "
-                                , tshow i
-                                , " packages"
-                                ]
-                        loop i
-                 in loop (0 :: Int))
-            )
-        runConduit $ sourceBuildPlans root .| mapM_C (\(sname, fp', eval) -> flip runSqlPool pool $ do
-            let (typ, action) =
-                    case eval of
-                        Left bp -> ("build-plan", liftIO bp >>= addPlan sname fp')
-                        Right dm -> ("doc-map", liftIO dm >>= addDocMap sname)
-            let i = Imported sname typ
-            eres <- insertBy i
-            case eres of
-                Left _ -> putStrLn $ "Skipping: " ++ tshow fp'
-                Right _ -> action
-            )
-        flip runSqlPool pool $ mapM_ (flip rawExecute []) ["COMMIT", "VACUUM", "BEGIN"]
-
-getDeprecated' :: [Deprecation] -> Tar.Entry -> [Deprecation]
-getDeprecated' orig e =
-    case (Tar.entryPath e, Tar.entryContent e) of
-        ("deprecated.yaml", Tar.NormalFile lbs _) ->
-            case decode $ toStrict lbs of
-                Just x -> x
-                Nothing -> orig
-        _ -> orig
-
-addDeprecated :: Deprecation -> SqlPersistT (ResourceT IO) ()
-addDeprecated (Deprecation name others) = do
-    name' <- getPackageId name
-    others' <- mapM getPackageId $ setToList others
-    insert_ $ Deprecated name' others'
-
-getPackageId :: MonadIO m => Text -> ReaderT SqlBackend m (Key Package)
-getPackageId x = do
-    keys' <- selectKeysList [PackageName ==. x] [LimitTo 1]
-    case keys' of
-        k:_ -> return k
-        [] -> insert Package
-            { packageName = x
-            , packageLatest = "unknown"
-            , packageSynopsis = "Metadata not found"
-            , packageDescription = "Metadata not found"
-            , packageChangelog = mempty
-            , packageAuthor = ""
-            , packageMaintainer = ""
-            , packageHomepage = ""
-            , packageLicenseName = ""
-            }
-
-addPackage :: Tar.Entry -> SqlPersistT (ResourceT IO) ()
-addPackage e =
-    case ("packages/" `isPrefixOf` fp && takeExtension fp == ".yaml", Tar.entryContent e) of
-        (True, Tar.NormalFile lbs _) ->
-          case decodeEither $ toStrict lbs of
-            Left err -> putStrLn $ "ERROR: Could not parse " ++ tshow fp ++ ": " ++ tshow err
-            Right pi -> onParse pi
-        _ -> return ()
-  where
-    onParse pi = do
-            let p = Package
-                    { packageName = pack base
-                    , packageLatest = display $ piLatest pi
-                    , packageSynopsis = piSynopsis pi
-                    , packageDescription = renderContent (piDescription pi) (piDescriptionType pi)
-                    , packageChangelog = renderContent (piChangeLog pi) (piChangeLogType pi)
-                    , packageAuthor = piAuthor pi
-                    , packageMaintainer = piMaintainer pi
-                    , packageHomepage = piHomepage pi
-                    , packageLicenseName = piLicenseName pi
-                    }
-
-            mp <- getBy $ UniquePackage $ packageName p
-            pid <- case mp of
-                Just (Entity pid _) -> do
-                    replace pid p
-                    return pid
-                Nothing -> insert p
-            deleteWhere [DepUser ==. pid]
-            forM_ (mapToList $ piBasicDeps pi) $ \(uses, range) -> insert_ Dep
-                { depUser = pid
-                , depUses = display uses
-                , depRange = display range
-                }
-
-    fp = Tar.entryPath e
-    base = takeBaseName fp
-
-    renderContent txt "markdown" = preEscapedToHtml $ commonmarkToHtml
-                                    [optSmart]
-                                    [extTable, extAutolink]
-                                    txt
-    renderContent txt "haddock" = renderHaddock txt
-    renderContent txt _ = toHtml $ Textarea txt
-
-addPlan :: SnapName -> FilePath -> BuildPlan -> SqlPersistT (ResourceT IO) ()
-addPlan name fp bp = do
-    putStrLn $ "Adding build plan: " ++ toPathPiece name
-    created <-
-        case name of
-            SNNightly d -> return d
-            SNLts _ _ -> do
-                let cp' = proc "git"
-                        [ "log"
-                        , "--format=%ad"
-                        , "--date=short"
-                        , takeFileName fp
-                        ]
-                    cp = cp' { cwd = Just $ takeDirectory fp }
-                t <- withCheckedProcess cp $ \ClosedStream out ClosedStream ->
-                    runConduit $ out .| decodeUtf8C .| foldC
-                case readMay $ concat $ take 1 $ words t of
-                    Just created -> return created
-                    Nothing -> do
-                        putStrLn $ "Warning: unknown git log output: " ++ tshow t
-                        return $ fromGregorian 1970 1 1
-    sid <- insert Snapshot
-        { snapshotName = name
-        , snapshotGhc = display $ siGhcVersion $ bpSystemInfo bp
-        , snapshotCreated = created
-        }
-    forM_ allPackages $ \(display -> pname, (display -> version, isCore)) -> do
-        pid <- getPackageId pname
-        insert_ SnapshotPackage
-            { snapshotPackageSnapshot = sid
-            , snapshotPackagePackage = pid
-            , snapshotPackageIsCore = isCore
-            , snapshotPackageVersion = version
-            }
-    case name of
-        SNLts x y -> insert_ Lts
-            { ltsSnap = sid
-            , ltsMajor = x
-            , ltsMinor = y
-            }
-        SNNightly d -> insert_ Nightly
-            { nightlySnap = sid
-            , nightlyDay = d
-            }
-  where
-    allPackages = mapToList
-        $ fmap (, True) (siCorePackages $ bpSystemInfo bp)
-       ++ fmap ((, False) . ppVersion) (bpPackages bp)
-
-addDocMap :: SnapName -> DocMap -> SqlPersistT (ResourceT IO) ()
-addDocMap name dm = do
-    [sid] <- selectKeysList [SnapshotName ==. name] []
-    putStrLn $ "Adding doc map: " ++ toPathPiece name
-    forM_ (mapToList dm) $ \(pkg, pd) -> do
-        pids <- selectKeysList [PackageName ==. pkg] []
-        pid <-
-          case pids of
-            [pid] -> return pid
-            _ -> error $ "addDocMap (1): " ++ show (name, pkg, pids)
-        spids <- selectKeysList [SnapshotPackageSnapshot ==. sid, SnapshotPackagePackage ==. pid] []
-        case spids of
-          [spid] ->
-            forM_ (mapToList $ pdModules pd) $ \(mname, _paths) ->
-                insert_ Module
-                    { modulePackage = spid
-                    , moduleName = mname
-                    }
-          -- FIXME figure out why this happens for the ghc package with GHC 8.2.1
-          _ -> sayErrString $ "addDocMap (2): " ++ show (name, pkg, pid, spids)
-
-run :: GetStackageDatabase m => SqlPersistT IO a -> m a
-run inner = do
-    StackageDatabase pool <- getStackageDatabase
-    liftIO $ runSqlPool inner pool
-
-newestSnapshot :: GetStackageDatabase m => SnapshotBranch -> m (Maybe SnapName)
-newestSnapshot LtsBranch = map (uncurry SNLts) <$> newestLTS
-newestSnapshot NightlyBranch = map SNNightly <$> newestNightly
-newestSnapshot (LtsMajorBranch x) = map (SNLts x) <$> newestLTSMajor x
-
-newestLTS :: GetStackageDatabase m => m (Maybe (Int, Int))
-newestLTS =
-    run $ liftM (fmap go) $ selectFirst [] [Desc LtsMajor, Desc LtsMinor]
-  where
-    go (Entity _ lts) = (ltsMajor lts, ltsMinor lts)
-
-newestLTSMajor :: GetStackageDatabase m => Int -> m (Maybe Int)
-newestLTSMajor x =
-    run $ liftM (fmap $ ltsMinor . entityVal) $ selectFirst [LtsMajor ==. x] [Desc LtsMinor]
-
-ltsMajorVersions :: GetStackageDatabase m => m [(Int, Int)]
-ltsMajorVersions =
-    run $ liftM (dropOldMinors . map (toPair . entityVal))
-        $ selectList [] [Desc LtsMajor, Desc LtsMinor]
-  where
-    toPair (Lts _ x y) = (x, y)
-
-    dropOldMinors [] = []
-    dropOldMinors (l@(x, _):rest) =
-        l : dropOldMinors (dropWhile sameMinor rest)
-      where
-        sameMinor (y, _) = x == y
-
-newestNightly :: GetStackageDatabase m => m (Maybe Day)
-newestNightly =
-    run $ liftM (fmap $ nightlyDay . entityVal) $ selectFirst [] [Desc NightlyDay]
-
--- | Get the snapshot which precedes the given one with respect to it's branch (nightly/lts)
-snapshotBefore :: GetStackageDatabase m => SnapName -> m (Maybe (SnapshotId, SnapName))
-snapshotBefore (SNLts x y)     = ltsBefore x y
-snapshotBefore (SNNightly day) = nightlyBefore day
-
-nightlyBefore :: GetStackageDatabase m => Day -> m (Maybe (SnapshotId, SnapName))
-nightlyBefore day = do
-    run $ liftM (fmap go) $ selectFirst [NightlyDay <. day] [Desc NightlyDay]
-  where
-    go (Entity _ nightly) = (nightlySnap nightly, SNNightly $ nightlyDay nightly)
-
-ltsBefore :: GetStackageDatabase m => Int -> Int -> m (Maybe (SnapshotId, SnapName))
-ltsBefore x y = do
-    run $ liftM (fmap go) $ selectFirst
-        ( [LtsMajor <=. x, LtsMinor <. y] ||.
-          [LtsMajor <. x]
-        )
-        [Desc LtsMajor, Desc LtsMinor]
-  where
-    go (Entity _ lts) = (ltsSnap lts, SNLts (ltsMajor lts) (ltsMinor lts))
-
-lookupSnapshot :: GetStackageDatabase m => SnapName -> m (Maybe (Entity Snapshot))
-lookupSnapshot name = run $ getBy $ UniqueSnapshot name
-
-snapshotTitle :: Snapshot -> Text
-snapshotTitle s = prettyName (snapshotName s) (snapshotGhc s)
-
-prettyName :: SnapName -> Text -> Text
-prettyName name ghc = concat [prettyNameShort name, " (ghc-", ghc, ")"]
-
-prettyNameShort :: SnapName -> Text
-prettyNameShort name =
-    case name of
-        SNLts x y -> concat ["LTS Haskell ", tshow x, ".", tshow y]
-        SNNightly d -> "Stackage Nightly " ++ tshow d
-
-getAllPackages :: GetStackageDatabase m => m [(Text, Text, Text)] -- FIXME add information on whether included in LTS and Nightly
-getAllPackages = liftM (map toPair) $ run $ do
-    E.select $ E.from $ \p -> do
-        E.orderBy [E.asc $ E.lower_ $ p E.^. PackageName]
-        return
-            ( p E.^. PackageName
-            , p E.^. PackageLatest
-            , p E.^. PackageSynopsis
-            )
-  where
-    toPair (E.Value x, E.Value y, E.Value z) = (x, y, z)
-
-data PackageListingInfo = PackageListingInfo
-    { pliName :: !Text
-    , pliVersion :: !Text
-    , pliSynopsis :: !Text
-    , pliIsCore :: !Bool
-    }
-
-instance A.ToJSON PackageListingInfo where
-   toJSON PackageListingInfo{..} =
-       A.object [ "name"     A..= pliName
-                , "version"  A..= pliVersion
-                , "synopsis" A..= pliSynopsis
-                , "isCore"   A..= pliIsCore
-                ]
-
-getPackages :: GetStackageDatabase m => SnapshotId -> m [PackageListingInfo]
-getPackages sid = liftM (map toPLI) $ run $ do
-    E.select $ E.from $ \(p,sp) -> do
-        E.where_ $
-            (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage) E.&&.
-            (sp E.^. SnapshotPackageSnapshot E.==. E.val sid)
-        E.orderBy [E.asc $ E.lower_ $ p E.^. PackageName]
-        return
-            ( p E.^. PackageName
-            , p E.^. PackageSynopsis
-            , sp E.^. SnapshotPackageVersion
-            , sp E.^. SnapshotPackageIsCore
-            )
-  where
-    toPLI (E.Value name, E.Value synopsis, E.Value version, E.Value isCore) = PackageListingInfo
-        { pliName = name
-        , pliVersion = version
-        , pliSynopsis = synopsis
-        , pliIsCore = isCore
-        }
-
-getPackageVersionBySnapshot
-  :: GetStackageDatabase m
-  => SnapshotId -> Text -> m (Maybe Text)
-getPackageVersionBySnapshot sid name = liftM (listToMaybe . map toPLI) $ run $ do
-    E.select $ E.from $ \(p,sp) -> do
-        E.where_ $
-            (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage) E.&&.
-            (sp E.^. SnapshotPackageSnapshot E.==. E.val sid) E.&&.
-            (E.lower_ (p E.^. PackageName) E.==. E.lower_ (E.val name))
-        E.orderBy [E.asc $ E.lower_ $ p E.^. PackageName]
-        return
-            ( sp E.^. SnapshotPackageVersion
-            )
-  where
-    toPLI (E.Value version) = version
-
-data ModuleListingInfo = ModuleListingInfo
-    { mliName :: !Text
-    , mliPackageVersion :: !Text
-    }
-
-getSnapshotModules
-    :: GetStackageDatabase m
-    => SnapshotId
-    -> m [ModuleListingInfo]
-getSnapshotModules sid = liftM (map toMLI) $ run $ do
-    E.select $ E.from $ \(p,sp,m) -> do
-        E.where_ $
-            (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage) E.&&.
-            (sp E.^. SnapshotPackageSnapshot E.==. E.val sid) E.&&.
-            (m E.^. ModulePackage E.==. sp E.^. SnapshotPackageId)
-        E.orderBy
-            [ E.asc $ m E.^. ModuleName
-            , E.asc $ E.lower_ $ p E.^. PackageName
-            ]
-        return
-            ( m E.^. ModuleName
-            , p E.^. PackageName
-            , sp E.^. SnapshotPackageVersion
-            )
-  where
-    toMLI (E.Value name, E.Value pkg, E.Value version) = ModuleListingInfo
-        { mliName = name
-        , mliPackageVersion = concat [pkg, "-", version]
-        }
-
-getPackageModules
-    :: GetStackageDatabase m
-    => SnapName
-    -> Text
-    -> m [Text]
-getPackageModules sname pname = run $ do
-    sids <- selectKeysList [SnapshotName ==. sname] []
-    pids <- selectKeysList [PackageName ==. pname] []
-    case (,) <$> listToMaybe sids <*> listToMaybe pids of
-        Nothing -> return []
-        Just (sid, pid) -> do
-            spids <- selectKeysList
-                [ SnapshotPackageSnapshot ==. sid
-                , SnapshotPackagePackage ==. pid
-                ] []
-            case spids of
-                spid:_ -> map (moduleName . entityVal)
-                      <$> selectList [ModulePackage ==. spid] [Asc ModuleName]
-                [] -> return []
-
-lookupSnapshotPackage
-    :: GetStackageDatabase m
-    => SnapshotId
-    -> Text
-    -> m (Maybe (Entity SnapshotPackage))
-lookupSnapshotPackage sid pname = run $ do
-    mp <- getBy $ UniquePackage pname
-    case mp of
-        Nothing -> return Nothing
-        Just (Entity pid _) -> getBy $ UniqueSnapshotPackage sid pid
-
-getDeprecated :: GetStackageDatabase m => Text -> m (Bool, [Text])
-getDeprecated name = run $ do
-    pids <- selectKeysList [PackageName ==. name] []
-    case pids of
-        [pid] -> do
-            mdep <- getBy $ UniqueDeprecated pid
-            case mdep of
-                Nothing -> return defRes
-                Just (Entity _ (Deprecated _ favors)) -> do
-                    names <- mapM getName favors
-                    return (True, catMaybes names)
-        _ -> return defRes
-  where
-    defRes = (False, [])
-
-    getName = fmap (fmap packageName) . get
-
-data LatestInfo = LatestInfo
-    { liSnapName :: !SnapName
-    , liVersion :: !Text
-    , liGhc :: !Text
-    }
-    deriving (Show, Eq)
-
-getLatests :: GetStackageDatabase m
-           => Text -- ^ package name
-           -> m [LatestInfo]
-getLatests pname = run $ fmap (nub . concat) $ forM [True, False] $ \requireDocs -> do
-    mlts <- latestHelper pname requireDocs
-        (\s ln -> s E.^. SnapshotId E.==. ln E.^. LtsSnap)
-        (\_ ln ->
-            [ E.desc $ ln E.^. LtsMajor
-            , E.desc $ ln E.^. LtsMinor
-            ])
-    mnightly <- latestHelper pname requireDocs
-        (\s ln -> s E.^. SnapshotId E.==. ln E.^. NightlySnap)
-        (\s _ln -> [E.desc $ s E.^. SnapshotCreated])
-    return $ concat [mlts, mnightly]
-
-latestHelper
-    :: (From E.SqlQuery E.SqlExpr SqlBackend t, MonadIO m, Functor m)
-    => Text -- ^ package name
-    -> Bool -- ^ require docs?
-    -> (E.SqlExpr (Entity Snapshot) -> t -> E.SqlExpr (E.Value Bool))
-    -> (E.SqlExpr (Entity Snapshot) -> t -> [E.SqlExpr E.OrderBy])
-    -> ReaderT SqlBackend m [LatestInfo]
-latestHelper pname requireDocs clause order = do
-  results <- E.select $ E.from $ \(s,ln,p,sp) -> do
-    E.where_ $
-        clause s ln E.&&.
-        (s E.^. SnapshotId E.==. sp E.^. SnapshotPackageSnapshot) E.&&.
-        (p E.^. PackageName E.==. E.val pname) E.&&.
-        (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage)
-    E.orderBy $ order s ln
-    E.limit 1
-    return
-        ( s E.^. SnapshotName
-        , s E.^. SnapshotGhc
-        , sp E.^. SnapshotPackageVersion
-        , sp E.^. SnapshotPackageId
-        )
-  if requireDocs
-    then
-      case results of
-        tuple@(_, _, _, E.Value spid):_ -> do
-          x <- count [ModulePackage ==. spid]
-          return $ if x > 0 then [toLatest tuple] else []
-        [] -> return []
-    else return $ map toLatest results
-  where
-    toLatest (E.Value sname, E.Value ghc, E.Value version, _) = LatestInfo
-        { liSnapName = sname
-        , liVersion = version
-        , liGhc = ghc
-        }
-
-getDeps :: GetStackageDatabase m => Text -> Maybe Int -> m [(Text, Text)]
-getDeps pname mcount = run $ do
-    mp <- getBy $ UniquePackage pname
-    case mp of
-        Nothing -> return []
-        Just (Entity pid _) -> fmap (map toPair) $ E.select $ E.from $ \d -> do
-            E.where_ $
-                (d E.^. DepUser E.==. E.val pid)
-            E.orderBy [E.asc $ d E.^. DepUses]
-            forM_ mcount $ E.limit . fromIntegral
-            return (d E.^. DepUses, d E.^. DepRange)
-  where
-    toPair (E.Value x, E.Value y) = (x, y)
-
-getRevDeps :: GetStackageDatabase m => Text -> Maybe Int -> m [(Text, Text)]
-getRevDeps pname mcount = run $ do
-    fmap (map toPair) $ E.select $ E.from $ \(d,p) -> do
-        E.where_ $
-            (d E.^. DepUses E.==. E.val pname) E.&&.
-            (d E.^. DepUser E.==. p E.^. PackageId)
-        E.orderBy [E.asc $ p E.^. PackageName]
-        forM_ mcount $ E.limit . fromIntegral
-        return (p E.^. PackageName, d E.^. DepRange)
-  where
-    toPair (E.Value x, E.Value y) = (x, y)
-
-getDepsCount :: GetStackageDatabase m => Text -> m (Int, Int)
-getDepsCount pname = run $ (,)
-  <$> (do
-          mp <- getBy $ UniquePackage pname
-          case mp of
-            Nothing -> return 0
-            Just (Entity pid _) -> count [DepUser ==. pid]
-      )
-  <*> count [DepUses ==. pname]
-
-getPackage :: GetStackageDatabase m => Text -> m (Maybe (Entity Package))
-getPackage = run . getBy . UniquePackage
-
-getSnapshotsForPackage
-    :: GetStackageDatabase m
-    => Text
-    -> m [(Snapshot, Text)] -- version
-getSnapshotsForPackage pname = run $ do
-    pid <- getPackageId pname
-    fmap (map go) $ E.select $ E.from $ \(s, sp) -> do
-      E.where_ $ s E.^. SnapshotId E.==. sp E.^. SnapshotPackageSnapshot
-          E.&&. sp E.^. SnapshotPackagePackage E.==. E.val pid
-      E.orderBy [E.desc $ s E.^. SnapshotCreated]
-      return (s, sp E.^. SnapshotPackageVersion)
-  where
-    go (Entity _ snapshot, E.Value version) = (snapshot, version)
-
--- | Count snapshots that belong to a specific SnapshotBranch
-countSnapshots :: (GetStackageDatabase m) => Maybe SnapshotBranch -> m Int
-countSnapshots Nothing                   = run $ count ([] :: [Filter Snapshot])
-countSnapshots (Just NightlyBranch)      = run $ count ([] :: [Filter Nightly])
-countSnapshots (Just LtsBranch)          = run $ count ([] :: [Filter Lts])
-countSnapshots (Just (LtsMajorBranch x)) = run $ count [LtsMajor ==. x]
-
--- | Get snapshots that belong to a specific SnapshotBranch
-getSnapshots :: (GetStackageDatabase m)
-             => Maybe SnapshotBranch
-             -> Int -- ^ limit
-             -> Int -- ^ offset
-             -> m [Entity Snapshot]
-getSnapshots mBranch l o = run $ case mBranch of
-    Nothing -> selectList [] [LimitTo l, OffsetBy o, Desc SnapshotCreated]
-    Just NightlyBranch ->
-        E.select $ E.from $ \(nightly `E.InnerJoin` snapshot) -> do
-            E.on $ nightly E.^. NightlySnap E.==. snapshot E.^. SnapshotId
-            E.orderBy [E.desc (nightly E.^. NightlyDay)]
-            E.limit $ fromIntegral l
-            E.offset $ fromIntegral o
-            pure snapshot
-    Just LtsBranch -> do
-        E.select $ E.from $ \(lts `E.InnerJoin` snapshot) -> do
-            E.on $ lts E.^. LtsSnap E.==. snapshot E.^. SnapshotId
-            E.orderBy [ E.desc (lts E.^. LtsMajor)
-                      , E.desc (lts E.^. LtsMinor) ]
-            E.limit $ fromIntegral l
-            E.offset $ fromIntegral o
-            pure snapshot
-    Just (LtsMajorBranch v) -> do
-        E.select $ E.from $ \(lts `E.InnerJoin` snapshot) -> do
-            E.on $ lts E.^. LtsSnap E.==. snapshot E.^. SnapshotId
-            E.orderBy [E.desc (lts E.^. LtsMinor)]
-            E.where_ ((lts E.^. LtsMajor) E.==. (E.val v))
-            E.limit $ fromIntegral l
-            E.offset $ fromIntegral o
-            pure snapshot
-
-last5Lts5Nightly :: GetStackageDatabase m => m [SnapName]
-last5Lts5Nightly = lastXLts5Nightly 5
-
-lastXLts5Nightly :: GetStackageDatabase m => Int -> m [SnapName]
-lastXLts5Nightly ltsCount = run $ do
-    ls <- selectList [] [Desc LtsMajor, Desc LtsMinor, LimitTo ltsCount]
-    ns <- selectList [] [Desc NightlyDay, LimitTo 5]
-    return $ map l ls ++ map n ns
-  where
-    l (Entity _ x) = SNLts (ltsMajor x) (ltsMinor x)
-    n (Entity _ x) = SNNightly (nightlyDay x)
-
-snapshotsJSON :: GetStackageDatabase m => m A.Value
-snapshotsJSON = do
-    mlatestNightly <- newestNightly
-    ltses <- ltsMajorVersions
-    let lts = case ltses of
-            [] -> []
-            majorVersions@(latest:_) ->
-                   ("lts" A..= printLts latest)
-                 : map toObj majorVersions
-        nightly = case mlatestNightly of
-            Nothing -> id
-            Just n -> (("nightly" A..= printNightly n):)
-    return $ A.object $ nightly lts
-  where
-    toObj lts@(major, _) =
-        pack ("lts-" ++ show major) A..= printLts lts
-    printLts (major, minor) =
-        "lts-" ++ show major ++ "." ++ show minor
-
-    printNightly day = "nightly-" ++ tshow day
-
-getPackageCount :: GetStackageDatabase m
-                => SnapshotId
-                -> m Int
-getPackageCount sid = run $ count [SnapshotPackageSnapshot ==. sid]
-
-getLatestLtsByGhc :: GetStackageDatabase m
-                  => m [(Int, Int, Text, Day)]
-getLatestLtsByGhc = run $ fmap (dedupe . map toTuple) $ do
-    E.select $ E.from $ \(lts `E.InnerJoin` snapshot) -> do
-        E.on $ lts E.^. LtsSnap E.==. snapshot E.^. SnapshotId
-        E.orderBy [E.desc (lts E.^. LtsMajor), E.desc (lts E.^. LtsMinor)]
-        E.groupBy (snapshot E.^. SnapshotGhc, lts E.^. LtsId, lts E.^. LtsMajor, lts E.^. LtsMinor, snapshot E.^. SnapshotId)
-        return (lts, snapshot)
-  where
-    toTuple (Entity _ lts, Entity _ snapshot) =
-        (ltsMajor lts, ltsMinor lts, snapshotGhc snapshot, snapshotCreated snapshot)
-
-    dedupe [] = []
-    dedupe (x:xs) = x : dedupe (dropWhile (\y -> thd x == thd y) xs)
-
-    thd (_, _, x, _) = x
+import Stackage.Database.Schema as X
+import Stackage.Database.Query as X
+import Stackage.Database.Types as X

src/Stackage/Database/Cron.hs

@@ -1,42 +1,74 @@
-{-# LANGUAGE CPP#-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 module Stackage.Database.Cron
     ( stackageServerCron
     , newHoogleLocker
     , singleRun
+    , StackageCronOptions(..)
+    , haddockBucketName
     ) where
 
-import ClassyPrelude.Conduit
-import Stackage.PackageIndex.Conduit
-import Database.Persist (Entity (Entity))
-import qualified Codec.Archive.Tar as Tar
-import Stackage.Database
+import Conduit
+import Control.Lens ((.~))
+import qualified Control.Monad.Trans.AWS as AWS (paginate)
+import Control.SingleRun
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Conduit.Binary as CB
+import Data.Conduit.Tar (FileInfo(..), FileType(..), untar)
+import Data.Conduit.Zlib (WindowBits(WindowBits), compress, ungzip)
+import qualified Data.IntMap.Strict as IntMap
+import Data.Monoid (Any(..))
+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 System.Directory
-import Web.PathPieces (toPathPiece)
-import Network.HTTP.Types (status200)
-import           Data.Streaming.Network (bindPortTCP)
-import           Network.AWS                   (Credentials (Discover), newEnv,
-                                                send, chunkedFile, defaultChunkSize,
-                                                envManager, runAWS)
-import           Control.Monad.Trans.AWS       (trying, _Error)
-import           Network.AWS.Data.Body         (toBody)
-import           Network.AWS.S3                (ObjectCannedACL (OPublicRead),
-                                                poACL, poContentType, putObject,
-                                                BucketName(BucketName),
-                                                ObjectKey(ObjectKey))
-import Control.Lens (set, view)
-import qualified Data.Conduit.Binary as CB
-import           Data.Conduit.Zlib             (WindowBits (WindowBits),
-                                                compress, ungzip)
-import qualified Hoogle
-import Control.SingleRun
-import qualified Data.ByteString.Lazy as L
-import System.FilePath (splitPath, takeDirectory)
-import System.Environment (getEnv)
+import Network.HTTP.Simple (getResponseBody, httpJSONEither, parseRequest)
+import Network.HTTP.Types (status200, status404)
+import Pantry (CabalFileInfo(..), DidUpdateOccur(..),
+               HpackExecutable(HpackBundled), PackageIdentifierRevision(..),
+               defaultHackageSecurityConfig)
+import Pantry.Internal.Stackage (HackageCabalId, HackageTarballResult(..),
+                                 PantryConfig(..), Storage(..),
+                                 forceUpdateHackageIndex, getHackageTarball,
+                                 getTreeForKey, loadBlobById, packageTreeKey,
+                                 treeCabal)
+import Path (parseAbsDir, toFilePath)
+import RIO
+import RIO.Directory
+import RIO.FilePath
+import RIO.List as L
+import qualified RIO.Map as Map
+import RIO.Process (mkDefaultProcessContext)
+import qualified RIO.Set as Set
+import qualified RIO.Text as T
+import RIO.Time
+import Settings
+import Stackage.Database.Github
+import Stackage.Database.PackageInfo
+import Stackage.Database.Query
+import Stackage.Database.Schema
+import Stackage.Database.Types
+import System.Environment (lookupEnv)
+import UnliftIO.Concurrent (getNumCapabilities)
+import Web.PathPieces (fromPathPiece, toPathPiece)
+
+
 
 hoogleKey :: SnapName -> Text
-hoogleKey name = concat
+hoogleKey name = T.concat
     [ "hoogle/"
     , toPathPiece name
     , "/"
@@ -45,202 +77,677 @@ hoogleKey name = concat
     ]
 
 hoogleUrl :: SnapName -> Text
-hoogleUrl n = concat
-    [ "https://s3.amazonaws.com/haddock.stackage.org/"
+hoogleUrl n = T.concat
+    [ "https://s3.amazonaws.com/"
+    , haddockBucketName
+    , "/"
     , hoogleKey n
     ]
 
-newHoogleLocker :: Bool -- ^ print exceptions?
-                -> Manager
-                -> IO (SingleRun SnapName (Maybe FilePath))
-newHoogleLocker toPrint man = mkSingleRun $ \name -> do
-    let fp = unpack $ hoogleKey name
-        fptmp = fp <.> "tmp"
 
-    exists <- doesFileExist fp
-    if exists
-        then return $ Just fp
-        else do
-            req' <- parseRequest $ unpack $ hoogleUrl name
-            let req = req' { decompress = const False }
-            withResponse req man $ \res -> if responseStatus res == status200
-                then do
-                    createDirectoryIfMissing True $ takeDirectory fptmp
-                    runConduitRes
-                       $ bodyReaderSource (responseBody res)
-                      .| ungzip
-                      .| sinkFile fptmp
-                    renamePath fptmp fp
-                    return $ Just fp
+hackageDeprecatedUrl :: Request
+hackageDeprecatedUrl = "https://hackage.haskell.org/packages/deprecated.json"
+
+withStorage :: Int -> (Storage -> IO a) -> IO a
+withStorage poolSize inner = do
+    connstr <-
+        lookupEnv "PGSTRING" >>= \case
+            Just connstr -> pure (T.pack connstr)
+            Nothing -> appPostgresString <$> getAppSettings
+    withStackageDatabase
+        False
+        PostgresConf {pgPoolSize = poolSize, pgConnStr = encodeUtf8 connstr}
+        (\ db -> inner (Storage (runDatabase db) id))
+
+
+getStackageSnapshotsDir :: RIO StackageCron FilePath
+getStackageSnapshotsDir = do
+    cron <- ask
+    cloneOrUpdate (scStackageRoot cron) (scSnapshotsRepo cron)
+
+
+withResponseUnliftIO :: MonadUnliftIO m => Request -> Manager -> (Response BodyReader -> m b) -> m b
+withResponseUnliftIO req man f = withRunInIO $ \ runInIO -> withResponse req man (runInIO . f)
+
+newHoogleLocker ::
+       (HasLogFunc env, MonadIO m) => env -> Manager -> m (SingleRun SnapName (Maybe FilePath))
+newHoogleLocker env man = mkSingleRun hoogleLocker
+  where
+    hoogleLocker :: MonadIO n => SnapName -> n (Maybe FilePath)
+    hoogleLocker name =
+        runRIO env $ do
+            let fp = T.unpack $ hoogleKey name
+                fptmp = fp <.> "tmp"
+            exists <- doesFileExist fp
+            if exists
+                then return $ Just fp
                 else do
-                    when toPrint $ mapM brRead res >>= print
+                    req' <- parseRequest $ T.unpack $ hoogleUrl name
+                    let req = req' {decompress = const False}
+                    withResponseUnliftIO req man $ \res ->
+                        case responseStatus res of
+                            status
+                                | status == status200 -> do
+                                    createDirectoryIfMissing True $ takeDirectory fptmp
+                                    -- TODO: https://github.com/commercialhaskell/rio/issues/160
+                                    -- withBinaryFileDurableAtomic fp WriteMode $ \h ->
+                                    --     runConduitRes $
+                                    --     bodyReaderSource (responseBody res) .| ungzip .|
+                                    --     sinkHandle h
+                                    runConduitRes $
+                                        bodyReaderSource (responseBody res) .| ungzip .|
+                                        sinkFile fptmp
+                                    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
+
+getHackageDeprecations ::
+       (HasLogFunc env, MonadReader env m, MonadIO m) => m [Deprecation]
+getHackageDeprecations = do
+    jsonResponseDeprecated <- httpJSONEither hackageDeprecatedUrl
+    case getResponseBody jsonResponseDeprecated of
+        Left err -> do
+            logError $
+                "There was an error parsing deprecated.json file: " <>
+                fromString (displayException err)
+            return []
+        Right deprecated -> return deprecated
+
+
+stackageServerCron :: StackageCronOptions -> IO ()
+stackageServerCron StackageCronOptions {..} = do
+    void $
+        -- Hacky approach instead of PID files
+        catchIO (bindPortTCP 17834 "127.0.0.1") $
+        const $ throwString "Stackage Cron loader process already running, exiting."
+    connectionCount <- getNumCapabilities
+    withStorage connectionCount $ \storage -> do
+        lo <- logOptionsHandle stdout True
+        stackageRootDir <- getAppUserDataDirectory "stackage"
+        pantryRootDir <- parseAbsDir (stackageRootDir </> "pantry")
+        createDirectoryIfMissing True (toFilePath pantryRootDir)
+        updateRef <- newMVar True
+        cabalImmutable <- newIORef Map.empty
+        cabalMutable <- newIORef Map.empty
+        gpdCache <- newIORef IntMap.empty
+        defaultProcessContext <- mkDefaultProcessContext
+        aws <- newEnv Discover
+        withLogFunc (setLogMinLevel scoLogLevel lo) $ \logFunc ->
+            let pantryConfig =
+                    PantryConfig
+                        { pcHackageSecurity = defaultHackageSecurityConfig
+                        , pcHpackExecutable = HpackBundled
+                        , pcRootDir = pantryRootDir
+                        , pcStorage = storage
+                        , pcUpdateRef = updateRef
+                        , pcParsedCabalFilesRawImmutable = cabalImmutable
+                        , pcParsedCabalFilesMutable = cabalMutable
+                        , pcConnectionCount = connectionCount
+                        }
+                stackage =
+                    StackageCron
+                        { scPantryConfig = pantryConfig
+                        , scStackageRoot = stackageRootDir
+                        , scProcessContext = defaultProcessContext
+                        , scLogFunc = logFunc
+                        , scForceFullUpdate = scoForceUpdate
+                        , scCachedGPD = gpdCache
+                        , scEnvAWS = aws
+                        , scDownloadBucketName = scoDownloadBucketName
+                        , scUploadBucketName = scoUploadBucketName
+                        , scSnapshotsRepo = scoSnapshotsRepo
+                        }
+             in runRIO stackage (runStackageUpdate scoDoNotUpload)
+
+
+runStackageUpdate :: Bool -> RIO StackageCron ()
+runStackageUpdate doNotUpload = do
+    forceFullUpdate <- scForceFullUpdate <$> ask
+    logInfo $ "Starting stackage-cron update" <> bool "" " with --force-update" forceFullUpdate
+    runStackageMigrations
+    didUpdate <- forceUpdateHackageIndex (Just "stackage-server cron job")
+    case didUpdate of
+        UpdateOccurred -> do
+            logInfo "Updated hackage index. Getting deprecated info now"
+            getHackageDeprecations >>= run . mapM_ addDeprecated
+        NoUpdateOccurred -> logInfo "No new packages in hackage index"
+    corePackageGetters <- makeCorePackageGetters
+    runResourceT $
+        join $
+        runConduit $ sourceSnapshots .| foldMC (createOrUpdateSnapshot corePackageGetters) (pure ())
+    run $ mapM_ (`rawExecute` []) ["COMMIT", "VACUUM", "BEGIN"]
+    unless doNotUpload $ do
+        uploadSnapshotsJSON
+        buildAndUploadHoogleDB
+
+
+-- | This will look at 'global-hints.yaml' and will create core package getters that are reused
+-- later for adding those package to individual snapshot.
+makeCorePackageGetters ::
+       RIO StackageCron (Map CompilerP [CorePackageGetter])
+makeCorePackageGetters = do
+    rootDir <- scStackageRoot <$> ask
+    contentDir <- getStackageContentDir 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))
+                hints
+        Left exc -> do
+            logError $
+                "Error parsing 'global-hints.yaml' file: " <> fromString (displayException exc)
+            return mempty
+
+-- | 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)
+makeCorePackageGetter _compiler pname ver =
+    run (getHackageCabalByRev0 pid) >>= \case
+        Nothing -> do
+            logWarn $
+                "Core package from global-hints: '" <> display pid <> "' was not found in pantry."
+            pure Nothing
+        Just (hackageCabalId, blobId, _) -> do
+            pkgInfoRef <- newIORef Nothing -- use for caching of pkgInfo
+            let getMemoPackageInfo =
+                    readIORef pkgInfoRef >>= \case
+                        Just pkgInfo -> return pkgInfo
+                        Nothing -> do
+                            logSticky $ "Loading core package: " <> display pid
+                            htr <- getHackageTarball pir Nothing
+                            case htrFreshPackageInfo htr of
+                                Just (gpd, treeId) -> do
+                                    mTree <- run $ getEntity treeId
+                                    let pkgInfo = (mTree, Just hackageCabalId, pid, gpd)
+                                    writeIORef pkgInfoRef $ Just pkgInfo
+                                    pure pkgInfo
+                                Nothing -> do
+                                    (cabalBlob, mTree) <-
+                                        run
+                                            ((,) <$> loadBlobById blobId <*>
+                                             getTreeForKey (packageTreeKey (htrPackage htr)))
+                                    let gpd = parseCabalBlob cabalBlob
+                                        pkgInfo = (mTree, Just hackageCabalId, pid, gpd)
+                                    writeIORef pkgInfoRef $ Just pkgInfo
+                                    pure pkgInfo
+            pure $ Just getMemoPackageInfo
+  where
+    pid = PackageIdentifierP pname ver
+    pir =
+        PackageIdentifierRevision (unPackageNameP pname) (unVersionP ver) (CFIRevision (Revision 0))
+
+
+-- TODO: for now it is only from hackage, PantryPackage needs an update to use other origins
+-- | A pantry package is being added to a particular snapshot. Extra information like compiler and
+-- flags are passed on in order to properly figure out dependencies and modules
+addPantryPackage ::
+       SnapshotId -> CompilerP -> Bool -> Map FlagNameP Bool -> PantryPackage -> RIO StackageCron Bool
+addPantryPackage sid compiler isHidden flags (PantryPackage pc treeKey) = do
+    gpdCachedRef <- scCachedGPD <$> ask
+    let blobKeyToInt = fromIntegral . unSqlBackendKey . unBlobKey
+    let updateCacheGPD blobId gpd =
+            atomicModifyIORef' gpdCachedRef (\cacheMap -> (IntMap.insert blobId gpd cacheMap, gpd))
+    let getCachedGPD treeCabal =
+            \case
+                Just gpd -> updateCacheGPD (blobKeyToInt treeCabal) gpd
+                Nothing -> do
+                    cacheMap <- readIORef gpdCachedRef
+                    case IntMap.lookup (blobKeyToInt treeCabal) cacheMap of
+                        Just gpd -> pure gpd
+                        Nothing ->
+                            loadBlobById treeCabal >>=
+                            updateCacheGPD (blobKeyToInt treeCabal) . parseCabalBlob
+    let storeHackageSnapshotPackage hcid mtid mgpd =
+            getTreeForKey treeKey >>= \case
+                Just (Entity treeId _)
+                    | Just tid <- mtid
+                    , tid /= treeId -> do
+                        lift $ logError $ "Pantry Tree Key mismatch for: " <> display pc
+                        pure False
+                mTree@(Just (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
+                        pure True
+                _ -> do
+                  lift $ logError $ "Pantry is missing the source tree for " <> display pc
+                  pure False
+    mHackageCabalInfo <- run $ getHackageCabalByKey pid (pcCabalKey pc)
+    case mHackageCabalInfo of
+        Nothing -> do
+          logError $ "Could not find the cabal file for: " <> display pc
+          pure False
+        Just (hcid, Nothing) -> do
+            mHPI <-
+                htrFreshPackageInfo <$>
+                getHackageTarball (toPackageIdentifierRevision pc) (Just treeKey)
+            run $
+                case mHPI of
+                    Just (gpd, treeId) -> storeHackageSnapshotPackage hcid (Just treeId) (Just gpd)
+                    Nothing -> storeHackageSnapshotPackage hcid Nothing Nothing
+        Just (hcid, mtid) -> run $ storeHackageSnapshotPackage hcid mtid Nothing
+  where
+    pid = PackageIdentifierP (pcPackageName pc) (pcVersion pc)
+
+
+
+
+-- | Download a list of available .html files from S3 bucket for a particular resolver and record
+-- in the database which modules have documentation available for them.
+checkForDocs :: SnapshotId -> SnapName -> ResourceT (RIO StackageCron) ()
+checkForDocs snapshotId snapName = do
+    bucketName <- lift (scDownloadBucketName <$> ask)
+    mods <-
+        runConduit $
+        AWS.paginate (req bucketName) .| concatMapC (^. lovrsContents) .|
+        mapC (\obj -> toText (obj ^. oKey)) .|
+        concatMapC (T.stripSuffix ".html") .|
+        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.
+    sidsCacheRef <- newIORef Map.empty
+    -- Cache is for SnapshotPackageId, there will be many modules per peckage, no need to look into
+    -- the database for each one of them.
+    n <- max 1 . (`div` 2) <$> getNumCapabilities
+    notFoundList <- lift $ pooledMapConcurrentlyN n (markModules sidsCacheRef) mods
+    forM_ (Set.fromList $ catMaybes notFoundList) $ \pid ->
+        lift $
+        logError $
+        "Documentation available for package '" <> display pid <>
+        "' but was not found in this snapshot: " <>
+        display snapName
+  where
+    prefix = textDisplay snapName <> "/"
+    req bucketName = listObjectsV2 (BucketName bucketName) & lovPrefix .~ Just prefix
+    -- | This function records all package modules that have documentation available, the ones
+    -- that are not found in the snapshot reported back as an error.  Besides being run
+    -- concurrently this function optimizes the SnapshotPackageId lookup as well, since that can
+    -- be shared amongst many modules of one package.
+    markModules sidsCacheRef (pid, modName) = do
+        sidsCache <- readIORef sidsCacheRef
+        let mSnapshotPackageId = Map.lookup pid sidsCache
+        mFound <- run $ markModuleHasDocs snapshotId pid mSnapshotPackageId modName
+        case mFound of
+            Nothing -> pure $ Just pid
+            Just snapshotPackageId
+                | Nothing <- mSnapshotPackageId -> do
+                    atomicModifyIORef'
+                        sidsCacheRef
+                        (\cacheMap -> (Map.insert pid snapshotPackageId cacheMap, ()))
+                    pure Nothing
+            _ -> pure Nothing
+
+data SnapshotFileInfo = SnapshotFileInfo
+    { sfiSnapName :: !SnapName
+    , sfiUpdatedOn :: !UTCTime
+    , sfiSnapshotFileGetter :: !(RIO StackageCron (Maybe SnapshotFile))
+    }
+
+-- | Use 'github.com/commercialhaskell/stackage-snapshots' repository to source all of the packages
+-- one snapshot at a time.
+sourceSnapshots :: ConduitT a SnapshotFileInfo (ResourceT (RIO StackageCron)) ()
+sourceSnapshots = do
+    snapshotsDir <- lift $ lift getStackageSnapshotsDir
+    sourceDirectoryDeep False (snapshotsDir </> "lts") .| concatMapMC (getLtsParser snapshotsDir)
+    sourceDirectoryDeep False (snapshotsDir </> "nightly") .|
+        concatMapMC (getNightlyParser snapshotsDir)
+  where
+    makeSnapshotFileInfo gitDir fp mFileNameDate snapName = do
+        let parseSnapshot updatedOn = do
+                esnap <- liftIO $ decodeFileEither fp
+                case esnap of
+                    Right snap ->
+                        let publishDate =
+                                sfPublishDate snap <|> mFileNameDate <|> Just (utctDay updatedOn)
+                         in return $ Just snap {sfPublishDate = publishDate}
+                    Left exc -> do
+                        logError $
+                            "Error parsing snapshot file: " <> fromString fp <> "\n" <>
+                            fromString (displayException exc)
+                        return Nothing
+        lastGitFileUpdate gitDir fp >>= \case
+            Left err -> do
+                logError $ "Error parsing git commit date: " <> fromString err
+                return Nothing
+            Right updatedOn -> do
+                env <- lift ask
+                return $
+                    Just
+                        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, "/")] ->
+                makeSnapshotFileInfo gitDir fp Nothing $ SNLts major minor
+            _ -> do
+                logError
+                    ("Couldn't parse the filepath into an LTS version: " <> display (T.pack fp))
+                return Nothing
+    getNightlyParser gitDir fp =
+        case mapM (BS8.readInt . BS8.pack) $ take 3 $ reverse (splitPath fp) of
+            Just [(day, ".yaml"), (month, "/"), (year, "/")]
+                | Just date <- fromGregorianValid (fromIntegral year) month day ->
+                    makeSnapshotFileInfo gitDir fp (Just date) $ SNNightly date
+            _ -> do
+                logError
+                    ("Couldn't parse the filepath into a Nightly date: " <> display (T.pack fp))
+                return Nothing
+
+
+-- | Creates a new `Snapshot` if it is not yet present in the database and decides if update
+-- is necessary when it already exists.
+decideOnSnapshotUpdate :: SnapshotFileInfo -> RIO StackageCron (Maybe (SnapshotId, SnapshotFile))
+decideOnSnapshotUpdate SnapshotFileInfo {sfiSnapName, sfiUpdatedOn, sfiSnapshotFileGetter} = do
+    forceUpdate <- scForceFullUpdate <$> ask
+    let mkLogMsg rest = "Snapshot with name: " <> display sfiSnapName <> " " <> rest
+    mKeySnapFile <-
+        run (getBy (UniqueSnapshot sfiSnapName)) >>= \case
+            Just (Entity _key snap)
+                | snapshotUpdatedOn snap == Just sfiUpdatedOn && not forceUpdate -> do
+                    logInfo $ mkLogMsg "already exists and is up to date."
                     return Nothing
+            Just entity@(Entity _key snap)
+                | Nothing <- snapshotUpdatedOn snap -> do
+                    logWarn $ mkLogMsg "did not finish updating last time."
+                    fmap (Just entity, ) <$> sfiSnapshotFileGetter
+            Just entity -> do
+                unless forceUpdate $ logWarn $ mkLogMsg "was updated, applying new patch."
+                fmap (Just entity, ) <$> sfiSnapshotFileGetter
+            Nothing -> fmap (Nothing, ) <$> sfiSnapshotFileGetter
+    -- Add new snapshot to the database, when necessary
+    case mKeySnapFile of
+        Just (Just (Entity snapKey snap), sf@SnapshotFile {sfCompiler, sfPublishDate})
+            | Just publishDate <- sfPublishDate -> do
+                let updatedSnap =
+                        Snapshot sfiSnapName sfCompiler publishDate (snapshotUpdatedOn snap)
+                run $ replace snapKey updatedSnap
+                pure $ Just (snapKey, sf)
+        Just (Nothing, sf@SnapshotFile {sfCompiler, sfPublishDate})
+            | Just publishDate <- sfPublishDate ->
+                fmap (, sf) <$>
+                run (insertUnique (Snapshot sfiSnapName sfCompiler publishDate Nothing))
+        _ -> return Nothing
 
-stackageServerCron :: IO ()
-stackageServerCron = do
-    -- Hacky approach instead of PID files
-    void $ catchIO (bindPortTCP 17834 "127.0.0.1") $ \_ ->
-        error $ "cabal loader process already running, exiting"
+type CorePackageGetter
+     = RIO StackageCron ( Maybe (Entity Tree)
+                        , Maybe HackageCabalId
+                        , PackageIdentifierP
+                        , GenericPackageDescription)
 
-    env <- newEnv Discover
-    let upload :: FilePath -> ObjectKey -> IO ()
-        upload fp key = do
-            let fpgz = fp <.> "gz"
-            runConduitRes
-               $ sourceFile fp
-              .| compress 9 (WindowBits 31)
-              .| CB.sinkFile fpgz
-            body <- chunkedFile defaultChunkSize fpgz
-            let po =
-                      set poACL (Just OPublicRead)
-                   $  putObject "haddock.stackage.org" key body
-            putStrLn $ "Uploading: " ++ tshow key
-            eres <- runResourceT $ runAWS env $ trying _Error $ send po
-            case eres of
-                Left e -> error $ show (fp, key, e)
-                Right _ -> putStrLn "Success"
+-- | This is an optimized version of snapshoat loading which can load a snapshot and documentation
+-- info for previous snapshot at the same time. It will execute concurrently the loading of
+-- current snapshot as well as an action that was passed as an argument. At the end it will return
+-- an action that should be invoked in order to mark modules that have documentation available,
+-- which in turn can be passed as an argument to the next snapshot loader.
+createOrUpdateSnapshot ::
+       Map CompilerP [CorePackageGetter]
+    -> ResourceT (RIO StackageCron) ()
+    -> SnapshotFileInfo
+    -> ResourceT (RIO StackageCron) (ResourceT (RIO StackageCron) ())
+createOrUpdateSnapshot corePackageInfoGetters prevAction sfi@SnapshotFileInfo { sfiSnapName
+                                                                              , sfiUpdatedOn
+                                                                              } = do
+    finishedDocs <- newIORef False
+    runConcurrently
+        (Concurrently (prevAction >> writeIORef finishedDocs True) *>
+         Concurrently (lift (loadCurrentSnapshot finishedDocs)))
+  where
+    loadCurrentSnapshot finishedDocs = do
+        loadDocs <-
+            decideOnSnapshotUpdate sfi >>= \case
+                Nothing -> return $ pure ()
+                Just (snapshotId, snapshotFile) ->
+                    updateSnapshot
+                        corePackageInfoGetters
+                        snapshotId
+                        sfiSnapName
+                        sfiUpdatedOn
+                        snapshotFile
+        unlessM (readIORef finishedDocs) $
+            logSticky "Still loading the docs for previous snapshot ..."
+        pure loadDocs
 
-    connstr <- getEnv "PGSTRING"
+-- | Updates all packages in the snapshot. If any missing they will be created. Returns an action
+-- that will check for available documentation for modules that are known to exist and mark as
+-- documented when haddock is present on AWS S3. Only after documentation has been checked this
+-- snapshot will be marked as completely updated. This is required in case something goes wrong and
+-- process is interrupted
+updateSnapshot ::
+       Map CompilerP [CorePackageGetter]
+    -> SnapshotId
+    -> SnapName
+    -> UTCTime
+    -> SnapshotFile
+    -> RIO StackageCron (ResourceT (RIO StackageCron) ())
+updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {..} = do
+    insertSnapshotName snapshotId snapName
+    case Map.lookup sfCompiler corePackageGetters of
+        Nothing -> logError $ "Hints are not found for the compiler: " <> display sfCompiler
+        Just compilerCorePackages ->
+            forM_ compilerCorePackages $ \getCorePackageInfo -> do
+                (mTree, mhcid, pid, gpd) <- getCorePackageInfo
+                run $ addSnapshotPackage snapshotId sfCompiler Core mTree mhcid False mempty pid gpd
+    loadedPackageCountRef <- newIORef (0 :: Int)
+    let totalPackages = length sfPackages
+        addPantryPackageWithReport pp = do
+            let PantryCabal {pcPackageName} = ppPantryCabal pp
+                isHidden = fromMaybe False (Map.lookup pcPackageName sfHidden)
+                flags = fromMaybe Map.empty $ Map.lookup pcPackageName sfFlags
+            curSucc <- addPantryPackage snapshotId sfCompiler isHidden flags pp
+            atomicModifyIORef' loadedPackageCountRef (\c -> (c + 1, ()))
+            pure curSucc
+    -- Leave some cores and db connections for the doc loader
+    n <- max 1 . (`div` 2) <$> getNumCapabilities
+    pantryUpdatesSucceeded <-
+        runConcurrently
+            (Concurrently (runProgressReporter loadedPackageCountRef totalPackages snapName) *>
+             Concurrently (pooledMapConcurrentlyN n addPantryPackageWithReport sfPackages))
+    return $ do
+        checkForDocsSucceeded <-
+            tryAny (checkForDocs snapshotId snapName) >>= \case
+                Left exc -> do
+                    logError $ "Received exception while getting the docs: " <> displayShow exc
+                    return False
+                Right () -> return True
+        if and pantryUpdatesSucceeded && checkForDocsSucceeded
+            then do
+                lift $ snapshotMarkUpdated snapshotId updatedOn
+                logInfo $ "Created or updated snapshot '" <> display snapName <> "' successfully"
+            else logError $ "There were errors while adding snapshot '" <> display snapName <> "'"
 
-    let dbfp = PostgresConf
-          { pgPoolSize = 5
-          , pgConnStr = encodeUtf8 $ pack connstr
-          }
-    createStackageDatabase dbfp
 
-#if !DEVELOPMENT          
-    db <- openStackageDatabase dbfp
+-- | Report how many packages has been loaded so far and provide statistics at the end.
+runProgressReporter :: IORef Int -> Int -> SnapName -> RIO StackageCron ()
+runProgressReporter loadedPackageCountRef totalPackages snapName = do
+    before <- getCurrentTime
+    let reportProgress = do
+            loadedPackageCount <- readIORef loadedPackageCountRef
+            if loadedPackageCount < totalPackages
+                then do
+                    logSticky $
+                        mconcat
+                            [ "Loading snapshot '"
+                            , display snapName
+                            , "' ("
+                            , displayShow loadedPackageCount
+                            , "/"
+                            , displayShow totalPackages
+                            , ")"
+                            ]
+                    threadDelay 1000000
+                    reportProgress
+                else do
+                    after <- getCurrentTime
+                    let timeTotal = round (diffUTCTime after before)
+                        (mins, secs) = timeTotal `quotRem` (60 :: Int)
+                        packagePerSecond =
+                            fromIntegral ((loadedPackageCount * 100) `div` timeTotal) / 100 :: Float
+                    logInfo $
+                        mconcat
+                            [ "Loading snapshot '"
+                            , display snapName
+                            , "' was done (in "
+                            , displayShow mins
+                            , "min "
+                            , displayShow secs
+                            , "sec). With average "
+                            , displayShow packagePerSecond
+                            , " packages/sec. There are still docs."
+                            ]
+    reportProgress
 
-    do
-        snapshots <- runReaderT snapshotsJSON db
-        let key = ObjectKey "snapshots.json"
-            po =
-                  set poACL (Just OPublicRead)
-               $  set poContentType (Just "application/json")
-               $  putObject (BucketName "haddock.stackage.org") key (toBody snapshots)
-        putStrLn $ "Uploading: " ++ tshow key
-        eres <- runResourceT $ runAWS env $ trying _Error $ send po
-        case eres of
-            Left e -> error $ show (key, e)
-            Right _ -> putStrLn "Success"
+-- | Uploads a json file to S3 with all latest snapshots per major lts version and one nightly.
+uploadSnapshotsJSON :: RIO StackageCron ()
+uploadSnapshotsJSON = do
+    snapshots <- snapshotsJSON
+    uploadBucket <- scUploadBucketName <$> ask
+    let key = ObjectKey "snapshots.json"
+    uploadFromRIO key $
+        set poACL (Just OPublicRead) $
+        set poContentType (Just "application/json") $
+        putObject (BucketName uploadBucket) key (toBody snapshots)
 
-    names <- runReaderT (lastXLts5Nightly 50) db
-    let manager = view envManager env
+-- | Writes a gzipped version of hoogle db into temporary file onto the file system and then uploads
+-- it to S3. Temporary file is removed upon completion
+uploadHoogleDB :: FilePath -> ObjectKey -> RIO StackageCron ()
+uploadHoogleDB fp key =
+    withTempFile (takeDirectory fp) (takeFileName fp <.> "gz") $ \fpgz h -> do
+        runConduitRes $ sourceFile fp .| compress 9 (WindowBits 31) .| CB.sinkHandle h
+        hClose h
+        body <- chunkedFile defaultChunkSize fpgz
+        uploadBucket <- scUploadBucketName <$> ask
+        uploadFromRIO key $
+            set poACL (Just OPublicRead) $ putObject (BucketName uploadBucket) key body
 
-    locker <- newHoogleLocker False manager
 
-    forM_ names $ \name -> do
-        mfp <- singleRun locker name
+uploadFromRIO :: AWSRequest a => ObjectKey -> a -> RIO StackageCron ()
+uploadFromRIO key po = do
+    logInfo $ "Uploading " <> displayShow key <> " to S3 bucket."
+    env <- ask
+    eres <- runResourceT $ runAWS env $ trying _Error $ send po
+    case eres of
+        Left e ->
+            logError $ "Couldn't upload " <> displayShow key <> " to S3 becuase " <> displayShow e
+        Right _ -> logInfo $ "Successfully uploaded " <> displayShow key <> " to S3"
+
+buildAndUploadHoogleDB :: RIO StackageCron ()
+buildAndUploadHoogleDB = do
+    snapshots <- lastLtsNightly 50 5
+    env <- ask
+    locker <- newHoogleLocker (env ^. logFuncL) (env ^. envManager)
+    void $ flip Map.traverseWithKey snapshots $ \snapshotId snapName -> do
+        logDebug $ "Starting Hoogle DB download: " <> display (hoogleKey snapName)
+        mfp <- singleRun locker snapName
         case mfp of
-            Just _ -> putStrLn $ "Hoogle database exists for: " ++ toPathPiece name
+            Just _ -> logDebug $ "Hoogle database exists for: " <> display snapName
             Nothing -> do
-                mfp' <- createHoogleDB db manager name
+                mfp' <- createHoogleDB snapshotId snapName
                 forM_ mfp' $ \fp -> do
-                    let key = hoogleKey name
-                    upload fp (ObjectKey key)
-                    let dest = unpack key
+                    let key = hoogleKey snapName
+                    uploadHoogleDB fp (ObjectKey key)
+                    let dest = T.unpack key
                     createDirectoryIfMissing True $ takeDirectory dest
                     renamePath fp dest
-#endif
 
-createHoogleDB :: StackageDatabase -> Manager -> SnapName -> IO (Maybe FilePath)
-createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
-    putStrLn $ "Creating Hoogle DB for " ++ toPathPiece name
-    req' <- parseRequest $ unpack tarUrl
-    let req = req' { decompress = const True }
-
-    unlessM (doesFileExist tarFP) $ withResponse req man $ \res -> do
-        let tmp = tarFP <.> "tmp"
-        createDirectoryIfMissing True $ takeDirectory tmp
-        runConduitRes
-           $ bodyReaderSource (responseBody res)
-          .| sinkFile tmp
-        renamePath tmp tarFP
-
-    void $ tryIO $ removeDirectoryRecursive bindir
-    void $ tryIO $ removeFile outname
-    createDirectoryIfMissing True bindir
-
-    withSystemTempDirectory ("hoogle-" ++ unpack (toPathPiece name)) $ \tmpdir -> do
-        allPackagePairs <- runConduitRes
-            $ sourceTarFile False tarFP
-           .| foldMapMC (liftIO . singleDB db name tmpdir)
-
-        when (null allPackagePairs) $ error $ "No Hoogle .txt files found for " ++ unpack (toPathPiece name)
-
-        stackDir <- getAppUserDataDirectory "stack"
-        let indexTar = stackDir </> "indices" </> "Hackage" </> "00-index.tar"
-        withBinaryFile indexTar ReadMode $ \h -> do
-            let loop Tar.Done = return ()
-                loop (Tar.Fail e) = throwIO e
-                loop (Tar.Next e es) = go e >> loop es
-
-                go e =
-                    case (Tar.entryContent e, splitPath $ Tar.entryPath e) of
-                        (Tar.NormalFile cabalLBS _, [pkg', ver', pkgcabal'])
-                          | Just pkg <- stripSuffix "/" (pack pkg')
-                          , Just ver <- stripSuffix "/" (pack ver')
-                          , Just pkg2 <- stripSuffix ".cabal" (pack pkgcabal')
-                          , pkg == pkg2
-                          , lookup pkg allPackagePairs == Just ver ->
-                                  runConduitRes
-                                $ sourceLazy cabalLBS
-                               .| sinkFile (tmpdir </> unpack pkg <.> "cabal")
-                        _ -> return ()
-            L.hGetContents h >>= loop . Tar.read
-
-        let args =
-                [ "generate"
-                , "--database=" ++ outname
-                , "--local=" ++ tmpdir
-                ]
-        putStrLn $ concat
-            [ "Merging databases... ("
-            , tshow args
-            , ")"
-            ]
-        Hoogle.hoogle args
-
-        putStrLn "Merge done"
-
-        return $ Just outname
+createHoogleDB :: SnapshotId -> SnapName -> RIO StackageCron (Maybe FilePath)
+createHoogleDB snapshotId snapName =
+    handleAny logException $ do
+        logInfo $ "Creating Hoogle DB for " <> display snapName
+        downloadBucket <- scDownloadBucketName <$> ask
+        let root = "hoogle-gen"
+            bindir = root </> "bindir"
+            outname = root </> "output.hoo"
+            tarKey = toPathPiece snapName <> "/hoogle/orig.tar"
+            tarUrl = "https://s3.amazonaws.com/" <> downloadBucket <> "/" <> tarKey
+            tarFP = root </> T.unpack tarKey
+        req <- parseRequest $ T.unpack tarUrl
+        man <- view envManager
+        unlessM (doesFileExist tarFP) $
+            withResponseUnliftIO req {decompress = const True} man $ \res -> do
+                throwErrorStatusCodes req res
+                createDirectoryIfMissing True $ takeDirectory tarFP
+                --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
+        withSystemTempDirectory ("hoogle-" ++ T.unpack (textDisplay snapName)) $ \tmpdir -> do
+            Any hasRestored <-
+                runConduitRes $
+                sourceFile tarFP .| untar (restoreHoogleTxtFileWithCabal tmpdir snapshotId snapName) .|
+                foldC
+            unless hasRestored $ error "No Hoogle .txt files found"
+            let args = ["generate", "--database=" ++ outname, "--local=" ++ tmpdir]
+            logInfo $
+                mconcat
+                    [ "Merging databases... ("
+                    , foldMap fromString $ L.intersperse " " ("hoogle" : args)
+                    , ")"
+                    ]
+            liftIO $ Hoogle.hoogle args
+            logInfo "Merge done"
+            return $ Just outname
   where
-    root = "hoogle-gen"
-    bindir = root </> "bindir"
-    outname = root </> "output.hoo"
+    logException exc =
+        logError ("Problem creating hoogle db for " <> display snapName <> ": " <> displayShow exc) $>
+        Nothing
 
-    tarKey = toPathPiece name ++ "/hoogle/orig.tar"
-    tarUrl = "https://s3.amazonaws.com/haddock.stackage.org/" ++ tarKey
-    tarFP = root </> unpack tarKey
+restoreHoogleTxtFileWithCabal ::
+       FilePath
+    -> SnapshotId
+    -> SnapName
+    -> FileInfo
+    -> ConduitM ByteString Any (ResourceT (RIO StackageCron)) ()
+restoreHoogleTxtFileWithCabal tmpdir snapshotId snapName fileInfo =
+    case fileType fileInfo of
+        FTNormal -> do
+            let txtFileName = T.decodeUtf8With T.lenientDecode $ filePath fileInfo
+                txtPackageName = T.takeWhile (/= '.') txtFileName
+                mpkg = fromPathPiece txtPackageName
+            maybe (pure Nothing) (lift . lift . getSnapshotPackageCabalBlob snapshotId) mpkg >>= \case
+                Nothing -> do
+                    logWarn $
+                        "Unexpected hoogle filename: " <> display txtFileName <>
+                        " in orig.tar for snapshot: " <>
+                        display snapName
+                    yield $ Any False
+                Just cabal -> do
+                    writeFileBinary (tmpdir </> T.unpack txtPackageName <.> "cabal") cabal
+                    sinkFile (tmpdir </> T.unpack txtFileName)
+                    yield $ Any True
+        _ -> yield $ Any False
+
+
+pathToPackageModule :: Text -> Maybe (PackageIdentifierP, ModuleNameP)
+pathToPackageModule txt =
+    case T.split (== '/') txt of
+        [pkgIdentifier, moduleNameDashes] -> do
+             modName :: ModuleNameP <- fromPathPiece moduleNameDashes
+             pkgId :: PackageIdentifierP <- fromPathPiece pkgIdentifier
+             Just (pkgId, modName)
+        _ -> Nothing
 
-singleDB :: StackageDatabase
-         -> SnapName
-         -> FilePath -- ^ temp directory to write .txt files to
-         -> Tar.Entry
-         -> IO (Map Text Text)
-singleDB db sname tmpdir e@(Tar.entryContent -> Tar.NormalFile lbs _) = do
-    --putStrLn $ "Loading file for Hoogle: " ++ pack (Tar.entryPath e)
 
-    let pkg = pack $ takeWhile (/= '.') $ Tar.entryPath e
-    msp <- flip runReaderT db $ do
-        Just (Entity sid _) <- lookupSnapshot sname
-        lookupSnapshotPackage sid pkg
-    case msp of
-        Nothing -> do
-            putStrLn $ "Unknown: " ++ pkg
-            return mempty
-        Just (Entity _ sp)  -> do
-            let out = tmpdir </> unpack pkg <.> "txt"
-                -- FIXME add @url directive
-            runConduitRes $ sourceLazy lbs .| sinkFile out
-            return $ singletonMap pkg (snapshotPackageVersion sp)
-                {-
-                docsUrl = concat
-                    [ "https://www.stackage.org/haddock/"
-                    , toPathPiece sname
-                    , "/"
-                    , pkgver
-                    , "/index.html"
-                    ] -}
 
-singleDB _ _ _ _ = return mempty

src/Stackage/Database/Github.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Stackage.Database.Github
+    ( cloneOrUpdate
+    , lastGitFileUpdate
+    , getStackageContentDir
+    , GithubRepo(..)
+    ) where
+
+import qualified Data.ByteString.Lazy.Char8 as LBS8
+import RIO
+import RIO.Directory
+import RIO.FilePath
+import RIO.Process
+import RIO.Time
+
+data GithubRepo = GithubRepo
+    { grAccount :: !String
+    , grName    :: !String
+    } deriving Show
+
+gitLog
+  :: (MonadReader env m, HasLogFunc env, HasProcessContext env,
+      MonadIO m) =>
+     FilePath -> String -> [String] -> m LBS8.ByteString
+gitLog gitDir filePath args =
+    withWorkingDir gitDir $ proc "git" ("log" : (args ++ [filePath])) readProcessStdout_
+
+
+-- | From the git commit log infer the timestamp when the file was changed last .
+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)
+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"
+            Just lbsDate ->
+                mapLeft (displayException :: SomeException -> String) <$>
+                try (parseTimeM False defaultTimeLocale fmt (LBS8.unpack lbsDate))
+
+-- | 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.
+cloneOrUpdate ::
+       (MonadReader env m, HasLogFunc env, HasProcessContext env, MonadIO m)
+    => FilePath -- ^ Path where the repo should be cloned
+    -> GithubRepo -- ^ Github user or organization name together with repository name
+    -> m FilePath
+cloneOrUpdate root GithubRepo {grAccount, grName} = do
+    exists <- doesDirectoryExist dest
+    if exists
+        then withWorkingDir dest $ do
+            proc "git" ["fetch"] runProcess_
+            proc "git" ["reset", "--hard", "origin/master"] runProcess_
+        else withWorkingDir root $
+            proc "git" ["clone", url, grName] runProcess_
+    return dest
+  where
+    url = "https://github.com/" <> grAccount <> "/" <> grName <> ".git"
+    dest = root </> grName
+
+
+
+getStackageContentDir ::
+       (MonadReader env m, HasLogFunc env, HasProcessContext env, MonadIO m)
+    => FilePath
+    -> m FilePath
+getStackageContentDir rootDir =
+    cloneOrUpdate rootDir (GithubRepo "commercialhaskell" "stackage-content")

src/Stackage/Database/Haddock.hs

@@ -1,16 +1,19 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 module Stackage.Database.Haddock
     ( renderHaddock
     ) where
 
+import ClassyPrelude.Conduit
+import qualified Documentation.Haddock.Parser as Haddock
+import Documentation.Haddock.Types (DocH(..), Example(..), Header(..),
+                                    Hyperlink(..), MetaDoc(..), Picture(..),
+                                    Table(..), TableCell(..), TableRow(..))
+import Text.Blaze.Html (Html, toHtml)
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
-import qualified Documentation.Haddock.Parser as Haddock
-import Documentation.Haddock.Types (DocH (..), Hyperlink (..), Picture (..), Header (..), Example (..), MetaDoc(..), Table (..), TableRow (..), TableCell (..))
-import ClassyPrelude.Conduit
-import Text.Blaze.Html (Html, toHtml)
 
-renderHaddock :: Text -> Html
-renderHaddock = hToHtml . Haddock.toRegular . _doc . Haddock.parseParas Nothing . unpack
+renderHaddock :: String -> Html
+renderHaddock = hToHtml . Haddock.toRegular . _doc . Haddock.parseParas Nothing
 
 -- | Convert a Haddock doc to HTML.
 hToHtml :: DocH String String -> Html

src/Stackage/Database/PackageInfo.hs

@@ -0,0 +1,278 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Stackage.Database.PackageInfo
+    ( PackageInfo(..)
+    , Identifier(..)
+    , renderEmail
+    , toPackageInfo
+    , parseCabalBlob
+    , parseCabalBlobMaybe
+    , extractDependencies
+    , extractModuleNames
+    , getSynopsis
+    , isMarkdownFilePath
+    ) where
+
+import CMarkGFM
+import Data.Coerce
+import Data.Char (isSpace)
+import Data.Map.Merge.Strict as Map
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
+import Distribution.Compiler (CompilerFlavor(GHC))
+import Distribution.Package (Dependency(..))
+import Distribution.PackageDescription (CondTree(..), Condition(..),
+                                        ConfVar(..),
+                                        Flag(flagDefault, flagName), FlagName,
+                                        GenericPackageDescription, author,
+                                        condExecutables, condLibrary,
+                                        description, genPackageFlags, homepage,
+                                        license, maintainer,
+                                        packageDescription, 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.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
+
+
+data PackageInfo = PackageInfo
+    { piSynopsis    :: !Text
+    , piDescription :: !Html
+    , piAuthors     :: ![Identifier]
+    , piMaintainers :: ![Identifier]
+    , piHomepage    :: !(Maybe Text)
+    , piLicenseName :: !Text
+    , piReadme      :: !Html
+    , piChangelog   :: !Html
+    }
+
+
+toPackageInfo ::
+       GenericPackageDescription
+    -> Maybe Readme
+    -> Maybe Changelog
+    -> PackageInfo
+toPackageInfo gpd mreadme mchangelog =
+    PackageInfo
+        { piSynopsis = T.pack $ synopsis pd
+        , piDescription = renderHaddock (description pd)
+        , piReadme = maybe mempty (\(Readme bs isMarkdown) -> renderContent bs isMarkdown) mreadme
+        , piChangelog =
+              maybe mempty (\(Changelog bs isMarkdown) -> renderContent bs isMarkdown) mchangelog
+        , piAuthors = parseIdentitiesLiberally $ T.pack $ author pd
+        , piMaintainers = parseIdentitiesLiberally $ T.pack $ maintainer pd
+        , piHomepage =
+              case T.strip $ T.pack $ homepage pd of
+                  "" -> Nothing
+                  x -> Just x
+        , piLicenseName = T.pack $ prettyShow $ license pd
+        }
+  where
+    pd = packageDescription gpd
+    renderContent bs isMarkdown =
+        let txt = decodeUtf8With lenientDecode bs
+         in if isMarkdown
+                then preEscapedToHtml $ commonmarkToHtml [optSmart] [extTable, extAutolink] txt
+                else toHtml $ Textarea txt
+
+getSynopsis :: GenericPackageDescription -> Text
+getSynopsis = T.pack . synopsis . packageDescription
+
+extractModuleNames :: GenericPackageDescription -> [ModuleNameP]
+extractModuleNames = maybe [] (coerce . exposedModules . condTreeData) . condLibrary
+
+
+isMarkdownFilePath :: SafeFilePath -> Bool
+isMarkdownFilePath sfp =
+    case T.split (== '.') $ unSafeFilePath sfp of
+        [_, "md"]       -> True
+        [_, "markdown"] -> True
+        _               -> False
+
+
+extractDependencies ::
+       CompilerP -> Map FlagNameP Bool -> GenericPackageDescription -> Map PackageNameP VersionRangeP
+extractDependencies compiler flags gpd =
+    fmap VersionRangeP $
+    combineDeps $
+    maybeToList (getDeps' <$> condLibrary gpd) ++ map (getDeps' . snd) (condExecutables gpd)
+  where
+    getDeps' :: CondTree ConfVar [Dependency] a -> Map PackageNameP VersionRange
+    getDeps' = getDeps (getCheckCond compiler (Map.mapKeysMonotonic unFlagNameP flags) gpd)
+
+-- | Parse a cabal blob and throw an error on failure.
+parseCabalBlob :: ByteString -> GenericPackageDescription
+parseCabalBlob cabalBlob =
+    case snd $ runParseResult $ parseGenericPackageDescription cabalBlob of
+        Left err  -> error $ "Problem parsing cabal blob: " <> show err
+        Right gpd -> gpd
+
+
+parseCabalBlobMaybe ::
+       (MonadIO m, MonadReader env m, HasLogFunc env)
+    => PackageNameP
+    -> ByteString
+    -> m (Maybe GenericPackageDescription)
+parseCabalBlobMaybe packageName cabalBlob =
+    case snd $ runParseResult $ parseGenericPackageDescription cabalBlob of
+        Left err ->
+            Nothing <$
+            logError
+                ("Problem parsing cabal blob for '" <> display packageName <> "': " <>
+                 displayShow err)
+        Right pgd -> pure $ Just pgd
+
+getCheckCond ::
+       CompilerP -> Map FlagName Bool -> GenericPackageDescription -> Condition ConfVar -> Bool
+getCheckCond compiler overrideFlags gpd = go
+  where
+    go (Var (OS os)) = os == Linux -- arbitrary
+    go (Var (Arch arch)) = arch == X86_64 -- arbitrary
+    go (Var (Flag flag)) = fromMaybe False $ Map.lookup flag flags
+    go (Var (Impl flavor range)) = flavor == compilerFlavor && compilerVersion `withinRange` range
+    go (Lit b) = b
+    go (CNot c) = not $ go c
+    go (CAnd x y) = go x && go y
+    go (COr x y) = go x || go y
+    (compilerFlavor, compilerVersion) =
+        case compiler of
+            CompilerGHC ver -> (GHC, unVersionP ver)
+    flags =
+        Map.merge
+            Map.dropMissing -- unknown flags should be discarded
+            Map.preserveMissing -- non-overriden flags stay as default
+            (Map.zipWithMatched (\_flagName new _default -> new)) -- override the flag
+            overrideFlags $
+        Map.fromList $ map toPair $ genPackageFlags gpd
+      where
+        toPair f = (flagName f, flagDefault f)
+
+getDeps ::
+       (Condition ConfVar -> Bool)
+    -> CondTree ConfVar [Dependency] a
+    -> Map PackageNameP VersionRange
+getDeps checkCond = goTree
+  where
+    goTree (CondNode _data deps comps) =
+        combineDeps $
+        map (\(Dependency name range) -> Map.singleton (PackageNameP name) range) deps ++
+        map goComp comps
+    goComp (CondBranch cond yes no)
+        | checkCond cond = goTree yes
+        | otherwise = maybe Map.empty goTree no
+
+
+combineDeps :: [Map PackageNameP VersionRange] -> Map PackageNameP VersionRange
+combineDeps =
+    Map.unionsWith
+        (\x -> normaliseVersionRange . simplifyVersionRange . intersectVersionRanges x)
+
+
+
+-- | An identifier specified in a package. Because this field has
+-- quite liberal requirements, we often encounter various forms. A
+-- name, a name and email, just an email, or maybe nothing at all.
+data Identifier
+  = EmailOnly !EmailAddress -- ^ An email only e.g. jones@example.com
+  | Contact !Text
+            !EmailAddress -- ^ A contact syntax, e.g. Dave Jones <jones@example.com>
+  | PlainText !Text -- ^ Couldn't parse anything sensible, leaving as-is.
+  deriving (Show,Eq)
+
+-- | An author/maintainer field may contain a comma-separated list of
+-- identifiers. It may be the case that a person's name is written as
+-- "Einstein, Albert", but we only parse commas when there's an
+-- accompanying email, so that would be:
+--
+--  Einstein, Albert <emc2@gmail.com>, Isaac Newton <falling@apple.com>
+--
+-- Whereas
+--
+-- Einstein, Albert, Isaac Newton
+--
+-- Will just be left alone. It's an imprecise parsing because the
+-- input is wide open, but it's better than nothing:
+--
+-- λ> parseIdentitiesLiberally "Chris Done, Dave Jones <chrisdone@gmail.com>, Einstein, Albert, Isaac Newton, Michael Snoyman <michael@snoyman.com>"
+-- [PlainText "Chris Done"
+-- ,Contact "Dave Jones" "chrisdone@gmail.com"
+-- ,PlainText "Einstein, Albert, Isaac Newton"
+-- ,Contact "Michael Snoyman" "michael@snoyman.com"]
+--
+-- I think that is quite a predictable and reasonable result.
+--
+parseIdentitiesLiberally :: Text -> [Identifier]
+parseIdentitiesLiberally =
+    filter (not . emptyPlainText) .
+    map strip .
+    concatPlains .
+    map parseChunk .
+    T.split (== ',')
+    where emptyPlainText (PlainText e) = T.null e
+          emptyPlainText _             = False
+          strip (PlainText t) = PlainText (T.strip t)
+          strip x             = x
+          concatPlains = go
+            where go (PlainText x:PlainText y:xs) =
+                    go (PlainText (x <> "," <> y) :
+                        xs)
+                  go (x:xs) = x : go xs
+                  go [] = []
+
+-- | Try to parse a chunk into an identifier.
+--
+-- 1. First tries to parse an \"email@domain.com\".
+-- 2. Then tries to parse a \"Foo <email@domain.com>\".
+-- 3. Finally gives up and returns a plain text.
+--
+-- λ> parseChunk "foo@example.com"
+-- EmailOnly "foo@example.com"
+-- λ> parseChunk "Dave Jones <dave@jones.com>"
+-- Contact "Dave Jones" "dave@jones.com"
+-- λ> parseChunk "<x>"
+-- PlainText "<x>"
+-- λ> parseChunk "Hello!"
+-- PlainText "Hello!"
+--
+parseChunk :: Text -> Identifier
+parseChunk chunk =
+    case emailAddress (T.encodeUtf8 (T.strip chunk)) of
+      Just email -> EmailOnly email
+      Nothing ->
+        case T.stripPrefix
+               ">"
+               (T.dropWhile isSpace
+                            (T.reverse chunk)) of
+          Just rest ->
+            case T.span (/= '<') rest of
+              (T.reverse -> emailStr,this) ->
+                case T.stripPrefix "< " this of
+                  Just (T.reverse -> name) ->
+                    case emailAddress (T.encodeUtf8 (T.strip emailStr)) of
+                      Just email ->
+                        Contact (T.strip name) email
+                      _ -> plain
+                  _ -> plain
+          _ -> plain
+    where plain = PlainText chunk
+
+-- | Render email to text.
+renderEmail :: EmailAddress -> Text
+renderEmail = T.decodeUtf8 . toByteString

src/Stackage/Database/Schema.hs

@@ -0,0 +1,192 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+module Stackage.Database.Schema
+    ( -- * Database
+      run
+    , runDatabase
+    , StackageDatabase
+    , GetStackageDatabase(..)
+    , withStackageDatabase
+    , runStackageMigrations
+    -- * Tables
+    , Unique(..)
+    , EntityField(..)
+    -- ** Snapshot
+    , Snapshot(..)
+    , SnapshotId
+    , Lts(..)
+    , Nightly(..)
+    -- ** Package
+    , SnapshotPackage(..)
+    , SnapshotPackageId
+    , SnapshotPackageModule(..)
+    , SnapshotPackageModuleId
+    , Dep(..)
+    , DepId
+    , Deprecated(..)
+    , DeprecatedId
+    -- ** Pantry
+    , module PS
+    ) where
+
+import Control.Monad.Logger (runNoLoggingT, runStdoutLoggingT)
+import qualified Data.Aeson as A
+import Data.Pool (destroyAllResources)
+import Database.Persist
+import Database.Persist.Postgresql
+import Database.Persist.TH
+import Pantry (HasPantryConfig(..), Revision)
+import Pantry.Internal.Stackage as PS (BlobId, HackageCabalId, ModuleNameId,
+                                       PackageNameId, Tree(..), TreeEntry(..),
+                                       TreeEntryId, TreeId, Unique(..),
+                                       VersionId, unBlobKey)
+import Pantry.Internal.Stackage (PantryConfig(..), Storage(..))
+import qualified Pantry.Internal.Stackage as Pantry (migrateAll)
+import RIO
+import RIO.Time
+import Types (CompilerP(..), FlagNameP, Origin, SnapName, VersionRangeP)
+
+currentSchema :: Int
+currentSchema = 1
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Schema
+    val Int
+    deriving Show
+
+Snapshot
+    name SnapName
+    compiler CompilerP
+    created Day
+    updatedOn UTCTime Maybe
+    UniqueSnapshot name
+Lts
+    snap SnapshotId
+    major Int
+    minor Int
+    UniqueLts major minor
+Nightly
+    snap SnapshotId
+    day Day
+    UniqueNightly day
+SnapshotPackage
+    snapshot SnapshotId
+    packageName PackageNameId
+    version VersionId
+    revision Revision Maybe
+    cabal BlobId Maybe
+    treeBlob BlobId Maybe
+    origin Origin
+    originUrl Text
+    synopsis Text
+    readme TreeEntryId Maybe
+    changelog TreeEntryId Maybe
+    isHidden Bool -- used for pantry, but is not relevant for stackage
+    flags (Map FlagNameP Bool)
+    UniqueSnapshotPackage snapshot packageName
+SnapshotPackageModule
+    snapshotPackage SnapshotPackageId
+    module ModuleNameId
+    hasDocs Bool
+    UniqueSnapshotPackageModule snapshotPackage module
+Dep
+    user SnapshotPackageId
+    uses PackageNameId
+    range VersionRangeP
+    UniqueDep user uses
+Deprecated
+    package PackageNameId
+    inFavourOf [PackageNameId]
+    UniqueDeprecated package
+|]
+
+_hideUnusedWarnings :: (SchemaId, LtsId, NightlyId) -> ()
+_hideUnusedWarnings _ = ()
+
+
+instance A.ToJSON Snapshot where
+  toJSON Snapshot{..} =
+    A.object [ "name"     A..= snapshotName
+             , "ghc"      A..= ghc -- TODO: deprecate? since it's encapsulated in `compiler`
+             , "compiler" A..= snapshotCompiler
+             , "created"  A..= formatTime defaultTimeLocale "%F" snapshotCreated
+             ]
+    where CompilerGHC ghc = snapshotCompiler
+
+
+newtype StackageDatabase = StackageDatabase
+    { _runDatabase :: forall env a . HasLogFunc env =>
+                                       ReaderT SqlBackend (RIO env) a -> (RIO env) a
+    }
+
+runDatabase ::
+       forall env a. HasLogFunc env
+    => StackageDatabase
+    -> ReaderT SqlBackend (RIO env) a
+    -> (RIO env) a
+runDatabase = _runDatabase
+
+class (MonadThrow m, MonadIO m) => GetStackageDatabase env m | m -> env where
+    getStackageDatabase :: m StackageDatabase
+
+    getLogFunc :: m RIO.LogFunc
+
+
+instance (HasLogFunc env, HasPantryConfig env) => GetStackageDatabase env (RIO env) where
+    getStackageDatabase = do
+      env <- view pantryConfigL
+      let Storage runStorage _ = pcStorage env
+      pure $ StackageDatabase runStorage
+    getLogFunc = view logFuncL
+
+
+
+run :: GetStackageDatabase env m => SqlPersistT (RIO RIO.LogFunc) a -> m a
+run inner = do
+    stackageDatabase <- getStackageDatabase
+    logFunc <- getLogFunc
+    runRIO logFunc $ runDatabase stackageDatabase inner
+
+
+withStackageDatabase :: MonadUnliftIO m => Bool -> PostgresConf -> (StackageDatabase -> m a) -> m a
+withStackageDatabase shouldLog pg inner = do
+    let getPoolIO =
+            if shouldLog
+                then runStdoutLoggingT $ createPostgresqlPool (pgConnStr pg) (pgPoolSize pg)
+                else runNoLoggingT $ createPostgresqlPool (pgConnStr pg) (pgPoolSize pg)
+    bracket (liftIO getPoolIO) (liftIO . destroyAllResources) $ \pool ->
+        inner (StackageDatabase (`runSqlPool` pool))
+
+
+getSchema :: (HasLogFunc env, GetStackageDatabase env (RIO env)) => RIO env (Maybe Int)
+getSchema =
+    run $ do
+        eres <- tryAny (selectList [] [])
+        lift $ logInfo $ "getSchema result: " <> displayShow eres
+        case eres of
+            Right [Entity _ (Schema v)] -> return $ Just v
+            _                           -> return Nothing
+
+runStackageMigrations :: (HasLogFunc env, GetStackageDatabase env (RIO env)) => RIO env ()
+runStackageMigrations = do
+    actualSchema <- getSchema
+    run $ do
+        runMigration Pantry.migrateAll
+        runMigration migrateAll
+        unless (actualSchema == Just currentSchema) $ do
+            lift $
+                logWarn $
+                "Current schema does not match actual schema: " <>
+                displayShow (actualSchema, currentSchema)
+            deleteWhere ([] :: [Filter Schema])
+            insert_ $ Schema currentSchema

src/Stackage/Database/Types.hs

@@ -1,54 +1,304 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
 module Stackage.Database.Types
-    ( SnapName (..)
+    ( SnapName(..)
     , isLts
     , isNightly
+    , SnapshotBranch(..)
+    , snapshotPrettyName
+    , snapshotPrettyNameShort
+    , CompilerP(..)
+    , FlagNameP(..)
+    , StackageCron(..)
+    , PantryCabal(..)
+    , BlobKey(..)
+    , GenericPackageDescription
+    , toPackageIdentifierRevision
+    , PantryPackage(..)
+    , SnapshotFile(..)
+    , SnapshotPackageInfo(..)
+    , SnapshotPackagePageInfo(..)
+    , spiVersionRev
+    , HackageCabalInfo(..)
+    , PackageListingInfo(..)
+    , ModuleListingInfo(..)
+    , PackageNameP(..)
+    , VersionP(..)
+    , Revision(..)
+    , VersionRangeP(..)
+    , PackageIdentifierP(..)
+    , VersionRev(..)
+    , toRevMaybe
+    , toVersionRev
+    , toVersionMRev
+    , PackageVersionRev(..)
+    , dropVersionRev
+    , ModuleNameP(..)
+    , SafeFilePath
+    , Origin(..)
+    , LatestInfo(..)
+    , Deprecation(..)
+    , haddockBucketName
+    , Changelog(..)
+    , Readme(..)
+    , StackageCronOptions(..)
     ) where
 
-import ClassyPrelude.Conduit
-import Web.PathPieces
 import Data.Aeson
+import qualified Data.Text as T
 import Data.Text.Read (decimal)
-import Database.Persist
-import Database.Persist.Sql
+import Network.AWS (Env, HasEnv(..))
+import Pantry as Pantry (BlobKey(..), CabalFileInfo(..), FileSize(..),
+                         HasPantryConfig(..), PackageIdentifierRevision(..),
+                         TreeKey(..))
+import Pantry.Internal.Stackage as Pantry (PackageNameP(..), PantryConfig,
+                                           VersionP(..))
+import Pantry.SHA256 (fromHexText)
+import RIO
+import RIO.Process (HasProcessContext(..), ProcessContext)
+import RIO.Time (Day, utctDay)
+import Stackage.Database.Github (GithubRepo(..))
+import Stackage.Database.Schema
+import Text.Blaze (ToMarkup(..))
+import Types
 
-data SnapName = SNLts !Int !Int
-              | SNNightly !Day
-    deriving (Eq, Ord, Read, Show)
+haddockBucketName :: Text
+haddockBucketName = "haddock.stackage.org"
 
-isLts :: SnapName -> Bool
-isLts SNLts{}     = True
-isLts SNNightly{} = False
+data StackageCronOptions = StackageCronOptions
+  { scoForceUpdate        :: !Bool
+  , scoDownloadBucketName :: !Text
+  , scoUploadBucketName   :: !Text
+  , scoDoNotUpload        :: !Bool
+  , scoLogLevel           :: !LogLevel
+  , scoSnapshotsRepo      :: !GithubRepo
+  }
 
-isNightly :: SnapName -> Bool
-isNightly SNLts{}     = False
-isNightly SNNightly{} = True
+data StackageCron = StackageCron
+    { scPantryConfig       :: !PantryConfig
+    , scStackageRoot       :: !FilePath
+    , scLogFunc            :: !LogFunc
+    , scProcessContext     :: !ProcessContext
+    , scForceFullUpdate    :: !Bool
+    , scCachedGPD          :: !(IORef (IntMap GenericPackageDescription))
+    , scEnvAWS             :: !Env
+    , scDownloadBucketName :: !Text
+    , scUploadBucketName   :: !Text
+    , scSnapshotsRepo      :: !GithubRepo
+    }
 
-instance ToJSONKey SnapName
+instance HasEnv StackageCron where
+    environment = lens scEnvAWS (\c f -> c {scEnvAWS = f})
 
-instance ToJSON SnapName where
-    toJSON = String . toPathPiece
+instance HasLogFunc StackageCron where
+    logFuncL = lens scLogFunc (\c f -> c {scLogFunc = f})
 
-instance PersistField SnapName where
-    toPersistValue = toPersistValue . toPathPiece
-    fromPersistValue v = do
-        t <- fromPersistValue v
-        case fromPathPiece t of
-            Nothing -> Left $ "Invalid SnapName: " ++ t
-            Just x -> return x
-instance PersistFieldSql SnapName where
-    sqlType = sqlType . fmap toPathPiece
-instance PathPiece SnapName where
-    toPathPiece (SNLts x y) = concat ["lts-", tshow x, ".", tshow y]
-    toPathPiece (SNNightly d) = "nightly-" ++ tshow d
+instance HasProcessContext StackageCron where
+    processContextL = lens scProcessContext (\c f -> c {scProcessContext = f})
 
-    fromPathPiece t0 =
-        nightly <|> lts
-      where
-        nightly = fmap SNNightly $ stripPrefix "nightly-" t0 >>= readMay
-        lts = do
-            t1 <- stripPrefix "lts-" t0
-            Right (x, t2) <- Just $ decimal t1
-            t3 <- stripPrefix "." t2
-            Right (y, "") <- Just $ decimal t3
-            return $ SNLts x y
+instance HasPantryConfig StackageCron where
+    pantryConfigL = lens scPantryConfig (\c f -> c {scPantryConfig = f})
 
+
+
+data SnapshotFile = SnapshotFile
+    { sfCompiler    :: !CompilerP
+    , sfPackages    :: ![PantryPackage]
+    , sfHidden      :: !(Map PackageNameP Bool)
+    , sfFlags       :: !(Map PackageNameP (Map FlagNameP Bool))
+    , sfPublishDate :: !(Maybe Day)
+    } deriving (Show)
+
+
+data PantryCabal = PantryCabal
+    { pcPackageName :: !PackageNameP
+    , pcVersion     :: !VersionP
+    , pcCabalKey    :: !BlobKey
+    } deriving (Show)
+
+instance Display PantryCabal where
+    display PantryCabal {..} =
+        display (PackageIdentifierP pcPackageName pcVersion) <> "@sha256:" <>
+        display pcCabalKey
+
+instance ToMarkup PantryCabal where
+    toMarkup = toMarkup . textDisplay
+
+data PantryPackage = PantryPackage
+    { ppPantryCabal :: !PantryCabal
+    , ppPantryKey   :: !TreeKey
+    } deriving (Show)
+
+toPackageIdentifierRevision :: PantryCabal -> PackageIdentifierRevision
+toPackageIdentifierRevision PantryCabal {..} =
+    PackageIdentifierRevision
+        (unPackageNameP pcPackageName)
+        (unVersionP pcVersion)
+        (CFIHash sha (Just size))
+  where
+    BlobKey sha size = pcCabalKey
+
+-- QUESTION: Potentially switch to `parsePackageIdentifierRevision`:
+   -- PackageIdentifierRevision pn v (CFIHash sha (Just size)) <-
+   --     either (fail . displayException) pure $ parsePackageIdentifierRevision txt
+   -- return (PantryCabal pn v sha size)
+-- Issues with such switch:
+--  * CFILatest and CFIRevision do not make sense in stackage-snapshots
+--  * Implementation below is faster
+instance FromJSON PantryCabal where
+    parseJSON =
+        withText "PantryCabal" $ \txt -> do
+            let (packageTxt, hashWithSize) = T.break (== '@') txt
+                (hashTxtWithAlgo, sizeWithComma) = T.break (== ',') hashWithSize
+            -- Split package identifier foo-bar-0.1.2 into package name and version
+            (pkgNameTxt, pkgVersionTxt) <-
+                case T.breakOnEnd "-" packageTxt of
+                    (pkgNameWithDashEnd, pkgVersionTxt)
+                        | Just pkgName <- T.stripSuffix "-" pkgNameWithDashEnd ->
+                            return (pkgName, pkgVersionTxt)
+                    _ -> fail $ "Invalid package identifier format: " ++ T.unpack packageTxt
+            pcPackageName <- parseJSON $ String pkgNameTxt
+            pcVersion <- parseJSON $ String pkgVersionTxt
+            hashTxt <-
+                maybe (fail $ "Unrecognized hashing algorithm: " ++ T.unpack hashTxtWithAlgo) pure $
+                T.stripPrefix "@sha256:" hashTxtWithAlgo
+            pcSHA256 <- either (fail . displayException) pure $ fromHexText hashTxt
+            (pcFileSize, "") <-
+                either fail (pure . first FileSize) =<<
+                maybe
+                    (fail $ "Wrong size format:" ++ show sizeWithComma)
+                    (pure . decimal)
+                    (T.stripPrefix "," sizeWithComma)
+            let pcCabalKey = BlobKey pcSHA256 pcFileSize
+            return PantryCabal {..}
+
+
+instance FromJSON PantryPackage where
+    parseJSON =
+        withObject "PantryPackage" $ \obj ->
+            PantryPackage <$> obj .: "hackage" <*> obj .: "pantry-tree"
+
+
+instance FromJSON SnapshotFile where
+    parseJSON =
+        withObject "SnapshotFile" $ \obj -> do
+            sfCompiler <-
+                obj .:? "resolver" >>= \case
+                    Just resolverCompiler -> resolverCompiler .: "compiler"
+                    Nothing -> obj .: "compiler"
+            sfPackages <- obj .: "packages"
+            sfHidden <- obj .:? "hidden" .!= mempty
+            sfFlags <- obj .:? "flags" .!= mempty
+            sfPublishDate <- fmap utctDay <$> obj .:? "publish-time"
+            pure SnapshotFile {..}
+
+
+data PackageListingInfo = PackageListingInfo
+    { pliName     :: !PackageNameP
+    , pliVersion  :: !VersionP
+    , pliSynopsis :: !Text
+    , pliOrigin   :: !Origin
+    } deriving Show
+
+
+instance ToJSON PackageListingInfo where
+    toJSON PackageListingInfo {..} =
+        object
+            [ "name"     .= pliName
+            , "version"  .= pliVersion
+            , "synopsis" .= pliSynopsis
+            , "origin"   .= pliOrigin
+            ]
+
+
+data HackageCabalInfo = HackageCabalInfo
+    { hciCabalId     :: !HackageCabalId
+    , hciCabalBlobId :: !BlobId
+    , hciPackageName :: !PackageNameP
+    , hciVersionRev  :: !VersionRev
+    } deriving (Show, Eq)
+
+data SnapshotPackageInfo = SnapshotPackageInfo
+    { spiSnapshotPackageId :: !SnapshotPackageId
+    , spiSnapshotId        :: !SnapshotId
+    , spiCabalBlobId       :: !(Maybe BlobId)
+    , spiSnapName          :: !SnapName
+    , spiPackageName       :: !PackageNameP
+    , spiVersion           :: !VersionP
+    , spiRevision          :: !(Maybe Revision)
+    , spiOrigin            :: !Origin
+    , spiReadme            :: !(Maybe TreeEntryId)
+    , spiChangelog         :: !(Maybe TreeEntryId)
+    } deriving (Show, Eq)
+
+
+data SnapshotPackagePageInfo = SnapshotPackagePageInfo
+    { sppiSnapshotPackageInfo    :: !SnapshotPackageInfo
+    -- ^ Info of the package on this page
+    , sppiLatestHackageCabalInfo :: !(Maybe HackageCabalInfo)
+    -- ^ If the package is available on hackage, show its latest info
+    , sppiForwardDeps            :: ![(PackageNameP, VersionRangeP)]
+    -- ^ Limited list of packages in the snapshot that this package depends on
+    , sppiForwardDepsCount       :: !Int
+    -- ^ Count of all packages in the snapshot that this package depends on
+    , sppiReverseDeps            :: ![(PackageNameP, VersionRangeP)]
+    -- ^ Limited list of packages in the snapshot that depend on this package
+    , sppiReverseDepsCount       :: !Int
+    -- ^ Count of all packages in the snapshot that depends on this package
+    , sppiLatestInfo             :: ![LatestInfo]
+    , sppiModuleNames            :: ![ModuleNameP]
+    , sppiPantryCabal            :: !(Maybe PantryCabal)
+    , sppiVersion                :: !(Maybe VersionRev)
+    -- ^ Version on this page. Should be present only if different from latest
+    }
+
+toRevMaybe :: Revision -> Maybe Revision
+toRevMaybe rev = guard (rev /= Revision 0) >> Just rev
+
+-- | Add revision only if it is non-zero
+toVersionRev :: VersionP -> Revision -> VersionRev
+toVersionRev v = VersionRev v . toRevMaybe
+
+-- | Add revision only if it is present and is non-zero
+toVersionMRev :: VersionP -> Maybe Revision -> VersionRev
+toVersionMRev v mrev = VersionRev v (maybe Nothing toRevMaybe mrev)
+
+spiVersionRev :: SnapshotPackageInfo -> VersionRev
+spiVersionRev spi = VersionRev (spiVersion spi) (spiRevision spi >>= toRevMaybe)
+
+dropVersionRev :: PackageVersionRev -> PackageNameP
+dropVersionRev (PackageVersionRev pname _) = pname
+
+
+data ModuleListingInfo = ModuleListingInfo
+    { mliModuleName        :: !ModuleNameP
+    , mliPackageIdentifier :: !PackageIdentifierP
+    } deriving Show
+
+
+data LatestInfo = LatestInfo
+    { liSnapName   :: !SnapName
+    , liVersionRev :: !VersionRev
+    } deriving (Show, Eq)
+
+
+
+data Deprecation = Deprecation
+    { depPackage    :: !PackageNameP
+    , depInFavourOf :: !(Set PackageNameP)
+    }
+instance ToJSON Deprecation where
+    toJSON d = object
+        [ "deprecated-package" .= depPackage d
+        , "in-favour-of" .= depInFavourOf d
+        ]
+instance FromJSON Deprecation where
+    parseJSON = withObject "Deprecation" $ \o -> Deprecation
+        <$> o .: "deprecated-package"
+        <*> o .: "in-favour-of"
+
+
+data Readme = Readme !ByteString !Bool
+data Changelog = Changelog !ByteString !Bool

src/Stackage/Metadata.hs

@@ -1,94 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE OverloadedStrings  #-}
-module Stackage.Metadata
-    ( PackageInfo (..)
-    , Deprecation (..)
-    ) where
-
-import           Control.Applicative           ((<$>), (<*>))
-import           Data.Aeson                    (FromJSON (..), ToJSON (..),
-                                                object, withObject, (.:), (.=))
-import           Data.Map                      (Map)
-import qualified Data.Map                      as Map
-import           Data.Set                      (Set)
-import qualified Data.Set                      as Set
-import           Data.Text                     (Text)
-import           Data.Typeable                 (Typeable)
-import           Distribution.Types.Version    (Version)
-import           Distribution.Package          (PackageName)
-import           Distribution.Version          (VersionRange)
-import           Prelude                       hiding (pi)
-import           Stackage.PackageIndex.Conduit (parseDistText, renderDistText)
-
-data PackageInfo = PackageInfo
-    { piLatest          :: !Version
-    , piHash            :: !Text
-    , piAllVersions     :: !(Set Version)
-    , piSynopsis        :: !Text
-    , piDescription     :: !Text
-    , piDescriptionType :: !Text
-    , piChangeLog       :: !Text
-    , piChangeLogType   :: !Text
-    , piBasicDeps       :: !(Map PackageName VersionRange)
-    , piTestBenchDeps   :: !(Map PackageName VersionRange)
-    , piAuthor          :: !Text
-    , piMaintainer      :: !Text
-    , piHomepage        :: !Text
-    , piLicenseName     :: !Text
-    }
-    deriving (Show, Eq, Typeable)
-instance ToJSON PackageInfo where
-    toJSON pi = object
-        [ "latest" .= renderDistText (piLatest pi)
-        , "hash" .= piHash pi
-        , "all-versions" .= map renderDistText (Set.toList $ piAllVersions pi)
-        , "synopsis" .= piSynopsis pi
-        , "description" .= piDescription pi
-        , "description-type" .= piDescriptionType pi
-        , "changelog" .= piChangeLog pi
-        , "changelog-type" .= piChangeLogType pi
-        , "basic-deps" .= showM (piBasicDeps pi)
-        , "test-bench-deps" .= showM (piTestBenchDeps pi)
-        , "author" .= piAuthor pi
-        , "maintainer" .= piMaintainer pi
-        , "homepage" .= piHomepage pi
-        , "license-name" .= piLicenseName pi
-        ]
-      where
-        showM = Map.mapKeysWith const renderDistText . Map.map renderDistText
-instance FromJSON PackageInfo where
-    parseJSON = withObject "PackageInfo" $ \o -> PackageInfo
-        <$> (o .: "latest" >>= parseDistText)
-        <*> o .: "hash"
-        <*> (o .: "all-versions" >>= fmap Set.fromList . mapM parseDistText)
-        <*> o .: "synopsis"
-        <*> o .: "description"
-        <*> o .: "description-type"
-        <*> o .: "changelog"
-        <*> o .: "changelog-type"
-        <*> (o .: "basic-deps" >>= parseM)
-        <*> (o .: "test-bench-deps" >>= parseM)
-        <*> o .: "author"
-        <*> o .: "maintainer"
-        <*> o .: "homepage"
-        <*> o .: "license-name"
-      where
-        parseM = fmap Map.fromList . mapM go . Map.toList
-        go (name, range) = do
-            name' <- parseDistText name
-            range' <- parseDistText range
-            return (name', range')
-
-data Deprecation = Deprecation
-    { depPackage    :: !Text
-    , depInFavourOf :: !(Set Text)
-    }
-instance ToJSON Deprecation where
-    toJSON d = object
-        [ "deprecated-package" .= depPackage d
-        , "in-favour-of" .= depInFavourOf d
-        ]
-instance FromJSON Deprecation where
-    parseJSON = withObject "Deprecation" $ \o -> Deprecation
-        <$> o .: "deprecated-package"
-        <*> o .: "in-favour-of"

src/Stackage/PackageIndex/Conduit.hs

@@ -1,88 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-module Stackage.PackageIndex.Conduit
-    ( sourceTarFile
-    , sourceAllCabalFiles
-    , parseDistText
-    , renderDistText
-    , CabalFileEntry (..)
-    ) where
-
-import qualified Codec.Archive.Tar                     as Tar
-import           Codec.Compression.GZip                (decompress)
-import           Control.Monad                         (guard)
-import           Control.Monad.IO.Class                (liftIO)
-import           Control.Monad.Trans.Resource          (MonadResource)
-import qualified Data.ByteString.Lazy                  as L
-import           Data.Conduit                          (ConduitT, bracketP, yield, (.|))
-import qualified Data.Conduit.List                     as CL
-import           Data.Version                          (Version)
-import           Distribution.Compat.ReadP             (readP_to_S)
-import           Distribution.Package                  (PackageName)
-import           Distribution.PackageDescription       (GenericPackageDescription)
-import           Distribution.PackageDescription.Parsec (ParseResult, parseGenericPackageDescription)
-import           Distribution.Text                     (disp, parse)
-import qualified Distribution.Text
-import           System.IO                             (openBinaryFile)
-import           Text.PrettyPrint                      (render)
-import Prelude
-import UnliftIO
-
-sourceTarFile :: MonadResource m
-              => Bool -- ^ ungzip?
-              -> FilePath
-              -> ConduitT i Tar.Entry m ()
-sourceTarFile toUngzip fp = do
-    bracketP (openBinaryFile fp ReadMode) hClose $ \h -> do
-        lbs <- liftIO $ L.hGetContents h
-        loop $ Tar.read $ ungzip' lbs
-  where
-    ungzip'
-        | toUngzip = decompress
-        | otherwise = id
-    loop Tar.Done = return ()
-    loop (Tar.Fail e) = throwIO e
-    loop (Tar.Next e es) = yield e >> loop es
-
-data CabalFileEntry = CabalFileEntry
-    { cfeName    :: !PackageName
-    , cfeVersion :: !Version
-    , cfeRaw     :: L.ByteString
-    , cfeEntry   :: Tar.Entry
-    , cfeParsed  :: ParseResult GenericPackageDescription
-    }
-
-sourceAllCabalFiles
-    :: MonadResource m
-    => IO FilePath
-    -> ConduitT i CabalFileEntry m ()
-sourceAllCabalFiles getIndexTar = do
-    tarball <- liftIO $ getIndexTar
-    sourceTarFile False tarball .| CL.mapMaybe go
-  where
-    go e =
-        case (toPkgVer $ Tar.entryPath e, Tar.entryContent e) of
-            (Just (name, version), Tar.NormalFile lbs _) -> Just CabalFileEntry
-                { cfeName = name
-                , cfeVersion = version
-                , cfeRaw = lbs
-                , cfeEntry = e
-                , cfeParsed = parseGenericPackageDescription $ L.toStrict lbs
-                }
-            _ -> Nothing
-
-    toPkgVer s0 = do
-        (name', '/':s1) <- Just $ break (== '/') s0
-        (version', '/':s2) <- Just $ break (== '/') s1
-        guard $ s2 == (name' ++ ".cabal")
-        name <- parseDistText name'
-        version <- parseDistText version'
-        Just (name, version)
-
-parseDistText :: (Monad m, Distribution.Text.Text t) => String -> m t
-parseDistText s =
-    case map fst $ filter (null . snd) $ readP_to_S parse s of
-        [x] -> return x
-        _ -> fail $ "Could not parse: " ++ s
-
-renderDistText :: Distribution.Text.Text t => t -> String
-renderDistText = render . disp

src/Stackage/Snapshot/Diff.hs

@@ -1,4 +1,8 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE ViewPatterns #-}
 module Stackage.Snapshot.Diff
   ( getSnapshotDiff
   , snapshotDiff
@@ -9,24 +13,24 @@ module Stackage.Snapshot.Diff
   , WithSnapshotNames(..)
   ) where
 
-import qualified Data.Text as T(commonPrefixes)
-import           Data.Align
-import           Data.Aeson
+import ClassyPrelude (sortOn, toCaseFold)
+import Data.Aeson
+import Data.Align
 import qualified Data.HashMap.Strict as HashMap
-import           Control.Arrow
-import           ClassyPrelude
-import           Data.These
-import           Stackage.Database (SnapshotId, PackageListingInfo(..),
-                                    GetStackageDatabase, getPackages)
-import           Stackage.Database.Types (SnapName)
-import           Types
-import           Web.PathPieces
+import qualified Data.Text as T (commonPrefixes)
+import Data.These
+import RIO
+import Stackage.Database (GetStackageDatabase, SnapshotId,
+                          getPackagesForSnapshot)
+import Stackage.Database.Types (PackageListingInfo(..), SnapName)
+import Types
+import Web.PathPieces
 
 data WithSnapshotNames a
     = WithSnapshotNames SnapName SnapName a
 
 newtype SnapshotDiff
-    = SnapshotDiff { unSnapshotDiff :: HashMap PackageName VersionChange }
+    = SnapshotDiff { unSnapshotDiff :: HashMap PackageNameP VersionChange }
     deriving (Show, Eq, Generic, Typeable)
 
 instance ToJSON (WithSnapshotNames SnapshotDiff) where
@@ -35,21 +39,23 @@ instance ToJSON (WithSnapshotNames SnapshotDiff) where
                , "diff"      .= toJSON (WithSnapshotNames nameA nameB <$> diff)
                ]
 
-toDiffList :: SnapshotDiff -> [(PackageName, VersionChange)]
-toDiffList = sortOn (toCaseFold . unPackageName . fst) . HashMap.toList . unSnapshotDiff
+toDiffList :: SnapshotDiff -> [(PackageNameP, VersionChange)]
+toDiffList = sortOn (toCaseFold . textDisplay . fst) . HashMap.toList . unSnapshotDiff
 
 versionPrefix :: VersionChange -> Maybe (Text, Text, Text)
 versionPrefix vc = case unVersionChange vc of
-        These (Version a) (Version b) -> T.commonPrefixes a b
-        _ -> Nothing
+        These va vb -> T.commonPrefixes (textDisplay va) (textDisplay vb)
+        _           -> Nothing
 
-versionedDiffList :: [(PackageName, VersionChange)] -> [(PackageName, VersionChange, Maybe (Text, Text, Text))]
+versionedDiffList ::
+       [(PackageNameP, VersionChange)] -> [(PackageNameP, VersionChange, Maybe (Text, Text, Text))]
 versionedDiffList = map withPrefixedVersion
   where
-    withPrefixedVersion (packageName, versionChange) = (packageName, versionChange, versionPrefix versionChange)
+    withPrefixedVersion (packageName, versionChange) =
+        (packageName, versionChange, versionPrefix versionChange)
 
 
-toVersionedDiffList :: SnapshotDiff -> [(PackageName, VersionChange, Maybe (Text, Text, Text))]
+toVersionedDiffList :: SnapshotDiff -> [(PackageNameP, VersionChange, Maybe (Text, Text, Text))]
 toVersionedDiffList = versionedDiffList . toDiffList
 
 -- | Versions of a package as it occurs in the listings provided to `snapshotDiff`.
@@ -57,7 +63,7 @@ toVersionedDiffList = versionedDiffList . toDiffList
 --   Would be represented with `These v1 v2` if the package is present in both listings,
 --   otherwise it would be `This v1` if the package is present only in the first listing,
 --   or `That v2` if only in the second.
-newtype VersionChange = VersionChange { unVersionChange :: These Version Version }
+newtype VersionChange = VersionChange { unVersionChange :: These VersionP VersionP }
                       deriving (Show, Eq, Generic, Typeable)
 
 instance ToJSON (WithSnapshotNames VersionChange) where
@@ -70,12 +76,12 @@ instance ToJSON (WithSnapshotNames VersionChange) where
 changed :: VersionChange -> Bool
 changed = these (const True) (const True) (/=) . unVersionChange
 
-getSnapshotDiff :: GetStackageDatabase m => SnapshotId -> SnapshotId -> m SnapshotDiff
-getSnapshotDiff a b = snapshotDiff <$> getPackages a <*> getPackages b
+getSnapshotDiff :: GetStackageDatabase env m => SnapshotId -> SnapshotId -> m SnapshotDiff
+getSnapshotDiff a b = snapshotDiff <$> getPackagesForSnapshot a <*> getPackagesForSnapshot b
 
 snapshotDiff :: [PackageListingInfo] -> [PackageListingInfo] -> SnapshotDiff
 snapshotDiff as bs =
     SnapshotDiff $ HashMap.filter changed
                  $ alignWith VersionChange (toMap as) (toMap bs)
   where
-    toMap = HashMap.fromList . map (PackageName . pliName &&& Version . pliVersion)
+    toMap = HashMap.fromList . map (pliName &&& pliVersion)

src/Stackage/Types.hs

@@ -1,47 +1,39 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 module Stackage.Types
   ( BuildPlan (..)
   , SystemInfo (..)
   , PackagePlan (..)
   , DocMap
   , PackageDocs (..)
-  , PackageName
-  , Version
-  , display
   ) where
 
-import qualified Distribution.Text               as DT
 import ClassyPrelude.Conduit
 import Data.Aeson
-import Distribution.Types.PackageName (PackageName, mkPackageName)
-import Distribution.Version (Version)
-import Control.Monad.Catch (MonadThrow, throwM)
-import Data.Typeable (TypeRep, Typeable, typeOf)
+import Pantry.Internal.Stackage (PackageNameP(..), VersionP(..))
 
 data BuildPlan = BuildPlan
-  { bpSystemInfo :: !SystemInfo
-  , bpPackages :: !(Map PackageName PackagePlan)
-  }
+    { bpSystemInfo :: !SystemInfo
+    , bpPackages :: !(Map PackageNameP PackagePlan)
+    }
 instance FromJSON BuildPlan where
-  parseJSON = withObject "BuildPlan" $ \o -> BuildPlan
-    <$> o .: "system-info"
-    <*> o .: "packages"
+    parseJSON = withObject "BuildPlan" $ \o -> BuildPlan
+        <$> o .: "system-info"
+        <*> o .: "packages"
 
 data SystemInfo = SystemInfo
-  { siGhcVersion :: !Version
-  , siCorePackages :: !(Map PackageName Version)
-  }
+    { siGhcVersion :: !VersionP
+    , siCorePackages :: !(Map PackageNameP VersionP)
+    }
 instance FromJSON SystemInfo where
-  parseJSON = withObject "SystemInfo" $ \o -> SystemInfo
-    <$> o .: "ghc-version"
-    <*> o .: "core-packages"
+    parseJSON = withObject "SystemInfo" $ \o -> SystemInfo
+        <$> o .: "ghc-version"
+        <*> o .: "core-packages"
 
-data PackagePlan = PackagePlan
-  { ppVersion :: Version
-  }
+newtype PackagePlan = PackagePlan
+    { ppVersion :: VersionP
+    }
 instance FromJSON PackagePlan where
-  parseJSON = withObject "PackagePlan" $ \o -> PackagePlan
-    <$> o .: "version"
+    parseJSON = withObject "PackagePlan" $ \o -> PackagePlan <$> o .: "version"
 
 type DocMap = Map Text PackageDocs
 
@@ -54,35 +46,3 @@ instance FromJSON PackageDocs where
         <$> o .: "version"
         <*> o .: "modules"
 
-display :: DT.Text a => a -> Text
-display = fromString . DT.display
-
-data ParseFailedException = ParseFailedException TypeRep Text
-    deriving (Show, Typeable)
-instance Exception ParseFailedException
-
-simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a
-simpleParse orig = withTypeRep $ \rep ->
-    case DT.simpleParse str of
-        Nothing -> throwM (ParseFailedException rep (pack str))
-        Just v  -> return v
-  where
-    str = unpack orig
-
-    withTypeRep :: Typeable a => (TypeRep -> m a) -> m a
-    withTypeRep f =
-        res
-      where
-        res = f (typeOf (unwrap res))
-
-        unwrap :: m a -> a
-        unwrap _ = error "unwrap"
-
--- orphans
-
-instance FromJSON Version where
-  parseJSON = withText "Version" $ either (fail . show) pure . simpleParse
-instance FromJSON PackageName where
-  parseJSON = withText "PackageName" $ pure . mkPackageName . unpack
-instance FromJSONKey PackageName where
-  fromJSONKey = FromJSONKeyText $ mkPackageName . unpack

src/Types.hs

@@ -1,77 +1,275 @@
-module Types where
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+module Types
+    ( SnapName (..)
+    , isLts
+    , isNightly
+    , SnapshotBranch(..)
+    , snapshotPrettyName
+    , snapshotPrettyNameShort
+    , PackageNameP(..)
+    , parsePackageNameP
+    , VersionP(..)
+    , Revision(..)
+    , VersionRev(..)
+    , VersionRangeP(..)
+    , CompilerP(..)
+    , parseCompilerP
+    , FlagNameP(..)
+    , PackageVersionRev(..)
+    , ModuleNameP(..)
+    , parseModuleNameP
+    , SafeFilePath
+    , unSafeFilePath
+    , moduleNameFromComponents
+    , PackageIdentifierP(..)
+    , PackageNameVersion(..)
+    , GenericPackageDescription
+    , HoogleVersion(..)
+    , currentHoogleVersion
+    , UnpackStatus(..)
+    , GhcMajorVersion(..)
+    , GhcMajorVersionFailedParse(..)
+    , ghcMajorVersionFromText
+    , keepMajorVersion
+    , dtDisplay
+    , dtParse
+    , SupportedArch(..)
+    , Year
+    , Month(Month)
+    , Origin(..)
+    ) where
 
-import ClassyPrelude.Yesod
-import Data.Aeson
-import Data.Hashable (hashUsing)
-import Text.Blaze (ToMarkup)
-import Database.Persist.Sql (PersistFieldSql (sqlType))
-import qualified Data.Text as T
-import qualified Data.Text.Lazy.Builder.Int as Builder
-import qualified Data.Text.Lazy.Builder as Builder
-import qualified Data.Text.Lazy as LText
-import qualified Data.Text.Read as Reader
-import Data.Char (ord)
+import ClassyPrelude.Yesod (ToBuilder(..))
 import Control.Monad.Catch (MonadThrow, throwM)
+import Data.Aeson
+import Data.Bifunctor (bimap)
+import Data.Char (ord)
+import Data.Hashable (hashUsing, hashWithSalt)
+import qualified Data.Text as T
+import qualified Data.Text.Read as Reader
+import Data.Typeable
+import Database.Esqueleto.Internal.Language
+import Database.Persist
+import Database.Persist.Sql (PersistFieldSql(sqlType))
+import qualified Distribution.ModuleName as DT (components, fromComponents,
+                                                validModuleComponent)
+import Distribution.PackageDescription (FlagName, GenericPackageDescription)
+import qualified Distribution.Text as DT (Text, display, simpleParse)
+import Distribution.Types.VersionRange (VersionRange)
+import Distribution.Version (mkVersion, versionNumbers)
+import Pantry (Revision(..))
+import Pantry.Internal.Stackage (ModuleNameP(..), PackageNameP(..),
+                                 SafeFilePath, VersionP(..), packageNameString,
+                                 parsePackageName, parseVersion,
+                                 parseVersionThrowing, unSafeFilePath,
+                                 versionString)
+import RIO
+import qualified RIO.Map as Map
+import RIO.Time (Day)
+import Text.Blaze (ToMarkup(..))
+import Web.PathPieces
+
+data ParseFailedException = ParseFailedException !TypeRep !String
+    deriving (Show, Typeable)
+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 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 = fromString . DT.display
+
+
+
+data SnapName = SNLts !Int !Int
+              | SNNightly !Day
+    deriving (Eq, Ord, Read, Show)
+
+isLts :: SnapName -> Bool
+isLts SNLts{}     = True
+isLts SNNightly{} = False
+
+isNightly :: SnapName -> Bool
+isNightly SNLts{}     = False
+isNightly SNNightly{} = True
+
+
+snapshotPrettyName :: SnapName -> CompilerP -> Text
+snapshotPrettyName sName sCompiler =
+    T.concat [snapshotPrettyNameShort sName, " (", textDisplay sCompiler, ")"]
+
+snapshotPrettyNameShort :: SnapName -> Text
+snapshotPrettyNameShort name =
+    case name of
+        SNLts x y -> T.concat ["LTS Haskell ", T.pack (show x), ".", T.pack (show y)]
+        SNNightly d -> "Stackage Nightly " <> T.pack (show d)
+
+
+instance ToJSONKey SnapName
+
+instance ToJSON SnapName where
+    toJSON = String . toPathPiece
+
+instance PersistField SnapName where
+    toPersistValue = toPersistValue . toPathPiece
+    fromPersistValue v = do
+        t <- fromPersistValue v
+        case fromPathPiece t of
+            Nothing -> Left $ "Invalid SnapName: " <> t
+            Just x  -> return x
+instance PersistFieldSql SnapName where
+    sqlType = sqlType . fmap toPathPiece
+instance PathPiece SnapName where
+    toPathPiece = textDisplay
+    fromPathPiece = parseSnapName
+
+instance FromJSON SnapName where
+    parseJSON = withText "SnapName" (maybe (fail "Can't parse snapshot name") pure . parseSnapName)
+
+instance ToMarkup SnapName where
+    toMarkup = toMarkup . textDisplay
+
+instance Display SnapName where
+    display =
+        \case
+            (SNLts x y) -> mconcat ["lts-", displayShow x, ".", displayShow y]
+            (SNNightly d) -> "nightly-" <> displayShow d
+
+parseSnapName :: Text -> Maybe SnapName
+parseSnapName t0 = nightly <|> lts
+  where
+    nightly = fmap SNNightly $ T.stripPrefix "nightly-" t0 >>= (readMaybe . T.unpack)
+    lts = do
+        t1 <- T.stripPrefix "lts-" t0
+        Right (x, t2) <- Just $ Reader.decimal t1
+        t3 <- T.stripPrefix "." t2
+        Right (y, "") <- Just $ Reader.decimal t3
+        return $ SNLts x y
 
 data SnapshotBranch = LtsMajorBranch Int
                     | LtsBranch
                     | NightlyBranch
                     deriving (Eq, Read, Show)
 instance PathPiece SnapshotBranch where
-    toPathPiece NightlyBranch = "nightly"
-    toPathPiece LtsBranch     = "lts"
-    toPathPiece (LtsMajorBranch x) = "lts-" ++ tshow x
+    toPathPiece NightlyBranch      = "nightly"
+    toPathPiece LtsBranch          = "lts"
+    toPathPiece (LtsMajorBranch x) = "lts-" <> T.pack (show x)
 
     fromPathPiece "nightly" = Just NightlyBranch
     fromPathPiece "lts" = Just LtsBranch
     fromPathPiece t0 = do
-        t1 <- stripPrefix "lts-" t0
+        t1 <- T.stripPrefix "lts-" t0
         Right (x, "") <- Just $ Reader.decimal t1
         Just $ LtsMajorBranch x
 
-newtype PackageName = PackageName { unPackageName :: Text }
-    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, IsString)
-instance ToJSON PackageName where
-    toJSON = toJSON . unPackageName
-instance ToJSONKey PackageName
-instance PersistFieldSql PackageName where
-    sqlType = sqlType . liftM unPackageName
-newtype Version = Version { unVersion :: Text }
-    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField)
-instance ToJSON Version where
-    toJSON = toJSON . unVersion
-instance PersistFieldSql Version where
-    sqlType = sqlType . liftM unVersion
 newtype PackageSetIdent = PackageSetIdent { unPackageSetIdent :: Text }
     deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField)
 instance PersistFieldSql PackageSetIdent where
-    sqlType = sqlType . liftM unPackageSetIdent
+    sqlType = sqlType . fmap unPackageSetIdent
+
+data PackageNameVersion = PNVTarball !PackageNameP !VersionP
+                        | PNVNameVersion !PackageNameP !VersionP
+                        | PNVName !PackageNameP
+    deriving (Read, Show, Eq, Ord)
+
+data PackageIdentifierP =
+    PackageIdentifierP !PackageNameP
+                       !VersionP
+    deriving (Eq, Ord, Show)
+
+instance Display PackageIdentifierP where
+    display (PackageIdentifierP pname ver) = display pname <> "-" <> display ver
+instance PathPiece PackageIdentifierP where
+    toPathPiece = textDisplay
+    fromPathPiece t = do
+        let (tName', tVer) = T.breakOnEnd "-" t
+        (tName, '-') <- T.unsnoc tName'
+        guard $ not (T.null tName || T.null tVer)
+        PackageIdentifierP <$> fromPathPiece tName <*> fromPathPiece tVer
+instance ToMarkup PackageIdentifierP where
+    toMarkup = toMarkup . textDisplay
+
+instance Hashable PackageNameP where
+    hashWithSalt = hashUsing textDisplay
+instance ToBuilder PackageNameP Builder where
+    toBuilder = getUtf8Builder . display
+
+parsePackageNameP :: String -> Maybe PackageNameP
+parsePackageNameP = fmap PackageNameP . parsePackageName
+
+instance PathPiece PackageNameP where
+    fromPathPiece = parsePackageNameP . T.unpack
+    toPathPiece = textDisplay
+instance ToMarkup PackageNameP where
+    toMarkup = toMarkup . packageNameString . unPackageNameP
+instance SqlString PackageNameP
+
+instance SqlString SafeFilePath
+
+instance PathPiece VersionP where
+    fromPathPiece = fmap VersionP . parseVersion . T.unpack
+    toPathPiece = textDisplay
+instance ToMarkup VersionP where
+    toMarkup (VersionP v) = toMarkup $ versionString v
+instance ToBuilder VersionP Builder where
+    toBuilder = getUtf8Builder . display
+instance SqlString VersionP
+
+keepMajorVersion :: VersionP -> VersionP
+keepMajorVersion pver@(VersionP ver) =
+    case versionNumbers ver of
+        nums@(_major:_minor:_) -> VersionP (mkVersion nums)
+        _                      -> pver
+
+
+instance ToMarkup Revision where
+    toMarkup (Revision r) = "rev:" <> toMarkup r
+
+data VersionRev = VersionRev
+    { vrVersion  :: !VersionP
+    , vrRevision :: !(Maybe Revision)
+    } deriving (Eq, Show)
+
+instance ToMarkup VersionRev where
+    toMarkup (VersionRev version mrev) =
+        toMarkup version <> maybe "" (("@" <>) . toMarkup) mrev
+
+data PackageVersionRev = PackageVersionRev !PackageNameP !VersionRev deriving (Eq, Show)
+
+instance ToMarkup PackageVersionRev where
+    toMarkup (PackageVersionRev pname version) = toMarkup pname <> "-" <> toMarkup version
 
-data PackageNameVersion = PNVTarball !PackageName !Version
-                        | PNVNameVersion !PackageName !Version
-                        | PNVName !PackageName
-    deriving (Show, Read, Typeable, Eq, Ord)
 
 instance PathPiece PackageNameVersion where
-    toPathPiece (PNVTarball x y) = concat [toPathPiece x, "-", toPathPiece y, ".tar.gz"]
-    toPathPiece (PNVNameVersion x y) = concat [toPathPiece x, "-", toPathPiece y]
+    toPathPiece (PNVTarball x y) = T.concat [toPathPiece x, "-", toPathPiece y, ".tar.gz"]
+    toPathPiece (PNVNameVersion x y) = T.concat [toPathPiece x, "-", toPathPiece y]
     toPathPiece (PNVName x) = toPathPiece x
-    fromPathPiece t' | Just t <- stripSuffix ".tar.gz" t' =
+    fromPathPiece t'
+        | Just t <- T.stripSuffix ".tar.gz" t' = do
+            PackageIdentifierP name version <- fromPathPiece t
+            return $ PNVTarball name version
+    fromPathPiece t =
         case T.breakOnEnd "-" t of
-            ("", _) -> Nothing
-            (_, "") -> Nothing
-            (T.init -> name, version) -> Just $ PNVTarball (PackageName name) (Version version)
-    fromPathPiece t = Just $
-        case T.breakOnEnd "-" t of
-            ("", _) -> PNVName (PackageName t)
-            (T.init -> name, version) | validVersion version ->
-                PNVNameVersion (PackageName name) (Version version)
-            _ -> PNVName (PackageName t)
-      where
-        validVersion =
-            all f
-          where
-            f c = (c == '.') || ('0' <= c && c <= '9')
+            ("", _) -> PNVName <$> fromPathPiece t
+            (fromPathPiece . T.init -> Just name, fromPathPiece -> Just version) ->
+                Just $ PNVNameVersion name version
+            _ -> PNVName <$> fromPathPiece t
+
 
 newtype HoogleVersion = HoogleVersion Text
     deriving (Show, Eq, Ord, Typeable, PathPiece)
@@ -82,62 +280,48 @@ data UnpackStatus = USReady
                   | USBusy
                   | USFailed !Text
 
-data StackageExecutable
-    = StackageWindowsExecutable
-    | StackageUnixExecutable
-    deriving (Show, Read, Eq)
-
-instance PathPiece StackageExecutable where
-    -- TODO: distribute stackage, not just stackage-setup
-    toPathPiece StackageWindowsExecutable = "stackage-setup.exe"
-    toPathPiece StackageUnixExecutable = "stackage-setup"
-
-    fromPathPiece "stackage-setup" = Just StackageUnixExecutable
-    fromPathPiece "stackage-setup.exe" = Just StackageWindowsExecutable
-    fromPathPiece _ = Nothing
-
 data GhcMajorVersion = GhcMajorVersion !Int !Int
   deriving (Eq)
 
-data GhcMajorVersionFailedParse = GhcMajorVersionFailedParse Text
-  deriving (Show, Typeable)
+newtype GhcMajorVersionFailedParse =
+    GhcMajorVersionFailedParse Text
+    deriving (Show)
 instance Exception GhcMajorVersionFailedParse
 
-ghcMajorVersionToText :: GhcMajorVersion -> Text
-ghcMajorVersionToText (GhcMajorVersion a b)
-  = LText.toStrict
-  $ Builder.toLazyText
-  $ Builder.decimal a <> "." <> Builder.decimal b
+instance Display GhcMajorVersion where
+    display (GhcMajorVersion a b) = display a <> "." <> display b
 
 ghcMajorVersionFromText :: MonadThrow m => Text -> m GhcMajorVersion
-ghcMajorVersionFromText t = case Reader.decimal t of
-  Right (a, T.uncons -> Just ('.', t')) -> case Reader.decimal t' of
-    Right (b, t'') | T.null t'' -> return $ GhcMajorVersion a b
-    _ -> failedParse
-  _ -> failedParse
+ghcMajorVersionFromText t =
+    case Reader.decimal t of
+        Right (a, T.uncons -> Just ('.', t')) ->
+            case Reader.decimal t' of
+                Right (b, t'')
+                    | T.null t'' -> return $ GhcMajorVersion a b
+                _ -> failedParse
+        _ -> failedParse
   where
     failedParse = throwM $ GhcMajorVersionFailedParse t
 
 instance PersistFieldSql GhcMajorVersion where
-    sqlType = sqlType . liftM ghcMajorVersionToText
+    sqlType = sqlType . fmap textDisplay
 
 instance PersistField GhcMajorVersion where
-    toPersistValue = toPersistValue . ghcMajorVersionToText
+    toPersistValue = toPersistValue . textDisplay
     fromPersistValue v = do
         t <- fromPersistValueText v
         case ghcMajorVersionFromText t of
             Just ver -> return ver
-            Nothing -> Left $ "Cannot convert to GhcMajorVersion: " <> t
+            Nothing  -> Left $ "Cannot convert to GhcMajorVersion: " <> t
 
 instance Hashable GhcMajorVersion where
-  hashWithSalt = hashUsing ghcMajorVersionToText
+    hashWithSalt = hashUsing textDisplay
 
 instance FromJSON GhcMajorVersion where
-  parseJSON = withText "GhcMajorVersion" $
-    either (fail . show) return . ghcMajorVersionFromText
+    parseJSON = withText "GhcMajorVersion" $ either (fail . show) return . ghcMajorVersionFromText
 
 instance ToJSON GhcMajorVersion where
-  toJSON = toJSON . ghcMajorVersionToText
+    toJSON = toJSON . textDisplay
 
 
 data SupportedArch
@@ -153,31 +337,168 @@ instance Hashable SupportedArch where
     hashWithSalt = hashUsing fromEnum
 
 instance PathPiece SupportedArch where
-    toPathPiece Win32 = "win32"
-    toPathPiece Win64 = "win64"
+    toPathPiece Win32   = "win32"
+    toPathPiece Win64   = "win64"
     toPathPiece Linux32 = "linux32"
     toPathPiece Linux64 = "linux64"
-    toPathPiece Mac32 = "mac32"
-    toPathPiece Mac64 = "mac64"
+    toPathPiece Mac32   = "mac32"
+    toPathPiece Mac64   = "mac64"
 
-    fromPathPiece "win32" = Just Win32
-    fromPathPiece "win64" = Just Win64
+    fromPathPiece "win32"   = Just Win32
+    fromPathPiece "win64"   = Just Win64
     fromPathPiece "linux32" = Just Linux32
     fromPathPiece "linux64" = Just Linux64
-    fromPathPiece "mac32" = Just Mac32
-    fromPathPiece "mac64" = Just Mac64
-    fromPathPiece _ = Nothing
+    fromPathPiece "mac32"   = Just Mac32
+    fromPathPiece "mac64"   = Just Mac64
+    fromPathPiece _         = Nothing
+
+
+newtype CompilerP =
+    CompilerGHC { ghcVersion :: VersionP }
+    deriving (Eq, Ord)
+
+instance Show CompilerP where
+    show = T.unpack . textDisplay
+
+instance FromJSONKey CompilerP where
+    fromJSONKey = FromJSONKeyTextParser (either fail pure . parseCompilerP)
+
+instance Display CompilerP where
+    display (CompilerGHC vghc) = "ghc-" <> display vghc
+instance ToJSON CompilerP where
+    toJSON = String . textDisplay
+instance FromJSON CompilerP where
+    parseJSON = withText "CompilerP" (either fail return .  parseCompilerP)
+instance PersistField CompilerP where
+    toPersistValue = PersistText . textDisplay
+    fromPersistValue v = fromPersistValue v >>= mapLeft T.pack . parseCompilerP
+instance PersistFieldSql CompilerP where
+    sqlType _ = SqlString
+
+parseCompilerP :: Text -> Either String CompilerP
+parseCompilerP txt =
+    case T.stripPrefix "ghc-" txt of
+        Just vTxt ->
+            bimap displayException (CompilerGHC . VersionP) $ parseVersionThrowing (T.unpack vTxt)
+        Nothing -> Left $ "Invalid prefix for compiler: " <> T.unpack txt
+
 
 type Year = Int
-newtype Month = Month Int
-  deriving (Eq, Read, Show, Ord)
+newtype Month =
+    Month Int
+    deriving (Eq, Read, Show, Ord)
 instance PathPiece Month where
-  toPathPiece (Month i)
-    | i < 10 = pack $ '0' : show i
-    | otherwise = tshow i
-  fromPathPiece "10" = Just $ Month 10
-  fromPathPiece "11" = Just $ Month 11
-  fromPathPiece "12" = Just $ Month 12
-  fromPathPiece (unpack -> ['0', c])
-    | '1' <= c && c <= '9' = Just $ Month $ ord c - ord '0'
-  fromPathPiece _ = Nothing
+    toPathPiece (Month i)
+        | i < 10 = T.pack $ '0' : show i
+        | otherwise = tshow i
+    fromPathPiece "10" = Just $ Month 10
+    fromPathPiece "11" = Just $ Month 11
+    fromPathPiece "12" = Just $ Month 12
+    fromPathPiece (T.unpack -> ['0', c])
+        | '1' <= c && c <= '9' = Just $ Month $ ord c - ord '0'
+    fromPathPiece _ = Nothing
+
+newtype VersionRangeP = VersionRangeP
+    { unVersionRangeP :: VersionRange
+    } deriving (Eq, Show, Read, Data, NFData)
+instance Display VersionRangeP where
+    display = dtDisplay . unVersionRangeP
+    textDisplay = dtDisplay . unVersionRangeP
+instance ToMarkup VersionRangeP where
+    toMarkup = dtDisplay . unVersionRangeP
+instance PersistField VersionRangeP where
+    toPersistValue = PersistText . textDisplay
+    fromPersistValue v =
+        fromPersistValue v >>= bimap (T.pack . displayException) VersionRangeP . dtParse
+instance PersistFieldSql VersionRangeP where
+    sqlType _ = SqlString
+
+
+-- | Construct a module name from valid components
+moduleNameFromComponents :: [Text] -> ModuleNameP
+moduleNameFromComponents = ModuleNameP . DT.fromComponents . map T.unpack
+
+instance ToMarkup ModuleNameP where
+    toMarkup = dtDisplay . unModuleNameP
+-- In urls modules are represented with dashes, instead of dots, i.e. Foo-Bar-Baz vs Foo.Bar.Baz
+instance PathPiece ModuleNameP where
+    toPathPiece (ModuleNameP moduleName) = T.intercalate "-" $ map T.pack $ DT.components moduleName
+    fromPathPiece moduleNameDashes = do
+        (moduleNameDashesNoDot, "") <- Just $ T.break (== '.') moduleNameDashes
+        -- \ make sure there are no dots in the module components
+        let moduleComponents = T.unpack <$> T.split (== '-') moduleNameDashesNoDot
+        guard (all DT.validModuleComponent moduleComponents)
+        pure $ ModuleNameP $ DT.fromComponents moduleComponents
+
+parseModuleNameP :: String -> Maybe ModuleNameP
+parseModuleNameP = fmap ModuleNameP . DT.simpleParse
+
+newtype FlagNameP = FlagNameP
+    { unFlagNameP :: FlagName
+    } deriving (Eq, Ord, Show, Read, Data, NFData)
+
+instance Display FlagNameP where
+    display = dtDisplay . unFlagNameP
+    textDisplay = dtDisplay . unFlagNameP
+
+instance ToMarkup FlagNameP where
+    toMarkup = dtDisplay . unFlagNameP
+
+instance PersistField FlagNameP where
+    toPersistValue = PersistText . textDisplay
+    fromPersistValue v = mapLeft T.pack . parseFlagNameP =<< fromPersistValue v
+instance PersistFieldSql FlagNameP where
+    sqlType _ = SqlString
+instance PersistField (Map FlagNameP Bool) where
+    toPersistValue = toPersistValue . Map.mapKeys textDisplay
+    fromPersistValue v =
+        fmap Map.fromList .
+        traverse (\(k, f) -> (,) <$> mapLeft T.pack (parseFlagNameP k) <*> fromPersistValue f) =<<
+        getPersistMap v
+instance PersistFieldSql (Map FlagNameP Bool) where
+    sqlType _ = SqlString
+
+instance FromJSON FlagNameP where
+    parseJSON = withText "FlagName" (either fail pure . parseFlagNameP)
+instance FromJSONKey FlagNameP where
+    fromJSONKey = FromJSONKeyTextParser (either fail pure . parseFlagNameP)
+
+parseFlagNameP :: Text -> Either String FlagNameP
+parseFlagNameP = bimap displayException FlagNameP . dtParse
+
+
+data Origin
+    = Core
+    | Hackage
+    | Archive
+    | GitRepo
+    | HgRepo
+    deriving (Show, Eq)
+
+instance PersistField Origin where
+    toPersistValue =
+        toPersistValue . \case
+            Core    -> 0 :: Int64
+            Hackage -> 1
+            Archive -> 2
+            GitRepo -> 3
+            HgRepo  -> 4
+    fromPersistValue v =
+        fromPersistValue v >>= \case
+            0 -> Right Core
+            1 -> Right Hackage
+            2 -> Right Archive
+            3 -> Right GitRepo
+            4 -> Right HgRepo
+            n -> Left $ "Unknown origin type: " <> textDisplay (n :: Int64)
+
+instance PersistFieldSql Origin where
+    sqlType _ = SqlInt64
+
+instance ToJSON Origin where
+    toJSON = \case
+      Core    -> "core"
+      Hackage -> "hackage"
+      Archive -> "archive"
+      GitRepo -> "git"
+      HgRepo  -> "mercurial"

stack.yaml

@@ -1 +1,10 @@
-resolver: lts-13.9
+resolver: lts-13.16
+packages:
+  - '.'
+extra-deps:
+- git: https://github.com/commercialhaskell/stack
+  commit: dfbf85ad7e8af5b01cf7b51367290870ffc2c90e
+  subdirs:
+  - subs/http-download
+  - subs/pantry
+  - subs/rio-prettyprint

templates/doc-list.hamlet

@@ -5,5 +5,5 @@
     <ul>
         $forall mli <- mlis
             <li>
-                <a href=#{mliUrl mli}>#{mliName mli}
-                (#{mliPackageVersion mli})
+                <a href=#{mliUrl mli}>#{mliModuleName mli}
+                (#{toPathPiece $ mliPackageIdentifier mli})

templates/home.hamlet

@@ -73,7 +73,7 @@
             <ul>
                 $forall (major, minor, ghc, date) <- latestLtsByGhc
                   <li>
-                    <a href=@{SnapshotR (SNLts major minor) StackageHomeR}>LTS #{major}.#{minor} for GHC #{ghc}#
+                    <a href=@{SnapshotR (SNLts major minor) StackageHomeR}>LTS #{major}.#{minor} for #{ghc}#
                     \, published #{dateDiff now' date}
             <h3>
                 Package Maintainers

templates/hoogle.hamlet

@@ -12,12 +12,12 @@
                         <p .self>
                             <a href=#{url}>#{preEscapedToHtml self}
                         <table .sources>
-                            $forall (pkg, modus) <- sources
+                            $forall (pkg, modules) <- sources
                                 <tr>
                                     <th>
                                         <a href=#{plURL pkg}>#{plName pkg}
                                     <td>
-                                        $forall ModuleLink name url' <- modus
+                                        $forall ModuleLink name url' <- modules
                                             <a href=#{url'}>#{name}
                         $if null docs
                             <p .nodocs>No documentation available.

templates/package-list.hamlet

@@ -3,12 +3,15 @@
     <div .packages>
         <table .table>
             <thead>
+                <th>Latest snapshot
                 <th>Package
                 <th>Synopsis
             <tbody>
-                $forall (name, version, synopsis) <- packages
+                $forall (snapName, pli) <- packages
                     <tr>
+                        <td nowrap>
+                            <a href=@{SnapshotR snapName SnapshotPackagesR}>#{snapName}
+                        <td nowrap>
+                            <a href=@{makePackageLink snapName pli}>#{pliName pli}-#{pliVersion pli}
                         <td>
-                            <a href=@{PackageR $ PackageName name}>#{name}-#{version}
-                        <td>
-                            #{strip synopsis}
+                            #{strip (pliSynopsis pli)}

templates/package-snapshots.hamlet

@@ -7,12 +7,12 @@ $newline never
             <table .table .snapshots>
                 <thead>
                     <th>
-                        Package
+                        Package version
                     <th>
                         Snapshot
-                $forall (snapshot, version) <- snapshots
+                $forall (compiler, spi) <- snapshots
                     <tr>
                         <td>
-                            #{version}
+                            #{spiVersionRev spi}
                         <td>
-                            <a href=@{SnapshotR (snapshotName snapshot) $ StackageSdistR $ PNVName pn}>#{snapshotTitle snapshot}
+                            <a href=@{SnapshotR (spiSnapName spi) $ StackageSdistR $ PNVName pn}>#{snapshotPrettyName (spiSnapName spi) compiler}

templates/package.hamlet

@@ -1,63 +1,65 @@
 $newline never
-<div .container #snapshot-home .content :deprecated:.deprecated>
+<div .container #snapshot-home .content :isDeprecated:.deprecated>
     <div .row>
         <div .span12>
-            $if deprecated
+            $if isDeprecated
               <h1 .package-deprecation-warning>
                 Deprecated
-              $if (not $ null ixInFavourOf)
+              $if (not $ null inFavourOf)
                 <div .in-favour-of>
                   In favour of
                   <div .in-favour-of-list>
-                    $forall (i, pn) <- ixInFavourOf
+                    $forall (i, pn) <- enumerate inFavourOf
                       $if i /= 0
                         , #
-                      <a href="@{PackageR $ PackageName pn}">
+                      <a href="@{PackageR pn}">
                         #{pn}
             <h1>
-               #{pn}
+               #{pname}
             <p .synopsis>
-                #{synopsis}
+                #{piSynopsis}
                \ #
-               $maybe url <- homepage
+               $maybe url <- piHomepage
                    <a href="#{url}">
                        #{url}
 
             <table>
-              $forall displayedVersion <- mdisplayedVersion
+              $maybe displayedVersion <- mdisplayedVersion
                 <tr>
                   <td align=right>Version on this page:
                   <td>
                     <span .version>#{displayedVersion}
-              $forall li <- latests
-                 <tr>
-                   <td align="right">
-                     <a href=@{SnapshotR (liSnapName li) StackageHomeR}>
-                        #{prettyNameShort (liSnapName li)}
-                     :
-                   <td>
-                     <span .version>
-                       <a href=@{SnapshotR (liSnapName li) (StackageSdistR (PNVName pn))}>#{liVersion li}
-              <tr>
-                <td align="right">Latest on Hackage:
-                <td>
-                  <a href="https://hackage.haskell.org/package/#{pn}-#{latestVersion}">
-                    <span .version>#{latestVersion}
+              $maybe sppi <- msppi
+                $forall li <- sppiLatestInfo sppi
+                   <tr>
+                     <td align="right">
+                       <a href=@{SnapshotR (liSnapName li) StackageHomeR}>
+                          #{snapshotPrettyNameShort (liSnapName li)}
+                       :
+                     <td>
+                       <span .version>
+                         <a href=@{SnapshotR (liSnapName li) (StackageSdistR (PNVName pname))}>#{liVersionRev li}
+              $maybe hciLatest <- mhciLatest
+                  <tr>
+                    <td align="right">Latest on Hackage:
+                    <td>
+                      <a href="https://hackage.haskell.org/package/#{hciPackageName hciLatest}">
+                        <span .version>#{hciVersionRev hciLatest}
 
-            $if null latests
+            $if isNothing msppi
                 <p .add-to-nightly>
                     This package is not currently in any snapshots. If you're interested in using it, we recommend #
                     <a href="https://github.com/fpco/stackage/#add-your-package">adding it to Stackage Nightly
                     . Doing so will make builds more reliable, and allow stackage.org to host generated Haddocks.
             $else
                 <p>
-                  <a href=@{PackageSnapshotsR pn}>See all snapshots <code>#{pn}</code> appears in
+                  <a href=@{PackageSnapshotsR pname}>See all snapshots <code>#{pname}</code> appears in
 
     <div .row>
         <div .span12>
             <div .authorship>
                 <span .license>
-                    #{packageLicenseName package} licensed #
+                    #{piLicenseName} licensed #
                     $if null maintainers
                         and maintained #
                 $if not (null authors)
@@ -76,47 +78,61 @@ $newline never
                                       #{name}
                               $of _
 
-           <div .maintainer>
-               $if not (null maintainers)
-                    Maintained by #
-                    $forall (i,identity) <- maintainers
-                         <strong .author>
-                             $case identity
-                                $of PlainText name
-                                    $if i /= 0
-                                        , #
-                                    #{name}
-                                $of Contact name email
-                                    $if i /= 0
-                                        , #
-                                    <a href="mailto:#{renderEmail email}">
-                                        #{name}
-                                $of EmailOnly email
-                                    $if i /= 0
-                                        , #
-                                    <a href="mailto:#{renderEmail email}">
-                                        #{renderEmail email}
+            <div .maintainer>
+                $if not (null maintainers)
+                     Maintained by #
+                     $forall (i,identity) <- maintainers
+                          <strong .author>
+                              $case identity
+                                 $of PlainText name
+                                     $if i /= 0
+                                         , #
+                                     #{name}
+                                 $of Contact name email
+                                     $if i /= 0
+                                         , #
+                                     <a href="mailto:#{renderEmail email}">
+                                         #{name}
+                                 $of EmailOnly email
+                                     $if i /= 0
+                                         , #
+                                     <a href="mailto:#{renderEmail email}">
+                                         #{renderEmail email}
 
-            $maybe (sname, version, modules) <- mdocs
-                <div .docs>
-                    <h4>
-                        Module documentation for #{version}
-                    $if null modules
-                        <p>There are no documented modules for this package.
-                    $else
-                        ^{hoogleForm sname}
-                        ^{renderModules sname (toPkgVer pname' version) modules}
 
-$if not (LT.null (LT.renderHtml (packageDescription package)))
+            $maybe sppi <- msppi
+                $with spi <- sppiSnapshotPackageInfo sppi
+                    <div .docs>
+                        <h4>
+                            Module documentation for #{spiVersion spi}
+                        $maybe pantryCabal <- sppiPantryCabal sppi
+                            <div .pantry-version>
+                                This version can be pinned in stack with:
+                                <code>#{pantryCabal}
+                        $if null (sppiModuleNames sppi)
+                            <p>There are no documented modules for this package.
+                        $else
+                            ^{hoogleForm (spiSnapName spi)}
+                            ^{renderModules sppi}
+
+$if not (LT.null (LT.renderHtml piReadme))
     <div .markdown-container .readme-container>
         <div .container .content>
             <div .row>
                 <div .span12 .expanding>
-                    #{packageDescription package}
+                    #{piReadme}
+                    <div .bottom-gradient>
+                        <i class="fa fa-angle-down">
+$elseif not (LT.null (LT.renderHtml piDescription))
+    <div .markdown-container .readme-container>
+        <div .container .content>
+            <div .row>
+                <div .span12 .expanding>
+                    #{piDescription}
                     <div .bottom-gradient>
                         <i class="fa fa-angle-down">
 
-$if not (LT.null (LT.renderHtml (packageChangelog package)))
+$if not (LT.null (LT.renderHtml piChangelog))
     <div .container .content id=changes>
        <div .row>
            <div .span12>
@@ -125,39 +141,40 @@ $if not (LT.null (LT.renderHtml (packageChangelog package)))
         <div .container>
             <div .row>
                 <div .span12 .expanding>
-                    #{packageChangelog package}
+                    #{piChangelog}
                     <div .bottom-gradient>
                         <i class="fa fa-angle-down">
 
 <div .container #snapshot-home .content>
     <div .row>
         <div .span12>
-            $if depsCount > 0
-              <div .dependencies #dependencies>
-                Depends on #{renderNoPackages depsCount}:
-                <div .dep-list>
-                    $forall (i,(name, range)) <- deps
-                        $if i /= 0
-                            , #
-                        <a href=@{PackageR $ PackageName name} title=#{range}>
-                            #{name}
-                    $if depsCount > maxDisplayedDeps
-                      , #
-                      <a href=@{packageDepsLink}>
-                        <b>and many more
-            $if revdepsCount > 0
-              <div .reverse-dependencies #reverse-dependencies>
-                Used by #{renderNoPackages revdepsCount}:
-                <div .dep-list>
-                    $forall (i,(name, range)) <- revdeps
-                        $if i /= 0
-                            , #
-                        <a href=@{PackageR $ PackageName name} title=#{range}>
-                            #{name}
-                    $if revdepsCount > maxDisplayedDeps
-                      , #
-                      <a href=@{packageRevDepsLink}>
-                        <b>and many more
+            $maybe sppi <- msppi
+                $with spi <- sppiSnapshotPackageInfo sppi
+                    $if (sppiForwardDepsCount sppi > 0)
+                      <div .dependencies #dependencies>
+                        Depends on #{renderNumPackages (sppiForwardDepsCount sppi)}
+                        <em>(<a href=@{makeDepsLink spi SnapshotPackageDepsR}>full list with versions</a>)</em>:
+                        <div .dep-list>
+                            $forall (i, (name, range)) <- enumerate (sppiForwardDeps sppi)
+                                $if i /= 0
+                                    , #
+                                <a href=@{PackageR name} title=#{range}>
+                                    #{name}
+                            $if (sppiForwardDepsCount sppi > maxDisplayedDeps)
+                              , <em>and many more</em>
+                    $if (sppiReverseDepsCount sppi > 0)
+                        <div .reverse-dependencies #reverse-dependencies>
+                          Used by #{renderNumPackages (sppiReverseDepsCount sppi)} in <b>#{spiSnapName spi}</b>
+                          <em>(<a href=@{makeDepsLink spi SnapshotPackageRevDepsR}>full list with versions</a>)</em>:
+                          <div .dep-list>
+                              $forall (i, (name, range)) <- enumerate (sppiReverseDeps sppi)
+                                  $if i /= 0
+                                      , #
+                                  <a href=@{PackageR name} title=#{range}>
+                                      #{name}
+                              $if (sppiReverseDepsCount sppi > maxDisplayedDeps)
+                                , <em>and many more</em>
+
 
 <div .container .content>
     <div .row>

templates/spam-package.hamlet

@@ -2,7 +2,7 @@
 
 <p>
   The package you have requested,
-  <code>#{name}#
+  <code>#{pname}#
   , has been identified as spam, and therefore will not be displayed.
 
 <p>

templates/stackage-home.hamlet

@@ -15,7 +15,7 @@ $newline never
 
     <p>Edit your stack.yaml and set the following:
     <p .stack-resolver-yaml>resolver: #{toPathPiece name}
-    <p>You can also use <code>--resolver #{toPathPiece name}</code> on the command line
+    <p>You can also use <code>stack --resolver #{toPathPiece name}</code> on the command line
 
     <p>
         <b>New to stack?
@@ -39,7 +39,7 @@ $newline never
                 $forall pli <- packages
                     <tr>
                         <td>
-                            <a href=@{packageUrl name (PackageName $ pliName pli) (Version $ pliVersion pli)}>
+                            <a class=package-name href=@{packageUrl name (pliName pli) (pliVersion pli)}>
                                 #{pliName pli}-#{pliVersion pli}
                         <td>
                             #{strip $ pliSynopsis pli}