content: {-# LANGUAGE NoImplicitPrelude #-}
  module Handler.Haddock
      ( getHaddockR
      , getHaddockBackupR
      ) where
  
  import Import
  import qualified Data.Text as T (takeEnd)
  import Stackage.Database
  
  makeURL :: SnapName -> [Text] -> Handler Text
  makeURL snapName rest = do
      bucketUrl <- getsYesod (appDownloadBucketUrl . appSettings)
      pure . concat
          $ bucketUrl
          : "/"
          : toPathPiece snapName
          : map (cons '/') rest
  
  shouldRedirect :: Bool
  shouldRedirect = False
  
  data DocType = DocHtml | DocJson
  
  getHaddockR :: SnapName -> [Text] -> Handler TypedContent
  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
          cacheSeconds $ 60 * 60 * 24 * 7
          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 "stackage")
                          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 =
      start
    where
      start = await >>= mapM_ start'
  
      start' bs =
        case checkNeedle fullNeedle bs of
          CNNotFound -> yield bs >> start
          CNFound before after -> yield before >> leftover after
          CNPartial before after newNeedle -> yield before >> loop (after:) newNeedle
  
      loop front needle =
          await >>= mapM_ loop'
        where
          loop' bs =
            if needle `isPrefixOf` bs
              then leftover $ concat $ front [bs]
              else
                case stripPrefix bs needle of
                  Just needle' -> loop (front . (bs:)) needle'
                  Nothing -> yieldMany (front [bs]) >> start
  
  data CheckNeedle
      = CNNotFound
      | CNFound !ByteString
                !ByteString
      | CNPartial !ByteString
                  !ByteString
                  !ByteString
  
  checkNeedle :: ByteString -> ByteString -> CheckNeedle
  checkNeedle needle bs0 =
      loop 0
    where
      loop idx
        | idx >= length bs0 = CNNotFound
        | otherwise =
            case uncurry checkIndex $ splitAt idx bs0 of
              CNNotFound -> loop (idx + 1)
              res -> res
  
      checkIndex before bs
        | needle `isPrefixOf` bs = CNFound before bs
        | Just needle' <- stripPrefix bs needle = CNPartial before bs needle'
        | otherwise = CNNotFound
  
  redirectWithVersion ::
         (GetStackageDatabase env m, MonadHandler m) => SnapName -> [Text] -> m (Maybe (Route App))
  redirectWithVersion snapName rest =
      case rest 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 spi -> do
                      return
                          (Just
                               (HaddockR
                                    snapName
                                    [toPathPiece $ PackageIdentifierP pname (spiVersion spi), file]))
          _ -> return Nothing
  
  getHaddockBackupR :: [Text] -> Handler ()
  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" $ do
      bucketUrl <- getsYesod (appDownloadBucketUrl . appSettings)
      redirect
          $ concat
          $ bucketUrl
          : map (cons '/') rest
  