PageLinks.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module GitHub.REST.PageLinks (
  PageLinks (..),
  parsePageLinks,
) where

import Data.Maybe (fromMaybe)

#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup(..))
#endif
import Data.Text (Text)
import qualified Data.Text as Text

{- | Helper type for GitHub pagination.

 https://developer.github.com/v3/guides/traversing-with-pagination/
-}
data PageLinks = PageLinks
  { pageFirst :: Maybe Text
  , pagePrev :: Maybe Text
  , pageNext :: Maybe Text
  , pageLast :: Maybe Text
  }
  deriving (Eq, Show)

instance Semigroup PageLinks where
  links1 <> links2 =
    PageLinks
      (pageFirst links1 <> pageFirst links2)
      (pagePrev links1 <> pagePrev links2)
      (pageNext links1 <> pageNext links2)
      (pageLast links1 <> pageLast links2)

instance Monoid PageLinks where
  mempty = PageLinks Nothing Nothing Nothing Nothing

#if !MIN_VERSION_base(4,11,0)
  mappend = (<>)
#endif

parsePageLinks :: Text -> PageLinks
parsePageLinks = foldl resolve mempty . split ","
  where
    resolve :: PageLinks -> Text -> PageLinks
    resolve pageLinks "" = pageLinks
    resolve pageLinks link =
      let (rel, url) = parsePageLink link
       in case rel of
            "first" -> pageLinks{pageFirst = Just url}
            "prev" -> pageLinks{pagePrev = Just url}
            "next" -> pageLinks{pageNext = Just url}
            "last" -> pageLinks{pageLast = Just url}
            _ -> error $ "Unknown rel in page link: " ++ show link

{- | Parse a single page link, like:

 <https://api.github.com/search/code?q=addClass+user%3Amozilla&page=2>; rel="next"

 Returns ("next", "/search/code?q=addClass+user%3Amozilla&page=2")
-}
parsePageLink :: Text -> (Text, Text)
parsePageLink link = fromMaybe (error $ "Unknown page link: " ++ show link) $ do
  (linkUrl, linkRel) <- case split ";" link of
    [url, rel] -> pure (url, rel)
    _ -> mempty

  url <- Text.stripPrefix ghUrl $ dropAround "<" ">" linkUrl
  rel <- case split "=" linkRel of
    ["rel", linkRel'] -> pure $ dropAround "\"" "\"" linkRel'
    _ -> mempty

  pure (rel, url)
  where
    ghUrl = "https://api.github.com"

{- Helpers -}

-- | Split the given text by the given delimiter, stripping any surrounding whitespace.
split :: Text -> Text -> [Text]
split delim = map Text.strip . Text.splitOn delim

-- | Drop the given strings at the beginning and end of the given text.
dropAround :: Text -> Text -> Text -> Text
dropAround begin end s = fromMaybe badDrop $ Text.stripSuffix end =<< Text.stripPrefix begin s
  where
    badDrop = error $ "Expected value to wrap within " ++ Text.unpack begin ++ "..." ++ Text.unpack end ++ ": " ++ Text.unpack s