Skip to content

Commit

Permalink
fix: fixes GitHub Project parsing when using automated cards #62
Browse files Browse the repository at this point in the history
  • Loading branch information
smallhadroncollider committed Feb 3, 2020
1 parent 7551f2a commit ee0634d
Showing 6 changed files with 122 additions and 24 deletions.
1 change: 1 addition & 0 deletions package.yaml
Original file line number Diff line number Diff line change
@@ -48,6 +48,7 @@ library:
- IO.Markdown.Parser
- IO.Markdown.Serializer
- IO.HTTP.GitHub
- IO.HTTP.GitHub.Card
- IO.HTTP.Trello.List
- IO.HTTP.Trello.ChecklistItem
- IO.Keyboard
41 changes: 31 additions & 10 deletions src/IO/HTTP/GitHub.hs
Original file line number Diff line number Diff line change
@@ -24,12 +24,14 @@ import Network.HTTP.Simple (getResponseBody, getResponseHeader, getRespons
import Network.HTTP.Types.Header (HeaderName)

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

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

type GitHubToken = Text

@@ -78,17 +80,36 @@ fetch' bs url = do
fetch :: Text -> ReaderGitHubToken (Int, [ByteString])
fetch = fetch' []

getCards :: Text -> ReaderGitHubToken (Either Text [Card])
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) <- fetch url
let iss = headMay body
case iss of
Nothing -> pure $ Left "Could not find card content"
Just is -> pure . first parseError $ issueToTask <$> eitherDecodeStrict is

getCards :: Text -> ReaderGitHubToken (Either Text [Task])
getCards url = do
(status, body) <- fetch url
pure $
case status of
200 ->
case concatEithers (eitherDecodeStrict <$> body) of
Right cards -> Right cards
Left err -> Left (parseError err)
429 -> Left "Too many cards"
_ -> Left $ tshow status <> " error while fetching " <> url
case status of
200 ->
case concatEithers (eitherDecodeStrict <$> body) of
Right cards -> do
cds <- sequence (fetchContent <$> cards)
let (ls, rs) = partitionEithers cds
pure $
if null ls
then Right rs
else Left (unlines 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
24 changes: 14 additions & 10 deletions src/IO/HTTP/GitHub/Card.hs
Original file line number Diff line number Diff line change
@@ -3,29 +3,33 @@
{-# LANGUAGE TemplateHaskell #-}

module IO.HTTP.GitHub.Card
( Card
, cardToTask
( MaybeCard(MaybeCard)
, maybeCardToTask
, content_url
) where

import ClassyPrelude

import Control.Lens (makeLenses, (^.))

import Data.Text (replace)
import Data.Text (replace)

import qualified Data.Taskell.Task as T (Task, new)
import IO.HTTP.Aeson (deriveFromJSON)

data Card = Card
{ _note :: Text
data MaybeCard = MaybeCard
{ _note :: Maybe Text
, _content_url :: Maybe Text
} deriving (Eq, Show)

-- strip underscores from field labels
$(deriveFromJSON ''Card)
$(deriveFromJSON ''MaybeCard)

-- create lenses
$(makeLenses ''Card)
$(makeLenses ''MaybeCard)

-- operations
cardToTask :: Card -> T.Task
cardToTask card = T.new $ replace "\r" "" $ replace "\n" " " (card ^. note)
maybeCardToTask :: MaybeCard -> Maybe T.Task
maybeCardToTask card =
case card ^. note of
Just txt -> Just . T.new $ replace "\r" "" $ replace "\n" " " txt
Nothing -> Nothing
8 changes: 4 additions & 4 deletions src/IO/HTTP/GitHub/Column.hs
Original file line number Diff line number Diff line change
@@ -11,10 +11,10 @@ import ClassyPrelude

import Control.Lens (Lens', makeLenses, (^.))

import IO.HTTP.Aeson (deriveFromJSON)
import IO.HTTP.GitHub.Card (Card, cardToTask)
import IO.HTTP.Aeson (deriveFromJSON)

import qualified Data.Taskell.List as L (List, create)
import qualified Data.Taskell.Task as T (Task)

data Column = Column
{ _name :: Text
@@ -31,5 +31,5 @@ $(makeLenses ''Column)
cardsURL :: Lens' Column Text
cardsURL = cards_url

columnToList :: Column -> [Card] -> L.List
columnToList ls cards = L.create (ls ^. name) (fromList $ cardToTask <$> cards)
columnToList :: Column -> [T.Task] -> L.List
columnToList ls tasks = L.create (ls ^. name) (fromList tasks)
33 changes: 33 additions & 0 deletions src/IO/HTTP/GitHub/Issue.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,33 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module IO.HTTP.GitHub.Issue
( Issue(Issue)
, issueToTask
) where

import ClassyPrelude

import Control.Lens (makeLenses, (^.))
import Data.Text (replace)

import qualified Data.Taskell.Task as T (Task, new, setDescription)
import IO.HTTP.Aeson (deriveFromJSON)

data Issue = Issue
{ _title :: Text
, _body :: Text
} deriving (Eq, Show)

-- strip underscores from field labels
$(deriveFromJSON ''Issue)

-- create lenses
$(makeLenses ''Issue)

-- operations
issueToTask :: Issue -> T.Task
issueToTask issue = T.setDescription (issue ^. body) task
where
task = T.new $ replace "\r" "" $ replace "\n" " " (issue ^. title)
39 changes: 39 additions & 0 deletions test/IO/GitHub/CardsTest.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,39 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

module IO.GitHub.CardsTest
( test_cards
) where

import ClassyPrelude

import Test.Tasty
import Test.Tasty.HUnit

import Data.Aeson

import IO.HTTP.GitHub.Card (MaybeCard (MaybeCard))

decodeCards :: Text -> Either String [MaybeCard]
decodeCards txt = eitherDecodeStrict $ encodeUtf8 txt

-- tests
test_cards :: TestTree
test_cards =
testGroup
"IO.HTTP.GitHub.Card"
[ testCase
"parses basic card"
(assertEqual
"Gives back card"
(Right [MaybeCard (Just "blah") Nothing])
(decodeCards "[{\"note\": \"blah\"}]"))
, testCase
"parses basic card"
(assertEqual
"Gives back card"
(Right
[MaybeCard Nothing (Just "https://api.github.com/projects/columns/7850783")])
(decodeCards
"[{\"note\": null, \"content_url\": \"https://api.github.com/projects/columns/7850783\"}]"))
]

0 comments on commit ee0634d

Please sign in to comment.