GitHub.hs

module Taskell.IO.HTTP.GitHub
    ( GitHubToken
    , GitHubIdentifier
    , getNextLink
    , getLists
    ) where

import ClassyPrelude

import Control.Lens  ((^.))
import Data.Sequence (mapWithIndex, (!?))
import Data.Text     (splitOn, strip)

import Data.Aeson
import Taskell.UI.CLI (prompt)

import Network.HTTP.Client       (requestHeaders)
import Network.HTTP.Simple       (Response, getResponseBody, getResponseHeader,
                                  getResponseStatusCode, httpBS, parseRequest)
import Network.HTTP.Types.Header (HeaderName)

import Taskell.IO.HTTP.Aeson                (parseError)
import Taskell.IO.HTTP.GitHub.AutomatedCard (automatedCardToTask)
import Taskell.IO.HTTP.GitHub.Card          (MaybeCard, content_url, maybeCardToTask)
import Taskell.IO.HTTP.GitHub.Column        (Column, cardsURL, columnToList)
import Taskell.IO.HTTP.GitHub.Project       (Project, columnsURL, name)

import Taskell.Data.List  (List)
import Taskell.Data.Lists (Lists)
import Taskell.Data.Task  (Task)

type GitHubToken = Text

type GitHubIdentifier = Text

type ReaderGitHubToken a = ReaderT GitHubToken IO a

concatEithers :: [Either String [a]] -> Either String [a]
concatEithers vals = bool (Left errs) (Right as) (null errs)
  where
    (errs, as) = bimap unlines concat $ partitionEithers vals

root :: Text
root = "https://api.github.com/"

headers :: ReaderGitHubToken [(HeaderName, ByteString)]
headers = do
    token <- ask
    pure
        [ ("User-Agent", "smallhadroncollider/taskell")
        , ("Accept", "application/vnd.github.inertia-preview+json")
        , ("Authorization", encodeUtf8 ("token " <> token))
        ]

getNextLink :: [ByteString] -> Maybe Text
getNextLink bs = do
    lnks <- splitOn "," . decodeUtf8 <$> headMay bs
    let rel = "rel=\"next\""
    next <- find (isSuffixOf rel) lnks
    stripPrefix "<" =<< stripSuffix (">; " <> rel) (strip next)

fetchURL :: Text -> ReaderGitHubToken (Response ByteString)
fetchURL url = do
    initialRequest <- lift $ parseRequest (unpack url)
    rHeaders <- headers
    lift . httpBS $ initialRequest {requestHeaders = rHeaders}

fetch' :: [ByteString] -> Text -> ReaderGitHubToken (Int, [ByteString])
fetch' bs url = do
    response <- fetchURL url
    let responses = bs <> [getResponseBody response]
    case getNextLink (getResponseHeader "Link" response) of
        Nothing  -> pure (getResponseStatusCode response, responses)
        Just lnk -> fetch' responses lnk

fetch :: Text -> ReaderGitHubToken (Int, [ByteString])
fetch = fetch' []

fetchContent :: MaybeCard -> ReaderGitHubToken (Either Text Task)
fetchContent card =
    case maybeCardToTask card of
        Just tsk -> pure $ Right tsk
        Nothing ->
            case card ^. content_url of
                Nothing -> pure $ Left "Could not parse card"
                Just url -> do
                    body <- getResponseBody <$> fetchURL url
                    pure . first parseError $ automatedCardToTask <$> eitherDecodeStrict body

getCards :: Text -> ReaderGitHubToken (Either Text [Task])
getCards url = do
    (status, body) <- fetch url
    case status of
        200 ->
            case concatEithers (eitherDecodeStrict <$> body) of
                Right cards -> do
                    cds <- sequence (fetchContent <$> cards)
                    let (ls, rs) = first unlines $ partitionEithers cds
                    pure $ bool (Left ls) (Right rs) (null ls)
                Left err -> pure $ Left (parseError err)
        429 -> pure $ Left "Too many cards"
        _ -> pure . Left $ tshow status <> " error while fetching " <> url

addCard :: Column -> ReaderGitHubToken (Either Text List)
addCard column = do
    cards <- getCards $ column ^. cardsURL
    pure $ columnToList column <$> cards

addCards :: [Column] -> ReaderGitHubToken (Either Text Lists)
addCards columns = (fromList <$>) . sequence <$> traverse addCard columns

getColumns :: Text -> ReaderGitHubToken (Either Text Lists)
getColumns url = do
    putStrLn "Fetching project from GitHub..."
    (status, body) <- fetch url
    case status of
        200 ->
            case concatEithers (eitherDecodeStrict <$> body) of
                Right columns -> addCards columns
                Left err      -> pure $ Left (parseError err)
        404 -> pure . Left $ "Could not find GitHub project ."
        401 -> pure . Left $ "You do not have permission to view GitHub project " <> url
        _ -> pure . Left $ tshow status <> " error. Cannot fetch columns from GitHub."

printProjects :: Seq Project -> Text
printProjects projects = unlines $ toList display
  where
    names = (^. name) <$> projects
    line i nm = concat ["[", tshow (i + 1), "] ", nm]
    display = line `mapWithIndex` names

chooseProject :: [Project] -> ReaderGitHubToken (Either Text Lists)
chooseProject projects = do
    let projects' = fromList projects
    putStrLn $ printProjects projects'
    chosen <- lift $ prompt "Import project"
    let project = (projects' !?) =<< (-) 1 <$> readMay chosen
    case project of
        Nothing   -> pure $ Left "Invalid project selected"
        Just proj -> getColumns (proj ^. columnsURL)

getLists :: GitHubIdentifier -> ReaderGitHubToken (Either Text Lists)
getLists identifier = do
    putStrLn "Fetching project list from GitHub...\n"
    let url = concat [root, identifier, "/projects"]
    (status, body) <- fetch url
    case status of
        200 ->
            case concatEithers (eitherDecodeStrict <$> body) of
                Right projects ->
                    if null projects
                        then pure . Left $ concat ["\nNo projects found for ", identifier, "\n"]
                        else chooseProject projects
                Left err -> pure $ Left (parseError err)
        404 ->
            pure . Left $
            "Could not find GitHub org/repo. For organisation make sure you use 'orgs/<org-name>' and for repos use 'repos/<username>/<repo-name>'"
        401 ->
            pure . Left $
            "You do not have permission to view the GitHub projects for " <> identifier
        _ -> pure . Left $ tshow status <> " error. Cannot fetch projects from GitHub."