Alternate.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnicodeSyntax #-}

module Alternate (AlternateException (..), extractAlternateLinks) where

-- {{{ Imports
import Data.Aeson
import qualified Data.ByteString.Char8 as Char8
import Imm.Link
import Imm.Logger as Logger
import Imm.Pretty
import Pipes
import Pipes.ByteString as Pipes (toHandle)
import System.IO (hClose)
import System.Process.Typed
import URI.ByteString.Extended

-- }}}

newtype AlternateException = FeedNotFound URI
  deriving (Eq, Show)

instance Exception AlternateException where
  displayException = show . pretty

instance Pretty AlternateException where
  pretty (FeedNotFound uri) = "No feeds found at" <+> prettyURI uri

data AlternateLink = AlternateLink Text Text Text
  deriving (Eq, Ord, Show)

instance Pretty AlternateLink where
  pretty (AlternateLink title linkType uri) = "Alternate link" <+> braces (hsep parameters)
   where
    parameters =
      [ "title" <> equals <> dquotes (pretty title)
      , "type" <> equals <> dquotes (pretty linkType)
      , "href" <> equals <> dquotes (pretty uri)
      ]

instance FromJSON AlternateLink where
  parseJSON = withObject "AlternateLink" $ \v →
    AlternateLink
      <$> (v .: "title" <|> pure mempty)
      <*> v .: "type"
      <*> v .: "href"

asFeedURI ∷ MonadFail m ⇒ URI → Text → m URI
asFeedURI baseURI href =
  let bytes = encodeUtf8 @Text href
   in case parseURI laxURIParserOptions bytes of
        Right uri → pure uri
        _ → case parseRelativeRef laxURIParserOptions bytes of
          Right relativeRef → pure $ mergeURIs baseURI relativeRef
          Left e → fail $ show e

mergeURIs ∷ URI → URIRef Relative → URI
mergeURIs uri relativeRef = URI scheme authority path query fragment
 where
  scheme = uriScheme uri
  authority = rrAuthority relativeRef <|> uriAuthority uri
  path = mergePaths (uriPath uri) (rrPath relativeRef)
  query = rrQuery relativeRef
  fragment = rrFragment relativeRef

mergePaths ∷ ByteString → ByteString → ByteString
mergePaths basePath path = case Char8.head path of
  '/' → path
  _ → basePath <> "/" <> path

asLink ∷ MonadFail m ⇒ URI → AlternateLink → m Link
asLink baseURI (AlternateLink title type' uri) = Link (Just Alternate) title (parseMediaType type') . AnyURI <$> asFeedURI baseURI uri

extractAlternateLinks ∷ MonadIO m ⇒ MonadFail m ⇒ Logger.Handle IO → URI → Producer ByteString IO () → m [Link]
extractAlternateLinks logger baseUri html = io $
  withProcessWait pup $ \pupProcess → do
    log logger Debug $ pretty $ show @String pupProcess

    runEffect $ html >-> toHandle (getStdin pupProcess)
    hClose (getStdin pupProcess)

    links ← getStdout pupProcess & atomically <&> decode <&> fromMaybe mempty
    log logger Info $ "Found alternate links:" <+> pretty links

    mapM (asLink baseUri) links
 where
  pup =
    proc "pup" ["html head link[rel=\"alternate\"] json{}"]
      & setStdin createPipe
      & setStdout byteStringOutput
      & setStderr nullStream