{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

module Niv.GitHub where

import Control.Arrow
import Data.Bool
import Data.Maybe
import qualified Data.Text as T
import Niv.GitHub.API
import Niv.Update

-- | The GitHub update function
-- TODO: fetchers for:
--  * npm
--  * hackage
--  * docker
--  * ... ?
githubUpdate ::
  -- | prefetch
  (Bool -> T.Text -> IO T.Text) ->
  -- | latest revision
  (T.Text -> T.Text -> T.Text -> IO T.Text) ->
  -- | get repo
  (T.Text -> T.Text -> IO GithubRepo) ->
  Update () ()
githubUpdate :: (Bool -> Text -> IO Text)
-> (Text -> Text -> Text -> IO Text)
-> (Text -> Text -> IO GithubRepo)
-> Update () ()
githubUpdate Bool -> Text -> IO Text
prefetch Text -> Text -> Text -> IO Text
latestRev Text -> Text -> IO GithubRepo
ghRepo = proc () -> do
  Box Text
urlTemplate <-
    Update (Box Text) (Box Text)
template
      Update (Box Text) (Box Text)
-> Update () (Box Text) -> Update () (Box Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< (Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"url_template" Update (Box Text) (Box Text)
-> Update () (Box Text) -> Update () (Box Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< Update () (Box Text)
completeSpec) Update () (Box Text)
-> Update () (Box Text) -> Update () (Box Text)
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> (Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"url_template")
      -<
        ()
  Box Text
url <- Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"url" -< Box Text
urlTemplate
  let isTarGuess :: Box Bool
isTarGuess = (\Text
u -> Text
"tar.gz" Text -> Text -> Bool
`T.isSuffixOf` Text
u Bool -> Bool -> Bool
|| Text
".tgz" Text -> Text -> Bool
`T.isSuffixOf` Text
u) (Text -> Bool) -> Box Text -> Box Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Text
url
  Box Text
type' <- Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"type" -< Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool Text
"file" Text
"tarball" (Bool -> Text) -> Box Bool -> Box Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Bool
isTarGuess :: Box T.Text
  let doUnpack :: Box Bool
doUnpack = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"tarball") (Text -> Bool) -> Box Text -> Box Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Text
type'
  Box Text
_sha256 <- Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"sha256" Update (Box Text) (Box Text)
-> Update (Box (Bool, Text)) (Box Text)
-> Update (Box (Bool, Text)) (Box Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< ((Bool, Text) -> IO Text) -> Update (Box (Bool, Text)) (Box Text)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (\(Bool
up, Text
u) -> Bool -> Text -> IO Text
prefetch Bool
up Text
u) -< (,) (Bool -> Text -> (Bool, Text))
-> Box Bool -> Box (Text -> (Bool, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Bool
doUnpack Box (Text -> (Bool, Text)) -> Box Text -> Box (Bool, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box Text
url
  Update () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()
  where
    completeSpec :: Update () (Box T.Text)
    completeSpec :: Update () (Box Text)
completeSpec = proc () -> do
      Box Text
owner <- Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"owner" -< ()
      Box Text
repo <- Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"repo" -< ()
      Box GithubRepo
repoInfo <- ((Text, Text) -> IO GithubRepo)
-> Update (Box (Text, Text)) (Box GithubRepo)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (\(Text
a, Text
b) -> Text -> Text -> IO GithubRepo
ghRepo Text
a Text
b) -< (,) (Text -> Text -> (Text, Text))
-> Box Text -> Box (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Text
owner Box (Text -> (Text, Text)) -> Box Text -> Box (Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box Text
repo
      Box Text
branch <-
        Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"branch" Update (Box Text) (Box Text)
-> Update (Box (Maybe Text)) (Box Text)
-> Update (Box (Maybe Text)) (Box Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< (Box (Maybe Text) -> Box Text)
-> Update (Box (Maybe Text)) (Box Text)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Maybe Text -> Text) -> Box (Maybe Text) -> Box Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe Text -> Text) -> Box (Maybe Text) -> Box Text)
-> (Maybe Text -> Text) -> Box (Maybe Text) -> Box Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"master")
          -<
            GithubRepo -> Maybe Text
repoDefaultBranch (GithubRepo -> Maybe Text) -> Box GithubRepo -> Box (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box GithubRepo
repoInfo
      Box (Maybe Text)
_description <- Text -> Update (Box (Maybe Text)) (Box (Maybe Text))
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"description" -< GithubRepo -> Maybe Text
repoDescription (GithubRepo -> Maybe Text) -> Box GithubRepo -> Box (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box GithubRepo
repoInfo
      Box (Maybe Text)
_homepage <- Text -> Update (Box (Maybe Text)) (Box (Maybe Text))
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"homepage" -< GithubRepo -> Maybe Text
repoHomepage (GithubRepo -> Maybe Text) -> Box GithubRepo -> Box (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box GithubRepo
repoInfo
      Box Text
_ <-
        Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"rev" Update (Box Text) (Box Text)
-> Update (Box (Text, Text, Text)) (Box Text)
-> Update (Box (Text, Text, Text)) (Box Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< ((Text, Text, Text) -> IO Text)
-> Update (Box (Text, Text, Text)) (Box Text)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run' (\(Text
a, Text
b, Text
c) -> Text -> Text -> Text -> IO Text
latestRev Text
a Text
b Text
c)
          -<
            (,,) (Text -> Text -> Text -> (Text, Text, Text))
-> Box Text -> Box (Text -> Text -> (Text, Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Text
owner Box (Text -> Text -> (Text, Text, Text))
-> Box Text -> Box (Text -> (Text, Text, Text))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box Text
repo Box (Text -> (Text, Text, Text))
-> Box Text -> Box (Text, Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box Text
branch
      Update (Box Text) (Box Text)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Text -> Box Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
githubURLTemplate

githubURLTemplate :: T.Text
githubURLTemplate :: Text
githubURLTemplate =
  (if Bool
githubSecure then Text
"https://" else Text
"http://")
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
githubHost
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
githubPath
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"<owner>/<repo>/archive/<rev>.tar.gz"