content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE ViewPatterns #-}
  module Handler.StackageHome
      ( getStackageHomeR
      , getApiV1SnapshotR
      , getStackageDiffR
      , getStackageCabalConfigR
      , getDocsR
      , getSnapshotPackagesR
      ) where
  
  import Data.These
  import Handler.StackageHome.Types (ApiSnapshotName(..))
  import Import
  import RIO (textDisplay)
  import RIO.Time (FormatTime)
  import Stackage.Database
  import Stackage.Snapshot.Diff
  
  -- | Return JSON representation of a snapshot.
  -- Redirect /lts, /nightly, /lts-X to the latest corresponding full snapshot.
  getApiV1SnapshotR :: ApiSnapshotName -> Handler Value
  getApiV1SnapshotR (ApiSnapshotNameBranch branch) = track "Handler.API.getApiV1SnapshotR.Branch" $ do
      mLatestSnap <- case branch of
          LtsBranch -> fmap (uncurry SNLts) <$> newestLTS
          LtsMajorBranch x -> fmap (SNLts x) <$> newestLTSMajor x
          NightlyBranch -> fmap SNNightly <$> newestNightly
      maybe notFound (redirectWith found302 . ApiV1SnapshotR . ApiSnapshotName) mLatestSnap
  
  getApiV1SnapshotR (ApiSnapshotName name) = track "Handler.API.getApiV1SnapshotR.Name" $ do
      Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return
      packages <- getPackagesForSnapshot sid
      pure $ toJSON $ SnapshotInfo snapshot packages
  
  getStackageHomeR :: SnapName -> Handler TypedContent
  getStackageHomeR name =
      track "Handler.StackageHome.getStackageHomeR" $ do
          cacheSeconds $ 60 * 60 * 12
          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
                   , packages :: [PackageListingInfo]
                   }
  instance ToJSON SnapshotInfo where
    toJSON SnapshotInfo{..} = object [ "snapshot" .= snapshot
                                     , "packages" .= packages
                                     ]
  
  getStackageDiffR :: SnapName -> SnapName -> Handler TypedContent
  getStackageDiffR name1 name2 = track "Handler.StackageHome.getStackageDiffR" $ do
      cacheSeconds $ 60 * 60 * 48
      Entity sid1 prevSnap <- lookupSnapshot name1 >>= maybe notFound return
      mprevprevSnapName <- map snd <$> snapshotBefore (snapshotName prevSnap)
      Entity sid2 _ <- lookupSnapshot name2 >>= maybe notFound return
      snapDiff <- getSnapshotDiff sid1 sid2
      selectRep $ do
          provideRep $ defaultLayout $ do
              setTitle $ "Compare " ++ toHtml (toPathPiece name1) ++ " with "
                                    ++ toHtml (toPathPiece name2)
              $(widgetFile "stackage-diff")
          provideRep $ pure $ toJSON $ WithSnapshotNames name1 name2 snapDiff
  
  getStackageCabalConfigR :: SnapName -> Handler TypedContent
  getStackageCabalConfigR name = track "Handler.StackageHome.getStackageCabalConfigR" $ do
      cacheSeconds $ 60 * 60 * 48
      Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return
      render <- getUrlRender
  
      mdownload <- lookupGetParam "download"
      when (mdownload == Just "true") $
          addHeader "Content-Disposition" "attachment; filename=cabal.config"
  
      mglobal <- lookupGetParam "global"
      let isGlobal = mglobal == Just "true"
  
      plis <- getPackagesForSnapshot sid
  
      respondSource typePlain $ yieldMany plis .|
          if isGlobal
              then conduitGlobal (snapshotCompiler snapshot) render
              else conduitLocal (snapshotCompiler snapshot) render
    where
      -- FIXME move this stuff into stackage-common
      conduitGlobal compiler render = do
          headerGlobal render
          compilerVersion compiler
          mapC (Chunk . showPackageGlobal)
  
      conduitLocal compiler render = do
          headerLocal render
          compilerVersion compiler
          goFirst
          mapC (Chunk . showPackageLocal)
          yield $ Chunk $ toBuilder '\n'
  
      revisionsWarning =
          toBuilder (asText "-- NOTE: Due to revisions, this file may not work. See:\n-- https://github.com/commercialhaskell/stackage-server/issues/232\n\n")
  
      headerGlobal render = yield $ Chunk $
          revisionsWarning ++
          toBuilder (asText "-- Stackage snapshot from: ") ++
          toBuilder (oldSnapshotUrl render) ++
          toBuilder (asText "\n-- Please append these contents to the end of your global cabal config file.\n-- To only use tested packages, uncomment the following line\n-- and comment out other remote-repo lines:\n-- remote-repo: stackage-") ++
          toBuilder (toPathPiece name) ++
          toBuilder ':' ++
          toBuilder (snapshotUrl render) ++
          toBuilder '\n'
  
      headerLocal render = yield $ Chunk $
          revisionsWarning ++
          toBuilder (asText "-- Stackage snapshot from: ") ++
          toBuilder (oldSnapshotUrl render) ++
          toBuilder (asText "\n-- Please place this file next to your .cabal file as cabal.config\n-- To only use tested packages, uncomment the following line:\n-- remote-repo: stackage-") ++
          toBuilder (toPathPiece name) ++
          toBuilder ':' ++
          toBuilder (snapshotUrl render) ++
          toBuilder '\n'
  
      compilerVersion compiler = yield $ Chunk $
          toBuilder (asText "with-compiler: ") ++
          toBuilder (textDisplay compiler) ++
          toBuilder '\n'
  
      oldSnapshotUrl render = asHttp $ render $ OldSnapshotR (toPathPiece name) []
      snapshotUrl render = asHttp $ render $ SnapshotR name StackageHomeR
  
      asHttp (stripPrefix "http://" -> Just s) = "http://" <> s
      asHttp (stripPrefix "https://" -> Just s) = "http://" <> s
      asHttp (stripPrefix "//" -> Just s) = "http://" <> s
      asHttp s = error $ "Unexpected url prefix: " <> unpack s
  
      constraint p
          | pliOrigin p == Core = toBuilder $ asText " installed"
          | otherwise = toBuilder (asText " ==") ++
                        toBuilder (pliVersion p)
  
      showPackageGlobal p =
          toBuilder (asText "constraint: ") ++
          toBuilder (pliName p) ++
          constraint p ++
          toBuilder '\n'
  
      goFirst = do
          mx <- await
          forM_ mx $ \p -> yield $ Chunk $
              toBuilder (asText "constraints: ") ++
              toBuilder (pliName p) ++
              constraint p
  
      showPackageLocal p =
          toBuilder (asText ",\n             ") ++
          toBuilder (pliName p) ++
          constraint p
  
  yearMonthDayTime :: FormatTime t => t -> String
  yearMonthDayTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M %Z"
  
  getSnapshotPackagesR :: SnapName -> Handler () -- FIXME move to OldLinks?
  getSnapshotPackagesR name = track "Handler.StackageHome.getSnapshotPackagesR" $
      redirect $ SnapshotR name StackageHomeR
  
  getDocsR :: SnapName -> Handler Html
  getDocsR name = track "Handler.StackageHome.getDocsR" $ do
      cacheSeconds $ 60 * 60 * 48
      Entity sid _ <- lookupSnapshot name >>= maybe notFound return
      mlis <- getSnapshotModules sid
      render <- getUrlRender
      let mliUrl mli = render $ haddockUrl name mli
      defaultLayout $ do
          setTitle $ toHtml $ "Module list for " ++ toPathPiece name
          $(widgetFile "doc-list")
  